Move 4.01 onto the main trunk.
/* Define as the symbol which marks the end of the data section */
#undef DATA_SECTION_END_MARKER
-/* Define as the decl which terminates the data section */
-#undef DATA_SECTION_END_MARKER_DECL
-
/* Define if time.h or sys/time.h define the altzone variable */
#undef HAVE_ALTZONE
-/* Define if you have /bin/sh */
-#define HAVE_BIN_SH 0
-
-/* Define if you have the GetModuleFileName function. */
-#define HAVE_GETMODULEFILENAME 0
-
/* Define if C compiler supports long long types */
#undef HAVE_LONG_LONG
/* Define if fcntl.h defines O_BINARY */
#undef HAVE_O_BINARY
-/* Define if compiler supports prototypes. */
-#define HAVE_PROTOTYPES 0
-
-/* Define if you have the WinExec function. */
-#define HAVE_WINEXEC 0
-
/* Define if C Symbols have a leading underscore added by the compiler */
#undef LEADING_UNDERSCORE
/* Define as the symbol which marks the end of the text section */
#undef TEXT_SECTION_END_MARKER
-/* Define to decl that terminates text section. */
-#undef TEXT_SECTION_END_MARKER_DECL
-
/* Define to the type of the timezone variable (usually long or time_t) */
#undef TYPE_TIMEZONE
-/* Define if signal handlers have type void (*)(int)
- * (Otherwise, they're assumed to have type int (*)(void).)
- */
-#define VOID_INT_SIGNALS 0
-
\f
/* Leave that blank line there!! Autoheader needs it.
If you're adding to this file, keep in mind:
-dnl $Id: aclocal.m4,v 1.34 1998/11/24 21:28:00 reid Exp $
+dnl $Id: aclocal.m4,v 1.35 1998/12/02 13:17:10 simonm Exp $
dnl
dnl Extra autoconf macros for the Glasgow fptools
dnl
fi
done
if test "$not_done" = 1; then
-FPTOOLS_IN_SCOPE(etext asm("etext"),etext,fptools_cv_end_of_text)
+FPTOOLS_IN_SCOPE(etext asm("etext"),etext,fptools_cv_end_of_text);
if test "$fptools_cv_end_of_text" = yes; then
AC_DEFINE(TEXT_SECTION_END_MARKER_DECL, etext asm("etext"))
AC_DEFINE(TEXT_SECTION_END_MARKER, etext)
fi
done
if test "$not_done" = 1; then
-FPTOOLS_IN_SCOPE(end asm("end"),end,fptools_cv_end_of_data)
+FPTOOLS_IN_SCOPE(end asm("end"),end,fptools_cv_end_of_data);
if test "$fptools_cv_end_of_data" = yes; then
AC_DEFINE(DATA_SECTION_END_MARKER_DECL, end asm("end"))
AC_DEFINE(DATA_SECTION_END_MARKER, end)
AC_HEADER_STDC
dnl ** check for specific header (.h) files that we are interested in
-AC_CHECK_HEADERS(Files.h assert.h console.h ctype.h dirent.h errno.h fcntl.h float.h ftw.h grp.h ieee754.h malloc.h memory.h nlist.h pascal.h pwd.h sgtty.h siginfo.h signal.h stat.h stdlib.h stdarg.h string.h sys/fault.h sys/file.h sys/ioctl.h sys/mman.h sys/param.h sys/procfs.h sys/resource.h sys/signal.h sys/socket.h netinet/tcp.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/vadvise.h sys/wait.h termio.h termios.h time.h types.h unistd.h utime.h values.h vfork.h readline/readline.h bfd.h)
+AC_CHECK_HEADERS(Files.h assert.h console.h ctype.h dirent.h errno.h fcntl.h float.h ftw.h grp.h ieee754.h malloc.h memory.h nlist.h pascal.h pwd.h sgtty.h siginfo.h signal.h stat.h stdlib.h stdarg.h string.h sys/fault.h sys/file.h sys/ioctl.h sys/limits.h sys/mman.h sys/param.h sys/procfs.h sys/resource.h sys/signal.h sys/socket.h netinet/tcp.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/vadvise.h sys/wait.h termio.h termios.h time.h types.h unistd.h utime.h values.h vfork.h readline/readline.h bfd.h)
dnl ** check for DOS include files
AC_CHECK_HEADERS(dos.h conio.h io.h std.h)
- The Glasgow Haskell Compiler -- version 3.02
+ The Glasgow Haskell Compiler -- version 4.01
==============================================
We are pleased to announce a new release of the Glasgow Haskell
-Compiler (GHC), version 3.02. The source distribution is freely
+Compiler (GHC), version 4.01. The source distribution is freely
available via the World-Wide Web and through anon. FTP; details below.
Haskell is "the" standard lazy functional programming language; the
+ What's new
=============
-GHC 3.02 is a source-only release. Major news items:
+GHC 4.01 is a small increment over 4.00. Many bugs have been fixed.
+The following features are new:
- * A new specialiser,
- * A new unsafeCoerce# primitive.
- * A NOINLINE pragma.
- * Many bugs fixed, including several performance-related ones,
+ * Weak pointers,
+ * The foreign function interface is now complete.
-GHC 3.02 produces the fastest code since 0.29, but there's still
-plenty of tuning to do.
+In addition, bootstrapping the compiler should now work out of the box.
+
+The following things have not been fixed yet:
+
+ * The native code generator is still flaky, and is turned off by
+ default for the time being.
+ * The profiler is still flaky.
+ Mailing lists
================
+ System requirements
======================
-To compile up this source-only release, you need a machine with 16+MB
+To compile up this source-only release, you need a machine with 32+MB
memory, GNU C (`gcc'), `perl' plus a version of GHC installed (version
-2.10 at least). We have seen GHC work on these platforms:
+2.10 at least). This release is known to work on the following platforms:
+
+ * i386-unknown-{linux,solaris2,freebsd,cygwin32}
+ * sparc-sun-{sunos4,solaris2}
+
+Ports to the following platforms should be relatively easy, but
+haven't been tested due to lack of time/hardware:
* alpha-dec-osf{2,3}
* hppa1.1-hp-hpux{9,10}
- * sparc-sun-{sunos4,solaris2}
* mips-sgi-irix{5,6}
- * i386-unknown-{linux,solaris2,freebsd,cygwin32}.
* {rs6000,powerpc}-ibm-aix
-Similar platforms should work with minimal hacking effort. The installer's
-guide included in distribution gives a complete run-down of what-ports-work;
-an on-line version can be found at
-
- http://www.dcs.gla.ac.uk/fp/software/ghc/3.02/installation_guide/installing_toc.html
+The installer's guide included in distribution gives a complete
+run-down of what-ports-work; an on-line version can be found at
-EOF
+ http://www.dcs.gla.ac.uk/fp/software/ghc/4.01/installation_guide/installing_toc.html
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.7 1997/03/24 08:39:19 sof Exp $
+# $Id: Makefile,v 1.8 1998/12/02 13:17:13 simonm Exp $
#
TOP=.
# we descend into compiler/ and lib/
#
ifeq "$(GhcWithHscBuiltViaC)" "NO"
-SUBDIRS = utils driver includes runtime docs compiler lib
+SUBDIRS = utils driver includes rts docs compiler lib
else
-SUBDIRS = utils driver includes runtime docs lib compiler
+SUBDIRS = utils driver includes rts docs lib compiler
endif
# Easier to copy
-The Glamorous Glasgow Haskell Compiler, version 3.02, patchlevel 0
+The Glamorous Glasgow Haskell Compiler, version 4.01, patchlevel 0
-This is version 3.02 of the Glorious Glasgow Haskell compilation
-system (GHC). GHC 3.02 is a compiler for Haskell 1.4.
+This is version 4.01 of the Glorious Glasgow Haskell compilation
+system (GHC). GHC 4.01 is a compiler for Haskell 1.4.
Haskell is "the" standard lazy functional programming language.
Haskell 1.4 is the current version of the language, released in
April 1997. The language definition is on the Web at
http://www.haskell.org/report/index.html.
+More information on GHC can be found on its web page
+
+ http://www.dcs.gla.ac.uk/fp/software/ghc
+
GHC documentation of interest:
-* docs/installing.{dvi,info,html}: How to configure, build, and
+* docs/installing.{dvi,html}: How to configure, build, and
install the system.
The document, as with many others, is in TeX-produced DVI format
- (.dvi suffix), or GNU Info format (.info); the latter is close to
- plain ASCII, if that's what you want.
+ (.dvi suffix), or HTML.
-* ghc/docs/users_guide/user.{dvi,info,html}: How to use GHC; e.g., what
+* ghc/docs/users_guide/user.{dvi,html}: How to use GHC; e.g., what
options are available, how to cope with common problems, how to use
the profiling facilities, etc.
+* ghc/docs/libraries/libs.{dvi,html}: Several libraries that are
+ provided by both GHC and Hugs.
+
We welcome your comments and suggestions about this software! Please
do not suffer or grumble in silence. The "bug reports" section of the
-User's Guide (docs/users_guide/user.{dvi,info,html}) says what we
-would like to know when you report a problem.
+User's Guide says what we would like to know when you report a
+problem.
-Current AQUA team (all @dcs.gla.ac.uk):
+Current GHC team:
+
+ Simon Peyton Jones ( simonpj@microsoft.com) [our Fearless Leader]
+ Sigbjorn Finne (v-sfinne@microsoft.com) [hired hand]
+ Simon Marlow (t-simonm@microsoft.com) [hired hand]
+
+Past contributors and/or continuing advisors (all @dcs.gla.ac.uk):
- Sigbjorn Finne (sof) [hired hand]
- Hans Wolfgang Loidl (hwloidl) [PhD student]
- Simon Marlow (simonm) [hired hand]
Thomas Nordin (nordin) [@cse.ogi.edu; Green Card Hero]
- Simon Peyton Jones (simonpj) [our Fearless Leader]
+ Hans Wolfgang Loidl (hwloidl) [PhD student]
Patrick Sansom (sansom) [hired hand, Bidirectional Analyses]
Phil Trinder (trinder) [hired hand, Parade]
-
-Past contributors and/or continuing advisors:
-
Andy Gill (andy) [PhD student; at HP]
Cordy Hall (cvh) [GRASP]
Kevin Hammond (kh) [GRASP; at St. Andrews]
David N Turner (dnt) [Linear Types; at An-Teallach]
Phil Wadler (wadler) [GRASP; at Lucent]
+And many others who've contributed bits of code / bug reports in the past.
+
Cool people who've let us use their machines:
sparc-sun-sunos{4,5} PacSoft, Oregon Graduate Institute
GRASP ('90-'92): Graph reduction applications support project
AQUA ('93- ): Declarative systems architecture: a quantitative approach
-GHC WWW page: http://www.dcs.gla.ac.uk/fp/software/ghc/
-
E-mail contacts:
glasgow-haskell-bugs@dcs.gla.ac.uk (bug reports mailing list)
glasgow-haskell-users@dcs.gla.ac.uk (users' mailing list)
Send mail to majordomo@dcs.gla.ac.uk with 'help' in the body of the
-message for information on joining either of these mailing lists.
+message for information on joining/leaving either of these mailing
+lists.
Anonymous FTP site: ftp://ftp.dcs.gla.ac.uk:pub/haskell/glasgow.
Mostly mirrored by ftp.cs.chalmers.se and haskell.org (same
--- /dev/null
+ToDo
+~~~~
+* Test effect of eta-expanding past (case x of ..)
+
+* Bottom strictness isn't right. Should be (eg) SSX, not just X.
+
+* Enumeration types in worker/wrapper for strictness analysis
+
+* Use (!) types in data cons to unbox.
+
+* Check constant folding
+
+* .hi file isn't updated if the only change is to the exports.
+ For example, UgenAll.lhs re-exports all of U_binding.hs; when a data type
+ decl in the latter changes, the .hi file for the former isn't updated.
+ I think this happens when a module exports another mdodule thus:
+
+ module UgenAll( module U_binding, ... ) where
+
+* This should be reported as an error:
+ data T k = MkT (k Int#)
+
+* Bogus report of overlapped pattern for
+ f (R {field = [c]}) = 1
+ f (R {}) = 2
+ This shows up for TyCon.maybeTyConSingleCon
+
+* > module Main( main ) where
+
+ > f :: String -> Int
+ > f "=<" = 0
+ > f "=" = 0
+
+ > g :: [Char] -> Int
+ > g ['=','<'] = 0
+ > g ['='] = 0
+
+ > main = return ()
+
+ For ``f'' the following is reported.
+
+ tmp.lhs:4:
+ Pattern match(es) are overlapped in the definition of function `f'
+ "=" = ...
+
+ There are no complaints for definition for ``g''.
+
+* Without -O I don't think we need change the module version
+ if the usages change; I forget why it changes even with -O
+
+* Record selectors for existential type; no good! What to do?
+ Record update doesn't make sense either.
+
+ Need to be careful when figuring out strictness, and when generating
+ worker-wrapper split.
+
+ Also when deriving.
+
+* Consructor re-use via CSE
+
+ Notes on module dependencies
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The Name/Var/Type group is a bit complicated. Here's the deal
+
+ Name, PrimRep, FieldLabel (uses Type.Type)
+then
+ Var (uses Const.Con, IdInfo.IdInfo, Type.GenType, Type.Kind)
+then
+ VarEnv, VarSet
+then
+ Class (uses TyCon.TyCon, Type.Type, SpecEnv.SpecEnv)
+then
+ TyCon (uses Type.Type, Type.Kind, DataCon.DataCon)
+then
+ Type (uses [DataCon.DataCon])
+then
+ DataCon, TysPrim, Unify, SpecEnv, PprType
+then
+ IdInfo, TysWiredIn (uses DataCon.mkDataCon, [MkId.mkDataConId])
+then
+ PrimOp (uses PprType, TysWiredIn)
+then
+ Const (needs PrimOp, [TysWiredIn.stringTy])
+then
+ Id (needs Const.Con(..)), CoreSyn
+then
+ CoreUtils, OccurAnal
+then
+ CoreUnfold (uses OccurAnal)
+then
+ MkId (uses CoreUnfold)
+
+
+PrimOp uses TysWiredIn
+
+
+Add
+~~~
+basicTypes/DataCon.lhs
+basicTypes/DataCon.hi-boot
+
+Remove
+~~~~~~
+specialise/SpecUtils.lhs
+basicTypes/IdUtils.lhs
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.45 1998/08/21 11:03:30 sof Exp $
+# $Id: Makefile,v 1.46 1998/12/02 13:17:15 simonm Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
HS_SRCS = $(SRCS_UGNHS) \
- $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \
- rename/ParseIface.hs
+ $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs))
+
+ifneq "$(GhcWithHscBuiltViaC)" "YES"
+HS_SRCS += rename/ParseIface.hs
+endif
# NB: it's no good to include *.hs in the top-line wildcard, because the .hs files
# in parser/ may not have been created at that point.
HCS = $(patsubst %.lhs, %.hc, $(patsubst %.hs, %.hc, $(HS_SRCS)))
+# ParseIface.hs ain't part of HS_SRCS when this is on..
+ifeq "$(GhcWithHscBuiltViaC)" "YES"
+HCS += rename/ParseIface.hc
+endif
HS_OBJS = \
$(patsubst %.hc, %.o, $(HCS)) \
LIBOBJS = \
$(SRCS_UGN_OBJS) parser/hslexer.o parser/hsparser.tab.o \
parser/id.o parser/infix.o parser/syntax.o parser/type2context.o \
- parser/util.o
+ parser/util.o parser/ctypes.o
-#
# stuff you get for free in a source distribution
#
-SRC_DIST_FILES += rename/ParseIface.hs \
- parser/U_tree.c parser/tree.h parser/tree.c \
- parser/hsparser.tab.c parser/hsparser.tab.h \
- parser/hslexer.c
+# SRC_DIST_FILES += rename/ParseIface.hs \
+# parser/U_tree.c parser/tree.h parser/tree.c \
+# parser/hsparser.tab.c parser/hsparser.tab.h \
+# parser/hslexer.c
# -----------------------------------------------------------------------------
# Haskell compilations
basicTypes/IdInfo_HC_OPTS = -K2m
hsSyn/HsExpr_HC_OPTS = -K2m
main/Main_HC_OPTS = -fvia-C
+main/Constants_HC_OPTS = -DHscIfaceFileVersion=$(HscIfaceFileVersion)
+
+ifneq "$(GhcWithHscBuiltViaC)" "YES"
ifeq "$(GhcReportCompiles)" "YES"
main/Main_HC_OPTS += -syslib misc -DREPORT_TO_MOTHERLODE
endif
+endif
main/CmdLineOpts_HC_OPTS = -fvia-C
nativeGen/PprMach_HC_OPTS = -K2m
rename/RnNames_HC_OPTS = -H12m
rename/RnMonad_HC_OPTS = -fvia-C
specialise/Specialise_HC_OPTS = -Onot -H12m
+simplCore/Simplify_HC_OPTS = -H15m
typecheck/TcGenDeriv_HC_OPTS = -H10m
+# tmp, -- SDM
+specialise/Specialise_HC_OPTS += -fno-prune-tydecls
+
# Was 10m for 2.10
typecheck/TcHsSyn_HC_OPTS = -H15m
+
# Was 10m for 2.10
typecheck/TcExpr_HC_OPTS = -H15m
+typecheck/TcBinds_HC_OPTS = -H10m
typecheck/TcEnv_HC_OPTS = -H10m
utils/Argv_HC_OPTS = -fvia-C
parser/hschooks.o : parser/hschooks.c
@$(RM) $@
- $(HC) -c -o $@ $(HC_OPTS) parser/hschooks.c
+ $(HC) -c -o $@ -I$(GHC_INCLUDE_DIR) $(HC_OPTS) parser/hschooks.c
# Interface-file parser uses Happy
# Linking
SRC_LD_OPTS += -no-link-chk
+
+ifneq "$(GhcWithHscBuiltViaC)" "YES"
ifeq "$(GhcReportCompiles)" "YES"
SRC_LD_OPTS += -syslib misc -syslib exts
endif
+endif
#-----------------------------------------------------------------------------
# install
#
# Before doing `make depend', need to build all derived Haskell source files
#
-depend :: $(LOOPS) $(SRCS_UGNHS) rename/ParseIface.hs
+depend :: $(LOOPS) $(SRCS_UGNHS)
+
+ifneq "$(GhcWithHscBuiltViaC)" "YES"
+depend :: rename/ParseIface.hs
+endif
#-----------------------------------------------------------------------------
# clean
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: AbsCSyn.lhs,v 1.18 1998/12/02 13:17:16 simonm Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
-- registers
MagicId(..), node, infoptr,
- isVolatileReg, noLiveRegsMask, mkLiveRegsMask,
+ isVolatileReg,
CostRes(Cost)
)-} where
#include "HsVersions.h"
import {-# SOURCE #-} ClosureInfo ( ClosureInfo )
-import {-# SOURCE #-} CLabel ( CLabel )
#if ! OMIT_NATIVE_CODEGEN
import {-# SOURCE #-} MachMisc
#endif
+import CLabel
import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
- mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
- lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
- lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
- )
-import HeapOffs ( VirtualSpAOffset, VirtualSpBOffset,
- VirtualHeapOffset, HeapOffset
- )
-import CostCentre ( CostCentre )
-import Literal ( mkMachInt, Literal )
-import PrimRep ( isFollowableRep, PrimRep(..) )
+ mAX_Double_REG, spRelToInt )
+import CostCentre ( CostCentre, CostCentreStack )
+import Const ( mkMachInt, Literal )
+import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp )
import Unique ( Unique )
+import StgSyn ( SRT(..) )
+import BitSet -- for liveness masks
\end{code}
-- CSwitch m [(tag,code)] AbsCNop == code
| CCodeBlock CLabel AbstractC
- -- [amode analog: CLabelledCode]
-- A labelled block of code; this "statement" is not
-- executed; rather, the labelled code will be hoisted
-- out to the top level (out of line) & it can be
RegRelative -- address of the info ptr
CAddrMode -- cost centre to place in closure
-- CReg CurCostCentre or CC_HDR(R1.p{-Node-})
- Bool -- inplace update or allocate
| COpStmt
[CAddrMode] -- Results
PrimOp
[CAddrMode] -- Arguments
- Int -- Live registers (may be obtainable from volatility? ADR)
[MagicId] -- Potentially volatile/live registers
-- (to save/restore around the call/op)
-- For example { a := b, b := a }
-- needs to go via (at least one) temporary
+ | CCheck -- heap or stack checks, or both.
+ CCheckMacro -- These might include some code to fill in tags
+ [CAddrMode] -- on the stack, so we can't use CMacroStmt below.
+ AbstractC
+
+ | CRetDirect -- Direct return
+ Unique -- for making labels
+ AbstractC -- return code
+ (CLabel,SRT) -- SRT info
+ Liveness -- stack liveness at the return point
+
-- see the notes about these next few; they follow below...
| CMacroStmt CStmtMacro [CAddrMode]
| CCallProfCtrMacro FAST_STRING [CAddrMode]
| CStaticClosure
CLabel -- The (full, not base) label to use for labelling the closure.
ClosureInfo
- CAddrMode -- cost centre identifier to place in closure
- [CAddrMode] -- free vars; ptrs, then non-ptrs
+ CAddrMode -- cost centre identifier to place in closure
+ [CAddrMode] -- free vars; ptrs, then non-ptrs.
+ | CSRT CLabel [CLabel] -- SRT declarations: basically an array of
+ -- pointers to static closures.
+
+ | CBitmap CLabel LivenessMask -- A larger-than-32-bits bitmap.
| CClosureInfoAndCode
- ClosureInfo -- Explains placement and layout of closure
- AbstractC -- Slow entry point code
+ ClosureInfo -- Explains placement and layout of closure
+ AbstractC -- Slow entry point code
(Maybe AbstractC)
- -- Fast entry point code, if any
- CAddrMode -- Address of update code; Nothing => should never be used
- -- (which is the case for all except constructors)
- String -- Closure description; NB we can't get this from
- -- ClosureInfo, because the latter refers to the *right* hand
- -- side of a defn, whereas the "description" refers to *left*
- -- hand side
- Int -- Liveness info; this is here because it is
- -- easy to produce w/in the CgMonad; hard
- -- thereafter. (WDP 95/11)
-
- | CRetVector -- Return vector with "holes"
- -- (Nothings) for the default
- CLabel -- vector-table label
- [Maybe CAddrMode]
- AbstractC -- (and what to put in a "hole" [when Nothing])
-
- | CRetUnVector -- Direct return
- CLabel -- unvector-table label
- CAddrMode -- return code
-
- | CFlatRetVector -- A labelled block of static data
- CLabel -- This is the flattened version of CRetVector
+ -- Fast entry point code, if any
+ (CLabel,SRT) -- SRT info
+ String -- Closure description; NB we can't get this
+ -- from ClosureInfo, because the latter refers
+ -- to the *right* hand side of a defn, whereas
+ -- the "description" refers to *left* hand side
+
+ | CRetVector -- A labelled block of static data
+ CLabel
[CAddrMode]
+ (CLabel,SRT) -- SRT info
+ Liveness -- stack liveness at the return point
- | CCostCentreDecl -- A cost centre *declaration*
- Bool -- True <=> local => full declaration
- -- False <=> extern; just say so
+ | CCostCentreDecl -- A cost centre *declaration*
+ Bool -- True <=> local => full declaration
+ -- False <=> extern; just say so
CostCentre
- | CClosureUpdInfo
- AbstractC -- InRegs Info Table (CClosureInfoTable)
- -- ^^^^^^^^^^^^^^^^^
- -- out of date -- HWL
+ | CCostCentreStackDecl -- A cost centre stack *declaration*
+ CostCentreStack -- this is the declaration for a
+ -- pre-defined singleton CCS (see
+ -- CostCentre.lhs)
- | CSplitMarker -- Split into separate object modules here
+ | CSplitMarker -- Split into separate object modules here
\end{code}
About @CMacroStmt@, etc.: notionally, they all just call some
overflow. This enumeration type lists all such macros:
\begin{code}
data CStmtMacro
- = ARGS_CHK_A_LOAD_NODE
- | ARGS_CHK_A
- | ARGS_CHK_B_LOAD_NODE
- | ARGS_CHK_B
- | HEAP_CHK
- | STK_CHK
- | UPD_CAF
- | UPD_IND
- | UPD_INPLACE_NOPTRS
- | UPD_INPLACE_PTRS
- | UPD_BH_UPDATABLE
- | UPD_BH_SINGLE_ENTRY
- | PUSH_STD_UPD_FRAME
- | POP_STD_UPD_FRAME
- | SET_TAG
+ = ARGS_CHK -- arg satisfaction check
+ | ARGS_CHK_LOAD_NODE -- arg check for top-level functions
+ | UPD_CAF -- update CAF closure with indirection
+ | UPD_BH_UPDATABLE -- eager backholing
+ | UPD_BH_SINGLE_ENTRY -- more eager blackholing
+ | PUSH_UPD_FRAME -- push update frame
+ | PUSH_SEQ_FRAME -- push seq frame
+ | SET_TAG -- set TagReg if it exists
| GRAN_FETCH -- for GrAnSim only -- HWL
| GRAN_RESCHEDULE -- for GrAnSim only -- HWL
| GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
deriving Text
\end{code}
+Heap/Stack checks. There are far too many of these.
+
+\begin{code}
+data CCheckMacro
+
+ = HP_CHK_NP -- heap/stack checks when
+ | STK_CHK_NP -- node points to the closure
+ | HP_STK_CHK_NP
+ | HP_CHK_SEQ_NP -- for 'seq' style case alternatives
+
+ | HP_CHK -- heap/stack checks when
+ | STK_CHK -- node doesn't point
+ | HP_STK_CHK
+ -- case alternative heap checks:
+
+ | HP_CHK_NOREGS -- no registers live
+ | HP_CHK_UNPT_R1 -- R1 is boxed/unlifted
+ | HP_CHK_UNBX_R1 -- R1 is unboxed
+ | HP_CHK_F1 -- FloatReg1 (only) is live
+ | HP_CHK_D1 -- DblReg1 (only) is live
+ | HP_CHK_L1 -- LngReg1 (only) is live
+ | HP_CHK_UT_ALT -- unboxed tuple return.
+
+ | HP_CHK_GEN -- generic heap check
+ deriving Text
+\end{code}
+
\item[@CCallProfCtrMacro@:]
The @String@ names a macro that, if \tr{#define}d, will bump one/some
of the STG-event profiling counters.
cost-centre-profiling-related action.
\end{description}
-HERE ARE SOME OLD NOTES ABOUT HEAP-CHK ENTRY POINTS:
-
-\item[@CCallStgC@:]
-Some parts of the system, {\em notably the storage manager}, are
-implemented by C~routines that must know something about the internals
-of the STG world, e.g., where the heap-pointer is. (The
-``C-as-assembler'' documents describes this stuff in detail.)
-
-This is quite a tricky business, especially with ``optimised~C,'' so
-we keep close tabs on these fellows. This enumeration type lists all
-such ``STG~C'' routines:
-
-HERE ARE SOME *OLD* NOTES ABOUT HEAP-CHK ENTRY POINTS:
-
-Heap overflow invokes the garbage collector (of your choice :-), and
-we have different entry points, to tell the GC the exact configuration
-before it.
-\begin{description}
-\item[Branch of a boxed case:]
-The @Node@ register points off to somewhere legitimate, the @TagReg@
-holds the tag, and the @RetReg@ points to the code for the
-alterative which should be resumed. (ToDo: update)
-
-\item[Branch of an unboxed case:]
-The @Node@ register points nowhere of any particular interest, a
-kind-specific register (@IntReg@, @FloatReg@, etc.) holds the unboxed
-value, and the @RetReg@ points to the code for the alternative
-which should be resumed. (ToDo: update)
-
-\item[Closure entry:]
-The @Node@ register points to the closure, and the @RetReg@ points
-to the code to be resumed. (ToDo: update)
-\end{description}
-
%************************************************************************
%* *
\subsection[CAddrMode]{C addressing modes}
%* *
%************************************************************************
-Addressing modes: these have @PrimitiveKinds@ pinned on them.
\begin{code}
data CAddrMode
= CVal RegRelative PrimRep
-- native code.
| CLbl CLabel -- Labels in the runtime system, etc.
- -- See comment under CLabelledData about (String,Name)
PrimRep -- the kind is so we can generate accurate C decls
- | CUnVecLbl -- A choice of labels left up to the back end
- CLabel -- direct
- CLabel -- vectored
-
| CCharLike CAddrMode -- The address of a static char-like closure for
-- the specified character. It is guaranteed to be in
-- the range 0..255.
| CIntLike CAddrMode -- The address of a static int-like closure for the
- -- specified small integer. It is guaranteed to be in the
- -- range mIN_INTLIKE..mAX_INTLIKE
+ -- specified small integer. It is guaranteed to be in
+ -- the range mIN_INTLIKE..mAX_INTLIKE
| CString FAST_STRING -- The address of the null-terminated string
| CLit Literal
-- into the C output
PrimRep
- | COffset HeapOffset -- A literal constant, not an offset *from* anything!
- -- ToDo: this should really be CLitOffset
-
- | CCode AbstractC -- Some code. Used mainly for return addresses.
-
- | CLabelledCode CLabel AbstractC -- Almost defunct? (ToDo?) --JSM
- -- Some code that must have a particular label
- -- (which is jumpable to)
-
- | CJoinPoint -- This is used as the amode of a let-no-escape-bound variable
- VirtualSpAOffset -- SpA and SpB values after any volatile free vars
- VirtualSpBOffset -- of the rhs have been saved on stack.
- -- Just before the code for the thing is jumped to,
- -- SpA/B will be set to these values,
- -- and then any stack-passed args pushed,
- -- then the code for this thing will be entered
-
+ | CJoinPoint -- This is used as the amode of a let-no-escape-bound
+ -- variable.
+ VirtualSpOffset -- Sp value after any volatile free vars
+ -- of the rhs have been saved on stack.
+ -- Just before the code for the thing is jumped to,
+ -- Sp will be set to this value,
+ -- and then any stack-passed args pushed,
+ -- then the code for this thing will be entered
| CMacroExpr
- PrimRep -- the kind of the result
+ !PrimRep -- the kind of the result
CExprMacro -- the macro to generate a value
[CAddrMode] -- and its arguments
-
- | CCostCentre -- If Bool is True ==> it to be printed as a String,
- CostCentre -- (*not* as a C identifier or some such).
- Bool -- (It's not just the double-quotes on either side;
- -- spaces and other funny characters will have been
- -- fiddled in the non-String variant.)
-
-mkCCostCentre cc
- = --ASSERT(not (currentOrSubsumedCosts cc))
- --FALSE: We do put subsumedCC in static closures
- CCostCentre cc False
\end{code}
Various C macros for values which are dependent on the back-end layout.
\begin{code}
data CExprMacro
- = INFO_PTR
- | ENTRY_CODE
- | INFO_TAG
- | EVAL_TAG
+ = ENTRY_CODE
+ | ARG_TAG -- stack argument tagging
+ | GET_TAG -- get current constructor tag
deriving(Text)
\end{code}
-A tiny convenience:
+Convenience functions:
+
\begin{code}
mkIntCLit :: Int -> CAddrMode
mkIntCLit i = CLit (mkMachInt (toInteger i))
+
+mkCCostCentre :: CostCentre -> CAddrMode
+mkCCostCentre cc = CLbl (mkCC_Label cc) DataPtrRep
+
+mkCCostCentreStack :: CostCentreStack -> CAddrMode
+mkCCostCentreStack ccs = CLbl (mkCCS_Label ccs) DataPtrRep
\end{code}
%************************************************************************
\begin{code}
data RegRelative
- = HpRel VirtualHeapOffset -- virtual offset of Hp
- VirtualHeapOffset -- virtual offset of The Thing
- | SpARel VirtualSpAOffset -- virtual offset of SpA
- VirtualSpAOffset -- virtual offset of The Thing
- | SpBRel VirtualSpBOffset -- virtual offset of SpB
- VirtualSpBOffset -- virtual offset of The Thing
- | NodeRel VirtualHeapOffset
+ = HpRel FAST_INT -- }
+ | SpRel FAST_INT -- }- offsets in StgWords
+ | NodeRel FAST_INT -- }
data ReturnInfo
= DirectReturn -- Jump directly, if possible
| StaticVectoredReturn Int -- Fixed tag, starting at zero
| DynamicVectoredReturn CAddrMode -- Dynamic tag given by amode, starting at zero
+
+hpRel :: VirtualHeapOffset -- virtual offset of Hp
+ -> VirtualHeapOffset -- virtual offset of The Thing
+ -> RegRelative -- integer offset
+hpRel IBOX(hp) IBOX(off) = HpRel (hp _SUB_ off)
+
+spRel :: VirtualSpOffset -- virtual offset of Sp
+ -> VirtualSpOffset -- virtual offset of The Thing
+ -> RegRelative -- integer offset
+spRel sp off = SpRel (case spRelToInt sp off of { IBOX(i) -> i })
+
+nodeRel :: VirtualHeapOffset
+ -> RegRelative
+nodeRel IBOX(off) = NodeRel off
+
\end{code}
%************************************************************************
%* *
-\subsection[MagicId]{@MagicIds@: registers and such}
+\subsection[RegRelative]{@RegRelatives@: ???}
%* *
%************************************************************************
-Much of what happens in Abstract-C is in terms of ``magic'' locations,
-such as the stack pointer, heap pointer, etc. If possible, these will
-be held in registers.
+We represent liveness bitmaps as a BitSet (whose internal
+representation really is a bitmap). These are pinned onto case return
+vectors to indicate the state of the stack for the garbage collector.
-Here are some notes about what's active when:
-\begin{description}
-\item[Always active:]
- Hp, HpLim, SpA, SpB, SuA, SuB
+\begin{code}
+type LivenessMask = [BitSet]
-\item[Entry set:]
- ArgPtr1 (= Node)...
+data Liveness = LvSmall BitSet
+ | LvLarge CLabel
+\end{code}
-\item[Return set:]
-Ptr regs: RetPtr1 (= Node), RetPtr2...
-Int/char regs: RetData1 (= TagReg = IntReg), RetData2...
-Float regs: RetFloat1, ...
-Double regs: RetDouble1, ...
-\end{description}
+%************************************************************************
+%* *
+\subsection[HeapOffset]{@Heap Offsets@}
+%* *
+%************************************************************************
+
+This used to be a grotesquely complicated datatype in an attempt to
+hide the details of header sizes from the compiler itself. Now these
+constants are imported from the RTS, and we deal in real Ints.
+
+\begin{code}
+type HeapOffset = Int -- ToDo: remove
+
+type VirtualHeapOffset = HeapOffset
+type VirtualSpOffset = Int
+
+type HpRelOffset = HeapOffset
+type SpRelOffset = Int
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[MagicId]{@MagicIds@: registers and such}
+%* *
+%************************************************************************
\begin{code}
data MagicId
= BaseReg -- mentioned only in nativeGen
- | StkOReg -- mentioned only in nativeGen
-
-- Argument and return registers
| VanillaReg -- pointers, unboxed ints and chars
- PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or ForeignObjRep
- -- (in case we need to distinguish)
+ PrimRep
FAST_INT -- its number (1 .. mAX_Vanilla_REG)
- | FloatReg -- single-precision floating-point registers
+ | FloatReg -- single-precision floating-point registers
FAST_INT -- its number (1 .. mAX_Float_REG)
- | DoubleReg -- double-precision floating-point registers
+ | DoubleReg -- double-precision floating-point registers
FAST_INT -- its number (1 .. mAX_Double_REG)
+ -- STG registers
+ | Sp -- Stack ptr; points to last occupied stack location.
+ | Su -- Stack update frame pointer
+ | SpLim -- Stack limit
+ | Hp -- Heap ptr; points to last occupied heap location.
+ | HpLim -- Heap limit register
+ | CurCostCentre -- current cost centre register.
+ | VoidReg -- see "VoidPrim" type; just a placeholder;
+ -- no actual register
| LongReg -- long int registers (64-bit, really)
PrimRep -- Int64Rep or Word64Rep
FAST_INT -- its number (1 .. mAX_Long_REG)
- | TagReg -- to return constructor tags; as almost all returns are vectored,
- -- this is rarely used.
-
- | RetReg -- topmost return address from the B stack
-
- | SpA -- Stack ptr; points to last occupied stack location.
- -- Stack grows downward.
- | SuA -- mentioned only in nativeGen
-
- | SpB -- Basic values, return addresses and update frames.
- -- Grows upward.
- | SuB -- mentioned only in nativeGen
-
- | Hp -- Heap ptr; points to last occupied heap location.
- -- Free space at lower addresses.
-
- | HpLim -- Heap limit register: mentioned only in nativeGen
-
- | LivenessReg -- (parallel only) used when we need to record explicitly
- -- what registers are live
-
- | StdUpdRetVecReg -- mentioned only in nativeGen
- | StkStubReg -- register holding STK_STUB_closure (for stubbing dead stack slots)
-
- | CurCostCentre -- current cost centre register.
-
- | VoidReg -- see "VoidPrim" type; just a placeholder; no actual register
node = VanillaReg PtrRep ILIT(1) -- A convenient alias for Node
-infoptr = VanillaReg DataPtrRep ILIT(2) -- An alias for InfoPtr
-
---------------------
-noLiveRegsMask :: Int -- Mask indicating nothing live
-noLiveRegsMask = 0
-
-mkLiveRegsMask
- :: [MagicId] -- Candidate live regs; depends what they have in them
- -> Int
-
-mkLiveRegsMask regs
- = foldl do_reg noLiveRegsMask regs
- where
- do_reg acc (VanillaReg kind reg_no)
- | isFollowableRep kind
- = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
+tagreg = VanillaReg WordRep ILIT(2) -- A convenient alias for TagReg
- do_reg acc anything_else = acc
-
- reg_tbl -- ToDo: mk Array!
- = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
- lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
\end{code}
We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
reg1 == reg2 = tag reg1 _EQ_ tag reg2
where
tag BaseReg = (ILIT(0) :: FAST_INT)
- tag StkOReg = ILIT(1)
- tag TagReg = ILIT(2)
- tag RetReg = ILIT(3)
- tag SpA = ILIT(4)
- tag SuA = ILIT(5)
- tag SpB = ILIT(6)
- tag SuB = ILIT(7)
- tag Hp = ILIT(8)
- tag HpLim = ILIT(9)
- tag LivenessReg = ILIT(10)
- tag StdUpdRetVecReg = ILIT(12)
- tag StkStubReg = ILIT(13)
- tag CurCostCentre = ILIT(14)
- tag VoidReg = ILIT(15)
-
- tag reg =
- ILIT(15) _ADD_ (
- case reg of
- VanillaReg _ i -> i
- FloatReg i -> maxv _ADD_ i
- DoubleReg i -> maxv _ADD_ maxf _ADD_ i
- LongReg _ i -> maxv _ADD_ maxf _ADD_ maxd _ADD_ i
- )
- where
- maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
- maxf = case mAX_Float_REG of { IBOX(x) -> x }
- maxd = case mAX_Double_REG of { IBOX(x) -> x }
+ tag Sp = ILIT(1)
+ tag Su = ILIT(2)
+ tag SpLim = ILIT(3)
+ tag Hp = ILIT(4)
+ tag HpLim = ILIT(5)
+ tag CurCostCentre = ILIT(6)
+ tag VoidReg = ILIT(7)
+
+ tag (VanillaReg _ i) = ILIT(8) _ADD_ i
+
+ tag (FloatReg i) = ILIT(8) _ADD_ maxv _ADD_ i
+ tag (DoubleReg i) = ILIT(8) _ADD_ maxv _ADD_ maxf _ADD_ i
+ tag (LongReg _ i) = ILIT(8) _ADD_ maxv _ADD_ maxf _ADD_ maxd _ADD_ i
+
+ maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
+ maxf = case mAX_Float_REG of { IBOX(x) -> x }
+ maxd = case mAX_Double_REG of { IBOX(x) -> x }
\end{code}
Returns True for any register that {\em potentially} dies across
C calls (or anything near equivalent). We just say @True@ and
let the (machine-specific) registering macros sort things out...
+
\begin{code}
isVolatileReg :: MagicId -> Bool
-
isVolatileReg any = True
---isVolatileReg (FloatReg _) = True
---isVolatileReg (DoubleReg _) = True
\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsCSyn-printing]{Pretty-printing Abstract~C}
-%* *
-%************************************************************************
-
-It's in \tr{PprAbsC.lhs}.
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[AbsCUtils]{Help functions for Abstract~C datatype}
mkAbstractCs, mkAbsCStmts,
mkAlgAltsCSwitch,
magicIdPrimRep,
- getAmodeRep, amodeCanSurviveGC,
+ getAmodeRep,
mixedTypeLocn, mixedPtrLocn,
flattenAbsC,
mkAbsCStmtList
#include "HsVersions.h"
-import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel )
- -- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel)
-
import AbsCSyn
-
import Digraph ( stronglyConnComp, SCC(..) )
-import HeapOffs ( possiblyEqualHeapOffset )
-import Id ( fIRST_TAG, ConTag )
-import Literal ( literalPrimRep, Literal(..), mkMachWord )
+import DataCon ( fIRST_TAG, ConTag )
+import Const ( literalPrimRep, mkMachWord )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
-import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
-import Util ( assocDefaultUsing, panic )
+import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+ UniqSupply )
import CmdLineOpts ( opt_ProduceC )
import Maybes ( maybeToBool )
import PrimOp ( PrimOp(..) )
+import Util ( panic )
infixr 9 `thenFlt`
\end{code}
-- for fiddling around w/ killing off AbsCNops ... (ToDo)
mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
-mkAbsCStmts = AbsCStmts
+mkAbsCStmts AbsCNop c = c
+mkAbsCStmts c AbsCNop = c
+mkAbsCStmts c1 c2 = c1 `AbsCStmts` c2
{- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
= case (case (nonemptyAbsC abc2) of
-- We also need to convert to Literals to keep the CSwitch happy
adjust tagged_alts
- = [ (mkMachWord (fromInt (tag - fIRST_TAG)), abs_c) | (tag, abs_c) <- tagged_alts ]
+ = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
+ | (tag, abs_c) <- tagged_alts ]
\end{code}
%************************************************************************
\begin{code}
magicIdPrimRep BaseReg = PtrRep
-magicIdPrimRep StkOReg = PtrRep
-magicIdPrimRep (VanillaReg kind _) = kind
+magicIdPrimRep (VanillaReg kind _) = kind
magicIdPrimRep (FloatReg _) = FloatRep
magicIdPrimRep (DoubleReg _) = DoubleRep
magicIdPrimRep (LongReg kind _) = kind
-magicIdPrimRep TagReg = IntRep
-magicIdPrimRep RetReg = RetRep
-magicIdPrimRep SpA = PtrRep
-magicIdPrimRep SuA = PtrRep
-magicIdPrimRep SpB = PtrRep
-magicIdPrimRep SuB = PtrRep
+magicIdPrimRep Sp = PtrRep
+magicIdPrimRep Su = PtrRep
+magicIdPrimRep SpLim = PtrRep
magicIdPrimRep Hp = PtrRep
magicIdPrimRep HpLim = PtrRep
-magicIdPrimRep LivenessReg = IntRep
-magicIdPrimRep StdUpdRetVecReg = PtrRep
-magicIdPrimRep StkStubReg = PtrRep
magicIdPrimRep CurCostCentre = CostCentreRep
magicIdPrimRep VoidReg = VoidRep
\end{code}
getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
getAmodeRep (CTemp uniq kind) = kind
getAmodeRep (CLbl label kind) = kind
-getAmodeRep (CUnVecLbl _ _) = PtrRep
getAmodeRep (CCharLike _) = PtrRep
getAmodeRep (CIntLike _) = PtrRep
-getAmodeRep (CString _) = PtrRep
+getAmodeRep (CString _) = PtrRep
getAmodeRep (CLit lit) = literalPrimRep lit
getAmodeRep (CLitLit _ kind) = kind
-getAmodeRep (COffset _) = IntRep
-getAmodeRep (CCode abs_C) = CodePtrRep
-getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
getAmodeRep (CTableEntry _ _ kind) = kind
getAmodeRep (CMacroExpr kind _ _) = kind
#ifdef DEBUG
-getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
-getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
+getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
#endif
\end{code}
-@amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
-across a garbage collection. Used only for PrimOp arguments (not that
-it matters).
-
-\begin{code}
-amodeCanSurviveGC :: CAddrMode -> Bool
-
-amodeCanSurviveGC (CTableEntry base offset _)
- = amodeCanSurviveGC base && amodeCanSurviveGC offset
- -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
-
-amodeCanSurviveGC (CLbl _ _) = True
-amodeCanSurviveGC (CUnVecLbl _ _) = True
-amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg
-amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg
-amodeCanSurviveGC (CString _) = True
-amodeCanSurviveGC (CLit _) = True
-amodeCanSurviveGC (CLitLit _ _) = True
-amodeCanSurviveGC (COffset _) = True
-amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
-
-amodeCanSurviveGC _ = False
- -- there are some amodes that "cannot occur" as args
- -- to a PrimOp, but it is safe to return False (rather than panic)
-\end{code}
-
@mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
location; that is, one which can contain values of various types.
\begin{code}
mixedTypeLocn :: CAddrMode -> Bool
-mixedTypeLocn (CVal (NodeRel _) _) = True
-mixedTypeLocn (CVal (SpBRel _ _) _) = True
-mixedTypeLocn (CVal (HpRel _ _) _) = True
+mixedTypeLocn (CVal (NodeRel _) _) = True
+mixedTypeLocn (CVal (SpRel _) _) = True
+mixedTypeLocn (CVal (HpRel _) _) = True
mixedTypeLocn other = False -- All the rest
\end{code}
\begin{code}
mixedPtrLocn :: CAddrMode -> Bool
-mixedPtrLocn (CVal (SpARel _ _) _) = True
+mixedPtrLocn (CVal (SpRel _) _) = True
mixedPtrLocn other = False -- All the rest
\end{code}
\end{itemize}
The ``stuff to be carried up'' always includes a label: a
-@CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
+@CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
@CCodeBlock@. The latter turns into a C function, and is never
actually produced by the code generator. Rather it always starts life
-as a @CLabelledCode@ addressing mode; when such an addr mode is
+as a @CCodeBlock@ addressing mode; when such an addr mode is
flattened, the ``tops'' stuff is a @CCodeBlock@.
\begin{code}
%* *
%************************************************************************
-The flattener is monadised. It's just a @UniqueSupply@, along with a
-``come-back-to-here'' label to pin on heap and stack checks.
+The flattener is monadised. It's just a @UniqueSupply@.
\begin{code}
-type FlatM result
- = CLabel
- -> UniqSupply
- -> result
+type FlatM result = UniqSupply -> result
initFlt :: UniqSupply -> FlatM a -> a
-initFlt init_us m = m (panic "initFlt:CLabel") init_us
+initFlt init_us m = m init_us
{-# INLINE thenFlt #-}
{-# INLINE returnFlt #-}
thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
-thenFlt expr cont label us
+thenFlt expr cont us
= case (splitUniqSupply us) of { (s1, s2) ->
- case (expr label s1) of { result ->
- cont result label s2 }}
+ case (expr s1) of { result ->
+ cont result s2 }}
returnFlt :: a -> FlatM a
-returnFlt result label us = result
+returnFlt result us = result
mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
returnFlt (r1:rs1, r2:rs2)
getUniqFlt :: FlatM Unique
-getUniqFlt label us = getUnique us
+getUniqFlt us = uniqFromSupply us
getUniqsFlt :: Int -> FlatM [Unique]
-getUniqsFlt i label us = getUniques i us
-
-setLabelFlt :: CLabel -> FlatM a -> FlatM a
-setLabelFlt new_label cont label us = cont new_label us
-
-getLabelFlt :: FlatM CLabel
-getLabelFlt label us = label
+getUniqsFlt i us = uniqsFromSupply i us
\end{code}
%************************************************************************
\begin{code}
flatAbsC :: AbstractC
- -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
- AbstractC) -- Stuff to put at top level flattened]
+ -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
+ AbstractC) -- Stuff to put at top level flattened]
flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
returnFlt (mkAbsCStmts inline_s1 inline_s2,
mkAbsCStmts top_s1 top_s2)
-flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
+flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast srt descr)
= flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
- flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
- returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
- CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
+ returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
+ CClosureInfoAndCode cl_info slow_heres fast_heres srt descr]
)
- where
- flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
- flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
- flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
- returnFlt (Just heres, tops)
flatAbsC (CCodeBlock label abs_C)
= flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
-flatAbsC (CClosureUpdInfo info) = flatAbsC info
-
-flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
- = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
- returnFlt (AbsCNop, tops `mkAbsCStmts`
- CStaticClosure closure_lbl closure_info new_cc new_amodes)
-
-flatAbsC (CRetVector tbl_label stuff deflt)
- = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
- mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
- returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
- mkAbstractCs alt_tops,
- CFlatRetVector tbl_label alt_amodes])
-
- where
- do_deflt deflt = case nonemptyAbsC deflt of
- Nothing -> returnFlt (bogus_default_label, AbsCNop)
- Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
- -- CJump (CLabelledCode ...) case
-
- do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
- do_alt deflt_amode (Just alt) = flatAmode alt
-
- bogus_default_label = panic ("flatAbsC: CRetVector: default needed and not available")
-
-
-flatAbsC (CRetUnVector label amode)
- = flatAmode amode `thenFlt` \ (new_amode, tops) ->
- returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
-
-flatAbsC (CFlatRetVector label amodes)
- = flatAmodes amodes `thenFlt` \ (new_amodes, tops) ->
- returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
-
-flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat
- = returnFlt (AbsCNop, cc)
-
--- now the real stmts:
-
-flatAbsC (CAssign dest source)
- = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) ->
- flatAmode source `thenFlt` \ (src_amode, src_tops) ->
- returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
-
--- special case: jump to some anonymous code
-flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
-
-flatAbsC (CJump target)
- = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
- returnFlt ( CJump targ_amode, targ_tops )
-
-flatAbsC (CFallThrough target)
- = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
- returnFlt ( CFallThrough targ_amode, targ_tops )
-
-flatAbsC (CReturn target return_info)
- = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
- returnFlt ( CReturn targ_amode return_info, targ_tops )
+flatAbsC (CRetDirect uniq slow_code srt liveness)
+ = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
+ returnFlt (AbsCNop,
+ mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
flatAbsC (CSwitch discrim alts deflt)
- = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) ->
- mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
+ = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
returnFlt (
- CSwitch discrim_amode flat_alts flat_def_alt,
- mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
+ CSwitch discrim flat_alts flat_def_alt,
+ mkAbstractCs (def_tops : flat_alts_tops)
)
where
flat_alt (tag, absC)
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
-flatAbsC stmt@(CInitHdr a b cc u)
- = flatAmode cc `thenFlt` \ (new_cc, tops) ->
- returnFlt (CInitHdr a b new_cc u, tops)
-
-flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _ _ _) args liveness_mask vol_regs)
+flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _) args vol_regs)
| maybeToBool opt_ProduceC
- = flatAmodes results `thenFlt` \ (results_here, tops1) ->
- flatAmodes args `thenFlt` \ (args_here, tops2) ->
- let tdef = CCallTypedef td results args in
- returnFlt (COpStmt results_here td args_here liveness_mask vol_regs,
- mkAbsCStmts tdef (mkAbsCStmts tops1 tops2))
-
-flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
- = flatAmodes results `thenFlt` \ (results_here, tops1) ->
- flatAmodes args `thenFlt` \ (args_here, tops2) ->
- returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
- mkAbsCStmts tops1 tops2)
+ = returnFlt (stmt, tdef)
+ where
+ tdef = CCallTypedef td results args
flatAbsC stmt@(CSimultaneous abs_c)
= flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
returnFlt (new_stmts_here, tops)
-flatAbsC stmt@(CMacroStmt macro amodes)
- = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
- returnFlt (CMacroStmt macro amodes_here, tops)
-
-flatAbsC stmt@(CCallProfCtrMacro str amodes)
- = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
- returnFlt (CCallProfCtrMacro str amodes_here, tops)
-
-flatAbsC stmt@(CCallProfCCMacro str amodes)
- = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
- returnFlt (CCallProfCCMacro str amodes_here, tops)
-
-flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[flat-amodes]{Flattening addressing modes}
-%* *
-%************************************************************************
-
-\begin{code}
-flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
-
--- easy ones first
-flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop)
-
-flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(CString _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop)
-flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop)
-
--- CIntLike must be a literal -- no flattening
-flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop)
-
--- CCharLike may be arbitrary value -- have to flatten
-flatAmode amode@(CCharLike char)
- = flatAmode char `thenFlt` \ (flat_char, tops) ->
- returnFlt(CCharLike flat_char, tops)
-
-flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
-
-flatAmode (CLabelledCode label abs_C)
- -- Push the code (with this label) to the top level
- = flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
- returnFlt (CLbl label CodePtrRep,
- tops `mkAbsCStmts` CCodeBlock label body_code)
-
-flatAmode (CCode abs_C)
- = case mkAbsCStmtList abs_C of
- [CJump amode] -> flatAmode amode -- Elide redundant labels
- _ ->
- -- de-anonymous-ise the code and push it (labelled) to the top level
- getUniqFlt `thenFlt` \ new_uniq ->
- case (mkReturnPtLabel new_uniq) of { return_pt_label ->
- flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
- returnFlt (
- CLbl return_pt_label CodePtrRep,
- tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
- -- DO NOT TOUCH the stuff sent to the top...
- ) }
-
-flatAmode (CTableEntry base index kind)
- = flatAmode base `thenFlt` \ (base_amode, base_tops) ->
- flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
- returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
-
-flatAmode (CMacroExpr pk macro amodes)
- = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
- returnFlt ( CMacroExpr pk macro amodes_here, tops )
-
-flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
+flatAbsC stmt@(CCheck macro amodes code)
+ = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
+ returnFlt (CCheck macro amodes code_here, code_tops)
+
+-- Some statements need no flattening at all:
+flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CCallProfCtrMacro str amodes) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
+
+-- Some statements only make sense at the top level, so we always float
+-- them. This probably isn't necessary.
+flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
\end{code}
-And a convenient way to do a whole bunch of 'em.
\begin{code}
-flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
-
-flatAmodes [] = returnFlt ([], AbsCNop)
-
-flatAmodes amodes
- = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
- returnFlt (amodes_here, mkAbstractCs tops)
+flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
+flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
+flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
+ returnFlt (Just heres, tops)
\end{code}
%************************************************************************
s1 assigns to something s2 uses
that is, if s1 should *follow* s2 in the final order
-ADR Comment
-
-Wow - fancy stuff. But are we ever going to do anything other than
-assignments in parallel? If not, wouldn't it be simpler to generate
-the following:
-
- x1, x2, x3 = e1, e2, e3
-
- |
- |
- V
- { int t1 = e1;
- int t2 = e2;
- int t3 = e3;
- x1 = t1;
- x2 = t2;
- x3 = t3;
- }
-
-and leave it to the C compiler to figure out whether it needs al
-those variables.
-
-(Likewise, why not let the C compiler delete silly code like
-
- x = x
-
-for us?)
-
-tnemmoC RDA
-
\begin{code}
type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
-- for fast comparison
-- At the moment we put in just enough to catch the cases we want:
-- the second (destination) argument is always a CVal.
sameAmode (CReg r1) (CReg r2) = r1 == r2
-sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
-sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
+sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 _EQ_ r2
sameAmode other1 other2 = False
doSimultaneously1 :: [CVertex] -> FlatM AbstractC
in
returnFlt (CAssign the_temp src, CAssign dest the_temp)
- go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
+ go_via_temps (COpStmt dests op srcs vol_regs)
= getUniqsFlt (length dests) `thenFlt` \ uniqs ->
let
the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
in
- returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
+ returnFlt (COpStmt the_temps op srcs vol_regs,
mkAbstractCs (zipWith CAssign dests the_temps))
in
mapFlt do_component components `thenFlt` \ abs_cs ->
should_follow :: AbstractC -> AbstractC -> Bool
(CAssign dest1 _) `should_follow` (CAssign _ src2)
= dest1 `conflictsWith` src2
- (COpStmt dests1 _ _ _ _) `should_follow` (CAssign _ src2)
+ (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1]
- (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _ _)
+ (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
= or [dest1 `conflictsWith` src2 | src2 <- srcs2]
- (COpStmt dests1 _ _ _ _) `should_follow` (COpStmt _ _ srcs2 _ _)
+ (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
-regConflictsWithRR SpA (SpARel _ _) = True
-regConflictsWithRR SpB (SpBRel _ _) = True
-regConflictsWithRR Hp (HpRel _ _) = True
+regConflictsWithRR Sp (SpRel _) = True
+regConflictsWithRR Hp (HpRel _) = True
regConflictsWithRR _ _ = False
rrConflictsWithRR :: Int -> Int -- Sizes of two things
-> RegRelative -> RegRelative -- The two amodes
-> Bool
-rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
+rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2
where
- rr (SpARel p1 o1) (SpARel p2 o2)
- | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
- | s1 == 1 && s2 == 1 = b1 == b2
- | otherwise = (b1+s1) >= b2 &&
- (b2+s2) >= b1
- where
- b1 = p1-o1
- b2 = p2-o2
-
- rr (SpBRel p1 o1) (SpBRel p2 o2)
- | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
- | s1 == 1 && s2 == 1 = b1 == b2
- | otherwise = (b1+s1) >= b2 &&
- (b2+s2) >= b1
- where
- b1 = p1-o1
- b2 = p2-o2
+ rr (SpRel o1) (SpRel o2)
+ | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
+ | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
+ | otherwise = (o1 _ADD_ s1) _GE_ o2 &&
+ (o2 _ADD_ s2) _GE_ o1
rr (NodeRel o1) (NodeRel o2)
- | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
- | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
+ | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
+ | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
| otherwise = True -- Give up
- rr (HpRel _ _) (HpRel _ _) = True -- Give up
+ rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
- rr other1 other2 = False
+ rr other1 other2 = False
\end{code}
+++ /dev/null
-_interface_ CLabel 1
-_exports_
-CLabel CLabel mkReturnPtLabel;
-_declarations_
-1 data CLabel;
-1 mkReturnPtLabel _:_ Unique.Unique -> CLabel ;;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CLabel.lhs,v 1.21 1998/12/02 13:17:19 simonm Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
CLabel, -- abstract type
mkClosureLabel,
+ mkSRTLabel,
mkInfoTableLabel,
mkStdEntryLabel,
mkFastEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
mkConInfoTableLabel,
- mkPhantomInfoTableLabel,
mkStaticClosureLabel,
mkStaticInfoTableLabel,
- mkVapEntryLabel,
- mkVapInfoTableLabel,
-
- mkConUpdCodePtrVecLabel,
- mkStdUpdCodePtrVecLabel,
-
- mkInfoTableVecTblLabel,
- mkStdUpdVecTblLabel,
+ mkApEntryLabel,
+ mkApInfoTableLabel,
mkReturnPtLabel,
+ mkReturnInfoLabel,
mkVecTblLabel,
mkAltLabel,
mkDefaultLabel,
+ mkBitmapLabel,
+
+ mkClosureTblLabel,
mkAsmTempLabel,
mkErrorStdEntryLabel,
+ mkUpdEntryLabel,
mkBlackHoleInfoTableLabel,
+ mkRtsPrimOpLabel,
+
+ mkSelectorInfoLabel,
+ mkSelectorEntryLabel,
+ mkCC_Label, mkCCS_Label,
+
needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
+ CLabelType(..), labelType,
+
pprCLabel
#if ! OMIT_NATIVE_CODEGEN
, pprCLabel_asm
import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
#endif
-import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
import CStrings ( pp_cSEP )
-import Id ( externallyVisibleId,
- isDataCon,
- fIRST_TAG,
- ConTag,
- Id
- )
-import Maybes ( maybeToBool )
-import PprType ( showTyCon )
+import DataCon ( ConTag, DataCon )
+import Name ( Name, isExternallyVisibleName )
import TyCon ( TyCon )
-import Unique ( showUnique, pprUnique, Unique )
-import Util ( assertPanic{-, pprTraceToDo:rm-} )
+import Unique ( pprUnique, Unique )
+import PrimOp ( PrimOp, pprPrimOp )
+import CostCentre ( CostCentre, CostCentreStack )
+import Util
import Outputable
\end{code}
* does it need declarations at all? (v common Prelude things are pre-declared)
+* what type does it have? (for generating accurate enough C declarations
+ so that the C compiler won't complain).
+
\begin{code}
data CLabel
= IdLabel -- A family of labels related to the
- CLabelId -- definition of a particular Id
- IdLabelInfo -- Includes DataCon
+ Name -- definition of a particular Id
+ IdLabelInfo
- | TyConLabel -- A family of labels related to the
- TyCon -- definition of a data type
- TyConLabelInfo
+ | DataConLabel -- Ditto data constructors
+ Name
+ DataConLabelInfo
| CaseLabel -- A family of labels related to a particular case expression
Unique -- Unique says which case expression
CaseLabelInfo
+ | TyConLabel TyCon -- currently only one kind of TyconLabel,
+ -- a 'Closure Table'.
+
| AsmTempLabel Unique
| RtsLabel RtsLabelInfo
- deriving (Eq, Ord)
-\end{code}
-
-The CLabelId is simply so we can declare alternative Eq and Ord
-instances which use cmpId_SpecDataCon (instead of cmpId). This avoids
-comparing the Uniques of two specialised data constructors (which have
-the same as the uniques their respective unspecialised data
-constructors). Instead, the specialising types and the uniques of the
-unspecialised constructors are compared.
+ | CC_Label CostCentre
+ | CCS_Label CostCentreStack
-\begin{code}
-data CLabelId = CLabelId Id
-
-instance Eq CLabelId where
- CLabelId a == CLabelId b = case (a `compare` b) of { EQ -> True; _ -> False }
- CLabelId a /= CLabelId b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord CLabelId where
- CLabelId a <= CLabelId b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- CLabelId a < CLabelId b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- CLabelId a > CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare (CLabelId a) (CLabelId b) = a `compare` b
+ deriving (Eq, Ord)
\end{code}
\begin{code}
data IdLabelInfo
= Closure -- Label for (static???) closure
- | StaticClosure -- Static closure -- e.g., nullary constructor
+
+ | SRT -- Static reference table
| InfoTbl -- Info table for a closure; always read-only
- | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check)
+ | EntryStd -- Thunk, or "slow", code entry point
+
| EntryFast Int -- entry pt when no arg satisfaction chk needed;
-- Int is the arity of the function (to be
-- encoded into the name)
- | ConEntry -- the only kind of entry pt for constructors
+ -- Ticky-ticky counting
+ | RednCounts -- Label of place to keep reduction-count info for
+ -- this Id
+ deriving (Eq, Ord)
+
+data DataConLabelInfo
+ = ConEntry -- the only kind of entry pt for constructors
| ConInfoTbl -- corresponding info table
+ | StaticClosure -- Static constructor closure
+ -- e.g., nullary constructor
| StaticConEntry -- static constructor entry point
| StaticInfoTbl -- corresponding info table
-
- | PhantomInfoTbl -- for phantom constructors that only exist in regs
-
- | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
- | VapEntry Bool
-
- -- Ticky-ticky counting
- | RednCounts -- Label of place to keep reduction-count info for this Id
- deriving (Eq, Ord)
-
-
-data TyConLabelInfo
- = UnvecConUpdCode -- Update code for the data type if it's unvectored
-
- | VecConUpdCode ConTag -- One for each constructor which returns in
- -- regs; this code actually performs an update
-
- | StdUpdCode ConTag -- Update code for all constructors which return
- -- in heap. There are a small number of variants,
- -- so that the update code returns (vectored/n or
- -- unvectored) in the right way.
- -- ToDo: maybe replace TyCon/Int with return conv.
-
- | InfoTblVecTbl -- For tables of info tables
-
- | StdUpdVecTbl -- Labels the update code, or table of update codes,
- -- for a particular type.
deriving (Eq, Ord)
data CaseLabelInfo
= CaseReturnPt
+ | CaseReturnInfo
| CaseVecTbl
| CaseAlt ConTag
| CaseDefault
+ | CaseBitmap
deriving (Eq, Ord)
data RtsLabelInfo
| RtsBlackHoleInfoTbl
- | RtsSelectorInfoTbl -- Selectors
- Bool -- True <=> the update-reqd version;
- -- False <=> the no-update-reqd version
- Int -- 0-indexed Offset from the "goods"
+ | RtsUpdEntry
+
+ | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks
+ | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
+
+ | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks
+ | RtsApEntry Bool{-updatable-} Int{-arity-}
+
+ | RtsPrimOp PrimOp
- | RtsSelectorEntry -- Ditto entry code
- Bool
- Int
deriving (Eq, Ord)
+
+-- Label Type: for generating C declarations.
+
+data CLabelType
+ = InfoTblType
+ | ClosureType
+ | VecTblType
+ | CodeType
+ | DataType
\end{code}
\begin{code}
-mkClosureLabel id = IdLabel (CLabelId id) Closure
-mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
-mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
+mkClosureLabel id = IdLabel id Closure
+mkSRTLabel id = IdLabel id SRT
+mkInfoTableLabel id = IdLabel id InfoTbl
+mkStdEntryLabel id = IdLabel id EntryStd
mkFastEntryLabel id arity = ASSERT(arity > 0)
- IdLabel (CLabelId id) (EntryFast arity)
-
-mkStaticClosureLabel con = ASSERT(isDataCon con)
- IdLabel (CLabelId con) StaticClosure
-mkStaticInfoTableLabel con = ASSERT(isDataCon con)
- IdLabel (CLabelId con) StaticInfoTbl
-mkConInfoTableLabel con = ASSERT(isDataCon con)
- IdLabel (CLabelId con) ConInfoTbl
-mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
- IdLabel (CLabelId con) PhantomInfoTbl
-mkConEntryLabel con = ASSERT(isDataCon con)
- IdLabel (CLabelId con) ConEntry
-mkStaticConEntryLabel con = ASSERT(isDataCon con)
- IdLabel (CLabelId con) StaticConEntry
-
-mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
-mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
-mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
-
-mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
-mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
-
-mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl
-mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl
+ IdLabel id (EntryFast arity)
+
+mkRednCountsLabel id = IdLabel id RednCounts
+
+mkStaticClosureLabel con = DataConLabel con StaticClosure
+mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl
+mkConInfoTableLabel con = DataConLabel con ConInfoTbl
+mkConEntryLabel con = DataConLabel con ConEntry
+mkStaticConEntryLabel con = DataConLabel con StaticConEntry
+
mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
+mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
mkDefaultLabel uniq = CaseLabel uniq CaseDefault
+mkBitmapLabel uniq = CaseLabel uniq CaseBitmap
+
+mkClosureTblLabel tycon = TyConLabel tycon
mkAsmTempLabel = AsmTempLabel
-- Some fixed runtime system labels
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
+mkUpdEntryLabel = RtsLabel RtsUpdEntry
mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
+mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
+
+mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off)
+mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off)
+
+mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off)
+mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
+
+ -- Cost centres etc.
+
+mkCC_Label cc = CC_Label cc
+mkCCS_Label ccs = CCS_Label ccs
\end{code}
\begin{code}
Declarations for (non-prelude) @Id@-based things are needed because of
mutual recursion.
-\begin{code}
-needsCDecl (IdLabel _ _) = True
-needsCDecl (CaseLabel _ _) = False
-
-needsCDecl (TyConLabel _ (StdUpdCode _)) = False
-needsCDecl (TyConLabel _ InfoTblVecTbl) = False
-needsCDecl (TyConLabel _ other) = True
-needsCDecl (AsmTempLabel _) = False
-needsCDecl (RtsLabel _) = False
+Declarations for direct return points are needed, because they may be
+let-no-escapes, which can be recursive.
-needsCDecl other = True
+\begin{code}
+needsCDecl (IdLabel _ _) = True
+needsCDecl (CaseLabel _ CaseReturnPt) = True
+needsCDecl (DataConLabel _ _) = True
+needsCDecl (CaseLabel _ _) = False
+
+needsCDecl (AsmTempLabel _) = False
+needsCDecl (TyConLabel _) = False
+needsCDecl (RtsLabel _) = False
+needsCDecl (CC_Label _) = False
+needsCDecl (CCS_Label _) = False
\end{code}
Whether the labelled thing can be put in C "text space":
+
\begin{code}
-isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
-isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
-isReadOnly (IdLabel _ StaticInfoTbl) = True
-isReadOnly (IdLabel _ PhantomInfoTbl) = True
-isReadOnly (IdLabel _ (VapInfoTbl _)) = True
-isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
-
-isReadOnly (TyConLabel _ _) = True
-isReadOnly (CaseLabel _ _) = True
-isReadOnly (AsmTempLabel _) = True
-isReadOnly (RtsLabel _) = True
+isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
+isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
+
+isReadOnly (DataConLabel _ _) = True -- and so on, for other
+isReadOnly (TyConLabel _) = True
+isReadOnly (CaseLabel _ _) = True
+isReadOnly (AsmTempLabel _) = True
+isReadOnly (RtsLabel _) = True
+isReadOnly (CC_Label _) = True
+isReadOnly (CCS_Label _) = True
\end{code}
Whether the label is an assembler temporary:
+
\begin{code}
isAsmTemp (AsmTempLabel _) = True
isAsmTemp _ = False
C ``static'' or not...
From the point of view of the code generator, a name is
-externally visible if it should be given put in the .o file's
-symbol table; that is, made static.
+externally visible if it has to be declared as exported
+in the .o file's symbol table; that is, made non-static.
+
+\begin{code}
+externallyVisibleCLabel (DataConLabel _ _) = True
+externallyVisibleCLabel (TyConLabel tc) = True
+externallyVisibleCLabel (CaseLabel _ _) = False
+externallyVisibleCLabel (AsmTempLabel _) = False
+externallyVisibleCLabel (RtsLabel _) = True
+externallyVisibleCLabel (IdLabel id _) = isExternallyVisibleName id
+externallyVisibleCLabel (CC_Label _) = False -- not strictly true
+externallyVisibleCLabel (CCS_Label _) = False -- not strictly true
+\end{code}
+
+For generating correct types in label declarations...
\begin{code}
-externallyVisibleCLabel (TyConLabel tc _) = True
-externallyVisibleCLabel (CaseLabel _ _) = False
-externallyVisibleCLabel (AsmTempLabel _) = False
-externallyVisibleCLabel (RtsLabel _) = True
-externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
+labelType :: CLabel -> CLabelType
+labelType (RtsLabel RtsBlackHoleInfoTbl) = InfoTblType
+labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
+labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType
+labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
+labelType (CaseLabel _ CaseReturnPt) = CodeType
+labelType (CaseLabel _ CaseVecTbl) = VecTblType
+
+labelType (IdLabel _ info) =
+ case info of
+ InfoTbl -> InfoTblType
+ Closure -> ClosureType
+ _ -> CodeType
+
+labelType (DataConLabel _ info) =
+ case info of
+ ConInfoTbl -> InfoTblType
+ StaticInfoTbl -> InfoTblType
+ StaticClosure -> ClosureType
+ _ -> CodeType
+
+labelType _ = DataType
\end{code}
OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
duplicate declarations in generating C (see @labelSeenTE@ in
@PprAbsC@).
+-----------------------------------------------------------------------------
+Printing out CLabels.
+
+Convention:
+
+ <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+ info Info table
+ srt Static reference table
+ entry Entry code
+ ret Direct return address
+ vtbl Vector table
+ <n>_alt Case alternative (tag n)
+ dflt Default case alternative
+ btm Large bitmap vector
+ closure Static closure
+ static_closure Static closure (???)
+ con_entry Dynamic Constructor entry code
+ con_info Dynamic Constructor info table
+ static_entry Static Constructor entry code
+ static_info Static Constructor info table
+ sel_info Selector info table
+ sel_entry Selector entry code
+
\begin{code}
-- specialised for PprAsm: saves lots of arg passing in NCG
#if ! OMIT_NATIVE_CODEGEN
#if ! OMIT_NATIVE_CODEGEN
pprCLabel (AsmTempLabel u)
- = text (fmtAsmLbl (showUnique u))
+ = text (fmtAsmLbl (show u))
#endif
pprCLabel lbl =
#endif
pprCLbl lbl
-
-pprCLbl (TyConLabel tc UnvecConUpdCode)
- = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc,
- pp_cSEP, ptext SLIT("upd")]
-
-pprCLbl (TyConLabel tc (VecConUpdCode tag))
- = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP,
- int tag, pp_cSEP, ptext SLIT("upd")]
-
-pprCLbl (TyConLabel tc (StdUpdCode tag))
- = case (ctrlReturnConvAlg tc) of
- UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
- VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
-
-pprCLbl (TyConLabel tc InfoTblVecTbl)
- = hcat [ppr_tycon tc, pp_cSEP, ptext SLIT("itblvtbl")]
-
-pprCLbl (TyConLabel tc StdUpdVecTbl)
- = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc,
- pp_cSEP, ptext SLIT("upd")]
-
pprCLbl (CaseLabel u CaseReturnPt)
- = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
+ = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
+pprCLbl (CaseLabel u CaseReturnInfo)
+ = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
pprCLbl (CaseLabel u CaseVecTbl)
- = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
+ = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
pprCLbl (CaseLabel u (CaseAlt tag))
- = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
+ = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
pprCLbl (CaseLabel u CaseDefault)
- = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
+ = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
+pprCLbl (CaseLabel u CaseBitmap)
+ = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
+
+pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
-pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
+pprCLbl (RtsLabel RtsUpdEntry) = ptext SLIT("Upd_frame_entry")
-pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
+pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BLACKHOLE_info")
pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
- = hcat [ptext SLIT("__sel_info_"), text (show offset),
- ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
- ptext SLIT("__")]
+ = hcat [ptext SLIT("__sel_"), text (show offset),
+ ptext (if upd_reqd
+ then SLIT("_upd_info")
+ else SLIT("_noupd_info"))
+ ]
pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
- = hcat [ptext SLIT("__sel_entry_"), text (show offset),
- ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
- ptext SLIT("__")]
-
-pprCLbl (IdLabel (CLabelId id) flavor)
- = ppr id <> ppFlavor flavor
-
-
-ppr_u u = pprUnique u
-
-ppr_tycon :: TyCon -> SDoc
-ppr_tycon tc = ppr tc
-{-
- = let
- str = showTyCon tc
- in
- --pprTrace "ppr_tycon:" (text str) $
- text str
--}
-
-ppFlavor :: IdLabelInfo -> SDoc
-
-ppFlavor x = (<>) pp_cSEP
- (case x of
+ = hcat [ptext SLIT("__sel_"), text (show offset),
+ ptext (if upd_reqd
+ then SLIT("_upd_entry")
+ else SLIT("_noupd_entry"))
+ ]
+
+pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
+ = hcat [ptext SLIT("__ap_"), text (show arity),
+ ptext (if upd_reqd
+ then SLIT("_upd_info")
+ else SLIT("_noupd_info"))
+ ]
+
+pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
+ = hcat [ptext SLIT("__ap_"), text (show arity),
+ ptext (if upd_reqd
+ then SLIT("_upd_entry")
+ else SLIT("_noupd_entry"))
+ ]
+
+pprCLbl (RtsLabel (RtsPrimOp primop))
+ = pprPrimOp primop <> ptext SLIT("_fast")
+
+pprCLbl (TyConLabel tc)
+ = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
+
+pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor
+pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
+
+pprCLbl (CC_Label cc) = ppr cc
+pprCLbl (CCS_Label ccs) = ppr ccs
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+
+ppIdFlavor x = pp_cSEP <>
+ (case x of
Closure -> ptext SLIT("closure")
+ SRT -> ptext SLIT("srt")
InfoTbl -> ptext SLIT("info")
EntryStd -> ptext SLIT("entry")
EntryFast arity -> --false:ASSERT (arity > 0)
(<>) (ptext SLIT("fast")) (int arity)
+ RednCounts -> ptext SLIT("ct")
+ )
+
+ppConFlavor x = pp_cSEP <>
+ (case x of
StaticClosure -> ptext SLIT("static_closure")
ConEntry -> ptext SLIT("con_entry")
ConInfoTbl -> ptext SLIT("con_info")
StaticConEntry -> ptext SLIT("static_entry")
StaticInfoTbl -> ptext SLIT("static_info")
- PhantomInfoTbl -> ptext SLIT("inregs_info")
- VapInfoTbl True -> ptext SLIT("vap_info")
- VapInfoTbl False -> ptext SLIT("vap_noupd_info")
- VapEntry True -> ptext SLIT("vap_entry")
- VapEntry False -> ptext SLIT("vap_noupd_entry")
- RednCounts -> ptext SLIT("ct")
- )
+ )
\end{code}
+
char_to_c '+' = ptext SLIT("Zp")
char_to_c '\'' = ptext SLIT("Zq")
char_to_c '*' = ptext SLIT("Zt")
- char_to_c '_' = ptext SLIT("Zu")
+ char_to_c '_' = ptext SLIT("_")
char_to_c c = if isAlphanum c
then char c
- else (<>) (char 'Z') (int (ord c))
+ else char 'Z' <> int (ord c)
\end{code}
For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
(
CallConv
, pprCallConv
+ , callConvToInt
, stdCallConv
, cCallConv
type CallConv = Int
pprCallConv :: CallConv -> SDoc
-pprCallConv 0 = ptext SLIT("_stdcall")
+pprCallConv 0 = ptext SLIT("__stdcall")
pprCallConv _ = ptext SLIT("_ccall")
stdCallConv :: CallConv
defaultCallConv :: CallConv
defaultCallConv = cCallConv
+
+callConvToInt :: CallConv -> Int
+callConvToInt x = x
\end{code}
Generate the gcc attribute corresponding to the given
\begin{code}
decorateExtName :: CallConv -> FAST_STRING -> [PrimRep] -> FAST_STRING
decorateExtName cc fs ps
-{- ifdef COMPILING_WIN32 -}
| cc /= stdCallConv = fs
| otherwise = fs _APPEND_ (_PK_ ('@':show (size::Int)))
-{- else
- = fs
--}
where
size = sum (map (adjustParamSize.getPrimRepSizeInBytes) ps)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
% Hans Wolfgang Loidl
%
% ---------------------------------------------------------------------------
import Util ( trace )
-- --------------------------------------------------------------------------
-newtype CostRes = Cost (Int, Int, Int, Int, Int)
+data CostRes = Cost (Int, Int, Int, Int, Int)
deriving (Text)
nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes
CCodeBlock _ absC -> costs absC
- CInitHdr cl_info reg_rel cost_centre inplace_upd -> initHdrCosts
+ CInitHdr cl_info reg_rel cost_centre -> initHdrCosts
{- This is more fancy but superflous: The addr modes
are fixed and so the costs are const!
For costing the args of this macro
see PprAbsC.lhs where args are inserted -}
- COpStmt modes_res primOp modes_args _ _ ->
+ COpStmt modes_res primOp modes_args _ ->
{-
let
n = length modes_res
CSimultaneous absC -> costs absC
+ CCheck _ amodes code -> Cost (2, 1, 0, 0, 0)
+
CMacroStmt macro modes -> stmtMacroCosts macro modes
CCallProfCtrMacro _ _ -> nullCosts
CStaticClosure _ _ _ _ -> nullCosts
- CClosureInfoAndCode _ _ _ _ _ _ -> nullCosts
-
- CRetVector _ _ _ -> nullCosts
+ CClosureInfoAndCode _ _ _ _ _ -> nullCosts
- CRetUnVector _ _ -> nullCosts
+ CRetDirect _ _ _ _ -> nullCosts
- CFlatRetVector _ _ -> nullCosts
+ CRetVector _ _ _ _ -> nullCosts
CCostCentreDecl _ _ -> nullCosts
-
- CClosureUpdInfo _ -> nullCosts
+ CCostCentreStackDecl _ -> nullCosts
CSplitMarker -> nullCosts
-- Rhs: typically: sethi %hi(lbl),%tmp_reg
-- or %tmp_reg,%lo(lbl),%target_reg
- CUnVecLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (2, 0, 0, 0, 0)
- -- same as CLbl
-
-- Check the following 3 (checked form CLit on)
CCharLike mode -> if lhs then Cost (0, 0, 0, 1, 0)
else Cost (1, 0, 0, 0, 0)
-- same es CLit
- COffset _ -> if lhs then nullCosts
- else Cost (1, 0, 0, 0, 0)
- -- same es CLit
-
- CCode absC -> costs absC
-
- CLabelledCode _ absC -> costs absC
-
- CJoinPoint _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
+ CJoinPoint _ -> if lhs then Cost (0, 0, 0, 1, 0)
else Cost (0, 0, 1, 0, 0)
CMacroExpr _ macro mode_list -> exprMacroCosts side macro mode_list
- CCostCentre _ _ -> nullCosts
-
-- ---------------------------------------------------------------------------
exprMacroCosts :: Side -> CExprMacro -> [CAddrMode] -> CostRes
in
arg_costs +
case macro of
- INFO_PTR -> if side == Lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
ENTRY_CODE -> nullCosts
- INFO_TAG -> if side == Lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
- EVAL_TAG -> if side == Lhs then Cost (1, 0, 0, 1, 0)
- else Cost (1, 0, 1, 0, 0)
- -- costs of INFO_TAG + (1,0,0,0,0)
+ ARG_TAG -> nullCosts -- XXX
+ GET_TAG -> nullCosts -- XXX
+
-- ---------------------------------------------------------------------------
[addrModeCosts mode Rhs | mode <- modes]
in
case macro of
- ARGS_CHK_A_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
+ ARGS_CHK_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
-- p=probability of PAP (instead of AP): + p*(3,1,0,0,0)
- ARGS_CHK_A -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- -- p=probability of PAP (instead of AP): + p*(0,1,0,0,0)
- ARGS_CHK_B_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- ARGS_CHK_B -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- HEAP_CHK -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- -- STK_CHK -> (2, 1, 0, 0, 0) {- StgMacros.lh -}
- STK_CHK -> Cost (0, 0, 0, 0, 0) {- StgMacros.lh -}
+ ARGS_CHK -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -}
- UPD_IND -> Cost (8, 2, 2, 0, 0) {- SMupdate.lh
- updatee in old-gen: Cost (4, 1, 1, 0, 0)
- updatee in new-gen: Cost (4, 1, 1, 0, 0)
- NB: we include costs fo checking if there is
- a BQ, but we omit costs for awakening BQ
- (these probably differ between old-gen and
- new gen) -}
- UPD_INPLACE_NOPTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh
- common for both: Cost (4, 1, 1, 0, 0)
- updatee in old-gen: Cost (14, 3, 2, 4, 0)
- updatee in new-gen: Cost (4, 1, 1, 0, 0) -}
- UPD_INPLACE_PTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh
- common for both: Cost (4, 1, 1, 0, 0)
- updatee in old-gen: Cost (14, 3, 2, 4, 0)
- updatee in new-gen: Cost (4, 1, 1, 0, 0) -}
-
UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
- PUSH_STD_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -}
- POP_STD_UPD_FRAME -> Cost (1, 0, 3, 0, 0) {- SMupdate.lh -}
+ PUSH_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -}
SET_TAG -> nullCosts {- COptRegs.lh -}
GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
-- Special cases
-primOpCosts (CCallOp _ _ _ _ _ _) = SAVE_COSTS + RESTORE_COSTS
+primOpCosts (CCallOp _ _ _ _) = SAVE_COSTS + RESTORE_COSTS
-- don't guess costs of ccall proper
-- for exact costing use a GRAN_EXEC
-- in the C code
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[HeapOffs]{Abstract C: heap offsets}
-
-Part of ``Abstract C.'' Heap offsets---main point: they are {\em
-symbolic}---are sufficiently turgid that they get their own module.
-
-INTERNAL MODULE: should be accessed via @AbsCSyn.hi@.
-
-\begin{code}
-module HeapOffs (
- HeapOffset,
-
- zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize,
- maxOff, addOff, subOff,
- isZeroOff, possiblyEqualHeapOffset,
-
- pprHeapOffset,
-
- intOffsetIntoGoods,
-
-#if ! OMIT_NATIVE_CODEGEN
- hpRelToInt,
-#endif
-
- VirtualHeapOffset, HpRelOffset,
- VirtualSpAOffset, VirtualSpBOffset,
- SpARelOffset, SpBRelOffset
- ) where
-
-#include "HsVersions.h"
-
-#if ! OMIT_NATIVE_CODEGEN
-import {-# SOURCE #-} MachMisc
-#endif
-
-import Maybes ( catMaybes )
-import SMRep
-import Util ( panic )
-import Outputable
-import GlaExts ( Int(..), Int#, (+#), negateInt#, (<=#), (>=#), (==#) )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Offsets-Heap-and-others]{Offsets, Heap and otherwise}
-%* *
-%************************************************************************
-
-\begin{code}
-{-
- < fixed-hdr-size> < var-hdr-size >
- ---------------------------------------------------------------------
- |info| | | | | | | | ptrs... | nonptrs ... | slop.... |
- ---------------------------------------------------------------------
- <------------- header ------------>
-
- * Node, the ptr to the closure, pts at its info-ptr field
--}
-data HeapOffset
- = MkHeapOffset
-
- FAST_INT -- this many words...
-
- FAST_INT -- PLUS: this many FixedHdrSizes
-
- [SMRep__Int] -- PLUS: for each elem in this list:
- -- "Int" VarHdrSizes for rep "SMRep"
- -- *sorted* by SMRep
- -- We never have any SpecReps in here, because their
- -- VarHdrSize is zero
-
- [SMRep__Int] -- PLUS: for each elem in this list:
- -- "Int" TotHdrSizes for rep "SMRep"
- -- *sorted* by SMRep
- -- We never have any SpecReps in here, because
- -- their TotHdrSize is just FixedHdrSize
-
- | MaxHeapOffset HeapOffset HeapOffset
- | SubHeapOffset HeapOffset HeapOffset
- | AddHeapOffset HeapOffset HeapOffset
- | ZeroHeapOffset
-
- deriving () -- but: see `eqOff` below
-
-data SMRep__Int = SMRI_ SMRep Int#
-#define SMRI(a,b) (SMRI_ a b)
-
-type VirtualHeapOffset = HeapOffset
-type VirtualSpAOffset = Int
-type VirtualSpBOffset = Int
-
-type HpRelOffset = HeapOffset
-type SpARelOffset = Int
-type SpBRelOffset = Int
-\end{code}
-
-Interface fns for HeapOffsets:
-\begin{code}
-zeroOff = ZeroHeapOffset
-
-intOff IBOX(n) = MkHeapOffset n ILIT(0) [] []
-
-fixedHdrSize = MkHeapOffset ILIT(0) ILIT(1) [] []
-
-totHdrSize sm_rep
- = if isSpecRep sm_rep -- Tot hdr size for a spec rep is just FixedHdrSize
- then MkHeapOffset ILIT(0) ILIT(1) [] []
- else MkHeapOffset ILIT(0) ILIT(0) [] [SMRI(sm_rep, ILIT(1))]
-
-varHdrSize sm_rep
- = if isSpecRep sm_rep
- then zeroOff
- else MkHeapOffset ILIT(0) ILIT(0) [SMRI(sm_rep, ILIT(1))] []
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Heap-offset-arithmetic]{Heap offset arithmetic}
-%* *
-%************************************************************************
-
-\begin{code}
--- For maxOff we do our best when we have something simple to deal with
-maxOff ZeroHeapOffset off2 = off2
-maxOff off1 ZeroHeapOffset = off1
-maxOff off1@(MkHeapOffset int_offs1 fixhdr_offs1 varhdr_offs1 tothdr_offs1)
- off2@(MkHeapOffset int_offs2 fixhdr_offs2 varhdr_offs2 tothdr_offs2)
- = if (int_offs1 _LE_ int_offs2) &&
- (real_fixed1 _LE_ real_fixed2) &&
- (all negative_or_zero difference_of_real_varhdrs)
- then
- off2
- else
- if (int_offs2 _LE_ int_offs1) &&
- (real_fixed2 _LE_ real_fixed1) &&
- (all positive_or_zero difference_of_real_varhdrs)
- then
- off1
- else
- MaxHeapOffset off1 off2
- where
- -- Normalise, by realising that each tot-hdr is really a
- -- var-hdr plus a fixed-hdr
- n_tothdr1 = total_of tothdr_offs1
- real_fixed1 = fixhdr_offs1 _ADD_ n_tothdr1
- real_varhdr1 = add_HdrSizes varhdr_offs1 tothdr_offs1
-
- n_tothdr2 = total_of tothdr_offs2
- real_fixed2 = fixhdr_offs2 _ADD_ n_tothdr2
- real_varhdr2 = add_HdrSizes varhdr_offs2 tothdr_offs2
-
- -- Take the difference of the normalised var-hdrs
- difference_of_real_varhdrs
- = add_HdrSizes real_varhdr1 (map negate_HdrSize real_varhdr2)
- where
- negate_HdrSize :: SMRep__Int -> SMRep__Int
- negate_HdrSize SMRI(rep,n) = SMRI(rep, (_NEG_ n))
-
- positive_or_zero SMRI(rep,n) = n _GE_ ILIT(0)
- negative_or_zero SMRI(rep,n) = n _LE_ ILIT(0)
-
- total_of [] = ILIT(0)
- total_of (SMRI(rep,n):offs) = n _ADD_ total_of offs
-
-maxOff other_off1 other_off2 = MaxHeapOffset other_off1 other_off2
-
-------------------------------------------------------------------
-
-subOff off1 ZeroHeapOffset = off1
-subOff off1
- (MkHeapOffset int_offs2 fxdhdr_offs2 varhdr_offs2 tothdr_offs2)
- = addOff off1
- (MkHeapOffset (_NEG_ int_offs2)
- (_NEG_ fxdhdr_offs2)
- (map negate_HdrSize varhdr_offs2)
- (map negate_HdrSize tothdr_offs2))
- where
- negate_HdrSize :: SMRep__Int -> SMRep__Int
- negate_HdrSize SMRI(rep,n) = SMRI(rep,(_NEG_ n))
-
-subOff other_off1 other_off2 = SubHeapOffset other_off1 other_off2
-
-------------------------------------------------------------------
-
-addOff ZeroHeapOffset off2 = off2
-addOff off1 ZeroHeapOffset = off1
-addOff (MkHeapOffset int_offs1 fxdhdr_offs1 varhdr_offs1 tothdr_offs1)
- (MkHeapOffset int_offs2 fxdhdr_offs2 varhdr_offs2 tothdr_offs2)
- = MkHeapOffset
- (int_offs1 _ADD_ int_offs2)
- (fxdhdr_offs1 _ADD_ fxdhdr_offs2)
- (add_HdrSizes varhdr_offs1 varhdr_offs2)
- (add_HdrSizes tothdr_offs1 tothdr_offs2)
-
-addOff other_off1 other_off2 = AddHeapOffset other_off1 other_off2
-
-------------------------------------------------------------------
--- not exported:
---
-add_HdrSizes :: [SMRep__Int] -> [SMRep__Int] -> [SMRep__Int]
-
-add_HdrSizes [] offs2 = offs2
-add_HdrSizes offs1 [] = offs1
-add_HdrSizes as@(off1@(SMRI(rep1,n1)) : offs1) bs@(off2@(SMRI(rep2,n2)) : offs2)
- = if rep1 `ltSMRepHdr` rep2 then
- off1 : (add_HdrSizes offs1 bs)
- else
- if rep2 `ltSMRepHdr` rep1 then
- off2 : (add_HdrSizes as offs2)
- else
- let
- n1_plus_n2 = n1 _ADD_ n2
- in
- -- So they are the same rep
- if n1_plus_n2 _EQ_ ILIT(0) then
- add_HdrSizes offs1 offs2
- else
- (SMRI(rep1, n1_plus_n2)) : (add_HdrSizes offs1 offs2)
-\end{code}
-
-\begin{code}
-isZeroOff :: HeapOffset -> Bool
-isZeroOff ZeroHeapOffset = True
-isZeroOff (MaxHeapOffset off1 off2) = isZeroOff off1 && isZeroOff off2
-
-isZeroOff (AddHeapOffset off1 off2) = isZeroOff off1 && isZeroOff off2
- -- This assumes that AddHeapOffset only has positive arguments
-
-isZeroOff (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs)
- = int_offs _EQ_ ILIT(0) && fxdhdr_offs _EQ_ ILIT(0) &&
- null varhdr_offs && null tothdr_offs
-
-isZeroOff (SubHeapOffset off1 off2) = panic "Can't say if a SubHeapOffset is zero"
-\end{code}
-
-@possiblyEqualHeapOffset@ tells if two heap offsets might be equal.
-It has to be conservative, but the situation in which it is used
-(@doSimultaneously@) makes it likely to give a good answer.
-
-\begin{code}
-possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
-possiblyEqualHeapOffset o1 o2
- = case (o1 `subOff` o2) of
-
- SubHeapOffset _ _ -> True -- Very conservative
-
- diff -> not (isZeroOff diff) -- Won't be any SubHeapOffsets in diff
- -- NB: this claim depends on the use of
- -- heap offsets, so this defn might need
- -- to be elaborated.
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[HeapOffs-printing]{Printing heap offsets}
-%* *
-%************************************************************************
-
-IMPORTANT: @pprHeapOffset@ and @pprHeapOffsetPieces@ guarantee to
-print either a single value, or a parenthesised value. No need for
-the caller to parenthesise.
-
-\begin{code}
-pprHeapOffset :: HeapOffset -> SDoc
-
-pprHeapOffset ZeroHeapOffset = char '0'
-
-pprHeapOffset (MaxHeapOffset off1 off2)
- = (<>) (ptext SLIT("STG_MAX"))
- (parens (hcat [pprHeapOffset off1, comma, pprHeapOffset off2]))
-
-pprHeapOffset (AddHeapOffset off1 off2)
- = parens (hcat [pprHeapOffset off1, char '+',
- pprHeapOffset off2])
-pprHeapOffset (SubHeapOffset off1 off2)
- = parens (hcat [pprHeapOffset off1, char '-',
- pprHeapOffset off2])
-
-pprHeapOffset (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs)
- = pprHeapOffsetPieces int_offs fxdhdr_offs varhdr_offs tothdr_offs
-\end{code}
-
-\begin{code}
-pprHeapOffsetPieces :: FAST_INT -- Words
- -> FAST_INT -- Fixed hdrs
- -> [SMRep__Int] -- Var hdrs
- -> [SMRep__Int] -- Tot hdrs
- -> SDoc
-
-pprHeapOffsetPieces n ILIT(0) [] [] = int IBOX(n) -- Deals with zero case too
-
-pprHeapOffsetPieces int_offs fxdhdr_offs varhdr_offs tothdr_offs
- = let pp_int_offs =
- if int_offs _EQ_ ILIT(0)
- then Nothing
- else Just (int IBOX(int_offs))
-
- pp_fxdhdr_offs =
- if fxdhdr_offs _EQ_ ILIT(0) then
- Nothing
- else if fxdhdr_offs _EQ_ ILIT(1) then
- Just (ptext SLIT("_FHS"))
- else
- Just (hcat [text "(", ptext SLIT("_FHS*"), int IBOX(fxdhdr_offs), text ")"])
-
- pp_varhdr_offs = pp_hdrs (ptext SLIT("_VHS")) varhdr_offs
-
- pp_tothdr_offs = pp_hdrs (ptext SLIT("_HS")) tothdr_offs
- in
- case (catMaybes [pp_tothdr_offs, pp_varhdr_offs, pp_fxdhdr_offs, pp_int_offs]) of
- [] -> char '0'
- [pp] -> pp -- Each blob is parenthesised if necessary
- pps -> text "(" <> (hcat (punctuate (char '+') pps)) <> text ")"
- where
- pp_hdrs hdr_pp [] = Nothing
- pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just ((<>) (text (show rep)) hdr_pp)
- pp_hdrs hdr_pp hdrs = Just (parens (hsep (punctuate (char '+')
- (map (pp_hdr hdr_pp) hdrs))))
-
- pp_hdr :: SDoc -> SMRep__Int -> SDoc
- pp_hdr pp_str (SMRI(rep, n))
- = if n _EQ_ ILIT(1) then
- (<>) (text (show rep)) pp_str
- else
- hcat [int IBOX(n), char '*', text (show rep), pp_str]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[HeapOffs-conversion]{Converting heap offsets to words}
-%* *
-%************************************************************************
-
-@intOffsetIntoGoods@ and @hpRelToInt@ convert HeapOffsets into Ints.
-
-@intOffsetIntoGoods@ {\em tries} to convert a HeapOffset in a SPEC
-closure into an Int, returning the (0-origin) index from the beginning
-of the ``goods'' in the closure. [SPECs don't have VHSs, by
-definition, so the index is merely ignoring the FHS].
-
-@hpRelToInt@ is for the native code-generator(s); it is courtesy of
-Jon Hill and the DAP code generator. We've just abstracted away some
-of the implementation-dependent bits.
-
-\begin{code}
-intOffsetIntoGoods :: HeapOffset -> Maybe Int
-
-intOffsetIntoGoods (MkHeapOffset n ILIT(1){-FHS-} [{-no VHSs-}] [{-no totHSs-}])
- = Just IBOX(n)
-intOffsetIntoGoods anything_else = Nothing
-\end{code}
-
-\begin{code}
-#if ! OMIT_NATIVE_CODEGEN
-
-hpRelToInt :: HeapOffset -> Int
-
-hpRelToInt ZeroHeapOffset = 0
-
-hpRelToInt (MaxHeapOffset left right)
- = hpRelToInt left `max` hpRelToInt right
-
-hpRelToInt (SubHeapOffset left right)
- = hpRelToInt left - hpRelToInt right
-
-hpRelToInt (AddHeapOffset left right)
- = hpRelToInt left + hpRelToInt right
-
-hpRelToInt (MkHeapOffset base fhs vhs ths)
- = let
- vhs_pieces, ths_pieces :: [Int]
- fhs_off, vhs_off, ths_off :: Int
-
- vhs_pieces = map (\ (SMRI(r, n)) -> vhs_size r * IBOX(n)) vhs
- ths_pieces = map (\ (SMRI(r, n)) -> (fhs_size + vhs_size r) * IBOX(n)) ths
-
- fhs_off = fhs_size * IBOX(fhs)
- vhs_off = sum vhs_pieces
- ths_off = sum ths_pieces
- in
- IBOX(base) + fhs_off + vhs_off + ths_off
- where
- fhs_size = fixedHdrSizeInWords
- vhs_size r = varHdrSizeInWords r
-
-#endif
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
dumpRealC
#ifdef DEBUG
, pprAmode -- otherwise, not exported
+ , pprMagicId
#endif
) where
import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
+
+import Constants ( mIN_UPD_SIZE )
import CallConv ( CallConv, callConvAttribute, cCallConv )
-import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
isReadOnly, needsCDecl, pprCLabel,
- CLabel{-instance Ord-}
+ mkReturnInfoLabel, mkReturnPtLabel,
+ CLabel, CLabelType(..), labelType
)
+
import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
-import CostCentre ( uppCostCentre, uppCostCentreDecl )
+import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
+
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
-import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
-import Literal ( showLiteral, Literal(..) )
+import Const ( Literal(..) )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
-import PrimRep ( isFloatingRep, PrimRep(..), showPrimRep )
-import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- isConstantRep, isSpecRep, isPhantomRep
- )
+import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
+import SMRep ( getSMRepStr )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
)
+import StgSyn ( SRT(..) )
+import BitSet ( intBS )
import Outputable
import Util ( nOfThem, panic, assertPanic )
+import Addr ( Addr )
+
+import ST
+import MutableArray
infixr 9 `thenTE`
\end{code}
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: Handle -> AbstractC -> SDoc -> IO ()
---writeRealC handle absC postlude =
+{-
+writeRealC :: Handle -> AbstractC -> IO ()
+writeRealC handle absC
+ -- avoid holding on to the whole of absC in the !Gransim case.
+ if opt_GranMacros
+ then printForCFast fp (pprAbsC absC (costs absC))
+ else printForCFast fp (pprAbsC absC (panic "costs"))
+ --printForC handle (pprAbsC absC (panic "costs"))
+dumpRealC :: AbstractC -> SDoc
+dumpRealC absC = pprAbsC absC (costs absC)
+-}
+
+writeRealC :: Handle -> AbstractC -> IO ()
+--writeRealC handle absC =
-- _scc_ "writeRealC"
-- printDoc LeftMode handle (pprAbsC absC (costs absC))
-writeRealC handle absC postlude =
- _scc_ "writeRealC"
- printForC handle (pprAbsC absC (costs absC) $$ postlude)
-
-dumpRealC :: AbstractC -> SDoc -> SDoc
-dumpRealC absC postlude
- | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC) $$ postlude)
- | otherwise = pprCode CStyle (pprAbsC absC (panic "costs") $$ postlude)
+
+writeRealC handle absC
+ | opt_GranMacros = _scc_ "writeRealC" printForC handle $
+ pprCode CStyle (pprAbsC absC (costs absC))
+ | otherwise = _scc_ "writeRealC" printForC handle $
+ pprCode CStyle (pprAbsC absC (panic "costs"))
+
+dumpRealC :: AbstractC -> SDoc
+dumpRealC absC
+ | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC))
+ | otherwise = pprCode CStyle (pprAbsC absC (panic "costs"))
+
\end{code}
This emits the macro, which is used in GrAnSim to compute the total costs
\begin{code}
emitMacro :: CostRes -> SDoc
--- ToDo: Check a compile time flag to decide whether a macro should be emitted
+emitMacro _ | not opt_GranMacros = empty
+
emitMacro (Cost (i,b,l,s,f))
= hcat [ ptext SLIT("GRAN_EXEC"), char '(',
int i, comma, int b, comma, int l, comma,
pprAbsC AbsCNop _ = empty
pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
-pprAbsC (CClosureUpdInfo info) c
- = pprAbsC info c
-
pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
+
pprAbsC (CJump target) c
= ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
(hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
(hcat [text jmp_lit, target, pp_paren_semi ])
where
target = case return_info of
- DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode am, rparen]
+ DirectReturn -> hcat [char '(', pprAmode am, rparen]
DynamicVectoredReturn am' -> mk_vector (pprAmode am')
StaticVectoredReturn n -> mk_vector (int n) -- Always positive
- mk_vector x = hcat [parens (pprAmode am), brackets (text "RVREL" <> parens x)]
+ mk_vector x = hcat [text "RET_VEC", char '(', pprAmode am, comma,
+ x, rparen ]
pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
-- Costs for addressing header of switch and cond. branching -- HWL
switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
-pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _ _ _) args liveness_mask vol_regs) _
- = pprCCall op args results liveness_mask vol_regs
+{-
+pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _) args vol_regs) _
+ = pprCCall op args results vol_regs
+-}
+pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _
+ = pprCCall op args results vol_regs
-pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
+pprAbsC stmt@(COpStmt results op args vol_regs) _
= let
non_void_args = grab_non_void_amodes args
non_void_results = grab_non_void_amodes results
-- primop macros do their own casting of result;
-- hence we can toss the provided cast...
+pprAbsC stmt@(CSRT lbl closures) c
+ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+ pp_exts
+ $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
+ $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
+ <> ptext SLIT("};")
+ }
+ where pp_closure_lbl lbl = char '&' <> pprCLabel lbl
+
+pprAbsC stmt@(CBitmap lbl mask) c
+ = vcat [
+ hcat [ ptext SLIT("BITMAP"), lparen,
+ pprCLabel lbl, comma,
+ int (length mask),
+ rparen ],
+ hcat (punctuate comma (map (int.intBS) mask)),
+ ptext SLIT("}};")
+ ]
+
pprAbsC (CSimultaneous abs_c) c
= hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
-pprAbsC stmt@(CMacroStmt macro as) _
+pprAbsC (CCheck macro as code) c
+ = hcat [text (show macro), lparen,
+ hcat (punctuate comma (map ppr_amode as)), comma,
+ pprAbsC code c, pp_paren_semi
+ ]
+pprAbsC (CMacroStmt macro as) _
= hcat [text (show macro), lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
-pprAbsC stmt@(CCallProfCtrMacro op as) _
+pprAbsC (CCallProfCtrMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallProfCCMacro op as) _
+pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv _ _) results args) _
+pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) _
= hsep [ ptext SLIT("typedef")
, ccall_res_ty
, fun_nm
char '}' ]
}
-pprAbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
- = hcat [ pp_init_hdr, text "_HDR(",
+
+pprAbsC (CInitHdr cl_info reg_rel cost_centre) _
+ = hcat [ ptext SLIT("SET_HDR_"), char '(',
ppr_amode (CAddr reg_rel), comma,
- pprCLabel info_lbl, comma,
- if_profiling (pprAmode cost_centre), comma,
- pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ]
+ pprCLabelAddr info_lbl, comma,
+ if_profiling (pprAmode cost_centre),
+ pp_paren_semi ]
where
info_lbl = infoTableLabelFromCI cl_info
- sm_rep = closureSMRep cl_info
- size = closureSizeWithoutFixedHdr cl_info
- ptr_wds = closurePtrsSize cl_info
-
- pp_init_hdr = text (if inplace_upd then
- getSMUpdInplaceHdrStr sm_rep
- else
- getSMInitHdrStr sm_rep)
pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
vcat [
pp_exts,
hcat [
- ptext SLIT("SET_STATIC_HDR"),char '(',
- pprCLabel closure_lbl, comma,
+ ptext SLIT("SET_STATIC_HDR"), char '(',
+ pprCLabel closure_lbl, comma,
pprCLabel info_lbl, comma,
- if_profiling (pprAmode cost_centre), comma,
+ if_profiling (pprAmode cost_centre), comma,
ppLocalness closure_lbl, comma,
- ppLocalnessMacro False{-for data-} info_lbl,
+ ppLocalnessMacro info_lbl,
char ')'
],
- nest 2 (hcat (map ppr_item amodes)),
- nest 2 (hcat (map ppr_item padding_wds)),
+ nest 2 (ppr_payload (amodes ++ padding_wds)),
ptext SLIT("};") ]
}
where
info_lbl = infoTableLabelFromCI cl_info
- ppr_item item
- = if getAmodeRep item == VoidRep
- then text ", (W_) 0" -- might not even need this...
- else (<>) (text ", (W_)") (ppr_amode item)
+ ppr_payload [] = empty
+ ppr_payload ls = comma <+>
+ braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
+ ppr_item item
+ | rep == VoidRep = text "0" -- might not even need this...
+ | rep == FloatRep = ppr_amode (floatToWord item)
+ | rep == DoubleRep = hcat (punctuate (text ", (L_)")
+ (map ppr_amode (doubleToWords item)))
+ | otherwise = ppr_amode item
+ where
+ rep = getAmodeRep item
+
+ -- always at least one padding word: this is the static link field for
+ -- the garbage collector.
padding_wds =
if not (closureUpdReqd cl_info) then
- []
+ [mkIntCLit 0]
else
- case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
+ case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
-{-
- STATIC_INIT_HDR(c,i,localness) blows into:
- localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
-
- then *NO VarHdr STUFF FOR STATIC*...
-
- then the amodes are dropped in...
- ,a1 ,a2 ... ,aN
- then a close brace:
- };
--}
-
-pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
+pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
= vcat [
hcat [
- pp_info_rep,
- ptext SLIT("_ITBL"),char '(',
- pprCLabel info_lbl, comma,
-
- -- CONST_ITBL needs an extra label for
- -- the static version of the object.
- if isConstantRep sm_rep
- then (<>) (pprCLabel (closureLabelFromCI cl_info)) comma
- else empty,
-
- pprCLabel slow_lbl, comma,
- pprAmode upd, comma,
- int liveness, comma,
+ ptext SLIT("INFO_TABLE"),
+ ( if is_selector then
+ ptext SLIT("_SELECTOR")
+ else if is_constr then
+ ptext SLIT("_CONSTR")
+ else if needs_srt then
+ ptext SLIT("_SRT")
+ else empty ), char '(',
+
+ pprCLabel info_lbl, comma,
+ pprCLabel slow_lbl, comma,
+ pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
+
+ ppLocalness info_lbl, comma,
+ ppLocalnessMacro slow_lbl, comma,
- pp_tag, comma,
- pp_size, comma,
- pp_ptr_wds, comma,
-
- ppLocalness info_lbl, comma,
- ppLocalnessMacro True{-function-} slow_lbl, comma,
-
- if is_selector
- then (<>) (int select_word_i) comma
- else empty,
-
- if_profiling pp_kind, comma,
if_profiling pp_descr, comma,
if_profiling pp_type,
text ");"
- ],
+ ],
pp_slow,
case maybe_fast of
Nothing -> empty
where
info_lbl = infoTableLabelFromCI cl_info
fast_lbl = fastLabelFromCI cl_info
- sm_rep = closureSMRep cl_info
(slow_lbl, pp_slow)
= case (nonemptyAbsC slow) of
maybe_selector = maybeSelectorInfo cl_info
is_selector = maybeToBool maybe_selector
- (Just (_, select_word_i)) = maybe_selector
+ (Just select_word_i) = maybe_selector
- pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
- = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
+ maybe_tag = closureSemiTag cl_info
+ is_constr = maybeToBool maybe_tag
+ (Just tag) = maybe_tag
- pp_tag = int (closureSemiTag cl_info)
+ needs_srt = has_srt srt && needsSRT cl_info
- is_phantom = isPhantomRep sm_rep
+ size = closureNonHdrSize cl_info
- pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
- int (closureNonHdrSize cl_info)
+ ptrs = closurePtrsSize cl_info
+ nptrs = size - ptrs
- else if is_phantom then -- do not have sizes for these
- empty
- else
- pprHeapOffset (closureSizeWithoutFixedHdr cl_info)
+ pp_rest | is_selector = int select_word_i
+ | otherwise = hcat [
+ int ptrs, comma,
+ int nptrs, comma,
+ if is_constr then
+ hcat [ int tag, comma ]
+ else if needs_srt then
+ pp_srt_info srt
+ else empty,
+ type_str ]
- pp_ptr_wds = if is_phantom then
- empty
- else
- int (closurePtrsSize cl_info)
+ type_str = text (getSMRepStr (closureSMRep cl_info))
- pp_kind = text (closureKind cl_info)
pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
-pprAbsC (CRetVector lbl maybes deflt) c
- = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
- nest 8 (sep (map ppr_maybe_amode maybes)),
- text "} /*default=*/ {", pprAbsC deflt c,
- char '}']
+pprAbsC stmt@(CRetDirect uniq code srt liveness) _
+ = vcat [
+ hcat [
+ ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen,
+ pprCLabel info_lbl, comma,
+ pprCLabel entry_lbl, comma,
+ pp_liveness liveness, comma, -- bitmap
+ pp_srt_info srt, -- SRT
+ ptext type_str, comma, -- closure type
+ ppLocalness info_lbl, comma, -- info table storage class
+ ppLocalnessMacro entry_lbl, comma, -- entry pt storage class
+ int 0, comma,
+ int 0, text ");"
+ ],
+ pp_code
+ ]
where
- ppr_maybe_amode Nothing = ptext SLIT("/*default*/")
- ppr_maybe_amode (Just a) = pprAmode a
+ info_lbl = mkReturnInfoLabel uniq
+ entry_lbl = mkReturnPtLabel uniq
-pprAbsC stmt@(CRetUnVector label amode) _
- = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma,
- pprAmode amode, rparen]
- where
- pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
+ pp_code = let stuff = CCodeBlock entry_lbl code in
+ pprAbsC stuff (costs stuff)
+
+ type_str = case liveness of
+ LvSmall _ -> SLIT("RET_SMALL")
+ LvLarge _ -> SLIT("RET_BIG")
+
+pprAbsC stmt@(CRetVector label amodes srt liveness) _
+ = vcat [
+ pp_vector,
+ hcat [
+ ptext SLIT(" }"), comma, ptext SLIT("\n VEC_INFO_TABLE"),
+ lparen,
+ pp_liveness liveness, comma, -- bitmap liveness mask
+ pp_srt_info srt, -- SRT
+ ptext type_str, -- or big, depending on the size
+ -- of the liveness mask.
+ rparen
+ ],
+ text "};"
+ ]
-pprAbsC stmt@(CFlatRetVector label amodes) _
- = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- vcat [
- pp_exts,
- hcat [ppLocalness label, ptext SLIT(" W_ "),
- pprCLabel label, text "[] = {"],
- nest 2 (sep (punctuate comma (map ppr_item amodes))),
- text "};" ] }
where
- ppr_item item = (<>) (text "(W_) ") (ppr_amode item)
+ pp_vector =
+ case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
+ vcat [
+ pp_exts,
+ hcat [ppLocalness label,
+ ptext SLIT(" vec_info_"), int size, space,
+ pprCLabel label, text "= { {"
+ ],
+ nest 2 (sep (punctuate comma (map ppr_item (reverse amodes))))
+ ] }
+
+ ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
+ size = length amodes
-pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc
+ type_str = case liveness of
+ LvSmall _ -> SLIT("RET_VEC_SMALL")
+ LvLarge _ -> SLIT("RET_VEC_BIG")
+
+
+pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
+pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code}
\begin{code}
ppLocalness label
= (<>) static const
where
- static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
- const = if not (isReadOnly label) then empty else ptext SLIT("const")
-
-ppLocalnessMacro for_fun{-vs data-} clabel
- = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
- if for_fun then
- ptext SLIT("F_")
- else
- (<>) (ptext SLIT("D_"))
- (if isReadOnly clabel then
- ptext SLIT("RO_")
- else
- empty)]
+ static = if (externallyVisibleCLabel label)
+ then empty
+ else ptext SLIT("static ")
+ const = if not (isReadOnly label)
+ then empty
+ else ptext SLIT("const")
+
+-- Horrible macros for declaring the types and locality of labels (see
+-- StgMacros.h).
+
+ppLocalnessMacro clabel =
+ hcat [
+ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
+ case labelType clabel of
+ InfoTblType -> ptext SLIT("I_")
+ ClosureType -> ptext SLIT("C_")
+ CodeType -> ptext SLIT("F_")
+ DataType -> ptext SLIT("D_") <>
+ if isReadOnly clabel
+ then ptext SLIT("RO_")
+ else empty
+ ]
\end{code}
\begin{code}
-- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
-- depending on the platform. (The "volatile regs" stuff handles all
-- other registers.) Just be *sure* BaseReg is OK before trying to do
--- anything else.
+-- anything else. The correct sequence of saves&restores are
+-- encoded by the CALLER_*_SYSTEM macros.
pp_basic_saves
- = vcat [
- ptext SLIT("CALLER_SAVE_Base"),
- ptext SLIT("CALLER_SAVE_SpA"),
- ptext SLIT("CALLER_SAVE_SuA"),
- ptext SLIT("CALLER_SAVE_SpB"),
- ptext SLIT("CALLER_SAVE_SuB"),
- ptext SLIT("CALLER_SAVE_Ret"),
--- ptext SLIT("CALLER_SAVE_Activity"),
- ptext SLIT("CALLER_SAVE_Hp"),
- ptext SLIT("CALLER_SAVE_HpLim") ]
-
-pp_basic_restores
- = vcat [
- ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
- ptext SLIT("CALLER_RESTORE_SpA"),
- ptext SLIT("CALLER_RESTORE_SuA"),
- ptext SLIT("CALLER_RESTORE_SpB"),
- ptext SLIT("CALLER_RESTORE_SuB"),
- ptext SLIT("CALLER_RESTORE_Ret"),
--- ptext SLIT("CALLER_RESTORE_Activity"),
- ptext SLIT("CALLER_RESTORE_Hp"),
- ptext SLIT("CALLER_RESTORE_HpLim"),
- ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
- ptext SLIT("CALLER_RESTORE_StkStub") ]
+ = vcat
+ [ ptext SLIT("CALLER_SAVE_Base")
+ , ptext SLIT("CALLER_SAVE_SYSTEM")
+ ]
+
+pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
+\end{code}
+
+\begin{code}
+has_srt (_, NoSRT) = False
+has_srt _ = True
+
+pp_srt_info srt =
+ case srt of
+ (lbl, NoSRT) ->
+ hcat [ int 0, comma,
+ int 0, comma,
+ int 0, comma ]
+ (lbl, SRT off len) ->
+ hcat [ pprCLabel lbl, comma,
+ int off, comma,
+ int len, comma ]
\end{code}
\begin{code}
(This happens after restoration of essential registers because we
might need the @Base@ register to access all the others correctly.)
-{- Doesn't apply anymore with ForeignObj, structure created via the primop.
- makeForeignObj (i.e., ForeignObj is not CReturnable)
-7) If returning Malloc Pointer, build a closure containing the
- appropriate value.
--}
Otherwise, copy local variable into result register.
8) If ccall (not casm), declare the function being called as extern so
can get at them.
* be sure that there are no live registers or we're in trouble.
(This can cause problems if you try something foolish like passing
- an array or foreign obj to a _ccall_GC_ thing.)
+ an array or a foreign obj to a _ccall_GC_ thing.)
* increment/decrement the @inCCallGC@ counter before/after the call so
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask vol_regs
- = if (may_gc && liveness_mask /= noLiveRegsMask)
- then pprPanic "Live register in _casm_GC_ "
- (doubleQuotes (text casm_str) <+> hsep pp_non_void_args)
- else
- vcat [
+pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
+ = vcat [
char '{',
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
]
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
-
(pp_save_context, pp_restore_context)
- | may_gc =
- ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;"
- , text "inCCallGC--; RestoreAllStgRegs();} while(0);"
- )
- | otherwise =
- ( pp_basic_saves $$ pp_saves
- , pp_basic_restores $$ pp_restores
- )
+ | may_gc = ( text "do { SaveThreadState();"
+ , text "LoadThreadState();} while(0);"
+ )
+ | otherwise = ( pp_basic_saves $$ pp_saves,
+ pp_basic_restores $$ pp_restores)
non_void_args =
let nvas = tail args
(local_arg_decls, pp_non_void_args)
= unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
- pp_liveness = pprAmode (mkIntCLit liveness_mask)
{-
In the non-casm case, to ensure that we're entering the given external
_ -> empty
(declare_local_vars, local_vars, assign_results)
- = ppr_casm_results non_void_results pp_liveness
+ = ppr_casm_results non_void_results
(Left asm_str) = op_str
is_dynamic =
If the argument is a heap object, we need to reach inside and pull out
the bit the C world wants to see. The only heap objects which can be
-passed are @Array@s, @ByteArray@s and @ForeignObj@s.
+passed are @Array@s and @ByteArray@s.
\begin{code}
ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
-- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
- ForeignObjRep -> (ptext SLIT("StgForeignObj"),
- hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
- pp_amode, char ')'])
+ ForeignObjRep -> (pp_kind,
+ hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
+ char '(', pp_amode, char ')'])
+
other -> (pp_kind, pp_amode)
declare_local_var
We only allow zero or one results.
-{- With the introduction of ForeignObj (MallocPtr++), no longer necess.
-2) Is the result is a foreign obj?
-
- The mallocptr must be encapsulated immediately in a heap object.
--}
\begin{code}
ppr_casm_results
:: [CAddrMode] -- list of results (length <= 1)
- -> SDoc -- liveness mask
->
( SDoc, -- declaration of any local vars
[SDoc], -- list of result vars (same length as results)
SDoc ) -- assignment (if any) of results in local var to registers
-ppr_casm_results [] liveness
+ppr_casm_results []
= (empty, [], empty) -- no results
-ppr_casm_results [r] liveness
+ppr_casm_results [r]
= let
result_reg = ppr_amode r
r_kind = getAmodeRep r
local_var = ptext SLIT("_ccall_result")
(result_type, assign_result)
- = case r_kind of
-{-
- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
- Instead, external references have to explicitly turned into ForeignObjs
- using the primop makeForeignObj#. Benefit: Multiple finalisation
- routines can be accommodated and the below special case is not needed.
- Price is, of course, that you have to explicitly wrap `foreign objects'
- with makeForeignObj#.
-
- ForeignObjRep ->
- (ptext SLIT("StgForeignObj"),
- hcat [ ptext SLIT("constructForeignObj"),char '(',
- liveness, comma,
- result_reg, comma,
- local_var,
- pp_paren_semi ])
--}
- _ ->
- (pprPrimKind r_kind,
- hcat [ result_reg, equals, local_var, semi ])
+ = (pprPrimKind r_kind,
+ hcat [ result_reg, equals, local_var, semi ])
declare_local_var = hcat [ result_type, space, local_var, semi ]
in
(declare_local_var, [local_var], assign_result)
-ppr_casm_results rs liveness
+ppr_casm_results rs
= panic "ppr_casm_results: ccall/casm with many results"
\end{code}
process_casm results args string = process results args string
where
process [] _ "" = empty
- process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
+ process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++
+ string ++
+ "\"\n(Try changing result type to PrimIO ()\n")
process ress args ('%':cs)
= case cs of
error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
('%':css) ->
- (<>) (char '%') (process ress args css)
+ char '%' <> process ress args css
('r':css) ->
case ress of
[] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
- [r] -> (<>) r (process [] args css)
+ [r] -> r <> (process [] args css)
_ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
other ->
case (read_int other) of
[(num,css)] ->
if 0 <= num && num < length args
- then (<>) (parens (args !! num))
- (process ress args css)
- else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
+ then parens (args !! num) <> process ress args css
+ else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
_ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
process ress args (other_c:cs)
- = (<>) (char other_c) (process ress args cs)
+ = char other_c <> process ress args cs
\end{code}
%************************************************************************
pprAssign ByteArrayRep dest src
| mixedPtrLocn src
- -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
+ -- Add in a cast iff the source is mixed
= hcat [ ppr_amode dest, equals,
- text "(B_)(", -- Here is the cast
+ text "(StgByteArray)(", -- Here is the cast
ppr_amode src, pp_paren_semi ]
pprAssign kind other_dest src
ppr_amode (CReg magic_id) = pprMagicId magic_id
-ppr_amode (CTemp uniq kind) = pprUnique uniq <> char '_'
-
-ppr_amode (CLbl label kind) = pprCLabel label
+ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
-ppr_amode (CUnVecLbl direct vectored)
- = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel direct, comma,
- pprCLabel vectored, rparen]
+ppr_amode (CLbl label kind) = pprCLabelAddr label
ppr_amode (CCharLike ch)
= hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
ppr_amode (CLitLit str _) = ptext str
-ppr_amode (COffset off) = pprHeapOffset off
-
-ppr_amode (CCode abs_C)
- = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
-
-ppr_amode (CLabelledCode label abs_C)
- = vcat [ hcat [pprCLabel label, ptext SLIT(" = { -- CLabelledCode")],
- nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ]
-
-ppr_amode (CJoinPoint _ _)
+ppr_amode (CJoinPoint _)
= panic "ppr_amode: CJoinPoint"
ppr_amode (CTableEntry base index kind)
ptext SLIT(")]")]
ppr_amode (CMacroExpr pk macro as)
- = hcat [lparen, pprPrimKind pk, text ")(", text (show macro), lparen,
- hcat (punctuate comma (map pprAmode as)), text "))"]
+ = parens (pprPrimKind pk) <+>
+ parens (text (show macro) <>
+ parens (hcat (punctuate comma (map pprAmode as))))
+\end{code}
-ppr_amode (CCostCentre cc print_as_string)
- = uppCostCentre print_as_string cc
+%************************************************************************
+%* *
+\subsection[ppr-liveness-masks]{Liveness Masks}
+%* *
+%************************************************************************
+
+\begin{code}
+pp_liveness :: Liveness -> SDoc
+pp_liveness lv =
+ case lv of
+ LvSmall mask -> int (intBS mask)
+ LvLarge lbl -> char '&' <> pprCLabel lbl
\end{code}
%************************************************************************
-> RegRelative
-> (SDoc, Maybe SDoc)
-pprRegRelative sign_wanted (SpARel spA off)
- = (pprMagicId SpA, pprSignedInt sign_wanted (spARelToInt spA off))
+pprRegRelative sign_wanted (SpRel off)
+ = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
-pprRegRelative sign_wanted (SpBRel spB off)
- = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
-
-pprRegRelative sign_wanted r@(HpRel hp off)
- = let to_print = hp `subOff` off
- pp_Hp = pprMagicId Hp
+pprRegRelative sign_wanted r@(HpRel o)
+ = let pp_Hp = pprMagicId Hp; off = I# o
in
- if isZeroOff to_print then
+ if off == 0 then
(pp_Hp, Nothing)
else
- (pp_Hp, Just ((<>) (char '-') (pprHeapOffset to_print)))
- -- No parens needed because pprHeapOffset
- -- does them when necessary
+ (pp_Hp, Just ((<>) (char '-') (int off)))
-pprRegRelative sign_wanted (NodeRel off)
- = let pp_Node = pprMagicId node
+pprRegRelative sign_wanted (NodeRel o)
+ = let pp_Node = pprMagicId node; off = I# o
in
- if isZeroOff off then
+ if off == 0 then
(pp_Node, Nothing)
else
- (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset off)))
+ (pp_Node, Just (addPlusSign sign_wanted (int off)))
\end{code}
pprMagicId :: MagicId -> SDoc
pprMagicId BaseReg = ptext SLIT("BaseReg")
-pprMagicId StkOReg = ptext SLIT("StkOReg")
pprMagicId (VanillaReg pk n)
= hcat [ pprVanillaReg n, char '.',
pprUnionTag pk ]
-pprMagicId (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n))
-pprMagicId (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n))
-pprMagicId (LongReg _ n) = (<>) (ptext SLIT("LngReg")) (int IBOX(n))
-pprMagicId TagReg = ptext SLIT("TagReg")
-pprMagicId RetReg = ptext SLIT("RetReg")
-pprMagicId SpA = ptext SLIT("SpA")
-pprMagicId SuA = ptext SLIT("SuA")
-pprMagicId SpB = ptext SLIT("SpB")
-pprMagicId SuB = ptext SLIT("SuB")
-pprMagicId Hp = ptext SLIT("Hp")
+pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n))
+pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n))
+pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n))
+pprMagicId Sp = ptext SLIT("Sp")
+pprMagicId Su = ptext SLIT("Su")
+pprMagicId SpLim = ptext SLIT("SpLim")
+pprMagicId Hp = ptext SLIT("Hp")
pprMagicId HpLim = ptext SLIT("HpLim")
-pprMagicId LivenessReg = ptext SLIT("LivenessReg")
-pprMagicId StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg")
-pprMagicId StkStubReg = ptext SLIT("StkStubReg")
-pprMagicId CurCostCentre = ptext SLIT("CCC")
+pprMagicId CurCostCentre = ptext SLIT("CCCS")
pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
pprVanillaReg :: FAST_INT -> SDoc
-
pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
pprUnionTag :: PrimRep -> SDoc
pprUnionTag PtrRep = char 'p'
pprUnionTag CodePtrRep = ptext SLIT("fp")
pprUnionTag DataPtrRep = char 'd'
-pprUnionTag RetRep = char 'r'
+pprUnionTag RetRep = char 'p'
pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
pprUnionTag CharRep = char 'c'
pprUnionTag IntRep = char 'i'
pprUnionTag WordRep = char 'w'
-pprUnionTag AddrRep = char 'v'
+pprUnionTag AddrRep = char 'a'
pprUnionTag FloatRep = char 'f'
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
pprUnionTag StablePtrRep = char 'i'
+pprUnionTag WeakPtrRep = char 'p'
pprUnionTag ForeignObjRep = char 'p'
+pprUnionTag ThreadIdRep = char 't'
+
pprUnionTag ArrayRep = char 'p'
pprUnionTag ByteArrayRep = char 'b'
\begin{code}
pprTempDecl :: Unique -> PrimRep -> SDoc
pprTempDecl uniq kind
- = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ]
+ = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
pprExternDecl :: CLabel -> PrimRep -> SDoc
pprExternDecl clabel kind
= if not (needsCDecl clabel) then
- empty -- do not print anything for "known external" things (e.g., < PreludeCore)
- else
- case (
- case kind of
- CodePtrRep -> ppLocalnessMacro True{-function-} clabel
- _ -> ppLocalnessMacro False{-data-} clabel
- ) of { pp_macro_str ->
-
- hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ]
- }
+ empty -- do not print anything for "known external" things
+ else
+ hcat [ ppLocalnessMacro clabel,
+ lparen, pprCLabel clabel, pp_paren_semi ]
\end{code}
\begin{code}
ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
returnTE (maybe_vcat [p1, p2])
-ppr_decls_AbsC (CClosureUpdInfo info)
- = ppr_decls_AbsC info
-
ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
ppr_decls_AbsC (CAssign dest source)
ppr_decls_AbsC (CCodeBlock label absC)
= ppr_decls_AbsC absC
-ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd)
+ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
-- ToDo: strictly speaking, should chk "cost_centre" amode
= labelSeenTE info_lbl `thenTE` \ label_seen ->
returnTE (Nothing,
where
info_lbl = infoTableLabelFromCI cl_info
-ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args)
+ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
+ppr_decls_AbsC (CCheck _ amodes code) =
+ ppr_decls_Amodes amodes `thenTE` \p1 ->
+ ppr_decls_AbsC code `thenTE` \p2 ->
+ returnTE (maybe_vcat [p1,p2])
+
ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
-- ToDo: strictly speaking, should chk "cost_centre" amode
= ppr_decls_Amodes amodes
-ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
- = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
+ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _)
+ = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
ppr_decls_AbsC slow `thenTE` \ p2 ->
(case maybe_fast of
Nothing -> returnTE (Nothing, Nothing)
Nothing -> mkErrorStdEntryLabel
Just _ -> entryLabelFromCI cl_info
-ppr_decls_AbsC (CRetVector label maybe_amodes absC)
- = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
- ppr_decls_AbsC absC `thenTE` \ p2 ->
- returnTE (maybe_vcat [p1, p2])
+ppr_decls_AbsC (CSRT lbl closure_lbls)
+ = mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
+ returnTE (Nothing,
+ if and seen then Nothing
+ else Just (vcat [ pprExternDecl l PtrRep
+ | (l,False) <- zip closure_lbls seen ]))
-ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
-ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
+ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
+ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
\end{code}
\begin{code}
ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing)
-- CIntLike must be a literal -- no decls
ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
returnTE (Nothing,
if label_seen then Nothing else Just (pprExternDecl label kind))
-{- WRONG:
-ppr_decls_Amode (CUnVecLbl direct vectored)
- = labelSeenTE direct `thenTE` \ dlbl_seen ->
- labelSeenTE vectored `thenTE` \ vlbl_seen ->
- let
- ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
- vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
- in
- returnTE (Nothing,
- if (dlbl_seen || not (needsCDecl direct)) &&
- (vlbl_seen || not (needsCDecl vectored)) then Nothing
- else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
--}
-
-ppr_decls_Amode (CUnVecLbl direct vectored)
- = -- We don't mark either label as "seen", because
- -- we don't know which one will be used and which one tossed
- -- by the C macro...
- --labelSeenTE direct `thenTE` \ dlbl_seen ->
- --labelSeenTE vectored `thenTE` \ vlbl_seen ->
- let
- ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
- vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
- in
- returnTE (Nothing,
- if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
- ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
- else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
-
ppr_decls_Amode (CTableEntry base index _)
= ppr_decls_Amode base `thenTE` \ p1 ->
ppr_decls_Amode index `thenTE` \ p2 ->
= mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
returnTE ( maybe_vcat ps )
\end{code}
+
+Print out a C Label where you want the *address* of the label, not the
+object it refers to. The distinction is important when the label may
+refer to a C structure (info tables and closures, for instance).
+
+When just generating a declaration for the label, use pprCLabel.
+
+\begin{code}
+pprCLabelAddr :: CLabel -> SDoc
+pprCLabelAddr clabel =
+ case labelType clabel of
+ InfoTblType -> addr_of_label
+ ClosureType -> addr_of_label
+ VecTblType -> addr_of_label
+ _ -> pp_label
+ where
+ addr_of_label = ptext SLIT("(P_)&") <> pp_label
+ pp_label = pprCLabel clabel
+\end{code}
+
+-----------------------------------------------------------------------------
+Initialising static objects with floating-point numbers. We can't
+just emit the floating point number, because C will cast it to an int
+by rounding it. We want the actual bit-representation of the float.
+
+This is a hack to turn the floating point numbers into ints that we
+can safely initialise to static locations.
+
+\begin{code}
+big_doubles = (getPrimRepSize DoubleRep) /= 1
+
+-- floatss are always 1 word
+floatToWord :: CAddrMode -> CAddrMode
+floatToWord (CLit (MachFloat r))
+ = runST (do
+ arr <- newFloatArray (0,0)
+ writeFloatArray arr 0 (fromRational r)
+ i <- readIntArray arr 0
+ return (CLit (MachInt (toInteger i) True))
+ )
+
+doubleToWords :: CAddrMode -> [CAddrMode]
+doubleToWords (CLit (MachDouble r))
+ | big_doubles -- doubles are 2 words
+ = runST (do
+ arr <- newDoubleArray (0,1)
+ writeDoubleArray arr 0 (fromRational r)
+ i1 <- readIntArray arr 0
+ i2 <- readIntArray arr 1
+ return [ CLit (MachInt (toInteger i1) True)
+ , CLit (MachInt (toInteger i2) True)
+ ]
+ )
+ | otherwise -- doubles are 1 word
+ = runST (do
+ arr <- newDoubleArray (0,0)
+ writeDoubleArray arr 0 (fromRational r)
+ i <- readIntArray arr 0
+ return [ CLit (MachInt (toInteger i) True) ]
+ )
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
\section[BasicTypes]{Miscellanous types}
Version, Arity,
Unused, unused,
Module, moduleString, pprModule,
- Fixity(..), FixityDirection(..),
+ Fixity(..), FixityDirection(..), StrictnessMark(..),
NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..)
) where
data NewOrData
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
+ | EnumType -- Enumeration; all constructors are nullary
deriving( Eq ) -- Needed because Demand derives Eq
\end{code}
--- /dev/null
+_interface_ Const 1
+_exports_
+Const Con ;
+_declarations_
+1 data Con ;
--- /dev/null
+__interface Const 1 0 where
+__export Const Con ;
+1 data Con ;
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
+
+\begin{code}
+module Const (
+ Con(..),
+ conType, conPrimRep,
+ conOkForApp, conOkForAlt, isWHNFCon, isDataCon,
+ conIsTrivial, conIsCheap,
+
+ DataCon, PrimOp, -- For completeness
+
+ -- Defined here
+ Literal(..), -- Exported to ParseIface
+ mkMachInt, mkMachWord,
+ mkMachInt_safe, mkMachInt64, mkMachWord64,
+ mkStrLit, -- ToDo: rm (not used anywhere)
+ isNoRepLit, isLitLitLit,
+ literalType, literalPrimRep
+ ) where
+
+#include "HsVersions.h"
+
+import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
+ intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
+ )
+import PrimOp ( PrimOp, primOpType, primOpIsCheap )
+import PrimRep ( PrimRep(..) )
+import DataCon ( DataCon, dataConType, dataConTyCon, isNullaryDataCon )
+import TyCon ( isNewTyCon )
+import Type ( Type, typePrimRep )
+import PprType ( pprParendType )
+import CStrings ( stringToC, charToC, charToEasyHaskell )
+
+import Outputable
+import Util ( thenCmp )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The main data type}
+%* *
+%************************************************************************
+
+\begin{code}
+data Con
+ = DataCon DataCon
+ | Literal Literal
+ | PrimOp PrimOp
+ | DEFAULT -- Used in case clauses
+ deriving (Eq, Ord)
+
+-- The Ord is needed for the FiniteMap used in the lookForConstructor
+-- in SimplEnv. If you declared that lookForConstructor *ignores*
+-- constructor-applications with LitArg args, then you could get
+-- rid of this Ord.
+
+instance Outputable Con where
+ ppr (DataCon dc) = ppr dc
+ ppr (Literal lit) = ppr lit
+ ppr (PrimOp op) = ppr op
+ ppr DEFAULT = ptext SLIT("__DEFAULT")
+
+instance Show Con where
+ showsPrec p con = showsPrecSDoc p (ppr con)
+
+conType :: Con -> Type
+conType (DataCon dc) = dataConType dc
+conType (Literal lit) = literalType lit
+conType (PrimOp op) = primOpType op
+
+conPrimRep :: Con -> PrimRep -- Only data valued constants
+conPrimRep (DataCon dc) = ASSERT( isNullaryDataCon dc) PtrRep
+conPrimRep (Literal lit) = literalPrimRep lit
+
+conOkForApp, conOkForAlt :: Con -> Bool
+
+-- OK for appliation site
+conOkForApp (DataCon dc) = not (isNewTyCon (dataConTyCon dc))
+conOkForApp (Literal _) = True
+conOkForApp (PrimOp op) = True
+conOkForApp DEFAULT = False
+
+-- OK for case alternative pattern
+conOkForAlt (DataCon dc) = not (isNewTyCon (dataConTyCon dc))
+conOkForAlt (Literal lit) = not (isNoRepLit lit)
+conOkForAlt (PrimOp _) = False
+conOkForAlt DEFAULT = True
+
+ -- isWHNFCon is false for PrimOps, which contain work
+ -- Ditto for newtype constructors, which can occur in the output
+ -- of the desugarer, but which will be inlined right away thereafter
+isWHNFCon (DataCon dc) = not (isNewTyCon (dataConTyCon dc))
+isWHNFCon (Literal _) = True
+isWHNFCon (PrimOp _) = False
+
+isDataCon (DataCon dc) = True
+isDataCon other = False
+
+-- conIsTrivial is true for constants we are unconditionally happy to duplicate
+-- cf CoreUtils.exprIsTrivial
+conIsTrivial (Literal lit) = not (isNoRepLit lit)
+conIsTrivial (PrimOp _) = False
+conIsTrivial con = True
+
+-- conIsCheap is true for constants whose applications we are willing
+-- to duplicate in exchange for some modest gain. cf CoreUtils.exprIsCheap
+conIsCheap (Literal lit) = not (isNoRepLit lit)
+conIsCheap (DataCon con) = True
+conIsCheap (PrimOp op) = primOpIsCheap op
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Literals}
+%* *
+%************************************************************************
+
+So-called @Literals@ are {\em either}:
+\begin{itemize}
+\item
+An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
+which is presumed to be surrounded by appropriate constructors
+(@mKINT@, etc.), so that the overall thing makes sense.
+\item
+An Integer, Rational, or String literal whose representation we are
+{\em uncommitted} about; i.e., the surrounding with constructors,
+function applications, etc., etc., has not yet been done.
+\end{itemize}
+
+\begin{code}
+data Literal
+ = ------------------
+ -- First the primitive guys
+ MachChar Char
+ | MachStr FAST_STRING
+
+ | MachAddr Integer -- Whatever this machine thinks is a "pointer"
+
+ | MachInt Integer -- For the numeric types, these are
+ Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
+
+ | MachInt64 Integer -- guaranteed 64-bit versions of the above.
+ Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
+
+
+ | MachFloat Rational
+ | MachDouble Rational
+
+ | MachLitLit FAST_STRING Type -- Type might be Add# or Int# etc
+
+ ------------------
+ -- The no-rep guys
+ | NoRepStr FAST_STRING Type -- This Type is always String
+ | NoRepInteger Integer Type -- This Type is always Integer
+ | NoRepRational Rational Type -- This Type is always Rational
+ -- We keep these Types in the literal because Rational isn't
+ -- (currently) wired in, so we can't conjure up its type out of
+ -- thin air. Integer is, so the type here is really redundant.
+\end{code}
+
+
+\begin{code}
+instance Outputable Literal where
+ ppr lit = pprLit lit
+
+instance Show Literal where
+ showsPrec p lit = showsPrecSDoc p (ppr lit)
+
+instance Eq Literal where
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord Literal where
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = cmpLit a b
+\end{code}
+
+
+ Construction
+ ~~~~~~~~~~~~
+\begin{code}
+mkMachInt, mkMachWord :: Integer -> Literal
+
+mkMachInt x = MachInt x True{-signed-}
+mkMachWord x = MachInt x False{-unsigned-}
+
+-- check if the int is within range
+mkMachInt_safe :: Integer -> Literal
+mkMachInt_safe i
+ | out_of_range =
+ pprPanic "mkMachInt_safe"
+ (hsep [text "ERROR: Int ", text (show i), text "out of range",
+ brackets (int minInt <+> text ".." <+> int maxInt)])
+ | otherwise = MachInt i True{-signed-}
+ where
+ out_of_range =
+-- i < fromInt minBound ||
+ i > fromInt maxInt
+
+mkMachInt64 x = MachInt64 x True{-signed-}
+mkMachWord64 x = MachInt64 x False{-unsigned-}
+
+mkStrLit :: String -> Type -> Literal
+mkStrLit s ty = NoRepStr (_PK_ s) ty
+\end{code}
+
+
+ Predicates
+ ~~~~~~~~~~
+\begin{code}
+isNoRepLit (NoRepStr _ _) = True -- these are not primitive typed!
+isNoRepLit (NoRepInteger _ _) = True
+isNoRepLit (NoRepRational _ _) = True
+isNoRepLit _ = False
+
+isLitLitLit (MachLitLit _ _) = True
+isLitLitLit _ = False
+\end{code}
+
+ Types
+ ~~~~~
+\begin{code}
+literalType :: Literal -> Type
+literalType (MachChar _) = charPrimTy
+literalType (MachStr _) = addrPrimTy
+literalType (MachAddr _) = addrPrimTy
+literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy
+literalType (MachInt64 _ signed) = if signed then int64PrimTy else word64PrimTy
+literalType (MachFloat _) = floatPrimTy
+literalType (MachDouble _) = doublePrimTy
+literalType (MachLitLit _ ty) = ty
+literalType (NoRepInteger _ ty) = ty
+literalType (NoRepRational _ ty) = ty
+literalType (NoRepStr _ ty) = ty
+\end{code}
+
+\begin{code}
+literalPrimRep :: Literal -> PrimRep
+
+literalPrimRep (MachChar _) = CharRep
+literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
+literalPrimRep (MachAddr _) = AddrRep
+literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
+literalPrimRep (MachInt64 _ signed) = if signed then Int64Rep else Word64Rep
+literalPrimRep (MachFloat _) = FloatRep
+literalPrimRep (MachDouble _) = DoubleRep
+literalPrimRep (MachLitLit _ ty) = typePrimRep ty
+#ifdef DEBUG
+literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger"
+literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
+literalPrimRep (NoRepStr _ _) = panic "literalPrimRep:NoRepString"
+#endif
+\end{code}
+
+
+ Comparison
+ ~~~~~~~~~~
+\begin{code}
+cmpLit (MachChar a) (MachChar b) = a `compare` b
+cmpLit (MachStr a) (MachStr b) = a `compare` b
+cmpLit (MachAddr a) (MachAddr b) = a `compare` b
+cmpLit (MachInt a b) (MachInt c d) = (a `compare` c) `thenCmp` (b `compare` d)
+cmpLit (MachFloat a) (MachFloat b) = a `compare` b
+cmpLit (MachDouble a) (MachDouble b) = a `compare` b
+cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d)
+cmpLit (NoRepStr a _) (NoRepStr b _) = a `compare` b
+cmpLit (NoRepInteger a _) (NoRepInteger b _) = a `compare` b
+cmpLit (NoRepRational a _) (NoRepRational b _) = a `compare` b
+cmpLit lit1 lit2 | litTag lit1 _LT_ litTag lit2 = LT
+ | otherwise = GT
+
+litTag (MachChar _) = ILIT(1)
+litTag (MachStr _) = ILIT(2)
+litTag (MachAddr _) = ILIT(3)
+litTag (MachInt _ _) = ILIT(4)
+litTag (MachFloat _) = ILIT(5)
+litTag (MachDouble _) = ILIT(6)
+litTag (MachLitLit _ _) = ILIT(7)
+litTag (NoRepStr _ _) = ILIT(8)
+litTag (NoRepInteger _ _) = ILIT(9)
+litTag (NoRepRational _ _) = ILIT(10)
+\end{code}
+
+ Printing
+ ~~~~~~~~
+* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
+ exceptions: MachFloat and MachAddr get an initial keyword prefix
+
+* NoRep things get an initial keyword prefix (e.g. _integer_ 3)
+
+\begin{code}
+pprLit lit
+ = getPprStyle $ \ sty ->
+ let
+ code_style = codeStyle sty
+ in
+ case lit of
+ MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), char '\'',
+ text (charToC ch), char '\'']
+ | ifaceStyle sty -> char '\'' <> text (charToEasyHaskell ch) <> char '\''
+ | otherwise -> text ['\'', ch, '\'']
+
+ MachStr s | code_style -> doubleQuotes (text (stringToC (_UNPK_ s)))
+ | otherwise -> pprFSAsString s
+
+
+ NoRepStr s ty | code_style -> pprPanic "NoRep in code style" (ppr lit)
+ | otherwise -> ptext SLIT("__string") <+> pprFSAsString s
+
+ MachInt i signed | code_style && out_of_range
+ -> pprPanic "" (hsep [text "ERROR: Int ", text (show i),
+ text "out of range",
+ brackets (ppr range_min <+> text ".."
+ <+> ppr range_max)])
+ | otherwise -> integer i
+
+ where
+ range_min = if signed then minInt else 0
+ range_max = maxInt
+ out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
+
+ MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f
+ | otherwise -> ptext SLIT("__float") <+> rational f
+
+ MachDouble d -> rational d
+
+ MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p
+ | otherwise -> ptext SLIT("__addr") <+> integer p
+
+ NoRepInteger i _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
+ | otherwise -> ptext SLIT("__integer") <+> integer i
+
+ NoRepRational r _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
+ | otherwise -> hsep [ptext SLIT("__rational"), integer (numerator r),
+ integer (denominator r)]
+
+ MachLitLit s ty | code_style -> ptext s
+ | otherwise -> parens (hsep [ptext SLIT("__litlit"),
+ pprFSAsString s,
+ pprParendType ty])
+\end{code}
--- /dev/null
+_interface_ DataCon 1
+_exports_
+DataCon DataCon ;
+_declarations_
+1 data DataCon ;
--- /dev/null
+__interface DataCon 1 0 where
+__export DataCon DataCon ;
+1 data DataCon ;
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
+
+\begin{code}
+module DataCon (
+ DataCon,
+ ConTag, fIRST_TAG,
+ mkDataCon,
+ dataConType, dataConSig, dataConName, dataConTag,
+ dataConArgTys, dataConRawArgTys, dataConTyCon,
+ dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
+ dataConNumFields, dataConNumInstArgs, dataConId,
+ isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
+ isExistentialDataCon
+ ) where
+
+#include "HsVersions.h"
+
+import CmdLineOpts ( opt_DictsStrict )
+import TysPrim
+import Type ( Type, ThetaType, TauType,
+ mkSigmaTy, mkFunTys, mkTyConApp,
+ mkTyVarTys, mkDictTy, substTy
+ )
+import TyCon ( TyCon, tyConDataCons, isDataTyCon,
+ isTupleTyCon, isUnboxedTupleTyCon )
+import Class ( classTyCon )
+import Name ( Name, NamedThing(..), nameUnique )
+import Var ( TyVar, Id )
+import VarEnv
+import FieldLabel ( FieldLabel )
+import BasicTypes ( StrictnessMark(..), Arity )
+import Outputable
+import Unique ( Unique, Uniquable(..) )
+import Util ( assoc )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Data constructors}
+%* *
+%************************************************************************
+
+\begin{code}
+data DataCon
+ = MkData { -- Used for data constructors only;
+ -- there *is* no constructor for a newtype
+ dcName :: Name,
+ dcUnique :: Unique, -- Cached from Name
+ dcTag :: ConTag,
+ dcType :: Type, -- Type of the constructor (see notes below)
+
+ dcTyVars :: [TyVar], -- Type vars and context for the data type decl
+ dcTheta :: ThetaType,
+
+ dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
+ dcExTheta :: ThetaType, -- the existentially quantified stuff
+
+ dcArgTys :: [Type], -- Argument types
+ dcTyCon :: TyCon, -- Result tycon
+
+ dcStricts :: [StrictnessMark], -- Strict args, in the same order as the argument types;
+ -- length = dataConNumFields dataCon
+
+ dcFields :: [FieldLabel], -- Field labels for this constructor, in the
+ -- same order as the argument types;
+ -- length = 0 (if not a record) or dataConSourceArity.
+
+ dcId :: Id -- The corresponding Id
+ }
+
+type ConTag = Int
+
+fIRST_TAG :: ConTag
+fIRST_TAG = 1 -- Tags allocated from here for real constructors
+\end{code}
+
+The dcType field contains the type of the representation of a contructor
+This may differ from the type of the contructor *Id* (built
+by MkId.mkDataConId) for two reasons:
+ a) the constructor Id may be overloaded, but the dictionary isn't stored
+ e.g. data Eq a => T a = MkT a a
+
+ b) the constructor may store an unboxed version of a strict field.
+
+Here's an example illustrating both:
+ data Ord a => T a = MkT Int! a
+Here
+ T :: Ord a => Int -> a -> T a
+but the rep type is
+ Trep :: Int# -> a -> T a
+Actually, the unboxed part isn't implemented yet!
+
+
+\begin{code}
+instance Eq DataCon where
+ a == b = getUnique a == getUnique b
+ a /= b = getUnique a /= getUnique b
+
+instance Ord DataCon where
+ a <= b = getUnique a <= getUnique b
+ a < b = getUnique a < getUnique b
+ a >= b = getUnique a >= getUnique b
+ a > b = getUnique a > getUnique b
+ compare a b = getUnique a `compare` getUnique b
+
+instance Uniquable DataCon where
+ getUnique = dcUnique
+
+instance NamedThing DataCon where
+ getName = dcName
+
+instance Outputable DataCon where
+ ppr con = ppr (dataConName con)
+
+instance Show DataCon where
+ showsPrec p con = showsPrecSDoc p (ppr con)
+\end{code}
+
+\begin{code}
+mkDataCon :: Name
+ -> [StrictnessMark] -> [FieldLabel]
+ -> [TyVar] -> ThetaType
+ -> [TyVar] -> ThetaType
+ -> [TauType] -> TyCon
+ -> Id
+ -> DataCon
+ -- Can get the tag from the TyCon
+
+mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta arg_tys tycon id
+ = ASSERT(length arg_stricts == length arg_tys)
+ -- The 'stricts' passed to mkDataCon are simply those for the
+ -- source-language arguments. We add extra ones for the
+ -- dictionary arguments right here.
+ con
+ where
+ con = MkData {dcName = name, dcUnique = nameUnique name,
+ dcTyVars = tyvars, dcTheta = theta, dcArgTys = arg_tys,
+ dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
+ dcStricts = all_stricts, dcFields = fields,
+ dcTag = tag, dcTyCon = tycon, dcType = ty,
+ dcId = id}
+
+ all_stricts = (map mk_dict_strict_mark ex_theta) ++ arg_stricts
+ -- Add a strictness flag for the existential dictionary arguments
+
+ tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
+ ty = mkSigmaTy (tyvars ++ ex_tyvars)
+ ex_theta
+ (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
+
+mk_dict_strict_mark (clas,tys)
+ | opt_DictsStrict &&
+ isDataTyCon (classTyCon clas) = MarkedStrict -- Don't mark newtype things as strict!
+ | otherwise = NotMarkedStrict
+\end{code}
+
+
+\begin{code}
+dataConName :: DataCon -> Name
+dataConName = dcName
+
+dataConTag :: DataCon -> ConTag
+dataConTag = dcTag
+
+dataConTyCon :: DataCon -> TyCon
+dataConTyCon = dcTyCon
+
+dataConType :: DataCon -> Type
+dataConType = dcType
+
+dataConId :: DataCon -> Id
+dataConId = dcId
+
+
+dataConFieldLabels :: DataCon -> [FieldLabel]
+dataConFieldLabels = dcFields
+
+dataConStrictMarks :: DataCon -> [StrictnessMark]
+dataConStrictMarks = dcStricts
+
+dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
+dataConRawArgTys = dcArgTys
+
+dataConSourceArity :: DataCon -> Arity
+ -- Source-level arity of the data constructor
+dataConSourceArity dc = length (dcArgTys dc)
+
+dataConSig :: DataCon -> ([TyVar], ThetaType,
+ [TyVar], ThetaType,
+ [TauType], TyCon)
+
+dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
+ dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
+ dcArgTys = arg_tys, dcTyCon = tycon})
+ = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
+
+dataConArgTys :: DataCon
+ -> [Type] -- Instantiated at these types
+ -- NB: these INCLUDE the existentially quantified arg types
+ -> [Type] -- Needs arguments of these types
+ -- NB: these INCLUDE the existentially quantified dict args
+ -- but EXCLUDE the data-decl context which is discarded
+
+dataConArgTys (MkData {dcArgTys = arg_tys, dcTyVars = tyvars,
+ dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys
+ = map (substTy (zipVarEnv (tyvars ++ ex_tyvars) inst_tys))
+ ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys)
+\end{code}
+
+dataConNumFields gives the number of actual fields in the
+{\em representation} of the data constructor. This may be more than appear
+in the source code; the extra ones are the existentially quantified
+dictionaries
+
+\begin{code}
+-- Number of type-instantiation arguments
+-- All the remaining arguments of the DataCon are (notionally)
+-- stored in the DataCon, and are matched in a case expression
+dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
+
+dataConNumFields (MkData {dcExTheta = theta, dcArgTys = arg_tys})
+ = length theta + length arg_tys
+
+isNullaryDataCon con
+ = dataConNumFields con == 0 -- function of convenience
+
+isTupleCon :: DataCon -> Bool
+isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc
+
+isUnboxedTupleCon :: DataCon -> Bool
+isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
+
+isExistentialDataCon :: DataCon -> Bool
+isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Demand]{@Demand@: the amount of demand on a value}
Demand(..),
wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum,
- isStrict,
+ isStrict, isLazy,
- showDemands
+ pprDemands
) where
#include "HsVersions.h"
import BasicTypes ( NewOrData(..) )
import Outputable
-import Util ( panic )
\end{code}
\begin{code}
isStrict :: Demand -> Bool
-
-isStrict WwStrict = True
-isStrict (WwUnpack DataType _ _) = True
isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
-isStrict WwPrim = True
-isStrict WwEnum = True
-isStrict _ = False
+isStrict (WwUnpack other _ _) = True
+isStrict WwStrict = True
+isStrict WwEnum = True
+isStrict WwPrim = False -- NB: we treat only lifted types as strict.
+ -- Why is this important? Mostly it doesn't matter
+ -- but it saves a test for lifted-ness in SimplUtils.etaCoreExpr
+isStrict _ = False
+\end{code}
+
+\begin{code}
+isLazy :: Demand -> Bool
+isLazy (WwLazy False) = True -- NB "Absent" args do *not* count!
+isLazy _ = False -- (as they imply a worker)
\end{code}
%************************************************************************
\begin{code}
-showDemands :: [Demand] -> String
-showDemands wrap_args = show_demands wrap_args ""
-
-
#ifdef REALLY_HASKELL_1_3
instance Read Demand where
readList str = read_em [] str
+
instance Show Demand where
- showsPrec prec wrap rest = show_demand wrap rest
- showList wrap_args rest = show_demands wrap_args rest
+ showsPrec p d = showsPrecSDoc p (ppr d)
#else
instance Text Demand where
- readList str = read_em [] str
- showList wrap_args rest = show_demands wrap_args rest
-
+ readList str = read_em [] str
+ showsPrec p d = showsPrecSDoc p (ppr d)
#endif
read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs
do_unpack new_or_data wrapper_unpacks acc xs
= case (read_em [] xs) of
[(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
- _ -> panic ("Demand.do_unpack:"++show acc++"::"++xs)
+ _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> text ("::"++xs))
+
-show_demands wrap_args rest
- = foldr show_demand rest wrap_args
+pprDemands demands = hcat (map pprDemand demands)
-show_demand (WwLazy False) rest = 'L' : rest
-show_demand (WwLazy True) rest = 'A' : rest
-show_demand WwStrict rest = 'S' : rest
-show_demand WwPrim rest = 'P' : rest
-show_demand WwEnum rest = 'E' : rest
-show_demand (WwUnpack nd wu args) rest = ch:'(':showList args (')' : rest)
+pprDemand (WwLazy False) = char 'L'
+pprDemand (WwLazy True) = char 'A'
+pprDemand WwStrict = char 'S'
+pprDemand WwPrim = char 'P'
+pprDemand WwEnum = char 'E'
+pprDemand (WwUnpack nd wu args) = char ch <> parens (pprDemands args)
where
ch = case nd of
DataType | wu -> 'U'
| otherwise -> 'n'
instance Outputable Demand where
- ppr si = text (showList [si] "")
+ ppr (WwLazy False) = empty
+ ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
\end{code}
+++ /dev/null
-_interface_ FieldLabel 1
-_exports_
-FieldLabel FieldLabel;
-_declarations_
-1 data FieldLabel;
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[FieldLabel]{The @FieldLabel@ type}
#include "HsVersions.h"
-import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique )
-import Type ( Type )
+import {-# SOURCE #-} Type( Type ) -- FieldLabel is compiled very early
+import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique )
import Outputable
import Unique ( Uniquable(..) )
\end{code}
getName (FieldLabel n _ _) = n
instance Uniquable FieldLabel where
- uniqueOf (FieldLabel n _ _) = nameUnique n
+ getUnique (FieldLabel n _ _) = nameUnique n
\end{code}
+++ /dev/null
-_interface_ Id 1
-_exports_
-Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) idType isNullaryDataCon mkDataCon mkTupleCon pprId idName;
-_declarations_
-1 type Id = Id.GenId Type!Type ;
-1 data GenId ty ;
-1 data StrictnessMark = MarkedStrict | NotMarkedStrict ;
-
-1 idType _:_ Id.Id -> Type!Type ;;
-1 isNullaryDataCon _:_ Id -> PrelBase.Bool ;;
-1 mkDataCon _:_ Name.Name -> [Id.StrictnessMark] -> [FieldLabel!FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id ;;
-1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type!Type -> Id ;;
-1 pprId _:_ _forall_ [ty] {Outputable.Outputable ty} => GenId ty -> Outputable.SDoc ;;
-1 idName _:_ _forall_ [ty] => GenId ty -> Name.Name ;;
-
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Id]{@Ids@: Value and constructor identifiers}
\begin{code}
module Id (
- -- TYPES
- GenId, -- Abstract
- Id,
- IdDetails(..), -- Exposed only to MkId
- StrictnessMark(..),
- ConTag, fIRST_TAG,
- DataCon, DictFun, DictVar,
-
- -- Construction and modification
- mkId, mkIdWithNewUniq, mkIdWithNewName, mkIdWithNewType,
- mkTemplateLocals,
- setIdVisibility, mkIdVisible,
- mkVanillaId,
-
- -- DESTRUCTION (excluding pragmatic info)
- idPrimRep,
- idType,
- idUnique,
- idName,
-
- -- Extracting pieces of particular sorts of Ids
- dataConRepType,
- dataConArgTys,
- dataConNumFields,
- dataConFieldLabels,
- dataConRawArgTys,
- dataConSig,
- dataConStrictMarks,
- dataConTag,
- dataConTyCon,
+ Id, DictId, GenId,
+ -- Simple construction
+ mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
+ mkTemplateLocals, mkWildId, mkUserId,
+
+ -- Taking an Id apart
+ idName, idType, idUnique, idInfo,
+ idPrimRep, isId,
recordSelectorFieldLabel,
- -- PREDICATES
+ -- Modifying an Id
+ setIdName, setIdUnique, setIdType, setIdInfo,
+ setIdVisibility, mkIdVisible,
+
+ -- Predicates
omitIfaceSigForId,
- cmpId,
externallyVisibleId,
- idHasNoFreeTyVars,
- idWantsToBeINLINEd, getInlinePragma,
- idMustBeINLINEd, idMustNotBeINLINEd,
- isBottomingId,
+ idFreeTyVars,
+
+ -- Inline pragma stuff
+ getInlinePragma, setInlinePragma, modifyInlinePragma,
+ idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
+ isSpecPragmaId,
- isDataCon, isAlgCon, isNewCon, isTupleCon,
- isNullaryDataCon,
-
- isRecordSelector, isSpecPragmaId,
- isPrimitiveId_maybe,
-
- -- PRINTING and RENUMBERING
- pprId,
- showId,
-
- -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
- idInfo,
- addIdUnfolding,
- addIdArity,
- addIdDemandInfo,
- addIdStrictness,
- addIdUpdateInfo,
+
+ isRecordSelector,
+ isPrimitiveId_maybe, isDataConId_maybe,
+ isConstantId,
+ isBottomingId,
+
+ -- IdInfo stuff
+ setIdUnfolding,
+ setIdArity,
+ setIdDemandInfo,
+ setIdStrictness,
+ setIdSpecialisation,
+ setIdUpdateInfo,
+ setIdCafInfo,
+
getIdArity,
getIdDemandInfo,
getIdStrictness,
getIdUnfolding,
- getIdUpdateInfo,
- replaceIdInfo,
- addInlinePragma, nukeNoInlinePragma, addNoInlinePragma,
getIdSpecialisation,
- setIdSpecialisation,
+ getIdUpdateInfo,
+ getIdCafInfo
- -- IdEnvs AND IdSets
- IdEnv, GenIdSet, IdSet,
- addOneToIdEnv,
- addOneToIdSet,
- combineIdEnvs,
- delManyFromIdEnv,
- delOneFromIdEnv,
- elementOfIdSet,
- emptyIdSet,
- growIdEnv,
- growIdEnvList,
- idSetToList,
- intersectIdSets,
- isEmptyIdSet,
- isNullIdEnv,
- lookupIdEnv, lookupIdSubst,
- lookupNoFailIdEnv,
- mapIdEnv,
- minusIdSet,
- mkIdEnv, elemIdEnv,
- mkIdSet,
- modifyIdEnv,
- modifyIdEnv_Directly,
- nullIdEnv,
- rngIdEnv,
- unionIdSets,
- unionManyIdSets,
- unitIdEnv,
- unitIdSet
) where
#include "HsVersions.h"
import {-# SOURCE #-} CoreUnfold ( Unfolding )
-import CmdLineOpts ( opt_PprStyle_All )
-import Bag
+import Var ( Id, GenId, DictId, VarDetails(..),
+ isId, mkId,
+ idName, idType, idUnique, idInfo, varDetails,
+ setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
+ externallyVisibleId
+ )
+import VarSet
+import Type ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars )
import IdInfo
-import Name ( nameUnique, isLocalName, mkSysLocalName,
- isWiredInName, setNameVisibility, mkNameVisible,
- changeUnique,
- ExportFlag(..), Provenance,
- OccName(..), Name, Module,
- NamedThing(..)
+import Demand ( Demand )
+import Name ( Name, OccName,
+ mkSysLocalName, mkLocalName,
+ isWiredInName, setNameVisibility, mkNameVisible
)
+import Const ( Con(..) )
+import PrimRep ( PrimRep )
import PrimOp ( PrimOp )
-import PrelMods ( pREL_TUP, pREL_BASE )
-import FieldLabel ( fieldLabelName, FieldLabel(..) )
-import SrcLoc ( mkBuiltinSrcLoc )
-import TysWiredIn ( tupleTyCon )
-import TyCon ( TyCon, isDataTyCon, isNewTyCon )
-import Type ( mkSigmaTy, mkTyVarTys, mkFunTys,
- mkTyConApp, instantiateTy, mkForAllTys,
- tyVarsOfType, instantiateTy, typePrimRep,
- instantiateTauTy,
- ThetaType, TauType, Type, GenType
- )
-import TyVar ( TyVar, alphaTyVars, isEmptyTyVarSet,
- TyVarEnv, zipTyVarEnv, mkTyVarEnv
- )
-import UniqFM
-import UniqSet -- practically all of it
-import Unique ( Unique, Uniquable(..), getBuiltinUniques )
+import FieldLabel ( FieldLabel(..) )
+import BasicTypes ( Module )
+import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
import Outputable
-import SrcLoc ( SrcLoc )
-import Util ( nOfThem, assoc )
-import GlaExts ( Int# )
-\end{code}
-
-Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
-follow.
-
-Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
-@Type@, and an @IdInfo@ (non-essential info about it, e.g.,
-strictness). The essential info about different kinds of @Ids@ is
-in its @IdDetails@.
-
-ToDo: possibly cache other stuff in the single-constructor @Id@ type.
-
-\begin{code}
-data GenId ty = Id {
- idUnique :: Unique, -- Key for fast comparison
- idName :: Name,
- idType :: ty, -- Id's type; used all the time;
- idDetails :: IdDetails, -- Stuff about individual kinds of Ids.
- idInfo :: IdInfo -- Properties of this Id deduced by compiler
- }
-
-type Id = GenId Type
-
-data StrictnessMark = MarkedStrict | NotMarkedStrict
-
-data IdDetails
-
- ---------------- Local values
-
- = VanillaId Bool -- Ordinary Id
- -- True <=> no free type vars
-
- | PrimitiveId PrimOp -- The Id for a primitive operation
-
-
- ---------------- Data constructors
-
- | AlgConId -- Used for both data and newtype constructors.
- -- You can tell the difference by looking at the TyCon
- ConTag
- [StrictnessMark] -- Strict args; length = arity
- [FieldLabel] -- Field labels for this constructor;
- --length = 0 (not a record) or arity
-
- [TyVar] ThetaType -- Type vars and context for the data type decl
- [TyVar] ThetaType -- Ditto for the context of the constructor,
- -- the existentially quantified stuff
- [Type] TyCon -- Args and result tycon
- -- the type is:
- -- forall tyvars1 ++ tyvars2. theta1 ++ theta2 =>
- -- unitype_1 -> ... -> unitype_n -> tycon tyvars
-
- | TupleConId Int -- Its arity
-
- | RecordSelId FieldLabel
- | SpecPragmaId -- This guy exists only to make Ids that are
- -- on the *LHS* of bindings created by SPECIALISE
- -- pragmas; eg: s = f Int d
- -- The SpecPragmaId is never itself mentioned; it
- -- exists solely so that the specialiser will find
- -- the call to f, and make specialised version of it.
- -- The SpecPragmaId binding is discarded by the specialiser
- -- when it gathers up overloaded calls.
- -- Meanwhile, it is not discarded as dead code.
-
-
-
-type ConTag = Int
-type DictVar = Id
-type DictFun = Id
-type DataCon = Id
+infixl 1 `setIdUnfolding`,
+ `setIdArity`,
+ `setIdDemandInfo`,
+ `setIdStrictness`,
+ `setIdSpecialisation`,
+ `setIdUpdateInfo`,
+ `setInlinePragma`
+ -- infixl so you can say (id `set` a `set` b)
\end{code}
+
%************************************************************************
%* *
-\subsection{Construction}
+\subsection{Simple Id construction}
%* *
%************************************************************************
\begin{code}
-mkId :: Name -> ty -> IdDetails -> IdInfo -> GenId ty
-mkId name ty details info
- = Id {idName = name, idUnique = nameUnique name, idType = ty,
- idDetails = details, idInfo = info}
-
-mkVanillaId :: Name -> (GenType flexi) -> IdInfo -> GenId (GenType flexi)
-mkVanillaId name ty info
- = Id {idName = name, idUnique = nameUnique name, idType = ty,
- idDetails = VanillaId (isEmptyTyVarSet (tyVarsOfType ty)),
- idInfo = info}
-
-mkIdWithNewUniq :: Id -> Unique -> Id
-mkIdWithNewUniq id uniq = id {idUnique = uniq, idName = changeUnique (idName id) uniq}
-
-mkIdWithNewName :: Id -> Name -> Id
-mkIdWithNewName id new_name
- = id {idUnique = uniqueOf new_name, idName = new_name}
-
-mkIdWithNewType :: GenId ty1 -> ty2 -> GenId ty2
-mkIdWithNewType id ty = id {idType = ty}
-\end{code}
+mkVanillaId :: Name -> (GenType flexi) -> GenId flexi
+mkVanillaId name ty = mkId name ty VanillaId noIdInfo
+
+mkImportedId :: Name -> Type -> IdInfo -> Id
+mkImportedId name ty info = mkId name ty VanillaId info
+mkUserId :: Name -> GenType flexi -> GenId flexi
+mkUserId name ty = mkVanillaId name ty
+
+-- SysLocal: for an Id being created by the compiler out of thin air...
+-- UserLocal: an Id with a name the user might recognize...
+mkUserLocal :: OccName -> Unique -> GenType flexi -> GenId flexi
+mkSysLocal :: Unique -> GenType flexi -> GenId flexi
+
+mkSysLocal uniq ty = mkVanillaId (mkSysLocalName uniq) ty
+mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty
+\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
\begin{code}
+-- "Wild Id" typically used when you need a binder that you don't expect to use
+mkWildId :: Type -> Id
+mkWildId ty = mkSysLocal (mkBuiltinUnique 1) ty
+
+-- "Template locals" typically used in unfoldings
mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys
- = zipWith3 mk (getBuiltinUniques (length tys)) tys [1..]
- where
- mk uniq ty n = mkVanillaId (mkSysLocalName uniq (_PK_ ("x"++show n)) mkBuiltinSrcLoc)
- ty noIdInfo
+mkTemplateLocals tys = zipWith mkSysLocal
+ (getBuiltinUniques (length tys))
+ tys
\end{code}
-\begin{code}
--- See notes with setNameVisibility (Name.lhs)
-setIdVisibility :: Maybe Module -> Unique -> Id -> Id
-setIdVisibility maybe_mod u id
- = id {idName = setNameVisibility maybe_mod u (idName id)}
-
-mkIdVisible :: Module -> Unique -> Id -> Id
-mkIdVisible mod u id = id {idName = mkNameVisible mod u (idName id)}
-
-replaceIdInfo :: GenId ty -> IdInfo -> GenId ty
-replaceIdInfo id info = id {idInfo = info}
-\end{code}
-
%************************************************************************
%* *
\subsection[Id-general-funs]{General @Id@-related functions}
%************************************************************************
\begin{code}
-fIRST_TAG :: ConTag
-fIRST_TAG = 1 -- Tags allocated from here for real constructors
+idFreeTyVars :: (GenId flexi) -> (GenTyVarSet flexi)
+idFreeTyVars id = tyVarsOfType (idType id)
--- isDataCon returns False for @newtype@ constructors
-isDataCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ tc}) = isDataTyCon tc
-isDataCon (Id {idDetails = TupleConId _}) = True
-isDataCon other = False
+setIdType :: GenId flexi1 -> GenType flexi2 -> GenId flexi2
+ -- Add free tyvar info to the type
+setIdType id ty = setVarType id (addFreeTyVars ty)
-isNewCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ tc}) = isNewTyCon tc
-isNewCon other = False
-
--- isAlgCon returns True for @data@ or @newtype@ constructors
-isAlgCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ _}) = True
-isAlgCon (Id {idDetails = TupleConId _}) = True
-isAlgCon other = False
-
-isTupleCon (Id {idDetails = TupleConId _}) = True
-isTupleCon other = False
+idPrimRep :: Id -> PrimRep
+idPrimRep id = typePrimRep (idType id)
\end{code}
+omitIfaceSigForId tells whether an Id's info is implied by other declarations,
+so we don't need to put its signature in an interface file, even if it's mentioned
+in some other interface unfolding.
+
\begin{code}
-idHasNoFreeTyVars :: Id -> Bool
-
-idHasNoFreeTyVars (Id {idDetails = details})
- = chk details
- where
- chk (AlgConId _ _ _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (RecordSelId _) = True
- chk (VanillaId no_free_tvs) = no_free_tvs
- chk (PrimitiveId _) = True
- chk SpecPragmaId = False -- Play safe
-
--- omitIfaceSigForId tells whether an Id's info is implied by other declarations,
--- so we don't need to put its signature in an interface file, even if it's mentioned
--- in some other interface unfolding.
-
-omitIfaceSigForId
- :: Id
- -> Bool
-
-omitIfaceSigForId (Id {idName = name, idDetails = details})
- | isWiredInName name
+omitIfaceSigForId :: Id -> Bool
+omitIfaceSigForId id
+ | isWiredInName (idName id)
= True
| otherwise
- = case details of
- (PrimitiveId _) -> True -- Ditto, for primitives
-
- -- This group is Ids that are implied by their type or class decl;
- -- remember that all type and class decls appear in the interface file.
- -- The dfun id must *not* be omitted, because it carries version info for
- -- the instance decl
- (AlgConId _ _ _ _ _ _ _ _ _) -> True
- (TupleConId _) -> True
- (RecordSelId _) -> True
-
- other -> False -- Don't omit!
- -- NB DefaultMethodIds are not omitted
-\end{code}
-
-\begin{code}
-isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id))
-
-isPrimitiveId_maybe (Id {idDetails = PrimitiveId primop}) = Just primop
-isPrimitiveId_maybe other = Nothing
-
-isSpecPragmaId (Id {idDetails = SpecPragmaId}) = True
-isSpecPragmaId _ = False
+ = case varDetails id of
+ RecordSelId _ -> True -- Includes dictionary selectors
+ ConstantId _ -> True
+ -- ConstantIds are implied by their type or class decl;
+ -- remember that all type and class decls appear in the interface file.
+ -- The dfun id must *not* be omitted, because it carries version info for
+ -- the instance decl
+
+ other -> False -- Don't omit!
\end{code}
-@externallyVisibleId@: is it true that another module might be
-able to ``see'' this Id in a code generation sense. That
-is, another .o file might refer to this Id.
-
-In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's
-local-ness precisely so that the test here would be easy
+See notes with setNameVisibility (Name.lhs)
\begin{code}
-externallyVisibleId :: Id -> Bool
-externallyVisibleId id = not (isLocalName (idName id))
- -- not local => global => externally visible
-\end{code}
-
-
-\begin{code}
-idPrimRep id = typePrimRep (idType id)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Id-arities]{Arity-related functions}
-%* *
-%************************************************************************
-
-For locally-defined Ids, the code generator maintains its own notion
-of their arities; so it should not be asking... (but other things
-besides the code-generator need arity info!)
-
-\begin{code}
-getIdArity :: Id -> ArityInfo
-getIdArity id = arityInfo (idInfo id)
+setIdVisibility :: Maybe Module -> Unique -> Id -> Id
+setIdVisibility maybe_mod u id
+ = setIdName id (setNameVisibility maybe_mod u (idName id))
-addIdArity :: Id -> ArityInfo -> Id
-addIdArity id@(Id {idInfo = info}) arity
- = id {idInfo = arity `setArityInfo` info}
+mkIdVisible :: Module -> Unique -> Id -> Id
+mkIdVisible mod u id
+ = setIdName id (mkNameVisible mod u (idName id))
\end{code}
%************************************************************************
%* *
-\subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
+\subsection{Special Ids}
%* *
%************************************************************************
-
-dataConNumFields gives the number of actual fields in the
-{\em representation} of the data constructor. This may be more than appear
-in the source code; the extra ones are the existentially quantified
-dictionaries
-
\begin{code}
-dataConNumFields id
- = ASSERT( if (isDataCon id) then True else
- pprTrace "dataConNumFields" (ppr id) False )
- case (dataConSig id) of { (_, _, _, con_theta, arg_tys, _) ->
- length con_theta + length arg_tys }
+recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel id = case varDetails id of
+ RecordSelId lbl -> lbl
-isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
+isRecordSelector id = case varDetails id of
+ RecordSelId lbl -> True
+ other -> False
-\end{code}
+isPrimitiveId_maybe id = case varDetails id of
+ ConstantId (PrimOp op) -> Just op
+ other -> Nothing
+isDataConId_maybe id = case varDetails id of
+ ConstantId (DataCon con) -> Just con
+ other -> Nothing
-\begin{code}
-dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-dataConTag (Id {idDetails = AlgConId tag _ _ _ _ _ _ _ _}) = tag
-dataConTag (Id {idDetails = TupleConId _}) = fIRST_TAG
-
-dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-dataConTyCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ tycon}) = tycon
-dataConTyCon (Id {idDetails = TupleConId a}) = tupleTyCon a
-
-dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon)
- -- will panic if not a DataCon
-
-dataConSig (Id {idDetails = AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon})
- = (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon)
-
-dataConSig (Id {idDetails = TupleConId arity})
- = (tyvars, [], [], [], tyvar_tys, tupleTyCon arity)
- where
- tyvars = take arity alphaTyVars
- tyvar_tys = mkTyVarTys tyvars
-
-
--- dataConRepType returns the type of the representation of a contructor
--- This may differ from the type of the contructor Id itself for two reasons:
--- a) the constructor Id may be overloaded, but the dictionary isn't stored
--- e.g. data Eq a => T a = MkT a a
---
--- b) the constructor may store an unboxed version of a strict field.
---
--- Here's an example illustrating both:
--- data Ord a => T a = MkT Int! a
--- Here
--- T :: Ord a => Int -> a -> T a
--- but the rep type is
--- Trep :: Int# -> a -> T a
--- Actually, the unboxed part isn't implemented yet!
-
-dataConRepType :: Id -> Type
-dataConRepType (Id {idDetails = AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon})
- = mkForAllTys (tyvars++con_tyvars)
- (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
-dataConRepType other_id
- = ASSERT( isDataCon other_id )
- idType other_id
-
-dataConFieldLabels :: DataCon -> [FieldLabel]
-dataConFieldLabels (Id {idDetails = AlgConId _ _ fields _ _ _ _ _ _}) = fields
-dataConFieldLabels (Id {idDetails = TupleConId _}) = []
-#ifdef DEBUG
-dataConFieldLabels x@(Id {idDetails = idt}) =
- panic ("dataConFieldLabel: " ++
- (case idt of
- VanillaId _ -> "l"
- PrimitiveId _ -> "p"
- RecordSelId _ -> "r"))
-#endif
-
-dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks (Id {idDetails = AlgConId _ stricts _ _ _ _ _ _ _}) = stricts
-dataConStrictMarks (Id {idDetails = TupleConId arity}) = nOfThem arity NotMarkedStrict
-
-dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
-dataConRawArgTys con = case (dataConSig con) of { (_,_, _, _, arg_tys,_) -> arg_tys }
-
-dataConArgTys :: DataCon
- -> [Type] -- Instantiated at these types
- -> [Type] -- Needs arguments of these types
-dataConArgTys con_id inst_tys
- = map (instantiateTy tenv) arg_tys
- where
- (tyvars, _, _, _, arg_tys, _) = dataConSig con_id
- tenv = zipTyVarEnv tyvars inst_tys
-\end{code}
-
-\begin{code}
-recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel (Id {idDetails = RecordSelId lbl}) = lbl
-
-isRecordSelector (Id {idDetails = RecordSelId lbl}) = True
-isRecordSelector other = False
+isConstantId id = case varDetails id of
+ ConstantId _ -> True
+ other -> False
\end{code}
%************************************************************************
%* *
-\subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
+\subsection{IdInfo stuff}
%* *
%************************************************************************
\begin{code}
-getIdUnfolding :: Id -> Unfolding
-
-getIdUnfolding id = unfoldingInfo (idInfo id)
-
-addIdUnfolding :: Id -> Unfolding -> Id
-addIdUnfolding id@(Id {idInfo = info}) unfolding
- = id {idInfo = unfolding `setUnfoldingInfo` info}
-\end{code}
-
-The inline pragma tells us to be very keen to inline this Id, but it's still
-OK not to if optimisation is switched off.
-
-\begin{code}
-getInlinePragma :: Id -> InlinePragInfo
-getInlinePragma id = inlinePragInfo (idInfo id)
-
-idWantsToBeINLINEd :: Id -> Bool
-
-idWantsToBeINLINEd id = case getInlinePragma id of
- IWantToBeINLINEd -> True
- IMustBeINLINEd -> True
- other -> False
-
-idMustNotBeINLINEd id = case getInlinePragma id of
- IDontWantToBeINLINEd -> True
- IMustNotBeINLINEd -> True
- other -> False
-
-idMustBeINLINEd id = case getInlinePragma id of
- IMustBeINLINEd -> True
- other -> False
-
-addInlinePragma :: Id -> Id
-addInlinePragma id@(Id {idInfo = info})
- = id {idInfo = setInlinePragInfo IWantToBeINLINEd info}
+ ---------------------------------
+ -- ARITY
+getIdArity :: GenId flexi -> ArityInfo
+getIdArity id = arityInfo (idInfo id)
-nukeNoInlinePragma :: Id -> Id
-nukeNoInlinePragma id@(Id {idInfo = info})
- = case inlinePragInfo info of
- IMustNotBeINLINEd -> id {idInfo = setInlinePragInfo NoPragmaInfo info}
- other -> id
+setIdArity :: GenId flexi -> ArityInfo -> GenId flexi
+setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
--- If the user has already marked this binding as NOINLINE, then don't
--- add the IMustNotBeINLINEd tag, since it will get nuked later whereas
--- IDontWantToBeINLINEd is permanent.
+ ---------------------------------
+ -- STRICTNESS
+getIdStrictness :: GenId flexi -> StrictnessInfo
+getIdStrictness id = strictnessInfo (idInfo id)
-addNoInlinePragma :: Id -> Id
-addNoInlinePragma id@(Id {idInfo = info})
- = case inlinePragInfo info of
- IDontWantToBeINLINEd -> id
- other -> id {idInfo = IMustNotBeINLINEd `setInlinePragInfo` info}
+setIdStrictness :: GenId flexi -> StrictnessInfo -> GenId flexi
+setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`)
-mustInlineInfo = IMustBeINLINEd `setInlinePragInfo` noIdInfo
-wantToInlineInfo = IWantToBeINLINEd `setInlinePragInfo` noIdInfo
-\end{code}
+isBottomingId :: GenId flexi -> Bool
+isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id))
+ ---------------------------------
+ -- UNFOLDING
+getIdUnfolding :: GenId flexi -> Unfolding
+getIdUnfolding id = unfoldingInfo (idInfo id)
+setIdUnfolding :: GenId flexi -> Unfolding -> GenId flexi
+setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
-%************************************************************************
-%* *
-\subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
-%* *
-%************************************************************************
-
-\begin{code}
-getIdDemandInfo :: Id -> DemandInfo
+ ---------------------------------
+ -- DEMAND
+getIdDemandInfo :: GenId flexi -> Demand
getIdDemandInfo id = demandInfo (idInfo id)
-addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdDemandInfo id@(Id {idInfo = info}) demand_info
- = id {idInfo = demand_info `setDemandInfo` info}
-\end{code}p
+setIdDemandInfo :: GenId flexi -> Demand -> GenId flexi
+setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`)
-\begin{code}
-getIdUpdateInfo :: Id -> UpdateInfo
+ ---------------------------------
+ -- UPDATE INFO
+getIdUpdateInfo :: GenId flexi -> UpdateInfo
getIdUpdateInfo id = updateInfo (idInfo id)
-addIdUpdateInfo :: Id -> UpdateInfo -> Id
-addIdUpdateInfo id@(Id {idInfo = info}) upd_info
- = id {idInfo = upd_info `setUpdateInfo` info}
-\end{code}
+setIdUpdateInfo :: GenId flexi -> UpdateInfo -> GenId flexi
+setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`)
-\begin{code}
-getIdSpecialisation :: Id -> IdSpecEnv
+ ---------------------------------
+ -- SPECIALISATION
+getIdSpecialisation :: GenId flexi -> IdSpecEnv
getIdSpecialisation id = specInfo (idInfo id)
-setIdSpecialisation :: Id -> IdSpecEnv -> Id
-setIdSpecialisation id@(Id {idInfo = info}) spec_info
- = id {idInfo = spec_info `setSpecInfo` info}
-\end{code}
-
-\begin{code}
-getIdStrictness :: Id -> StrictnessInfo
-getIdStrictness id = strictnessInfo (idInfo id)
-
-addIdStrictness :: Id -> StrictnessInfo -> Id
-addIdStrictness id@(Id {idInfo = info}) strict_info
- = id {idInfo = strict_info `setStrictnessInfo` info}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Id-comparison]{Comparison functions for @Id@s}
-%* *
-%************************************************************************
-
-Comparison: equality and ordering---this stuff gets {\em hammered}.
-
-\begin{code}
-cmpId (Id {idUnique = u1}) (Id {idUnique = u2}) = compare u1 u2
-\end{code}
-
-\begin{code}
-instance Eq (GenId ty) where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord (GenId ty) where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = cmpId a b
-\end{code}
+setIdSpecialisation :: GenId flexi -> IdSpecEnv -> GenId flexi
+setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`)
-%************************************************************************
-%* *
-\subsection[Id-other-instances]{Other instance declarations for @Id@s}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable ty => Outputable (GenId ty) where
- ppr id = pprId id
+ ---------------------------------
+ -- CAF INFO
+getIdCafInfo :: GenId flexi -> CafInfo
+getIdCafInfo id = cafInfo (idInfo id)
-showId :: Id -> String
-showId id = showSDoc (pprId id)
+setIdCafInfo :: GenId flexi -> CafInfo -> GenId flexi
+setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
\end{code}
-Default printing code (not used for interfaces):
-\begin{code}
-pprId :: Outputable ty => GenId ty -> SDoc
-
-pprId Id {idUnique = u, idName = n, idInfo = info}
- = hcat [ppr n, pp_prags]
- where
- pp_prags sty
- | opt_PprStyle_All && not (codeStyle sty)
- = (case inlinePragInfo info of
- IMustNotBeINLINEd -> text "{n}"
- IWantToBeINLINEd -> text "{i}"
- IMustBeINLINEd -> text "{I}"
- other -> empty) sty
-
- | otherwise
- = empty sty
-\end{code}
+ ---------------------------------
+ -- INLINING
+The inline pragma tells us to be very keen to inline this Id, but it's still
+OK not to if optimisation is switched off.
\begin{code}
-instance Uniquable (GenId ty) where
- uniqueOf = idUnique
+getInlinePragma :: GenId flexi -> InlinePragInfo
+getInlinePragma id = inlinePragInfo (idInfo id)
-instance NamedThing (GenId ty) where
- getName = idName
-\end{code}
+setInlinePragma :: GenId flexi -> InlinePragInfo -> GenId flexi
+setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag)
-Note: The code generator doesn't carry a @UniqueSupply@, so it uses
-the @Uniques@ out of local @Ids@ given to it.
+modifyInlinePragma :: GenId flexi -> (InlinePragInfo -> InlinePragInfo) -> GenId flexi
+modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info)
-%************************************************************************
-%* *
-\subsection{@IdEnv@s and @IdSet@s}
-%* *
-%************************************************************************
+idWantsToBeINLINEd :: GenId flexi -> Bool
+idWantsToBeINLINEd id = case getInlinePragma id of
+ IWantToBeINLINEd -> True
+ IMustBeINLINEd -> True
+ other -> False
-\begin{code}
-type IdEnv elt = UniqFM elt
-
-nullIdEnv :: IdEnv a
-
-mkIdEnv :: [(GenId ty, a)] -> IdEnv a
-unitIdEnv :: GenId ty -> a -> IdEnv a
-addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
-growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
-growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
-
-delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
-delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
-combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
-mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
-modifyIdEnv :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
-rngIdEnv :: IdEnv a -> [a]
-
-isNullIdEnv :: IdEnv a -> Bool
-lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
-lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
-elemIdEnv :: Id -> IdEnv a -> Bool
-\end{code}
+idMustNotBeINLINEd id = case getInlinePragma id of
+ IMustNotBeINLINEd -> True
+ IAmASpecPragmaId -> True
+ IAmALoopBreaker -> True
+ other -> False
-\begin{code}
-elemIdEnv = elemUFM
-addOneToIdEnv = addToUFM
-combineIdEnvs = plusUFM_C
-delManyFromIdEnv = delListFromUFM
-delOneFromIdEnv = delFromUFM
-growIdEnv = plusUFM
-lookupIdEnv = lookupUFM
-mapIdEnv = mapUFM
-mkIdEnv = listToUFM
-nullIdEnv = emptyUFM
-rngIdEnv = eltsUFM
-unitIdEnv = unitUFM
-isNullIdEnv = isNullUFM
-
-growIdEnvList env pairs = plusUFM env (listToUFM pairs)
-lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
-
-lookupIdSubst :: IdEnv Id -> Id -> Id
-lookupIdSubst env id = case lookupIdEnv env id of
- Just id' -> id' -- Return original if
- Nothing -> id -- it isn't in subst
-
--- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
--- modify function, and put it back.
-
-modifyIdEnv mangle_fn env key
- = case (lookupIdEnv env key) of
- Nothing -> env
- Just xx -> addOneToIdEnv env key (mangle_fn xx)
-
-modifyIdEnv_Directly mangle_fn env key
- = case (lookupUFM_Directly env key) of
- Nothing -> env
- Just xx -> addToUFM_Directly env key (mangle_fn xx)
-\end{code}
+idMustBeINLINEd id = case getInlinePragma id of
+ IMustBeINLINEd -> True
+ other -> False
-\begin{code}
-type GenIdSet ty = UniqSet (GenId ty)
-type IdSet = UniqSet (GenId Type)
-
-emptyIdSet :: GenIdSet ty
-intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
-idSetToList :: GenIdSet ty -> [GenId ty]
-unitIdSet :: GenId ty -> GenIdSet ty
-addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
-elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
-minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-isEmptyIdSet :: GenIdSet ty -> Bool
-mkIdSet :: [GenId ty] -> GenIdSet ty
-
-emptyIdSet = emptyUniqSet
-unitIdSet = unitUniqSet
-addOneToIdSet = addOneToUniqSet
-intersectIdSets = intersectUniqSets
-unionIdSets = unionUniqSets
-unionManyIdSets = unionManyUniqSets
-idSetToList = uniqSetToList
-elementOfIdSet = elementOfUniqSet
-minusIdSet = minusUniqSet
-isEmptyIdSet = isEmptyUniqSet
-mkIdSet = mkUniqSet
+isSpecPragmaId id = case getInlinePragma id of
+ IAmASpecPragmaId -> True
+ other -> False
\end{code}
--- /dev/null
+_interface_ IdInfo 1
+_exports_
+IdInfo IdInfo ;
+_declarations_
+1 data IdInfo ;
--- /dev/null
+__interface IdInfo 1 0 where
+__export IdInfo IdInfo ;
+1 data IdInfo ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}
-- Arity
ArityInfo(..),
exactArity, atLeastArity, unknownArity,
- arityInfo, setArityInfo, ppArityInfo,
-
- -- Demand
- DemandInfo,
- noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, setDemandInfo, willBeDemanded,
- Demand(..), -- Non-abstract
+ arityInfo, setArityInfo, ppArityInfo, arityLowerBound,
-- Strictness
StrictnessInfo(..), -- Non-abstract
- workerExists,
- mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
- strictnessInfo, ppStrictnessInfo, setStrictnessInfo,
+ workerExists, mkStrictnessInfo, mkBottomStrictnessInfo,
+ noStrictnessInfo, bottomIsGuaranteed, strictnessInfo,
+ ppStrictnessInfo, setStrictnessInfo,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
+ -- DemandInfo
+ demandInfo, setDemandInfo,
+
-- Inline prags
- InlinePragInfo(..),
- inlinePragInfo, setInlinePragInfo,
+ InlinePragInfo(..), OccInfo(..),
+ inlinePragInfo, setInlinePragInfo, notInsideLambda,
-- Specialisation
IdSpecEnv, specInfo, setSpecInfo,
UpdateInfo, UpdateSpec,
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, setUpdateInfo,
- -- Arg usage
- ArgUsageInfo, ArgUsage(..), ArgUsageType,
- mkArgUsageInfo, argUsageInfo, setArgUsageInfo, getArgUsage,
-
- -- FB type
- FBTypeInfo, FBType(..), FBConsum(..), FBProd(..),
- fbTypeInfo, ppFBTypeInfo, setFBTypeInfo, mkFBTypeInfo, getFBType
+ -- CAF info
+ CafInfo(..), cafInfo, setCafInfo, ppCafInfo,
) where
#include "HsVersions.h"
import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding )
import {-# SOURCE #-} CoreSyn ( CoreExpr )
--- for mkdependHS, CoreSyn.hi-boot refers to it:
-import BinderInfo ( BinderInfo )
-
import SpecEnv ( SpecEnv, emptySpecEnv )
-import BasicTypes ( NewOrData )
-
-import Demand
+import Demand ( Demand, isLazy, wwLazy, pprDemands )
import Outputable
-
-import Char ( ord )
\end{code}
An @IdInfo@ gives {\em optional} information about an @Id@. If
data IdInfo
= IdInfo {
arityInfo :: ArityInfo, -- Its arity
-
- demandInfo :: DemandInfo, -- Whether or not it is definitely demanded
-
+ demandInfo :: Demand, -- Whether or not it is definitely demanded
specInfo :: IdSpecEnv, -- Specialisations of this function which exist
-
strictnessInfo :: StrictnessInfo, -- Strictness properties
-
- unfoldingInfo :: Unfolding, -- Its unfolding; for locally-defined
- -- things, this can *only* be NoUnfolding
-
+ unfoldingInfo :: Unfolding, -- Its unfolding
updateInfo :: UpdateInfo, -- Which args should be updated
-
- argUsageInfo :: ArgUsageInfo, -- how this Id uses its arguments
-
- fbTypeInfo :: FBTypeInfo, -- the Foldr/Build W/W property of this function.
-
- inlinePragInfo :: InlinePragInfo -- Inline pragmas
+ cafInfo :: CafInfo,
+ inlinePragInfo :: !InlinePragInfo -- Inline pragmas
}
\end{code}
Setters
\begin{code}
-setFBTypeInfo fb info = info { fbTypeInfo = fb }
-setArgUsageInfo au info = info { argUsageInfo = au }
setUpdateInfo ud info = info { updateInfo = ud }
setDemandInfo dd info = info { demandInfo = dd }
setStrictnessInfo st info = info { strictnessInfo = st }
setArityInfo ar info = info { arityInfo = ar }
setInlinePragInfo pr info = info { inlinePragInfo = pr }
setUnfoldingInfo uf info = info { unfoldingInfo = uf }
+setCafInfo cf info = info { cafInfo = cf }
\end{code}
\begin{code}
noIdInfo = IdInfo {
arityInfo = UnknownArity,
- demandInfo = UnknownDemand,
+ demandInfo = wwLazy,
specInfo = emptySpecEnv,
strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
updateInfo = NoUpdateInfo,
- argUsageInfo = NoArgUsageInfo,
- fbTypeInfo = NoFBTypeInfo,
- inlinePragInfo = NoPragmaInfo
+ cafInfo = MayHaveCafRefs,
+ inlinePragInfo = NoInlinePragInfo
}
\end{code}
\begin{code}
-ppIdInfo :: Bool -- True <=> print specialisations, please
- -> IdInfo
- -> SDoc
-
-ppIdInfo specs_please (IdInfo {arityInfo, updateInfo, strictnessInfo, demandInfo})
+ppIdInfo :: IdInfo -> SDoc
+ppIdInfo (IdInfo {arityInfo,
+ demandInfo,
+ specInfo,
+ strictnessInfo,
+ unfoldingInfo,
+ updateInfo,
+ cafInfo,
+ inlinePragInfo})
= hsep [
ppArityInfo arityInfo,
ppUpdateInfo updateInfo,
ppStrictnessInfo strictnessInfo,
- ppDemandInfo demandInfo
+ ppr demandInfo,
+ ppCafInfo cafInfo
+ -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
]
\end{code}
%* *
%************************************************************************
+For locally-defined Ids, the code generator maintains its own notion
+of their arities; so it should not be asking... (but other things
+besides the code-generator need arity info!)
+
\begin{code}
data ArityInfo
= UnknownArity -- No idea
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
+arityLowerBound :: ArityInfo -> Int
+arityLowerBound UnknownArity = 0
+arityLowerBound (ArityAtLeast n) = n
+arityLowerBound (ArityExactly n) = n
+
+
ppArityInfo UnknownArity = empty
-ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
-ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
+ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("__A"), int arity]
+ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("__AL"), int arity]
\end{code}
%************************************************************************
\begin{code}
data InlinePragInfo
- = NoPragmaInfo
+ = NoInlinePragInfo
- | IWantToBeINLINEd -- user requests that we inline this
+ | IAmASpecPragmaId -- Used for spec-pragma Ids; don't discard or inline
- | IDontWantToBeINLINEd -- user requests that we don't inline this
+ | IWantToBeINLINEd -- User INLINE pragma
+ | IMustNotBeINLINEd -- User NOINLINE pragma
- | IMustNotBeINLINEd -- Used by the simplifier to prevent looping
- -- on recursive definitions
+ | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers
+ -- in a group of recursive definitions
- | IMustBeINLINEd -- Absolutely must inline; used for PrimOps only
+ | ICanSafelyBeINLINEd -- Used by the occurrence analyser to mark things
+ -- that manifesly occur once, not inside SCCs,
+ -- not in constructor arguments
+
+ OccInfo -- Says whether the occurrence is inside a lambda
+ -- If so, must only substitute WHNFs
+
+ Bool -- False <=> occurs in more than one case branch
+ -- If so, there's a code-duplication issue
+
+ | IAmDead -- Marks unused variables. Sometimes useful for
+ -- lambda and case-bound variables.
+
+ | IMustBeINLINEd -- Absolutely must inline; used for PrimOps and
+ -- constructors only.
+
+instance Outputable InlinePragInfo where
+ ppr NoInlinePragInfo = empty
+ ppr IMustBeINLINEd = ptext SLIT("__UU")
+ ppr IWantToBeINLINEd = ptext SLIT("__U")
+ ppr IMustNotBeINLINEd = ptext SLIT("__Unot")
+ ppr IAmALoopBreaker = ptext SLIT("__Ux")
+ ppr IAmDead = ptext SLIT("__Ud")
+ ppr (ICanSafelyBeINLINEd _ _) = ptext SLIT("__Us")
+ ppr IAmASpecPragmaId = ptext SLIT("__US")
+
+instance Show InlinePragInfo where
+ showsPrec p prag = showsPrecSDoc p (ppr prag)
\end{code}
+The @IMustNotBeDiscarded@ exists only to make Ids that are
+on the *LHS* of bindings created by SPECIALISE pragmas;
+eg: s = f Int d
+The SpecPragmaId is never itself mentioned; it
+exists solely so that the specialiser will find
+the call to f, and make specialised version of it.
+The SpecPragmaId binding is discarded by the specialiser
+when it gathers up overloaded calls.
+Meanwhile, it is not discarded as dead code.
+
+\begin{code}
+data OccInfo
+ = StrictOcc -- Occurs syntactically strictly;
+ -- i.e. in a function position or case scrutinee
+
+ | LazyOcc -- Not syntactically strict (*even* that of a strict function)
+ -- or in a case branch where there's more than one alternative
+
+ | InsideLam -- Inside a non-linear lambda (that is, a lambda which
+ -- is sure to be instantiated only once).
+ -- Substituting a redex for this occurrence is
+ -- dangerous because it might duplicate work.
+
+instance Outputable OccInfo where
+ ppr StrictOcc = text "s"
+ ppr LazyOcc = empty
+ ppr InsideLam = text "l"
+
+
+notInsideLambda :: OccInfo -> Bool
+notInsideLambda StrictOcc = True
+notInsideLambda LazyOcc = True
+notInsideLambda InsideLam = False
+\end{code}
%************************************************************************
%* *
mkStrictnessInfo :: [Demand] -> Bool -> StrictnessInfo
mkStrictnessInfo xs has_wrkr
- | all is_lazy xs = NoStrictnessInfo -- Uninteresting
+ | all isLazy xs = NoStrictnessInfo -- Uninteresting
| otherwise = StrictnessInfo xs has_wrkr
- where
- is_lazy (WwLazy False) = True -- NB "Absent" args do *not* count!
- is_lazy _ = False -- (as they imply a worker)
noStrictnessInfo = NoStrictnessInfo
mkBottomStrictnessInfo = BottomGuaranteed
bottomIsGuaranteed other = False
ppStrictnessInfo NoStrictnessInfo = empty
-ppStrictnessInfo BottomGuaranteed = ptext SLIT("_bot_")
+ppStrictnessInfo BottomGuaranteed = ptext SLIT("__bot")
ppStrictnessInfo (StrictnessInfo wrapper_args wrkr_maybe)
- = hsep [ptext SLIT("_S_"), text (showList wrapper_args "")]
+ = hsep [ptext SLIT("__S"), pprDemands wrapper_args]
\end{code}
%************************************************************************
%* *
-\subsection[demand-IdInfo]{Demand info about an @Id@}
-%* *
-%************************************************************************
-
-Whether a value is certain to be demanded or not. (This is the
-information that is computed by the ``front-end'' of the strictness
-analyser.)
-
-This information is only used within a module, it is not exported
-(obviously).
-
-\begin{code}
-data DemandInfo
- = UnknownDemand
- | DemandedAsPer Demand
-\end{code}
-
-\begin{code}
-noDemandInfo = UnknownDemand
-
-mkDemandInfo :: Demand -> DemandInfo
-mkDemandInfo demand = DemandedAsPer demand
-
-willBeDemanded :: DemandInfo -> Bool
-willBeDemanded (DemandedAsPer demand) = isStrict demand
-willBeDemanded _ = False
-
-ppDemandInfo UnknownDemand = text "{-# L #-}"
-ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[update-IdInfo]{Update-analysis info about an @Id@}
%* *
%************************************************************************
Text instance so that the update annotations can be read in.
\begin{code}
-ppUpdateInfo NoUpdateInfo = empty
+ppUpdateInfo NoUpdateInfo = empty
ppUpdateInfo (SomeUpdateInfo []) = empty
-ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
+ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("__U ")) (hcat (map int spec))
\end{code}
%************************************************************************
%* *
-\subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
+\subsection[CAF-IdInfo]{CAF-related information}
%* *
%************************************************************************
-\begin{code}
-data ArgUsageInfo
- = NoArgUsageInfo
- | SomeArgUsageInfo ArgUsageType
-
-data ArgUsage = ArgUsage Int -- number of arguments (is linear!)
- | UnknownArgUsage
-
-type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB
-\end{code}
+This information is used to build Static Reference Tables (see
+simplStg/ComputeSRT.lhs).
\begin{code}
-mkArgUsageInfo [] = NoArgUsageInfo
-mkArgUsageInfo au = SomeArgUsageInfo au
+data CafInfo
+ = MayHaveCafRefs -- either:
+ -- (1) A function or static constructor
+ -- that refers to one or more CAFs,
+ -- (2) A real live CAF
-getArgUsage :: ArgUsageInfo -> ArgUsageType
-getArgUsage NoArgUsageInfo = []
-getArgUsage (SomeArgUsageInfo u) = u
-\end{code}
-
-\begin{code}
-{- UNUSED:
-ppArgUsageInfo NoArgUsageInfo = empty
-ppArgUsageInfo (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
--}
-
-ppArgUsage (ArgUsage n) = int n
-ppArgUsage (UnknownArgUsage) = char '-'
-
-ppArgUsageType aut = hcat
- [ char '"' ,
- hcat (punctuate comma (map ppArgUsage aut)),
- char '"' ]
-\end{code}
+ | NoCafRefs -- A function or static constructor
+ -- that refers to no CAFs.
+-- LATER: not sure how easy this is...
+-- | OneCafRef Id
-%************************************************************************
-%* *
-\subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
-%* *
-%************************************************************************
-
-\begin{code}
-data FBTypeInfo
- = NoFBTypeInfo
- | SomeFBTypeInfo FBType
-data FBType = FBType [FBConsum] FBProd deriving (Eq)
-
-data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq)
-data FBProd = FBGoodProd | FBBadProd deriving(Eq)
-\end{code}
-
-\begin{code}
-mkFBTypeInfo = SomeFBTypeInfo
-
-getFBType :: FBTypeInfo -> Maybe FBType
-getFBType NoFBTypeInfo = Nothing
-getFBType (SomeFBTypeInfo u) = Just u
-\end{code}
-
-\begin{code}
-ppFBTypeInfo NoFBTypeInfo = empty
-ppFBTypeInfo (SomeFBTypeInfo (FBType cons prod))
- = (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod)
-
-ppFBType cons prod = hcat
- ([ char '"' ] ++ map ppCons cons ++ [ char '-', ppProd prod, char '"' ])
- where
- ppCons FBGoodConsum = char 'G'
- ppCons FBBadConsum = char 'B'
- ppProd FBGoodProd = char 'G'
- ppProd FBBadProd = char 'B'
+ppCafInfo NoCafRefs = ptext SLIT("__C")
+ppCafInfo MayHaveCafRefs = empty
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[IdUtils]{Constructing PrimOp Ids}
-
-\begin{code}
-module IdUtils ( primOpName ) where
-
-#include "HsVersions.h"
-
-import CoreSyn
-import CoreUnfold ( Unfolding )
-import MkId ( mkPrimitiveId )
-import IdInfo -- quite a few things
-import Name ( mkWiredInIdName, Name )
-import PrimOp ( primOpInfo, tagOf_PrimOp, PrimOpInfo(..), PrimOp )
-import PrelMods ( pREL_GHC )
-import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyConApp )
-import TysWiredIn ( boolTy )
-import Unique ( mkPrimOpIdUnique )
-import Util ( panic )
-\end{code}
-
-\begin{code}
-primOpName :: PrimOp -> Name
-primOpName op
- = case (primOpInfo op) of
- Dyadic str ty ->
- mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
-
- Monadic str ty ->
- mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
-
- Compare str ty ->
- mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
-
- Coercing str ty1 ty2 ->
- mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
-
- PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mk_prim_name op str
- tyvars
- arg_tys
- (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp prim_tycon res_tys)))
- (length arg_tys) -- arity
-
- AlgResult str tyvars arg_tys tycon res_tys ->
- mk_prim_name op str
- tyvars
- arg_tys
- (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp tycon res_tys)))
- (length arg_tys) -- arity
- where
- mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
- = name
- where
- key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
- name = mkWiredInIdName key pREL_GHC occ_name the_id
- the_id = mkPrimitiveId name ty prim_op
-\end{code}
-
-\begin{code}
-dyadic_fun_ty ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = ty `mkFunTy` ty
-compare_fun_ty ty = mkFunTys [ty, ty] boolTy
-\end{code}
+++ /dev/null
-_interface_ Literal 1
-_exports_
-Literal Literal;
-_declarations_
-1 data Literal;
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
-
-\begin{code}
-module Literal
- (
- Literal(..)
-
- , mkMachInt
- , mkMachInt_safe
- , mkMachWord
- , literalType
- , literalPrimRep
- , showLiteral
- , isNoRepLit
- , isLitLitLit
- ) where
-
-#include "HsVersions.h"
-
--- friends:
-import PrimRep ( PrimRep(..), ppPrimRep ) -- non-abstract
-import TysPrim ( getPrimRepInfo,
- addrPrimTy, intPrimTy, floatPrimTy,
- doublePrimTy, charPrimTy, wordPrimTy
- )
-
--- others:
-import Type ( Type )
-import CStrings ( stringToC, charToC, charToEasyHaskell )
-import TysWiredIn ( stringTy )
-import Outputable
-import Util ( thenCmp )
-
-\end{code}
-
-So-called @Literals@ are {\em either}:
-\begin{itemize}
-\item
-An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
-which is presumed to be surrounded by appropriate constructors
-(@mKINT@, etc.), so that the overall thing makes sense.
-\item
-An Integer, Rational, or String literal whose representation we are
-{\em uncommitted} about; i.e., the surrounding with constructors,
-function applications, etc., etc., has not yet been done.
-\end{itemize}
-
-\begin{code}
-data Literal
- = MachChar Char
- | MachStr FAST_STRING
-
- | MachAddr Integer -- whatever this machine thinks is a "pointer"
-
- | MachInt Integer -- for the numeric types, these are
- Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
-
- | MachInt64 Integer -- guaranteed 64-bit versions of the above.
- Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
-
- | MachFloat Rational
- | MachDouble Rational
-
- | MachLitLit FAST_STRING
- PrimRep
-
- | NoRepStr FAST_STRING
- | NoRepInteger Integer Type -- This Type is always Integer
- | NoRepRational Rational Type -- This Type is always Rational
- -- We keep these Types in the literal because Rational isn't
- -- (currently) wired in, so we can't conjure up its type out of
- -- thin air. Integer is, so the type here is really redundant.
-
- -- deriving (Eq, Ord): no, don't want to compare Types
- -- The Ord is needed for the FiniteMap used in the lookForConstructor
- -- in SimplEnv. If you declared that lookForConstructor *ignores*
- -- constructor-applications with LitArg args, then you could get
- -- rid of this Ord.
-
-mkMachInt, mkMachWord :: Integer -> Literal
-
-mkMachInt x = MachInt x True{-signed-}
-mkMachWord x = MachInt x False{-unsigned-}
-
--- check if the int is within range
-mkMachInt_safe :: Integer -> Literal
-mkMachInt_safe i
- | out_of_range =
- pprPanic "mkMachInt_safe"
- (hsep [text "ERROR: Int ", text (show i), text "out of range",
- brackets (int minInt <+> text ".." <+> int maxInt)])
- | otherwise = MachInt i True{-signed-}
- where
- out_of_range =
--- i < fromInt minBound ||
- i > fromInt maxInt
-
-mkMachInt64 x = MachInt64 x True{-signed-}
-mkMachWord64 x = MachInt64 x False{-unsigned-}
-
-cmpLit (MachChar a) (MachChar b) = a `compare` b
-cmpLit (MachStr a) (MachStr b) = a `compare` b
-cmpLit (MachAddr a) (MachAddr b) = a `compare` b
-cmpLit (MachInt a b) (MachInt c d) = (a `compare` c) `thenCmp` (b `compare` d)
-cmpLit (MachFloat a) (MachFloat b) = a `compare` b
-cmpLit (MachDouble a) (MachDouble b) = a `compare` b
-cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d)
-cmpLit (NoRepStr a) (NoRepStr b) = a `compare` b
-cmpLit (NoRepInteger a _) (NoRepInteger b _) = a `compare` b
-cmpLit (NoRepRational a _) (NoRepRational b _) = a `compare` b
-
- -- now we *know* the tags are different, so...
-cmpLit other_1 other_2
- | tag1 _LT_ tag2 = LT
- | otherwise = GT
- where
- tag1 = tagof other_1
- tag2 = tagof other_2
-
- tagof (MachChar _) = ILIT(1)
- tagof (MachStr _) = ILIT(2)
- tagof (MachAddr _) = ILIT(3)
- tagof (MachInt _ _) = ILIT(4)
- tagof (MachFloat _) = ILIT(5)
- tagof (MachDouble _) = ILIT(6)
- tagof (MachLitLit _ _) = ILIT(7)
- tagof (NoRepStr _) = ILIT(8)
- tagof (NoRepInteger _ _) = ILIT(9)
- tagof (NoRepRational _ _) = ILIT(10)
-
-instance Eq Literal where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord Literal where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = cmpLit a b
-\end{code}
-
-\begin{code}
-isNoRepLit (NoRepStr _) = True -- these are not primitive typed!
-isNoRepLit (NoRepInteger _ _) = True
-isNoRepLit (NoRepRational _ _) = True
-isNoRepLit _ = False
-
-isLitLitLit (MachLitLit _ _) = True
-isLitLitLit _ = False
-\end{code}
-
-\begin{code}
-literalType :: Literal -> Type
-
-literalType (MachChar _) = charPrimTy
-literalType (MachStr _) = addrPrimTy
-literalType (MachAddr _) = addrPrimTy
-literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy
-literalType (MachFloat _) = floatPrimTy
-literalType (MachDouble _) = doublePrimTy
-literalType (MachLitLit _ k) = case (getPrimRepInfo k) of { (_,t,_) -> t }
-literalType (NoRepInteger _ t) = t
-literalType (NoRepRational _ t) = t
-literalType (NoRepStr _) = stringTy
-\end{code}
-
-\begin{code}
-literalPrimRep :: Literal -> PrimRep
-
-literalPrimRep (MachChar _) = CharRep
-literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
-literalPrimRep (MachAddr _) = AddrRep
-literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
-literalPrimRep (MachInt64 _ signed) = if signed then Int64Rep else Word64Rep
-literalPrimRep (MachFloat _) = FloatRep
-literalPrimRep (MachDouble _) = DoubleRep
-literalPrimRep (MachLitLit _ k) = k
-#ifdef DEBUG
-literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger"
-literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
-literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
-#endif
-\end{code}
-
-The boring old output stuff:
-\begin{code}
--- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
--- exceptions: MachFloat and MachAddr get an initial keyword prefix
---
--- NoRep things get an initial keyword prefix (e.g. _integer_ 3)
-
-instance Outputable Literal where
- ppr lit = pprLit lit
-
-pprLit lit
- = getPprStyle $ \ sty ->
- let
- code_style = codeStyle sty
- in
- case lit of
- MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), char '\'', text (charToC ch), char '\'']
- | ifaceStyle sty -> char '\'' <> text (charToEasyHaskell ch) <> char '\''
- | otherwise -> text ['\'', ch, '\'']
-
- MachStr s | code_style -> doubleQuotes (text (stringToC (_UNPK_ s)))
- | otherwise -> text (show (_UNPK_ s))
-
- NoRepStr s | code_style -> pprPanic "NoRep in code style" (ppr lit)
- | otherwise -> ptext SLIT("_string_") <+> text (show (_UNPK_ s))
-
- MachInt i _ -> integer i
-{-
- | code_style && out_of_range
- -> pprPanic "" (hsep [text "ERROR: Int ", text (show i), text "out of range",
- brackets (ppr range_min <+> text ".." <+> ppr range_max)])
- | otherwise -> integer i
-
- where
- range_min = if signed then minInt else 0
- range_max = maxInt
- out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
--}
-
- MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f
- | otherwise -> ptext SLIT("_float_") <+> rational f
-
- MachDouble d -> rational d
-
- MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p
- | otherwise -> ptext SLIT("_addr_") <+> integer p
-
- NoRepInteger i _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
- | otherwise -> ptext SLIT("_integer_") <+> integer i
-
- NoRepRational r _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
- | otherwise -> hsep [ptext SLIT("_rational_"), integer (numerator r),
- integer (denominator r)]
-
- MachLitLit s k | code_style -> ptext s
- | otherwise -> hsep [ptext SLIT("_litlit_"), ppPrimRep k, text (show (_UNPK_ s))]
-
-showLiteral :: Literal -> String
-showLiteral lit = showSDoc (ppr lit)
-\end{code}
-
_interface_ MkId 1
_exports_
-MkId mkDataCon mkTupleCon ;
+MkId mkDataConId ;
_declarations_
-1 mkDataCon _:_ Name.Name -> [Id!StrictnessMark] -> [FieldLabel!FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id!Id ;;
-1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type!Type -> Id!Id ;;
+1 mkDataConId _:_ DataCon.DataCon -> Var.Id ;;
--- /dev/null
+__interface MkId 1 0 where
+__export MkId mkDataConId ;
+1 mkDataConId :: DataCon.DataCon -> Var.Id ;
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1998
%
\section[StdIdInfo]{Standard unfoldings}
\begin{code}
module MkId (
- mkImportedId,
- mkUserId,
- mkUserLocal, mkSysLocal,
- mkSpecPragmaId,
+ mkSpecPragmaId, mkWorkerId,
- mkDataCon, mkTupleCon,
-
- mkDictFunId,
- mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
+ mkDictFunId, mkDefaultMethodId,
+ mkMethodSelId, mkSuperDictSelId,
+ mkDataConId,
mkRecordSelId,
-
- mkPrimitiveId,
- mkWorkerId
-
+ mkPrimitiveId
) where
#include "HsVersions.h"
import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
-import Type
-import CoreSyn
-import Literal
-import TysWiredIn ( tupleCon )
-import Name ( mkLocalName, mkSysLocalName, mkCompoundName,
- occNameString, Name, OccName, NamedThing(..)
+import TysWiredIn ( boolTy )
+import Type ( Type, ThetaType,
+ mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
+ isUnLiftedType, substFlexiTheta,
+ splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
+ splitFunTys, splitForAllTys
+ )
+import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
+import Class ( Class, classBigSig, classTyCon )
+import Var ( Id, TyVar, VarDetails(..), mkId )
+import VarEnv ( zipVarEnv )
+import Const ( Con(..) )
+import Name ( mkCompoundName, mkWiredInIdName,
+ mkWorkerName, mkSuperDictSelName,
+ Name, NamedThing(..),
+ )
+import PrimOp ( PrimOp, primOpType, primOpStr, primOpUniq )
+import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels,
+ dataConArgTys, dataConSig
)
-import Id ( idType, fIRST_TAG,
- mkTemplateLocals, mkId, mkVanillaId,
- dataConStrictMarks, dataConFieldLabels, dataConArgTys,
- recordSelectorFieldLabel, dataConSig,
- StrictnessMark(..),
- Id, IdDetails(..), GenId
+import Id ( idType,
+ mkUserLocal, mkVanillaId, mkTemplateLocals,
+ setInlinePragma
)
import IdInfo ( noIdInfo,
exactArity, setUnfoldingInfo,
setArityInfo, setInlinePragInfo,
InlinePragInfo(..), IdInfo
)
-import Class ( Class, classBigSig, classTyCon )
import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags
)
-import TyVar ( TyVar )
-import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
+import CoreSyn
import PrelVals ( rEC_SEL_ERROR_ID )
+import PrelMods ( pREL_GHC )
import Maybes
-import SrcLoc ( SrcLoc )
-import BasicTypes ( Arity )
+import BasicTypes ( Arity, StrictnessMark(..) )
import Unique ( Unique )
import Maybe ( isJust )
import Outputable
import Util ( assoc )
+import List ( nub )
\end{code}
%************************************************************************
\begin{code}
-mkImportedId :: Name -> ty -> IdInfo -> GenId ty
-mkImportedId name ty info = mkId name ty (VanillaId True) info
-
--- SysLocal: for an Id being created by the compiler out of thin air...
--- UserLocal: an Id with a name the user might recognize...
-mkSysLocal :: FAST_STRING -> Unique -> (GenType flexi) -> SrcLoc -> GenId (GenType flexi)
-mkUserLocal :: OccName -> Unique -> (GenType flexi) -> SrcLoc -> GenId (GenType flexi)
-
-mkSysLocal str uniq ty loc
- = mkVanillaId (mkSysLocalName uniq str loc) ty noIdInfo
-
-mkUserLocal occ uniq ty loc
- = mkVanillaId (mkLocalName uniq occ loc) ty noIdInfo
-
-mkSpecPragmaId occ uniq ty loc
- = mkId (mkLocalName uniq occ loc) ty SpecPragmaId noIdInfo
-
-mkUserId :: Name -> GenType flexi -> GenId (GenType flexi)
-mkUserId name ty
- = mkVanillaId name ty noIdInfo
+mkSpecPragmaId occ uniq ty
+ = mkUserLocal occ uniq ty `setInlinePragma` IAmASpecPragmaId
mkDefaultMethodId dm_name rec_c ty
- = mkVanillaId dm_name ty noIdInfo
+ = mkVanillaId dm_name ty
-mkDictFunId dfun_name full_ty clas itys
- = mkVanillaId dfun_name full_ty noIdInfo
-
-mkWorkerId uniq unwrkr ty info
- = mkVanillaId name ty info
- where
- name = mkCompoundName name_fn uniq (getName unwrkr)
- name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
+mkWorkerId uniq unwrkr ty
+ = mkVanillaId (mkCompoundName mkWorkerName uniq (getName unwrkr)) ty
\end{code}
-
%************************************************************************
%* *
\subsection{Data constructors}
%************************************************************************
\begin{code}
-mkDataCon :: Name
- -> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ThetaType
- -> [TyVar] -> ThetaType
- -> [TauType] -> TyCon
- -> Id
- -- can get the tag and all the pieces of the type from the Type
-
-mkDataCon name stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
- = ASSERT(length stricts == length args_tys)
- data_con
- where
- -- NB: data_con self-recursion; should be OK as tags are not
- -- looked at until late in the game.
- data_con = mkId name data_con_ty details (dataConInfo data_con)
- details = AlgConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
-
- data_con_tag = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
- data_con_family = tyConDataCons tycon
- data_con_ty = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt)
- (mkFunTys args_tys (mkTyConApp tycon (mkTyVarTys tvs)))
-
-
-mkTupleCon :: Arity -> Name -> Type -> Id
-mkTupleCon arity name ty
- = con_id
+mkDataConId :: DataCon -> Id
+mkDataConId data_con
+ = mkId (getName data_con)
+ id_ty
+ (ConstantId (DataCon data_con))
+ (dataConInfo data_con)
where
- con_id = mkId name ty (TupleConId arity) (dataConInfo con_id)
+ (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
+ id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
+ (theta ++ ex_theta)
+ (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
\end{code}
We're going to build a constructor that looks like:
to be here.
\begin{code}
-dataConInfo :: Id -> IdInfo
+dataConInfo :: DataCon -> IdInfo
-dataConInfo con_id
+dataConInfo data_con
= setInlinePragInfo IMustBeINLINEd $
- -- Always inline constructors; we don't create a binding for them
- -- (well, at least not for dict constructors, since they are
- -- always applied)
+ -- Always inline constructors; we won't create a binding for them
setArityInfo (exactArity (length locals)) $
setUnfoldingInfo unfolding $
noIdInfo
where
unfolding = mkUnfolding con_rhs
- (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
+ (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
+ all_tyvars = tyvars ++ ex_tyvars
dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
- con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
+ ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
n_dicts = length dict_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
- locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
+ locals = mkTemplateLocals (dict_tys ++ ex_dict_tys ++ arg_tys)
data_args = drop n_dicts locals
(data_arg1:_) = data_args -- Used for newtype only
- strict_marks = dataConStrictMarks con_id
+ strict_marks = dataConStrictMarks data_con
strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
-- NB: we can't call mkTemplateLocals twice, because it
-- always starts from the same unique.
= ASSERT( length arg_tys == 1)
Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
| otherwise
- = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
+ = mkConApp data_con (map Type (mkTyVarTys all_tyvars) ++ map Var data_args)
- con_rhs = mkTyLam tyvars $
- mkValLam locals $
+ con_rhs = mkLams all_tyvars $ mkLams locals $
foldr mk_case con_app strict_args
- mk_case arg body | isUnpointedType (idType arg)
+ mk_case arg body | isUnLiftedType (idType arg)
= body -- "!" on unboxed arg does nothing
| otherwise
- = Case (Var arg) (AlgAlts [] (BindDefault arg body))
+ = Case (Var arg) arg [(DEFAULT,[],body)]
-- This case shadows "arg" but that's fine
\end{code}
[data_id] = mkTemplateLocals [data_ty]
alts = map mk_maybe_alt data_cons
the_alts = catMaybes alts
+ default_alt | all isJust alts = [] -- No default needed
+ | otherwise = [(DEFAULT, [], error_expr)]
- sel_rhs = mkTyLam tyvars $
- mkValLam [data_id] $
- Case (Var data_id)
- -- if any of the constructors don't have the label, ...
- (if any (not . isJust) alts then
- AlgAlts the_alts(BindDefault data_id error_expr)
- else
- AlgAlts the_alts NoDefault)
+ sel_rhs = mkLams tyvars $ Lam data_id $
+ Case (Var data_id) data_id (the_alts ++ default_alt)
mk_maybe_alt data_con
= case maybe_the_arg_id of
Nothing -> Nothing
- Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
+ Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
where
arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
-- The first one will shadow data_id, but who cares
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
- error_expr = mkApp (Var rEC_SEL_ERROR_ID) [rhs_ty] [LitArg msg_lit]
+ error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
- msg_lit = NoRepStr (_PK_ full_msg)
\end{code}
mkSuperDictSelId uniq clas index ty
= mkDictSelId name clas ty
where
- name = mkCompoundName name_fn uniq (getName clas)
- name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
+ name = mkCompoundName (mkSuperDictSelName index) uniq (getName clas)
-- For method selectors the clean thing to do is
-- to give the method selector the same name as the class op itself.
dict_ty = mkDictTy clas tyvar_tys
(dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
- rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
+ rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
- | otherwise = mkLam tyvars [dict_id] $
- Case (Var dict_id) $
- AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
+ | otherwise = mkLams tyvars $ Lam dict_id $
+ Case (Var dict_id) dict_id
+ [(DataCon data_con, arg_ids, Var the_arg_id)]
\end{code}
\begin{code}
-mkPrimitiveId name ty prim_op
- = mkId name ty (PrimitiveId prim_op) info
+mkPrimitiveId :: PrimOp -> Id
+mkPrimitiveId prim_op
+ = id
where
-
+ occ_name = primOpStr prim_op
+ key = primOpUniq prim_op
+ ty = primOpType prim_op
+ name = mkWiredInIdName key pREL_GHC occ_name id
+ id = mkId name ty (ConstantId (PrimOp prim_op)) info
+
info = setUnfoldingInfo unfolding $
setInlinePragInfo IMustBeINLINEd $
-- The pragma @IMustBeINLINEd@ says that this Id absolutely
(arg_tys, _) = splitFunTys tau
args = mkTemplateLocals arg_tys
- rhs = mkLam tyvars args $
- Prim prim_op
- ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
- [VarArg v | v <- args])
+ rhs = mkLams tyvars $ mkLams args $
+ mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
+\end{code}
+
+\end{code}
+
+\begin{code}
+dyadic_fun_ty ty = mkFunTys [ty, ty] ty
+monadic_fun_ty ty = ty `mkFunTy` ty
+compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
%************************************************************************
%* *
-\subsection{Catch-all}
+\subsection{DictFuns}
%* *
%************************************************************************
\begin{code}
-addStandardIdInfo id
- = pprTrace "addStandardIdInfo missing:" (ppr id) id
+mkDictFunId :: Name -- Name to use for the dict fun;
+ -> Class
+ -> [TyVar]
+ -> [Type]
+ -> ThetaType
+ -> Id
+
+mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
+ = mkVanillaId dfun_name dfun_ty
+ where
+ (class_tyvars, sc_theta, _, _, _) = classBigSig clas
+ sc_theta' = substFlexiTheta (zipVarEnv class_tyvars inst_tys) sc_theta
+ -- Doesn't really need to be flexi
+
+ dfun_theta = case inst_decl_theta of
+ [] -> [] -- If inst_decl_theta is empty, then we don't
+ -- want to have any dict arguments, so that we can
+ -- expose the constant methods.
+
+ other -> nub (inst_decl_theta ++ sc_theta')
+ -- Otherwise we pass the superclass dictionaries to
+ -- the dictionary function; the Mark Jones optimisation.
+ --
+ -- NOTE the "nub". I got caught by this one:
+ -- class Monad m => MonadT t m where ...
+ -- instance Monad m => MonadT (EnvT env) m where ...
+ -- Here, the inst_decl_theta has (Monad m); but so
+ -- does the sc_theta'!
+
+ dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
\end{code}
-
--- /dev/null
+__interface Name 1 0 where
+__export Name Name;
+1 data Name ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Name]{@Name@: to transmit name info from renamer to typechecker}
Module,
pprModule, moduleString,
+ -- The basic form of names
+ isLexCon, isLexVar, isLexId, isLexSym,
+ isLexConId, isLexConSym, isLexVarId, isLexVarSym,
+ mkTupNameStr, mkUbxTupNameStr, isLowerISO, isUpperISO,
+
-- The OccName type
- OccName(..),
+ OccName(..), varOcc,
pprOccName, occNameString, occNameFlavour,
isTvOcc, isTCOcc, isVarOcc, prefixOccName,
- uniqToOccName,
-- The Name type
Name, -- Abstract
nameUnique, changeUnique, setNameProvenance, getNameProvenance,
setNameVisibility, mkNameVisible,
- nameOccName, nameString, nameModule,
+ nameOccName, nameModule,
isExportedName, nameSrcLoc,
isLocallyDefinedName,
- isLocalName,
+ isSysLocalName, isLocalName, isGlobalName, isExternallyVisibleName,
pprNameProvenance,
- -- Sets of Names
- NameSet,
- emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
- minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet,
+ -- Special Names
+ dictNamePrefix, mkSuperDictSelName, mkWorkerName,
+ mkDefaultMethodName, mkClassTyConStr, mkClassDataConStr,
-- Misc
Provenance(..), pprProvenance,
#include "HsVersions.h"
-import {-# SOURCE #-} Id ( Id )
+import {-# SOURCE #-} Var ( Id )
import {-# SOURCE #-} TyCon ( TyCon )
import CStrings ( identToC )
-import CmdLineOpts ( opt_PprStyle_All, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
+import PrelMods ( pREL_BASE, pREL_TUP, pREL_GHC )
+import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import BasicTypes ( Module, IfaceFlavour(..), moduleString, pprModule )
-import Lex ( isLexConId )
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
-import Unique ( pprUnique, showUnique, Unique, Uniquable(..) )
-import UniqSet ( UniqSet,
- emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList,
- isEmptyUniqSet, unionManyUniqSets, minusUniqSet, mkUniqSet,
- elementOfUniqSet, addListToUniqSet, addOneToUniqSet
- )
-import UniqFM ( UniqFM )
+import Unique ( pprUnique, Unique, Uniquable(..) )
import Outputable
+import Char ( isUpper, isLower, ord )
+import Util ( nOfThem )
+import GlaExts
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Lexical categories}
+%* *
+%************************************************************************
+
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report.
+
+\begin{code}
+isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
+ isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+
+isLexCon cs = isLexConId cs || isLexConSym cs
+isLexVar cs = isLexVarId cs || isLexVarSym cs
+
+isLexId cs = isLexConId cs || isLexVarId cs
+isLexSym cs = isLexConSym cs || isLexVarSym cs
+
+-------------
+
+isLexConId cs
+ | _NULL_ cs = False
+ | cs == SLIT("[]") = True
+ | c == '(' = True -- (), (,), (,,), ...
+ | otherwise = isUpper c || isUpperISO c
+ where
+ c = _HEAD_ cs
+
+isLexVarId cs
+ | _NULL_ cs = False
+ | otherwise = isLower c || isLowerISO c
+ where
+ c = _HEAD_ cs
+
+isLexConSym cs
+ | _NULL_ cs = False
+ | otherwise = c == ':'
+ || cs == SLIT("->")
+ where
+ c = _HEAD_ cs
+
+isLexVarSym cs
+ | _NULL_ cs = False
+ | otherwise = isSymbolASCII c
+ || isSymbolISO c
+ where
+ c = _HEAD_ cs
+
+-------------
+isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
+isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
+isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'#
+--0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
+--0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+\end{code}
+
+\begin{code}
+mkTupNameStr 0 = (pREL_BASE, SLIT("()"))
+mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr 2 = (pREL_TUP, _PK_ "(,)") -- not strictly necessary
+mkTupNameStr 3 = (pREL_TUP, _PK_ "(,,)") -- ditto
+mkTupNameStr 4 = (pREL_TUP, _PK_ "(,,,)") -- ditto
+mkTupNameStr n = (pREL_TUP, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
+
+mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???"
+mkUbxTupNameStr 1 = (pREL_GHC, _PK_ "(# #)") -- 1 and 0 both make sense!!!
+mkUbxTupNameStr 2 = (pREL_GHC, _PK_ "(#,#)")
+mkUbxTupNameStr 3 = (pREL_GHC, _PK_ "(#,,#)")
+mkUbxTupNameStr 4 = (pREL_GHC, _PK_ "(#,,,#)")
+mkUbxTupNameStr n = (pREL_GHC, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
\end{code}
then identToC (occNameString n)
else ptext (occNameString n)
+varOcc :: FAST_STRING -> OccName
+varOcc = VarOcc
+
occNameString :: OccName -> FAST_STRING
occNameString (VarOcc s) = s
occNameString (TvOcc s) = s
occNameString (TCOcc s) = s
+mapOccName :: (FAST_STRING -> FAST_STRING) -> OccName -> OccName
+mapOccName f (VarOcc s) = VarOcc (f s)
+mapOccName f (TvOcc s) = TvOcc (f s)
+mapOccName f (TCOcc s) = TCOcc (f s)
+
prefixOccName :: FAST_STRING -> OccName -> OccName
prefixOccName prefix (VarOcc s) = VarOcc (prefix _APPEND_ s)
prefixOccName prefix (TvOcc s) = TvOcc (prefix _APPEND_ s)
\begin{code}
data Name
= Local Unique
- OccName
- SrcLoc
+ (Maybe OccName) -- For ones that started life with a user name
| Global Unique
Module -- The defining module
| NonLocalDef -- Defined non-locally
SrcLoc -- Defined non-locally; src-loc gives defn site
- IfaceFlavour -- Whether the defn site is an .hi-boot file or not
+ IfaceFlavour -- Whether the defn site is an .hi-boot file
PrintUnqualified
| WiredInTyCon TyCon -- There's a wired-in version
| WiredInId Id -- ...ditto...
-type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is
- -- in scope in this module, so print it unqualified
- -- in error messages
+type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is
+ -- in scope in this module, so print it
+ -- unqualified in error messages
\end{code}
Something is "Exported" if it may be mentioned by another module without
Furthermore, being Exported means that we can't see all call sites of the thing.
Exported things include:
- - explicitly exported Ids, including data constructors, class method selectors
+
+ - explicitly exported Ids, including data constructors,
+ class method selectors
+
- dfuns from instance decls
Being Exported is *not* the same as finally appearing in the .o file's
\end{code}
\begin{code}
-mkLocalName :: Unique -> OccName -> SrcLoc -> Name
-mkLocalName = Local
+mkLocalName :: Unique -> OccName -> Name
+mkLocalName uniq occ = Local uniq (Just occ)
mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name
mkGlobalName = Global
-mkSysLocalName :: Unique -> FAST_STRING -> SrcLoc -> Name
-mkSysLocalName uniq str loc = Local uniq (VarOcc str) loc
+mkSysLocalName :: Unique -> Name
+mkSysLocalName uniq = Local uniq Nothing
mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name
mkWiredInIdName uniq mod occ id
= Global uniq mod (TCOcc occ) (WiredInTyCon tycon)
-mkCompoundName :: (FAST_STRING -> FAST_STRING) -- Occurrence-name modifier
- -> Unique -- New unique
- -> Name -- Base name (must be a Global)
+mkCompoundName :: (OccName -> OccName)
+ -> Unique -- New unique
+ -> Name -- Base name
-> Name -- Result is always a value name
-mkCompoundName str_fn uniq (Global _ mod occ prov)
- = Global uniq mod new_occ prov
- where
- new_occ = VarOcc (str_fn (occNameString occ)) -- Always a VarOcc
+mkCompoundName f uniq (Global _ mod occ prov)
+ = Global uniq mod (f occ) prov
-mkCompoundName str_fn uniq (Local _ occ loc)
- = Local uniq (VarOcc (str_fn (occNameString occ))) loc
+mkCompoundName f uniq (Local _ (Just occ))
+ = Local uniq (Just (f occ))
+mkCompoundName f uniq (Local _ Nothing)
+ = Local uniq Nothing
setNameProvenance :: Name -> Provenance -> Name
- -- setNameProvenance used to only change the provenance of Implicit-provenance things,
- -- but that gives bad error messages for names defined twice in the same
- -- module, so I changed it to set the provenance of *any* global (SLPJ Jun 97)
+ -- setNameProvenance used to only change the provenance of
+ -- Implicit-provenance things, but that gives bad error messages
+ -- for names defined twice in the same module, so I changed it to
+ -- set the provenance of *any* global (SLPJ Jun 97)
setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov
setNameProvenance other_name prov = other_name
getNameProvenance :: Name -> Provenance
getNameProvenance (Global uniq mod occ prov) = prov
-getNameProvenance (Local uniq occ locn) = LocalDef locn NotExported
+getNameProvenance (Local uniq occ) = LocalDef noSrcLoc NotExported
-- When we renumber/rename things, we need to be
-- able to change a Name's Unique to match the cached
-- one in the thing it's the name of. If you know what I mean.
-changeUnique (Local _ n l) u = Local u n l
+changeUnique (Local _ n ) u = Local u n
changeUnique (Global _ mod occ prov) u = Global u mod occ prov
\end{code}
\begin{code}
setNameVisibility :: Maybe Module -> Unique -> Name -> Name
-setNameVisibility maybe_mod occ_uniq name@(Global uniq mod occ (LocalDef loc NotExported))
+setNameVisibility maybe_mod uniq name@(Global _ mod occ (LocalDef loc NotExported))
| not all_toplev_ids_visible || not_top_level maybe_mod
- = Local uniq (uniqToOccName occ_uniq) loc -- Localise Global name
+ = Local uniq Nothing -- Localise Global name
-setNameVisibility maybe_mod occ_uniq name@(Global _ _ _ _)
+setNameVisibility maybe_mod uniq name@(Global _ _ _ _)
= name -- Otherwise don't fiddle with Global
-setNameVisibility (Just mod) occ_uniq (Local uniq occ loc)
+setNameVisibility (Just mod) uniq (Local _ _)
| all_toplev_ids_visible
= Global uniq mod -- Globalise Local name
- (uniqToOccName occ_uniq)
- (LocalDef loc NotExported)
+ (uniqToOccName uniq)
+ (LocalDef noSrcLoc NotExported)
-setNameVisibility maybe_mod occ_uniq (Local uniq occ loc)
- = Local uniq (uniqToOccName occ_uniq) loc -- New OccName for Local
+setNameVisibility maybe_mod uniq (Local _ _)
+ = Local uniq Nothing -- New unique for Local; zap its occ
-- make the Name globally visible regardless.
mkNameVisible :: Module -> Unique -> Name -> Name
mkNameVisible mod occ_uniq nm@(Global _ _ _ _) = nm
-mkNameVisible mod occ_uniq nm@(Local uniq occ loc)
- = Global uniq mod (uniqToOccName occ_uniq) (LocalDef loc Exported)
-
+mkNameVisible mod occ_uniq nm@(Local uniq occ)
+ = Global uniq mod (uniqToOccName occ_uniq) (LocalDef noSrcLoc Exported)
-uniqToOccName uniq = VarOcc (_PK_ ('$':showUnique uniq))
- -- The "$" is to make sure that this OccName is distinct from all user-defined ones
+uniqToOccName uniq = VarOcc (_PK_ ('_':show uniq))
+ -- The "_" is to make sure that this OccName is distinct from all user-defined ones
not_top_level (Just m) = False
not_top_level Nothing = True
-all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible
- opt_EnsureSplittableC -- Splitting requires visiblilty
+all_toplev_ids_visible =
+ not opt_OmitInterfacePragmas || -- Pragmas can make them visible
+ opt_EnsureSplittableC -- Splitting requires visiblilty
\end{code}
%************************************************************************
nameModAndOcc :: Name -> (Module, OccName) -- Globals only
nameOccName :: Name -> OccName
nameModule :: Name -> Module
-nameString :: Name -> FAST_STRING -- A.b form
nameSrcLoc :: Name -> SrcLoc
isLocallyDefinedName :: Name -> Bool
isExportedName :: Name -> Bool
isWiredInName :: Name -> Bool
isLocalName :: Name -> Bool
+isGlobalName :: Name -> Bool
+isExternallyVisibleName :: Name -> Bool
-nameUnique (Local u _ _) = u
+nameUnique (Local u _) = u
nameUnique (Global u _ _ _) = u
-nameOccName (Local _ occ _) = occ
-nameOccName (Global _ _ occ _) = occ
+nameOccName (Local _ (Just occ)) = occ
+nameOccName (Local uniq Nothing) = pprPanic "nameOccName" (ppr uniq)
+nameOccName (Global _ _ occ _) = occ
nameModule (Global _ mod occ _) = mod
nameModAndOcc (Global _ mod occ _) = (mod,occ)
-nameString (Local _ occ _) = occNameString occ
-nameString (Global _ mod occ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ
-
isExportedName (Global _ _ _ (LocalDef _ Exported)) = True
isExportedName other = False
-nameSrcLoc (Local _ _ loc) = loc
+nameSrcLoc (Local _ _) = noSrcLoc
nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc
nameSrcLoc (Global _ _ _ (NonLocalDef loc _ _)) = loc
nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc
nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc
nameSrcLoc other = noSrcLoc
-isLocallyDefinedName (Local _ _ _) = True
+isLocallyDefinedName (Local _ _) = True
isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True
isLocallyDefinedName other = False
maybeWiredInTyConName other = Nothing
-isLocalName (Local _ _ _) = True
-isLocalName _ = False
+isLocalName (Local _ _) = True
+isLocalName _ = False
+
+isSysLocalName (Local _ Nothing) = True
+isSysLocalName other = False
+
+isGlobalName (Global _ _ _ _) = True
+isGlobalName other = False
+
+-- Global names are by definition those that are visible
+-- outside the module, *as seen by the linker*. Externally visible
+-- does not mean visible at the source level (that's isExported).
+isExternallyVisibleName name = isGlobalName name
\end{code}
\begin{code}
cmpName n1 n2 = c n1 n2
where
- c (Local u1 _ _) (Local u2 _ _) = compare u1 u2
- c (Local _ _ _) _ = LT
+ c (Local u1 _) (Local u2 _) = compare u1 u2
+ c (Local _ _) _ = LT
c (Global u1 _ _ _) (Global u2 _ _ _) = compare u1 u2
c (Global _ _ _ _) _ = GT
\end{code}
compare a b = cmpName a b
instance Uniquable Name where
- uniqueOf = nameUnique
+ getUnique = nameUnique
instance NamedThing Name where
getName n = n
\end{code}
+%************************************************************************
+%* *
+\subsection[Special-Names]{Special Kinds of names}
+%* *
+%************************************************************************
+
+Here's our convention for splitting up the object file name space:
+
+ _d... dictionary identifiers
+ _g... externally visible (non-user visible) names
+
+ _m... default methods
+ _n... default methods (encoded symbols, eg. <= becomes _nle)
+
+ _p... superclass selectors
+
+ _w... workers
+ _v... workers (encoded symbols)
+
+ _x... local variables
+
+ _u... user-defined names that previously began with '_'
+
+ _[A-Z]... compiler-generated tycons/datacons (namely dictionary
+ constructors)
+
+ __.... keywords (__export, __letrec etc.)
+
+This knowledge is encoded in the following functions.
+
+\begin{code}
+dictNamePrefix :: FAST_STRING
+dictNamePrefix = SLIT("_d")
+
+mkSuperDictSelName :: Int -> OccName -> OccName
+mkSuperDictSelName index = prefixOccName (_PK_ ("_p" ++ show index ++ "_"))
+
+mkWorkerName :: OccName -> OccName
+mkWorkerName nm
+ | isLexSym nm_str =
+ prefixOccName SLIT("_v") (mapOccName trName nm)
+ | otherwise =
+ prefixOccName SLIT("_w") nm
+ where nm_str = occNameString nm
+
+mkDefaultMethodName :: OccName -> OccName
+mkDefaultMethodName nm
+ | isLexSym nm_str =
+ prefixOccName SLIT("_n") (mapOccName trName nm)
+ | otherwise =
+ prefixOccName SLIT("_m") nm
+ where nm_str = occNameString nm
+
+-- not used yet:
+--mkRecordSelectorName :: Name -> Name
+--mkMethodSelectorName :: Name -> Name
+
+mkClassTyConStr, mkClassDataConStr :: FAST_STRING -> FAST_STRING
+
+mkClassTyConStr s = SLIT("_") _APPEND_ s
+mkClassDataConStr s = SLIT("_") _APPEND_ s
+
+-- translate a string such that it can occur as *part* of an identifer. This
+-- is used when we prefix identifiers to create new names, for example the
+-- name of a default method.
+
+trName :: FAST_STRING -> FAST_STRING
+trName nm = _PK_ (foldr tran "" (_UNPK_ nm))
+ where
+ tran c cs = case trChar c of
+ '\0' -> '_' : show (ord c) ++ cs
+ c' -> c' : cs
+ trChar '&' = 'a'
+ trChar '|' = 'b'
+ trChar ':' = 'c'
+ trChar '/' = 'd'
+ trChar '=' = 'e'
+ trChar '>' = 'g'
+ trChar '#' = 'h'
+ trChar '@' = 'i'
+ trChar '<' = 'l'
+ trChar '-' = 'm'
+ trChar '!' = 'n'
+ trChar '+' = 'p'
+ trChar '\'' = 'q'
+ trChar '$' = 'r'
+ trChar '?' = 's'
+ trChar '*' = 't'
+ trChar '_' = 'u'
+ trChar '.' = 'v'
+ trChar '\\' = 'w'
+ trChar '%' = 'x'
+ trChar '~' = 'y'
+ trChar '^' = 'z'
+ trChar _ = '\0'
+\end{code}
%************************************************************************
%* *
pprName name
= getPprStyle $ \ sty ->
let
- ppr (Local u n _)
- | userStyle sty
- || ifaceStyle sty = ptext (occNameString n)
- | codeStyle sty = pprUnique u
- | otherwise = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u]
+ -- when printing local names for interface files, prepend the '_'
+ -- to avoid clashes with user-defined names. In fact, these names
+ -- will always begin with 'g' for top-level ids and 'x' otherwise,
+ -- because these are the unique supplies going into the tidy phase.
+ ppr (Local u n) | codeStyle sty = pprUnique u
+ | ifaceStyle sty = char '_' <> pprUnique u
+
+ ppr (Local u Nothing) = pprUnique u
+ ppr (Local u (Just occ)) | userStyle sty = ptext (occNameString occ)
+ | otherwise = ptext (occNameString occ) <> char '_' <> pprUnique u
ppr name@(Global u m n prov)
| codeStyle sty
= hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name]
where
pp_mod_dot
- = case prov of -- Omit home module qualifier if its in scope
- LocalDef _ _ -> pp_qual dot (user_sty || iface_sty)
- NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty)
- WiredInTyCon _ -> pp_qual dot user_sty -- Hack: omit qualifers on wired in things
- WiredInId _ -> pp_qual dot user_sty -- in user style only
- NoProvenance -> pp_qual dot False
+ = case prov of -- Omit home module qualifier if in scope
+ LocalDef _ _ -> pp_qual dot (user_sty || iface_sty)
+ NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty)
+ -- Hack: omit qualifers on wired in things
+ -- in user style only
+ WiredInTyCon _ -> pp_qual dot user_sty
+ WiredInId _ -> pp_qual dot user_sty
+ NoProvenance -> pp_qual dot False
pp_qual sep omit_qual
| omit_qual = empty
| debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p, text "-}"]
| otherwise = empty
where
- prov_p | opt_PprStyle_All = comma <> pp_prov prov
- | otherwise = empty
+ prov_p | opt_PprStyle_NoPrags = empty
+ | otherwise = comma <> pp_prov prov
pp_prov (LocalDef _ Exported) = char 'x'
pp_prov (LocalDef _ NotExported) = char 'l'
-- pprNameProvenance is used in error messages to say where a name came from
pprNameProvenance :: Name -> SDoc
-pprNameProvenance (Local _ _ loc) = pprProvenance (LocalDef loc NotExported)
+pprNameProvenance (Local _ _) = pprProvenance (LocalDef noSrcLoc NotExported)
pprNameProvenance (Global _ _ _ prov) = pprProvenance prov
pprProvenance :: Provenance -> SDoc
%************************************************************************
%* *
-\subsection[Sets of names}
-%* *
-%************************************************************************
-
-\begin{code}
-type NameSet = UniqSet Name
-emptyNameSet :: NameSet
-unitNameSet :: Name -> NameSet
-addListToNameSet :: NameSet -> [Name] -> NameSet
-addOneToNameSet :: NameSet -> Name -> NameSet
-mkNameSet :: [Name] -> NameSet
-unionNameSets :: NameSet -> NameSet -> NameSet
-unionManyNameSets :: [NameSet] -> NameSet
-minusNameSet :: NameSet -> NameSet -> NameSet
-elemNameSet :: Name -> NameSet -> Bool
-nameSetToList :: NameSet -> [Name]
-isEmptyNameSet :: NameSet -> Bool
-
-isEmptyNameSet = isEmptyUniqSet
-emptyNameSet = emptyUniqSet
-unitNameSet = unitUniqSet
-mkNameSet = mkUniqSet
-addListToNameSet = addListToUniqSet
-addOneToNameSet = addOneToUniqSet
-unionNameSets = unionUniqSets
-unionManyNameSets = unionManyUniqSets
-minusNameSet = minusUniqSet
-elemNameSet = elementOfUniqSet
-nameSetToList = uniqSetToList
-\end{code}
-
-
-
-%************************************************************************
-%* *
\subsection{Overloaded functions related to Names}
%* *
%************************************************************************
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+\section[NameSet]{@NameSets@}
+
+\begin{code}
+module NameSet (
+ -- Sets of Names
+ NameSet,
+ emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
+ minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet,
+ ) where
+
+#include "HsVersions.h"
+
+import Name
+import UniqSet
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Sets of names}
+%* *
+%************************************************************************
+
+\begin{code}
+type NameSet = UniqSet Name
+emptyNameSet :: NameSet
+unitNameSet :: Name -> NameSet
+addListToNameSet :: NameSet -> [Name] -> NameSet
+addOneToNameSet :: NameSet -> Name -> NameSet
+mkNameSet :: [Name] -> NameSet
+unionNameSets :: NameSet -> NameSet -> NameSet
+unionManyNameSets :: [NameSet] -> NameSet
+minusNameSet :: NameSet -> NameSet -> NameSet
+elemNameSet :: Name -> NameSet -> Bool
+nameSetToList :: NameSet -> [Name]
+isEmptyNameSet :: NameSet -> Bool
+
+isEmptyNameSet = isEmptyUniqSet
+emptyNameSet = emptyUniqSet
+unitNameSet = unitUniqSet
+mkNameSet = mkUniqSet
+addListToNameSet = addListToUniqSet
+addOneToNameSet = addOneToUniqSet
+unionNameSets = unionUniqSets
+unionManyNameSets = unionManyUniqSets
+minusNameSet = minusUniqSet
+elemNameSet = elementOfUniqSet
+nameSetToList = uniqSetToList
+\end{code}
+
+
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[PprEnv]{The @PprEnv@ type}
\begin{code}
module PprEnv (
- PprEnv{-abstract-},
+ PprEnv, --
BindingSite(..),
initPprEnv,
- pCon, pLit, pValBndr, pOcc, pPrim, pSCC,
- pTy, pTyVarB, pTyVarO
-
+ pCon, pBndr, pOcc, pSCC,
+ pTy, pTyVarO
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Id ( Id )
-import {-# SOURCE #-} PrimOp ( PrimOp )
-import {-# SOURCE #-} CostCentre ( CostCentre )
+import {-# SOURCE #-} Const ( Con )
+import Var ( GenId, GenTyVar )
+import CostCentre ( CostCentre )
import Type ( GenType )
-import TyVar ( GenTyVar )
-import Literal ( Literal )
import Outputable
-import Unique ( Unique )
-import UniqFM ( emptyUFM, UniqFM )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data PprEnv flexi bndr occ
- = PE (Literal -> SDoc)
- (Id -> SDoc)
- (PrimOp -> SDoc)
- (CostCentre -> SDoc)
+data PprEnv bndr flexi
+ = PE {
+ pCon :: Con -> SDoc,
+ pSCC :: CostCentre -> SDoc,
- (GenTyVar flexi -> SDoc) -- to print tyvar binders
- (GenTyVar flexi -> SDoc) -- to print tyvar occurrences
- (GenType flexi -> SDoc) -- to print types
-
- (BindingSite -> bndr -> SDoc) -- to print val_bdrs
- (occ -> SDoc) -- to print bindees
+ pTyVarO :: GenTyVar flexi -> SDoc, -- to print tyvar occurrences
+ pTy :: GenType flexi -> SDoc, -- to print types
+ pBndr :: BindingSite -> bndr -> SDoc, -- to print value binders
+ pOcc :: GenId flexi -> SDoc -- to print value occurrences
+ }
\end{code}
@BindingSite@ is used to tell the thing that prints binder what
\begin{code}
initPprEnv
- :: Maybe (Literal -> SDoc)
- -> Maybe (Id -> SDoc)
- -> Maybe (PrimOp -> SDoc)
+ :: Maybe (Con -> SDoc)
-> Maybe (CostCentre -> SDoc)
-> Maybe (GenTyVar flexi -> SDoc)
- -> Maybe (GenTyVar flexi -> SDoc)
-> Maybe (GenType flexi -> SDoc)
-> Maybe (BindingSite -> bndr -> SDoc)
- -> Maybe (occ -> SDoc)
- -> PprEnv flexi bndr occ
+ -> Maybe (GenId flexi -> SDoc)
+ -> PprEnv bndr flexi
-- you can specify all the printers individually; if
-- you don't specify one, you get bottom
-initPprEnv l d p c tvb tvo ty val_bndr occ
- = PE (demaybe l)
- (demaybe d)
- (demaybe p)
+initPprEnv p c tvo ty bndr occ
+ = PE (demaybe p)
(demaybe c)
- (demaybe tvb)
(demaybe tvo)
(demaybe ty)
- (demaybe val_bndr)
+ (demaybe bndr)
(demaybe occ)
where
demaybe Nothing = bottom
bottom = panic "PprEnv.initPprEnv: unspecified printing function"
\end{code}
-\begin{code}
-pLit (PE pp _ _ _ _ _ _ _ _) = pp
-pCon (PE _ pp _ _ _ _ _ _ _) = pp
-pPrim (PE _ _ pp _ _ _ _ _ _) = pp
-pSCC (PE _ _ _ pp _ _ _ _ _) = pp
-
-pTyVarB (PE _ _ _ _ pp _ _ _ _) = pp
-pTyVarO (PE _ _ _ _ _ pp _ _ _) = pp
-pTy (PE _ _ _ _ _ _ pp _ _) = pp
-
-pValBndr (PE _ _ _ _ _ _ _ pp _) = pp
-pOcc (PE _ _ _ _ _ _ _ _ pp) = pp
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
import Outputable
import FastString ( unpackFS )
-import GlaExts ( Int(..), Int#, (+#) )
+import GlaExts ( Int(..), (+#) )
\end{code}
%************************************************************************
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[UniqSupply]{The @UniqueSupply@ data type and a (monadic) supply thereof}
UniqSupply, -- Abstractly
- getUnique, getUniques, -- basic ops
+ uniqFromSupply, uniqsFromSupply, -- basic ops
UniqSM, -- type: unique supply monad
- initUs, thenUs, returnUs, fixUs,
+ initUs, thenUs, thenUs_, returnUs, fixUs, getUs, setUs,
+ getUniqueUs, getUniquesUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us,
thenMaybeUs, mapAccumLUs,
mkSplitUniqSupply :: Char -> IO UniqSupply
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
-getUnique :: UniqSupply -> Unique
-getUniques :: Int -> UniqSupply -> [Unique]
+uniqFromSupply :: UniqSupply -> Unique
+uniqsFromSupply :: Int -> UniqSupply -> [Unique]
\end{code}
\begin{code}
\end{code}
\begin{code}
-getUnique (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
+uniqFromSupply (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
-getUniques (I# i) supply = i `get_from` supply
+uniqsFromSupply (I# i) supply = i `get_from` supply
where
get_from 0# _ = []
get_from n (MkSplitUniqSupply (I# u) _ s2)
%************************************************************************
\begin{code}
-type UniqSM result = UniqSupply -> result
+type UniqSM result = UniqSupply -> (result, UniqSupply)
-- the initUs function also returns the final UniqSupply
initUs :: UniqSupply -> UniqSM a -> a
-initUs init_us m = m init_us
+initUs init_us m = case m init_us of { (r,_) -> r }
{-# INLINE thenUs #-}
{-# INLINE returnUs #-}
\begin{code}
fixUs :: (a -> UniqSM a) -> UniqSM a
fixUs m us
- = r where r = m r us
+ = (r,us') where (r,us') = m r us
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
-
thenUs expr cont us
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (expr s1) of { result ->
- cont result s2 }}
-\end{code}
+ = case (expr us) of { (result, us') -> cont result us' }
+
+thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
+thenUs_ expr cont us
+ = case (expr us) of { (_, us') -> cont us' }
-\begin{code}
returnUs :: a -> UniqSM a
-returnUs result us = result
+returnUs result us = (result, us)
+
+getUs :: UniqSM UniqSupply
+getUs us = (us, panic "getUs: bad supply")
+setUs :: UniqSupply -> UniqSM ()
+setUs us old_us = ((), us)
+
+getUniqueUs :: UniqSM Unique
+getUniqueUs us = case splitUniqSupply us of
+ (us1,us2) -> (uniqFromSupply us1, us2)
+
+getUniquesUs :: Int -> UniqSM [Unique]
+getUniquesUs n us = case splitUniqSupply us of
+ (us1,us2) -> (uniqsFromSupply n us1, us2)
+\end{code}
+
+\begin{code}
mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
mapUs f [] = returnUs []
-
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
@Uniques@ are used to distinguish entities in the compiler (@Ids@,
@Classes@, etc.) from each other. Thus, @Uniques@ are the basic
Unique, Uniquable(..),
u2i, -- hack: used in UniqFM
- pprUnique, pprUnique10, showUnique,
+ pprUnique, pprUnique10,
mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
+ getKey, -- Used in Var only!
incrUnique, -- Used for renumbering
- initTyVarUnique, mkTyVarUnique,
+ initTyVarUnique,
initTidyUniques,
-- now all the built-in Uniques (and functions to make them)
mkAlphaTyVarUnique,
mkPrimOpIdUnique,
mkTupleDataConUnique,
+ mkUbxTupleDataConUnique,
mkTupleTyConUnique,
+ mkUbxTupleTyConUnique,
getBuiltinUniques, mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
addrDataConKey,
addrPrimTyConKey,
addrTyConKey,
- andandIdKey,
appendIdKey,
arrayPrimTyConKey,
assertIdKey,
augmentIdKey,
boolTyConKey,
boundedClassKey,
- buildDataConKey,
+ boxedKindConKey,
buildIdKey,
byteArrayPrimTyConKey,
cCallableClassKey,
charDataConKey,
charPrimTyConKey,
charTyConKey,
- coerceIdKey,
- composeIdKey,
+ concatIdKey,
consDataConKey,
doubleDataConKey,
doublePrimTyConKey,
enumFromToClassOpKey,
eqClassKey,
eqClassOpKey,
- eqDataConKey,
errorIdKey,
- evalClassKey,
falseDataConKey,
+ filterIdKey,
floatDataConKey,
floatPrimTyConKey,
floatTyConKey,
foreignObjDataConKey,
foreignObjPrimTyConKey,
foreignObjTyConKey,
- forkIdKey,
+ weakPrimTyConKey,
fractionalClassKey,
fromEnumClassOpKey,
fromIntClassOpKey,
funTyConKey,
functorClassKey,
geClassOpKey,
- gtDataConKey,
- inlineIdKey,
intDataConKey,
intPrimTyConKey,
intTyConKey,
integerMinusOneIdKey,
integerPlusOneIdKey,
integerPlusTwoIdKey,
+ int2IntegerIdKey,
+ addr2IntegerIdKey,
integerTyConKey,
integerZeroIdKey,
integralClassKey,
irrefutPatErrorIdKey,
ixClassKey,
- lexIdKey,
- liftDataConKey,
- liftTyConKey,
listTyConKey,
- ltDataConKey,
mainKey,
+ mapIdKey,
minusClassOpKey,
monadClassKey,
monadPlusClassKey,
monadZeroClassKey,
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
+ mutVarPrimTyConKey,
nilDataConKey,
noMethodBindingErrorIdKey,
nonExhaustiveGuardsErrorIdKey,
- notIdKey,
numClassKey,
+ openKindConKey,
ordClassKey,
orderingTyConKey,
otherwiseIdKey,
ratioTyConKey,
rationalTyConKey,
readClassKey,
- readParenIdKey,
realClassKey,
realFloatClassKey,
realFracClassKey,
recConErrorIdKey,
recSelErrIdKey,
recUpdErrorIdKey,
- return2GMPsDataConKey,
- return2GMPsTyConKey,
- returnIntAndGMPDataConKey,
- returnIntAndGMPTyConKey,
returnMClassOpKey,
- seqIdKey,
showClassKey,
- showParenIdKey,
- showSpaceIdKey,
- showStringIdKey,
- stTyConKey,
- stDataConKey,
ioTyConKey,
ioDataConKey,
- ioResultTyConKey,
- ioOkDataConKey,
- ioFailDataConKey,
stablePtrDataConKey,
stablePtrPrimTyConKey,
stablePtrTyConKey,
- stateAndAddrPrimDataConKey,
- stateAndAddrPrimTyConKey,
- stateAndArrayPrimDataConKey,
- stateAndArrayPrimTyConKey,
- stateAndByteArrayPrimDataConKey,
- stateAndByteArrayPrimTyConKey,
- stateAndCharPrimDataConKey,
- stateAndCharPrimTyConKey,
- stateAndDoublePrimDataConKey,
- stateAndDoublePrimTyConKey,
- stateAndFloatPrimDataConKey,
- stateAndFloatPrimTyConKey,
- stateAndForeignObjPrimDataConKey,
- stateAndForeignObjPrimTyConKey,
- stateAndIntPrimDataConKey,
- stateAndIntPrimTyConKey,
- stateAndInt64PrimDataConKey,
- stateAndInt64PrimTyConKey,
- stateAndMutableArrayPrimDataConKey,
- stateAndMutableArrayPrimTyConKey,
- stateAndMutableByteArrayPrimDataConKey,
- stateAndMutableByteArrayPrimTyConKey,
- stateAndPtrPrimDataConKey,
- stateAndPtrPrimTyConKey,
- stateAndStablePtrPrimDataConKey,
- stateAndStablePtrPrimTyConKey,
- stateAndSynchVarPrimDataConKey,
- stateAndSynchVarPrimTyConKey,
- stateAndWordPrimDataConKey,
- stateAndWordPrimTyConKey,
- stateAndWord64PrimDataConKey,
- stateAndWord64PrimTyConKey,
stateDataConKey,
- stRetDataConKey,
- statePrimTyConKey,
stateTyConKey,
- stRetTyConKey,
- synchVarPrimTyConKey,
+
+ statePrimTyConKey,
+ superKindConKey,
+ mVarPrimTyConKey,
thenMClassOpKey,
+ threadIdPrimTyConKey,
toEnumClassOpKey,
traceIdKey,
trueDataConKey,
+ unboxedKindConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
unpackCStringFoldrIdKey,
unpackCStringIdKey,
- ureadListIdKey,
unsafeCoerceIdKey,
ushowListIdKey,
voidIdKey,
word64DataConKey,
word64PrimTyConKey,
word64TyConKey,
- zeroClassOpKey
- , copyableIdKey
- , noFollowIdKey
- , parAtAbsIdKey
- , parAtForNowIdKey
- , parAtIdKey
- , parAtRelIdKey
- , parGlobalIdKey
- , parLocalIdKey
- , unboundKey
- , byteArrayTyConKey
- , mutableByteArrayTyConKey
- , allClassKey
+ zeroClassOpKey,
+ zipIdKey,
+ bindIOIdKey,
+ deRefStablePtrIdKey,
+ makeStablePtrIdKey,
+ unboundKey,
+ byteArrayTyConKey,
+ mutableByteArrayTyConKey
) where
#include "HsVersions.h"
mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply
+getKey :: Unique -> Int# -- for Var
+
incrUnique :: Unique -> Unique
\end{code}
\begin{code}
mkUniqueGrimily x = MkUnique x
+{-# INLINE getKey #-}
+getKey (MkUnique x) = x
+
incrUnique (MkUnique i) = MkUnique (i +# 1#)
-- pop the Char in the top 8 bits of the Unique(Supply)
\begin{code}
class Uniquable a where
- uniqueOf :: a -> Unique
+ getUnique :: a -> Unique
instance Uniquable FastString where
- uniqueOf fs = mkUniqueGrimily (uniqueOfFS fs)
+ getUnique fs = mkUniqueGrimily (uniqueOfFS fs)
instance Uniquable Int where
- uniqueOf (I# i#) = mkUniqueGrimily i#
+ getUnique (I# i#) = mkUniqueGrimily i#
\end{code}
-----------------
instance Uniquable Unique where
- uniqueOf u = u
+ getUnique u = u
\end{code}
We do sometimes make strings with @Uniques@ in them:
char (chr (ord 'a' + u))
finish_ppr tag u pp_u = char tag <> pp_u
-showUnique :: Unique -> String
-showUnique uniq = showSDoc (pprUnique uniq)
-
instance Outputable Unique where
ppr u = pprUnique u
-instance Text Unique where
- showsPrec p uniq rest = showUnique uniq
+instance Show Unique where
+ showsPrec p uniq = showsPrecSDoc p (pprUnique uniq)
\end{code}
%************************************************************************
B: builtin
C-E: pseudo uniques (used in native-code generator)
_: unifiable tyvars (above)
- 1-8: prelude things below
+ 0-9: prelude things below
\begin{code}
-mkAlphaTyVarUnique i = mkUnique '1' i
+mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
mkPreludeTyConUnique i = mkUnique '3' i
mkTupleTyConUnique a = mkUnique '4' a
+mkUbxTupleTyConUnique a = mkUnique '5' a
-mkPreludeDataConUnique i = mkUnique '5' i -- must be alphabetic
-mkTupleDataConUnique a = mkUnique '6' a -- ditto (*may* be used in C labels)
+mkPreludeDataConUnique i = mkUnique '6' i -- must be alphabetic
+mkTupleDataConUnique a = mkUnique '7' a -- ditto (*may* be used in C labels)
+mkUbxTupleDataConUnique a = mkUnique '8' a
-mkPrimOpIdUnique op = mkUnique '7' op
-mkPreludeMiscIdUnique i = mkUnique '8' i
+mkPrimOpIdUnique op = mkUnique '9' op
+mkPreludeMiscIdUnique i = mkUnique '0' i
-- The "tyvar uniques" print specially nicely: a, b, c, etc.
-- See pprUnique for details
initTyVarUnique :: Unique
initTyVarUnique = mkUnique 't' 0
-mkTyVarUnique :: Int -> Unique
-mkTyVarUnique n = mkUnique 't' n
-
initTidyUniques :: (Unique, Unique) -- Global and local
initTidyUniques = (mkUnique 'g' 0, mkUnique 'x' 0)
mkBuiltinUnique :: Int -> Unique
mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
+mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs
mkPseudoUnique2 i = mkUnique 'D' i -- ditto
mkPseudoUnique3 i = mkUnique 'E' i -- ditto
boundedClassKey = mkPreludeClassUnique 1
enumClassKey = mkPreludeClassUnique 2
eqClassKey = mkPreludeClassUnique 3
-evalClassKey = mkPreludeClassUnique 4
floatingClassKey = mkPreludeClassUnique 5
fractionalClassKey = mkPreludeClassUnique 6
integralClassKey = mkPreludeClassUnique 7
cReturnableClassKey = mkPreludeClassUnique 20
ixClassKey = mkPreludeClassUnique 21
-allClassKey = mkPreludeClassUnique 22 -- Pseudo class used for universal quantification
\end{code}
%************************************************************************
int64PrimTyConKey = mkPreludeTyConUnique 19
int64TyConKey = mkPreludeTyConUnique 20
integerTyConKey = mkPreludeTyConUnique 21
-liftTyConKey = mkPreludeTyConUnique 22
-listTyConKey = mkPreludeTyConUnique 23
-foreignObjPrimTyConKey = mkPreludeTyConUnique 24
-foreignObjTyConKey = mkPreludeTyConUnique 25
+listTyConKey = mkPreludeTyConUnique 22
+foreignObjPrimTyConKey = mkPreludeTyConUnique 23
+foreignObjTyConKey = mkPreludeTyConUnique 24
+weakPrimTyConKey = mkPreludeTyConUnique 25
mutableArrayPrimTyConKey = mkPreludeTyConUnique 26
mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 27
orderingTyConKey = mkPreludeTyConUnique 28
-synchVarPrimTyConKey = mkPreludeTyConUnique 29
+mVarPrimTyConKey = mkPreludeTyConUnique 29
ratioTyConKey = mkPreludeTyConUnique 30
rationalTyConKey = mkPreludeTyConUnique 31
realWorldTyConKey = mkPreludeTyConUnique 32
-return2GMPsTyConKey = mkPreludeTyConUnique 33
-returnIntAndGMPTyConKey = mkPreludeTyConUnique 34
-stablePtrPrimTyConKey = mkPreludeTyConUnique 35
-stablePtrTyConKey = mkPreludeTyConUnique 36
-stateAndAddrPrimTyConKey = mkPreludeTyConUnique 37
-stateAndArrayPrimTyConKey = mkPreludeTyConUnique 38
-stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 39
-stateAndCharPrimTyConKey = mkPreludeTyConUnique 40
-stateAndDoublePrimTyConKey = mkPreludeTyConUnique 41
-stateAndFloatPrimTyConKey = mkPreludeTyConUnique 42
-stateAndIntPrimTyConKey = mkPreludeTyConUnique 43
-stateAndInt64PrimTyConKey = mkPreludeTyConUnique 44
-stateAndForeignObjPrimTyConKey = mkPreludeTyConUnique 45
-stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 46
-stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 47
-stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 48
-stateAndPtrPrimTyConKey = mkPreludeTyConUnique 49
-stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 50
-stateAndWordPrimTyConKey = mkPreludeTyConUnique 51
-stateAndWord64PrimTyConKey = mkPreludeTyConUnique 52
-statePrimTyConKey = mkPreludeTyConUnique 53
-stateTyConKey = mkPreludeTyConUnique 54
-mutableByteArrayTyConKey = mkPreludeTyConUnique 55
-stTyConKey = mkPreludeTyConUnique 56
-stRetTyConKey = mkPreludeTyConUnique 57
-ioTyConKey = mkPreludeTyConUnique 58
-ioResultTyConKey = mkPreludeTyConUnique 59
-byteArrayTyConKey = mkPreludeTyConUnique 60
-wordPrimTyConKey = mkPreludeTyConUnique 61
-wordTyConKey = mkPreludeTyConUnique 62
-word8TyConKey = mkPreludeTyConUnique 63
-word16TyConKey = mkPreludeTyConUnique 64
-word32TyConKey = mkPreludeTyConUnique 65
-word64PrimTyConKey = mkPreludeTyConUnique 66
-word64TyConKey = mkPreludeTyConUnique 67
-voidTyConKey = mkPreludeTyConUnique 68
+stablePtrPrimTyConKey = mkPreludeTyConUnique 33
+stablePtrTyConKey = mkPreludeTyConUnique 34
+stateTyConKey = mkPreludeTyConUnique 50
+statePrimTyConKey = mkPreludeTyConUnique 51
+mutableByteArrayTyConKey = mkPreludeTyConUnique 52
+mutVarPrimTyConKey = mkPreludeTyConUnique 53
+ioTyConKey = mkPreludeTyConUnique 55
+byteArrayTyConKey = mkPreludeTyConUnique 56
+wordPrimTyConKey = mkPreludeTyConUnique 57
+wordTyConKey = mkPreludeTyConUnique 58
+word8TyConKey = mkPreludeTyConUnique 59
+word16TyConKey = mkPreludeTyConUnique 60
+word32TyConKey = mkPreludeTyConUnique 61
+word64PrimTyConKey = mkPreludeTyConUnique 62
+word64TyConKey = mkPreludeTyConUnique 63
+voidTyConKey = mkPreludeTyConUnique 64
+boxedKindConKey = mkPreludeTyConUnique 65
+unboxedKindConKey = mkPreludeTyConUnique 66
+openKindConKey = mkPreludeTyConUnique 67
+superKindConKey = mkPreludeTyConUnique 68
+threadIdPrimTyConKey = mkPreludeTyConUnique 69
+
\end{code}
%************************************************************************
\begin{code}
addrDataConKey = mkPreludeDataConUnique 1
-buildDataConKey = mkPreludeDataConUnique 2
-charDataConKey = mkPreludeDataConUnique 4
-consDataConKey = mkPreludeDataConUnique 5
-doubleDataConKey = mkPreludeDataConUnique 6
-eqDataConKey = mkPreludeDataConUnique 7
-falseDataConKey = mkPreludeDataConUnique 8
-floatDataConKey = mkPreludeDataConUnique 9
-gtDataConKey = mkPreludeDataConUnique 10
-intDataConKey = mkPreludeDataConUnique 11
-int8DataConKey = mkPreludeDataConUnique 12
-int16DataConKey = mkPreludeDataConUnique 13
-int32DataConKey = mkPreludeDataConUnique 14
-int64DataConKey = mkPreludeDataConUnique 15
-integerDataConKey = mkPreludeDataConUnique 16
-liftDataConKey = mkPreludeDataConUnique 17
-ltDataConKey = mkPreludeDataConUnique 18
-foreignObjDataConKey = mkPreludeDataConUnique 19
-nilDataConKey = mkPreludeDataConUnique 20
-ratioDataConKey = mkPreludeDataConUnique 21
-return2GMPsDataConKey = mkPreludeDataConUnique 22
-returnIntAndGMPDataConKey = mkPreludeDataConUnique 23
-stablePtrDataConKey = mkPreludeDataConUnique 24
-stateAndAddrPrimDataConKey = mkPreludeDataConUnique 25
-stateAndArrayPrimDataConKey = mkPreludeDataConUnique 26
-stateAndByteArrayPrimDataConKey = mkPreludeDataConUnique 27
-stateAndCharPrimDataConKey = mkPreludeDataConUnique 28
-stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29
-stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30
-stateAndIntPrimDataConKey = mkPreludeDataConUnique 31
-stateAndInt64PrimDataConKey = mkPreludeDataConUnique 32
-stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 33
-stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 34
-stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 35
-stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 36
-stateAndPtrPrimDataConKey = mkPreludeDataConUnique 37
-stateAndStablePtrPrimDataConKey = mkPreludeDataConUnique 38
-stateAndWordPrimDataConKey = mkPreludeDataConUnique 39
-stateAndWord64PrimDataConKey = mkPreludeDataConUnique 40
-stateDataConKey = mkPreludeDataConUnique 41
-trueDataConKey = mkPreludeDataConUnique 42
-wordDataConKey = mkPreludeDataConUnique 43
-word8DataConKey = mkPreludeDataConUnique 44
-word16DataConKey = mkPreludeDataConUnique 45
-word32DataConKey = mkPreludeDataConUnique 46
-word64DataConKey = mkPreludeDataConUnique 47
-stDataConKey = mkPreludeDataConUnique 48
-stRetDataConKey = mkPreludeDataConUnique 49
-ioDataConKey = mkPreludeDataConUnique 50
-ioOkDataConKey = mkPreludeDataConUnique 51
-ioFailDataConKey = mkPreludeDataConUnique 52
+charDataConKey = mkPreludeDataConUnique 2
+consDataConKey = mkPreludeDataConUnique 3
+doubleDataConKey = mkPreludeDataConUnique 4
+falseDataConKey = mkPreludeDataConUnique 5
+floatDataConKey = mkPreludeDataConUnique 6
+intDataConKey = mkPreludeDataConUnique 7
+int8DataConKey = mkPreludeDataConUnique 8
+int16DataConKey = mkPreludeDataConUnique 9
+int32DataConKey = mkPreludeDataConUnique 10
+int64DataConKey = mkPreludeDataConUnique 11
+integerDataConKey = mkPreludeDataConUnique 12
+foreignObjDataConKey = mkPreludeDataConUnique 13
+nilDataConKey = mkPreludeDataConUnique 14
+ratioDataConKey = mkPreludeDataConUnique 15
+stablePtrDataConKey = mkPreludeDataConUnique 16
+stateDataConKey = mkPreludeDataConUnique 33
+trueDataConKey = mkPreludeDataConUnique 34
+wordDataConKey = mkPreludeDataConUnique 35
+word8DataConKey = mkPreludeDataConUnique 36
+word16DataConKey = mkPreludeDataConUnique 37
+word32DataConKey = mkPreludeDataConUnique 38
+word64DataConKey = mkPreludeDataConUnique 39
+stDataConKey = mkPreludeDataConUnique 40
+ioDataConKey = mkPreludeDataConUnique 42
\end{code}
%************************************************************************
\begin{code}
absentErrorIdKey = mkPreludeMiscIdUnique 1
-andandIdKey = mkPreludeMiscIdUnique 2
-appendIdKey = mkPreludeMiscIdUnique 3
-augmentIdKey = mkPreludeMiscIdUnique 4
-buildIdKey = mkPreludeMiscIdUnique 5
-composeIdKey = mkPreludeMiscIdUnique 6
-errorIdKey = mkPreludeMiscIdUnique 7
-foldlIdKey = mkPreludeMiscIdUnique 8
-foldrIdKey = mkPreludeMiscIdUnique 9
-forkIdKey = mkPreludeMiscIdUnique 10
-recSelErrIdKey = mkPreludeMiscIdUnique 11
-integerMinusOneIdKey = mkPreludeMiscIdUnique 12
-integerPlusOneIdKey = mkPreludeMiscIdUnique 13
-integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
-integerZeroIdKey = mkPreludeMiscIdUnique 15
-irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
-lexIdKey = mkPreludeMiscIdUnique 17
-noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 20
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21
-notIdKey = mkPreludeMiscIdUnique 22
-packCStringIdKey = mkPreludeMiscIdUnique 23
-parErrorIdKey = mkPreludeMiscIdUnique 24
-parIdKey = mkPreludeMiscIdUnique 25
-patErrorIdKey = mkPreludeMiscIdUnique 26
-readParenIdKey = mkPreludeMiscIdUnique 27
-realWorldPrimIdKey = mkPreludeMiscIdUnique 28
-recConErrorIdKey = mkPreludeMiscIdUnique 29
-recUpdErrorIdKey = mkPreludeMiscIdUnique 30
-seqIdKey = mkPreludeMiscIdUnique 31
-showParenIdKey = mkPreludeMiscIdUnique 32
-showSpaceIdKey = mkPreludeMiscIdUnique 33
-showStringIdKey = mkPreludeMiscIdUnique 34
-traceIdKey = mkPreludeMiscIdUnique 35
-unpackCString2IdKey = mkPreludeMiscIdUnique 36
-unpackCStringAppendIdKey = mkPreludeMiscIdUnique 37
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 38
-unpackCStringIdKey = mkPreludeMiscIdUnique 39
-unsafeCoerceIdKey = mkPreludeMiscIdUnique 40
-voidIdKey = mkPreludeMiscIdUnique 41
-ushowListIdKey = mkPreludeMiscIdUnique 42
-ureadListIdKey = mkPreludeMiscIdUnique 43
-
-copyableIdKey = mkPreludeMiscIdUnique 44
-noFollowIdKey = mkPreludeMiscIdUnique 45
-parAtAbsIdKey = mkPreludeMiscIdUnique 46
-parAtForNowIdKey = mkPreludeMiscIdUnique 47
-parAtIdKey = mkPreludeMiscIdUnique 48
-parAtRelIdKey = mkPreludeMiscIdUnique 49
-parGlobalIdKey = mkPreludeMiscIdUnique 50
-parLocalIdKey = mkPreludeMiscIdUnique 51
+appendIdKey = mkPreludeMiscIdUnique 2
+augmentIdKey = mkPreludeMiscIdUnique 3
+buildIdKey = mkPreludeMiscIdUnique 4
+errorIdKey = mkPreludeMiscIdUnique 5
+foldlIdKey = mkPreludeMiscIdUnique 6
+foldrIdKey = mkPreludeMiscIdUnique 7
+recSelErrIdKey = mkPreludeMiscIdUnique 8
+integerMinusOneIdKey = mkPreludeMiscIdUnique 9
+integerPlusOneIdKey = mkPreludeMiscIdUnique 10
+integerPlusTwoIdKey = mkPreludeMiscIdUnique 11
+integerZeroIdKey = mkPreludeMiscIdUnique 12
+int2IntegerIdKey = mkPreludeMiscIdUnique 13
+addr2IntegerIdKey = mkPreludeMiscIdUnique 14
+irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15
+lexIdKey = mkPreludeMiscIdUnique 16
+noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
+packCStringIdKey = mkPreludeMiscIdUnique 19
+parErrorIdKey = mkPreludeMiscIdUnique 20
+parIdKey = mkPreludeMiscIdUnique 21
+patErrorIdKey = mkPreludeMiscIdUnique 22
+realWorldPrimIdKey = mkPreludeMiscIdUnique 23
+recConErrorIdKey = mkPreludeMiscIdUnique 24
+recUpdErrorIdKey = mkPreludeMiscIdUnique 25
+traceIdKey = mkPreludeMiscIdUnique 26
+unpackCString2IdKey = mkPreludeMiscIdUnique 27
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29
+unpackCStringIdKey = mkPreludeMiscIdUnique 30
+voidIdKey = mkPreludeMiscIdUnique 31
+ushowListIdKey = mkPreludeMiscIdUnique 32
+unsafeCoerceIdKey = mkPreludeMiscIdUnique 33
+concatIdKey = mkPreludeMiscIdUnique 34
+filterIdKey = mkPreludeMiscIdUnique 35
+zipIdKey = mkPreludeMiscIdUnique 36
+bindIOIdKey = mkPreludeMiscIdUnique 37
+deRefStablePtrIdKey = mkPreludeMiscIdUnique 38
+makeStablePtrIdKey = mkPreludeMiscIdUnique 39
\end{code}
-Certain class operations from Prelude classes. They get
-their own uniques so we can look them up easily when we want
-to conjure them up during type checking.
+Certain class operations from Prelude classes. They get their own
+uniques so we can look them up easily when we want to conjure them up
+during type checking.
+
\begin{code}
-fromIntClassOpKey = mkPreludeMiscIdUnique 52
-fromIntegerClassOpKey = mkPreludeMiscIdUnique 53
-minusClassOpKey = mkPreludeMiscIdUnique 54
-fromRationalClassOpKey = mkPreludeMiscIdUnique 55
-enumFromClassOpKey = mkPreludeMiscIdUnique 56
-enumFromThenClassOpKey = mkPreludeMiscIdUnique 57
-enumFromToClassOpKey = mkPreludeMiscIdUnique 58
-enumFromThenToClassOpKey= mkPreludeMiscIdUnique 59
-eqClassOpKey = mkPreludeMiscIdUnique 50
-geClassOpKey = mkPreludeMiscIdUnique 61
-zeroClassOpKey = mkPreludeMiscIdUnique 62
-thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=)
-unboundKey = mkPreludeMiscIdUnique 64 -- Just a place holder for unbound
- -- variables produced by the renamer
-fromEnumClassOpKey = mkPreludeMiscIdUnique 65
-
-mainKey = mkPreludeMiscIdUnique 66
-returnMClassOpKey = mkPreludeMiscIdUnique 67
-otherwiseIdKey = mkPreludeMiscIdUnique 68
-toEnumClassOpKey = mkPreludeMiscIdUnique 69
+fromIntClassOpKey = mkPreludeMiscIdUnique 101
+fromIntegerClassOpKey = mkPreludeMiscIdUnique 102
+minusClassOpKey = mkPreludeMiscIdUnique 103
+fromRationalClassOpKey = mkPreludeMiscIdUnique 104
+enumFromClassOpKey = mkPreludeMiscIdUnique 105
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 106
+enumFromToClassOpKey = mkPreludeMiscIdUnique 107
+enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108
+eqClassOpKey = mkPreludeMiscIdUnique 109
+geClassOpKey = mkPreludeMiscIdUnique 110
+zeroClassOpKey = mkPreludeMiscIdUnique 112
+thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
+ -- Just a place holder for unbound variables produced by the renamer:
+unboundKey = mkPreludeMiscIdUnique 114
+fromEnumClassOpKey = mkPreludeMiscIdUnique 115
+
+mainKey = mkPreludeMiscIdUnique 116
+returnMClassOpKey = mkPreludeMiscIdUnique 117
+otherwiseIdKey = mkPreludeMiscIdUnique 118
+toEnumClassOpKey = mkPreludeMiscIdUnique 119
+mapIdKey = mkPreludeMiscIdUnique 120
\end{code}
\begin{code}
-inlineIdKey = mkPreludeMiscIdUnique 70
-coerceIdKey = mkPreludeMiscIdUnique 71
-assertIdKey = mkPreludeMiscIdUnique 72
+assertIdKey = mkPreludeMiscIdUnique 121
\end{code}
--- /dev/null
+_interface_ Var 1
+_exports_
+Var Var Id ;
+_declarations_
+
+-- Used by Name
+1 type Id = Var BasicTypes.Unused BasicTypes.Unused ;
+1 data Var a b ;
--- /dev/null
+__interface Var 1 0 where
+__export Var Var Id ;
+-- Used by Name
+1 type Id = Var BasicTypes.Unused BasicTypes.Unused ;
+1 data Var a b ;
--- /dev/null
+
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{@Vars@: Variables}
+
+\begin{code}
+module Var (
+ Var, IdOrTyVar, -- Abstract
+ VarDetails(..), -- Concrete
+ varName, varUnique, varDetails, varInfo, varType,
+ setVarName, setVarUnique, setVarType,
+
+
+ -- TyVars
+ TyVar, GenTyVar,
+ tyVarName, tyVarKind,
+ tyVarFlexi, setTyVarFlexi, removeTyVarFlexi, setTyVarName, setTyVarUnique,
+ mkFlexiTyVar, mkTyVar, mkSysTyVar, isTyVar, isFlexiTyVar,
+
+ -- Ids
+ Id, DictId, GenId,
+ idName, idType, idUnique, idInfo, modifyIdInfo,
+ setIdName, setIdUnique, setIdInfo,
+ mkId, isId, externallyVisibleId
+ ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Type( GenType, Kind )
+import {-# SOURCE #-} IdInfo( IdInfo )
+import {-# SOURCE #-} Const( Con )
+
+import FieldLabel ( FieldLabel )
+import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
+import Name ( Name, NamedThing(..),
+ changeUnique, nameUnique,
+ mkSysLocalName, isExternallyVisibleName
+ )
+import BasicTypes ( Unused )
+import Outputable
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{The main data type declarations}
+%* *
+%************************************************************************
+
+
+Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a
+@Type@, and an @IdInfo@ (non-essential info about it, e.g.,
+strictness). The essential info about different kinds of @Vars@ is
+in its @VarDetails@.
+
+\begin{code}
+type IdOrTyVar = Var Unused Unused
+
+data Var flex_self flex_ty
+ = Var {
+ varName :: Name,
+ realUnique :: Int#, -- Key for fast comparison
+ -- Identical to the Unique in the name,
+ -- cached here for speed
+ varType :: GenType flex_ty,
+ varDetails :: VarDetails flex_self,
+ varInfo :: IdInfo -- Only used for Ids at the moment
+ }
+
+varUnique Var{realUnique = uniq} = mkUniqueGrimily uniq
+
+data VarDetails flex_self
+ = TyVar
+ | FlexiTyVar flex_self -- Used during unification
+ | VanillaId -- Most Ids are like this
+ | ConstantId Con -- The Id for a constant (data constructor or primop)
+ | RecordSelId FieldLabel -- The Id for a record selector
+\end{code}
+
+\begin{code}
+instance Outputable (Var fs ft) where
+ ppr var = ppr (varName var)
+
+instance Show (Var fs ft) where
+ showsPrec p var = showsPrecSDoc p (ppr var)
+
+instance NamedThing (Var fs ft) where
+ getName = varName
+
+instance Uniquable (Var fs ft) where
+ getUnique = varUnique
+
+instance Eq (Var fs ft) where
+ a == b = realUnique a ==# realUnique b
+
+instance Ord (Var fs ft) where
+ a <= b = realUnique a <=# realUnique b
+ a < b = realUnique a <# realUnique b
+ a >= b = realUnique a >=# realUnique b
+ a > b = realUnique a ># realUnique b
+ a `compare` b = varUnique a `compare` varUnique b
+\end{code}
+
+
+\begin{code}
+setVarUnique :: Var fs ft -> Unique -> Var fs ft
+setVarUnique var uniq = var {realUnique = getKey uniq,
+ varName = changeUnique (varName var) uniq}
+
+setVarName :: Var fs ft -> Name -> Var fs ft
+setVarName var new_name
+ = var { realUnique = getKey (getUnique new_name), varName = new_name }
+
+setVarType :: Var flex_self flex_ty1 -> GenType flex_ty2 -> Var flex_self flex_ty2
+setVarType var ty = var {varType = ty}
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Type variables}
+%* *
+%************************************************************************
+
+\begin{code}
+type GenTyVar flex_self = Var flex_self Unused -- Perhaps a mutable tyvar, but
+ -- with a fixed Kind
+
+type TyVar = GenTyVar Unused -- NOt even mutable
+\end{code}
+
+\begin{code}
+tyVarName = varName
+tyVarKind = varType
+
+setTyVarUnique = setVarUnique
+setTyVarName = setVarName
+
+tyVarFlexi :: GenTyVar flexi -> flexi
+tyVarFlexi (Var {varDetails = FlexiTyVar flex}) = flex
+tyVarFlexi other_var = pprPanic "tyVarFlexi" (ppr other_var)
+
+setTyVarFlexi :: GenTyVar flexi1 -> flexi2 -> GenTyVar flexi2
+setTyVarFlexi var flex = var {varDetails = FlexiTyVar flex}
+
+removeTyVarFlexi :: GenTyVar flexi1 -> GenTyVar flexi2
+removeTyVarFlexi var = var {varDetails = TyVar}
+\end{code}
+
+\begin{code}
+mkTyVar :: Name -> Kind -> GenTyVar flexi
+mkTyVar name kind = Var { varName = name, realUnique = getKey (nameUnique name),
+ varType = kind, varDetails = TyVar }
+
+mkSysTyVar :: Unique -> Kind -> GenTyVar flexi
+mkSysTyVar uniq kind = Var { varName = name, realUnique = getKey uniq,
+ varType = kind, varDetails = TyVar }
+ where
+ name = mkSysLocalName uniq
+
+mkFlexiTyVar :: Name -> Kind -> flexi -> GenTyVar flexi
+mkFlexiTyVar name kind flex = Var { varName = name,
+ realUnique = getKey (nameUnique name),
+ varType = kind,
+ varDetails = FlexiTyVar flex }
+\end{code}
+
+\begin{code}
+isTyVar :: Var fs ft -> Bool
+isTyVar (Var {varDetails = details}) = case details of
+ TyVar -> True
+ FlexiTyVar _ -> True
+ other -> False
+
+isFlexiTyVar :: Var fs ft -> Bool
+isFlexiTyVar (Var {varDetails = FlexiTyVar _}) = True
+isFlexiTyVar other = False
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Id Construction}
+%* *
+%************************************************************************
+
+ Most Id-related functions are in Id.lhs and MkId.lhs
+
+\begin{code}
+type GenId flex_ty = Var Unused flex_ty
+type Id = GenId Unused
+type DictId = Id
+\end{code}
+
+\begin{code}
+idName = varName
+idType = varType
+idUnique = varUnique
+idInfo = varInfo
+idDetails = varDetails
+
+setIdUnique :: Id -> Unique -> Id
+setIdUnique = setVarUnique
+
+setIdName :: Id -> Name -> Id
+setIdName = setVarName
+
+setIdInfo :: GenId flexi -> IdInfo -> GenId flexi
+setIdInfo var info = var {varInfo = info}
+
+modifyIdInfo :: GenId flexi -> (IdInfo -> IdInfo) -> GenId flexi
+modifyIdInfo var@(Var {varInfo = info}) fn = var {varInfo = fn info}
+\end{code}
+
+\begin{code}
+mkId :: Name -> GenType flex_ty -> VarDetails Unused -> IdInfo -> GenId flex_ty
+mkId name ty details info
+ = Var {varName = name, realUnique = getKey (nameUnique name), varType = ty,
+ varDetails = details, varInfo = info}
+\end{code}
+
+\begin{code}
+isId :: Var fs ft -> Bool
+isId (Var {varDetails = details}) = case details of
+ VanillaId -> True
+ ConstantId _ -> True
+ RecordSelId _ -> True
+ other -> False
+\end{code}
+
+@externallyVisibleId@: is it true that another module might be
+able to ``see'' this Id in a code generation sense. That
+is, another .o file might refer to this Id.
+
+In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's
+local-ness precisely so that the test here would be easy
+
+This defn appears here (rather than, say, in Id.lhs) because
+CostCentre.lhs uses it (CostCentre feeds PprType feeds Id.lhs)
+
+\end{code}
+\begin{code}
+externallyVisibleId :: Id -> Bool
+externallyVisibleId var = isExternallyVisibleName (varName var)
+\end{code}
--- /dev/null
+
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{@VarEnvs@: Variable environments}
+
+\begin{code}
+module VarEnv (
+ VarEnv, IdEnv, TyVarEnv,
+ emptyVarEnv, unitVarEnv, mkVarEnv,
+ elemVarEnv, rngVarEnv,
+ extendVarEnv, extendVarEnvList,
+ plusVarEnv, plusVarEnv_C,
+ delVarEnvList, delVarEnv,
+ lookupVarEnv, lookupVarEnv_NF,
+ mapVarEnv, zipVarEnv,
+ modifyVarEnv, modifyVarEnv_Directly,
+ isEmptyVarEnv, foldVarEnv
+ ) where
+
+#include "HsVersions.h"
+
+import Var ( Var, Id )
+import UniqFM
+import Util ( zipEqual )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{@VarEnv@s}
+%* *
+%************************************************************************
+
+\begin{code}
+type VarEnv elt = UniqFM elt
+type IdEnv elt = VarEnv elt
+type TyVarEnv elt = VarEnv elt
+
+emptyVarEnv :: VarEnv a
+mkVarEnv :: [(Var fs ft, a)] -> VarEnv a
+zipVarEnv :: [Var fs ft] -> [a] -> VarEnv a
+unitVarEnv :: Var fs ft -> a -> VarEnv a
+extendVarEnv :: VarEnv a -> Var fs ft -> a -> VarEnv a
+plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a
+extendVarEnvList :: VarEnv a -> [(Var fs ft, a)] -> VarEnv a
+
+delVarEnvList :: VarEnv a -> [Var fs ft] -> VarEnv a
+delVarEnv :: VarEnv a -> Var fs ft -> VarEnv a
+plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
+mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
+modifyVarEnv :: (a -> a) -> VarEnv a -> Var fs ft -> VarEnv a
+rngVarEnv :: VarEnv a -> [a]
+
+isEmptyVarEnv :: VarEnv a -> Bool
+lookupVarEnv :: VarEnv a -> Var fs ft -> Maybe a
+lookupVarEnv_NF :: VarEnv a -> Var fs ft -> a
+elemVarEnv :: Var fs ft -> VarEnv a -> Bool
+foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
+\end{code}
+
+\begin{code}
+elemVarEnv = elemUFM
+extendVarEnv = addToUFM
+plusVarEnv_C = plusUFM_C
+delVarEnvList = delListFromUFM
+delVarEnv = delFromUFM
+plusVarEnv = plusUFM
+lookupVarEnv = lookupUFM
+mapVarEnv = mapUFM
+mkVarEnv = listToUFM
+emptyVarEnv = emptyUFM
+rngVarEnv = eltsUFM
+unitVarEnv = unitUFM
+isEmptyVarEnv = isNullUFM
+foldVarEnv = foldUFM
+
+zipVarEnv tyvars tys = listToUFM (zipEqual "zipVarEnv" tyvars tys)
+extendVarEnvList env pairs = plusUFM env (listToUFM pairs)
+lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
+\end{code}
+
+@modifyVarEnv@: Look up a thing in the VarEnv,
+then mash it with the modify function, and put it back.
+
+\begin{code}
+modifyVarEnv mangle_fn env key
+ = case (lookupVarEnv env key) of
+ Nothing -> env
+ Just xx -> extendVarEnv env key (mangle_fn xx)
+
+modifyVarEnv_Directly mangle_fn env key
+ = case (lookupUFM_Directly env key) of
+ Nothing -> env
+ Just xx -> addToUFM_Directly env key (mangle_fn xx)
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{@VarSet@: Variable sets}
+
+\begin{code}
+module VarSet (
+ VarSet, IdSet, GenIdSet, TyVarSet, GenTyVarSet, IdOrTyVarSet,
+ emptyVarSet, unitVarSet, mkVarSet,
+ extendVarSet,
+ elemVarSet, varSetElems,
+ unionVarSet, unionVarSets,
+ intersectVarSet, intersectsVarSet,
+ isEmptyVarSet, delVarSet,
+ minusVarSet, foldVarSet, filterVarSet,
+ lookupVarSet, mapVarSet,
+
+ uniqAway
+ ) where
+
+#include "HsVersions.h"
+
+import Var ( Var, Id, GenId, TyVar, GenTyVar, IdOrTyVar, setVarUnique )
+import Unique ( Uniquable(..), incrUnique )
+import UniqSet
+import Outputable
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@VarSet@s}
+%* *
+%************************************************************************
+
+\begin{code}
+type VarSet fs ft = UniqSet (Var fs ft)
+type IdSet = UniqSet Id
+type GenIdSet flexi = UniqSet (GenId flexi)
+type TyVarSet = UniqSet TyVar
+type GenTyVarSet flexi = UniqSet (GenTyVar flexi)
+type IdOrTyVarSet = UniqSet IdOrTyVar
+
+emptyVarSet :: VarSet fs ft
+intersectVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft
+intersectsVarSet:: VarSet fs ft -> VarSet fs ft -> Bool -- True if non-empty intersection
+unionVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft
+unionVarSets :: [VarSet fs ft] -> VarSet fs ft
+varSetElems :: VarSet fs ft -> [Var fs ft]
+unitVarSet :: Var fs ft -> VarSet fs ft
+extendVarSet :: VarSet fs ft -> Var fs ft -> VarSet fs ft
+elemVarSet :: Var fs ft -> VarSet fs ft -> Bool
+delVarSet :: VarSet fs ft -> Var fs ft -> VarSet fs ft
+minusVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft
+isEmptyVarSet :: VarSet fs ft -> Bool
+mkVarSet :: [Var fs ft] -> VarSet fs ft
+foldVarSet :: (Var fs ft -> a -> a) -> a -> VarSet fs ft -> a
+lookupVarSet :: VarSet fs ft -> Var fs ft -> Maybe (Var fs ft)
+ -- Returns the set element, which may be
+ -- (==) to the argument, but not the same as
+mapVarSet :: (Var fs ft -> Var fs ft) -> VarSet fs ft -> VarSet fs ft
+filterVarSet :: (Var fs ft -> Bool) -> VarSet fs ft -> VarSet fs ft
+
+emptyVarSet = emptyUniqSet
+unitVarSet = unitUniqSet
+extendVarSet = addOneToUniqSet
+intersectVarSet = intersectUniqSets
+intersectsVarSet s1 s2 = not (isEmptyVarSet (s1 `intersectVarSet` s2))
+unionVarSet = unionUniqSets
+unionVarSets = unionManyUniqSets
+varSetElems = uniqSetToList
+elemVarSet = elementOfUniqSet
+minusVarSet = minusUniqSet
+delVarSet = delOneFromUniqSet
+isEmptyVarSet = isEmptyUniqSet
+mkVarSet = mkUniqSet
+foldVarSet = foldUniqSet
+lookupVarSet = lookupUniqSet
+mapVarSet = mapUniqSet
+filterVarSet = filterUniqSet
+\end{code}
+
+\begin{code}
+uniqAway :: VarSet fs ft -> Var fs ft -> Var fs ft
+-- Give the Var a new unique, different to any in the VarSet
+uniqAway set var
+ = try 1 (incrUnique (getUnique var))
+ where
+ try n uniq | uniq `elemUniqSet_Directly` set = try ((n+1)::Int) (incrUnique uniq)
+ | otherwise = {- pprTrace "uniqAway:" (ppr n <+> text "tries") -}
+ setVarUnique var uniq
+\end{code}
_interface_ CgBindery 1
_exports_
-CgBindery CgBindings CgIdInfo(MkCgIdInfo) VolatileLoc StableLoc nukeVolatileBinds maybeAStkLoc maybeBStkLoc;
+CgBindery CgBindings CgIdInfo(MkCgIdInfo) VolatileLoc StableLoc nukeVolatileBinds maybeStkLoc;
_declarations_
-1 type CgBindings = Id.IdEnv CgIdInfo;
-1 data CgIdInfo = MkCgIdInfo Id.Id VolatileLoc StableLoc ClosureInfo!LambdaFormInfo;
+1 type CgBindings = VarEnv.IdEnv CgIdInfo;
+1 data CgIdInfo = MkCgIdInfo Var.Id VolatileLoc StableLoc ClosureInfo!LambdaFormInfo;
1 data VolatileLoc;
1 data StableLoc;
1 nukeVolatileBinds _:_ CgBindings -> CgBindings ;;
-1 maybeAStkLoc _:_ StableLoc -> PrelMaybe.Maybe HeapOffs.VirtualSpAOffset ;;
-1 maybeBStkLoc _:_ StableLoc -> PrelMaybe.Maybe HeapOffs.VirtualSpBOffset ;;
+1 maybeStkLoc _:_ StableLoc -> PrelMaybe.Maybe AbsCSyn.VirtualSpOffset ;;
--- /dev/null
+_interface_ CgBindery 1 0
+_exports_
+CgBindery CgBindings CgIdInfo{MkCgIdInfo} VolatileLoc StableLoc nukeVolatileBinds maybeStkLoc;
+_declarations_
+1 type CgBindings = VarEnv.IdEnv CgIdInfo;
+1 data CgIdInfo = MkCgIdInfo Var.Id VolatileLoc StableLoc ClosureInfo!LambdaFormInfo;
+1 data VolatileLoc;
+1 data StableLoc;
+1 nukeVolatileBinds _:_ CgBindings -> CgBindings ;;
+1 maybeStkLoc _:_ StableLoc -> PrelMaybe.Maybe AbsCSyn.VirtualSpOffset ;;
--- /dev/null
+__interface CgBindery 1 0 where
+__export CgBindery CgBindings CgIdInfo{MkCgIdInfo} VolatileLoc StableLoc nukeVolatileBinds maybeStkLoc;
+1 type CgBindings = VarEnv.IdEnv CgIdInfo;
+1 data CgIdInfo = MkCgIdInfo Var.Id VolatileLoc StableLoc ClosureInfo!LambdaFormInfo;
+1 data VolatileLoc;
+1 data StableLoc;
+1 nukeVolatileBinds :: CgBindings -> CgBindings ;
+1 maybeStkLoc :: StableLoc -> PrelMaybe.Maybe AbsCSyn.VirtualSpOffset ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CgBindery]{Utility functions related to doing @CgBindings@}
CgBindings, CgIdInfo(..){-dubiously concrete-},
StableLoc, VolatileLoc,
- maybeAStkLoc, maybeBStkLoc,
+ maybeStkLoc,
stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
nukeVolatileBinds,
+ nukeDeadBindings,
- bindNewToAStack, bindNewToBStack,
+ bindNewToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp, bindNewPrimToAmode,
getArgAmode, getArgAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
- rebindToAStack, rebindToBStack
+
+ buildLivenessMask, buildContLivenessMask
) where
#include "HsVersions.h"
import AbsCSyn
import CgMonad
-import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabel ( mkStaticClosureLabel, mkClosureLabel )
-import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
-import HeapOffs ( VirtualHeapOffset,
- VirtualSpAOffset, VirtualSpBOffset
- )
-import Id ( idPrimRep,
- mkIdEnv, rngIdEnv, IdEnv,
- idSetToList,
- Id
- )
-import Literal ( Literal )
-import Maybes ( catMaybes )
-import Name ( isLocallyDefined, isWiredInName,
- Name{-instance NamedThing-}, NamedThing(..) )
+import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
+import CgStackery ( freeStackSlots, addFreeSlots )
+import CLabel ( mkStaticClosureLabel, mkClosureLabel,
+ mkBitmapLabel )
+import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
+import BitSet ( mkBS, emptyBS )
+import PrimRep ( isFollowableRep, getPrimRepSize )
+import DataCon ( DataCon, dataConName )
+import Id ( Id, idPrimRep, idType )
+import Type ( typePrimRep )
+import VarEnv
+import VarSet ( varSetElems )
+import Const ( Con(..), Literal )
+import Maybes ( catMaybes, maybeToBool )
+import Name ( isLocallyDefined, isWiredInName, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
-import PrimRep ( PrimRep )
+import PrimRep ( PrimRep(..) )
import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) )
import Unique ( Unique, Uniquable(..) )
-import Util ( zipWithEqual, panic )
+import UniqSet ( elementOfUniqSet )
+import Util ( zipWithEqual, panic, sortLt )
import Outputable
\end{code}
\begin{code}
data StableLoc
= NoStableLoc
- | VirAStkLoc VirtualSpAOffset
- | VirBStkLoc VirtualSpBOffset
+ | VirStkLoc VirtualSpOffset
| LitLoc Literal
| StableAmodeLoc CAddrMode
-- these are so StableLoc can be abstract:
-maybeAStkLoc (VirAStkLoc offset) = Just offset
-maybeAStkLoc _ = Nothing
-
-maybeBStkLoc (VirBStkLoc offset) = Just offset
-maybeBStkLoc _ = Nothing
+maybeStkLoc (VirStkLoc offset) = Just offset
+maybeStkLoc _ = Nothing
\end{code}
%************************************************************************
heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
-letNoEscapeIdInfo i spa spb lf_info
- = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info
+letNoEscapeIdInfo i sp lf_info
+ = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
newTempAmodeAndIdInfo name lf_info
= (temp_amode, temp_idinfo)
where
- uniq = uniqueOf name
+ uniq = getUnique name
temp_amode = CTemp uniq (idPrimRep name)
temp_idinfo = tempIdInfo name uniq lf_info
idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
- = returnFC (CVal (NodeRel nd_off) kind)
+ = returnFC (CVal (nodeRel nd_off) kind)
-- Virtual offsets from Node increase into the closures,
-- and so do Node-relative offsets (which we want in the CVal),
-- so there is no mucking about to do to the offset.
= getHpRelOffset hp_off `thenFC` \ rel_hp ->
returnFC (CAddr rel_hp)
-idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i)
- = getSpARelOffset i `thenFC` \ rel_spA ->
- returnFC (CVal rel_spA kind)
-
-idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
- = getSpBRelOffset i `thenFC` \ rel_spB ->
- returnFC (CVal rel_spB kind)
+idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
+ = getSpRelOffset i `thenFC` \ rel_sp ->
+ returnFC (CVal rel_sp kind)
#ifdef DEBUG
idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
\begin{code}
nukeVolatileBinds :: CgBindings -> CgBindings
nukeVolatileBinds binds
- = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds))
+ = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
where
keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
returnFC (amode, lf_info)
where
name = getName id
- global_amode = CLbl (mkClosureLabel id) kind
+ global_amode = CLbl (mkClosureLabel name) kind
kind = idPrimRep id
getCAddrMode :: Id -> FCode CAddrMode
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
getVolatileRegs vars
- = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff ->
+ = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
returnFC (catMaybes stuff)
where
snaffle_it var
getArgAmode :: StgArg -> FCode CAddrMode
-getArgAmode (StgConArg var)
+getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
+
+getArgAmode (StgConArg (DataCon con))
{- Why does this case differ from StgVarArg?
Because the program might look like this:
data Foo a = Empty | Baz a
is really
App f (StgCon Empty [])
-}
- = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var))
+ = returnFC (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep)
-getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
-getArgAmode (StgLitArg lit) = returnFC (CLit lit)
+getArgAmode (StgConArg (Literal lit)) = returnFC (CLit lit)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
-bindNewToAStack (name, offset)
- = addBindC name info
- where
- info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument
-
-bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
-bindNewToBStack (name, offset)
+bindNewToStack :: (Id, VirtualSpOffset) -> Code
+bindNewToStack (name, offset)
= addBindC name info
where
- info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
- -- B-stack things shouldn't need lambda-form info!
+ info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
bindNewToNode name offset lf_info
arg `bind` reg = bindNewToReg arg reg mkLFArgument
\end{code}
-@bindNewPrimToAmode@ works only for certain addressing modes, because
-those are the only ones we've needed so far!
+@bindNewPrimToAmode@ works only for certain addressing modes. Making
+this work for stack offsets is non-trivial (virt vs. real stack offset
+difficulties).
\begin{code}
bindNewPrimToAmode :: Id -> CAddrMode -> Code
-bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
- -- was: mkLFArgument
- -- LFinfo is irrelevant for primitives
+bindNewPrimToAmode name (CReg reg)
+ = bindNewToReg name reg (panic "bindNewPrimToAmode")
+
bindNewPrimToAmode name (CTemp uniq kind)
= addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
- -- LFinfo is irrelevant for primitives
-
-bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
-
-bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
- = bindNewToBStack (name, offset)
-
-bindNewPrimToAmode name (CVal (NodeRel offset) _)
- = bindNewToNode name offset (panic "bindNewPrimToAmode node")
- -- See comment on idInfoPiecesToAmode for VirNodeLoc
#ifdef DEBUG
bindNewPrimToAmode name amode
\end{code}
\begin{code}
-rebindToAStack :: Id -> VirtualSpAOffset -> Code
-rebindToAStack name offset
+rebindToStack :: Id -> VirtualSpOffset -> Code
+rebindToStack name offset
= modifyBindC name replace_stable_fn
where
replace_stable_fn (MkCgIdInfo i vol stab einfo)
- = MkCgIdInfo i vol (VirAStkLoc offset) einfo
+ = MkCgIdInfo i vol (VirStkLoc offset) einfo
+\end{code}
-rebindToBStack :: Id -> VirtualSpBOffset -> Code
-rebindToBStack name offset
- = modifyBindC name replace_stable_fn
+%************************************************************************
+%* *
+\subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
+%* *
+%************************************************************************
+
+ToDo: remove the dependency on 32-bit words.
+
+There are two ways to build a liveness mask, and both appear to have
+problems.
+
+ 1) Find all the pointer words by searching through the binding list.
+ Invert this to find the non-pointer words and build the bitmap.
+
+ 2) Find all the non-pointer words by search through the binding list.
+ Merge this with the list of currently free slots. Build the
+ bitmap.
+
+Method (1) conflicts with update frames - these contain pointers but
+have no bindings in the environment. We could bind the updatee to its
+location in the update frame at the point when the update frame is
+pushed, but this binding would be dropped by the first case expression
+(nukeDeadBindings).
+
+Method (2) causes problems because we must make sure that every
+non-pointer word on the stack is either a free stack slot or has a
+binding in the environment. Things like cost centres break this (but
+only for case-of-case expressions - because that's when there's a cost
+centre on the stack from the outer case and we need to generate a
+bitmap for the inner case's continuation).
+
+This method also works "by accident" for update frames: since all
+unaccounted for slots on the stack are assumed to be pointers, and an
+update frame always occurs at virtual Sp offsets 0-3 (i.e. the bottom
+of the stack frame), the bitmap will simply end at the start of the
+update frame.
+
+We use method (2) at the moment.
+
+\begin{code}
+buildLivenessMask
+ :: Unique -- unique for for large bitmap label
+ -> VirtualSpOffset -- offset from which the bitmap should start
+ -> FCode Liveness -- mask for free/unlifted slots
+
+buildLivenessMask uniq sp info_down
+ state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage))
+ = ASSERT(all (>=0) rel_slots)
+ livenessToAbsC uniq liveness_mask info_down state
where
- replace_stable_fn (MkCgIdInfo i vol stab einfo)
- = MkCgIdInfo i vol (VirBStkLoc offset) einfo
+ -- find all unboxed stack-resident ids
+ unboxed_slots =
+ [ (ofs, getPrimRepSize rep) |
+ (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ let rep = idPrimRep id,
+ not (isFollowableRep rep)
+ ]
+
+ -- flatten this list into a list of unboxed stack slots
+ flatten_slots = foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
+ unboxed_slots
+
+ -- merge in the free slots
+ all_slots = addFreeSlots flatten_slots free ++
+ if vsp < sp then [vsp+1 .. sp] else []
+
+ -- recalibrate the list to be sp-relative
+ rel_slots = reverse (map (sp-) all_slots)
+
+ -- build the bitmap
+ liveness_mask = listToLivenessMask rel_slots
+
+{- ALTERNATE version that doesn't work because update frames aren't
+ recorded in the environment.
+
+ -- find all boxed stack-resident ids
+ boxed_slots =
+ [ ofs | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ isFollowableRep (idPrimRep id)
+ ]
+ all_slots = [1..vsp]
+
+ -- invert to get unboxed slots
+ unboxed_slots = filter (`notElem` boxed_slots) all_slots
+-}
+
+listToLivenessMask :: [Int] -> LivenessMask
+listToLivenessMask [] = []
+listToLivenessMask slots =
+ mkBS this : listToLivenessMask (map (\x -> x-32) rest)
+ where (this,rest) = span (<32) slots
+
+livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
+livenessToAbsC uniq [] = returnFC (LvSmall emptyBS)
+livenessToAbsC uniq [one] = returnFC (LvSmall one)
+livenessToAbsC uniq many =
+ absC (CBitmap lbl many) `thenC`
+ returnFC (LvLarge lbl)
+ where lbl = mkBitmapLabel uniq
\end{code}
+In a continuation, we want a liveness mask that starts from just after
+the return address, which is on the stack at realSp.
+
+\begin{code}
+buildContLivenessMask
+ :: Unique
+ -> FCode Liveness
+buildContLivenessMask uniq
+ = getRealSp `thenFC` \ realSp ->
+ buildLivenessMask uniq (realSp-1)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[CgMonad-deadslots]{Finding dead stack slots}
+%* *
+%************************************************************************
+
+nukeDeadBindings does the following:
+
+ - Removes all bindings from the environment other than those
+ for variables in the argument to nukeDeadBindings.
+ - Collects any stack slots so freed, and returns them to the stack free
+ list.
+ - Moves the virtual stack pointer to point to the topmost used
+ stack locations.
+
+You can have multi-word slots on the stack (where a Double# used to
+be, for instance); if dead, such a slot will be reported as *several*
+offsets (one per word).
+
+Probably *naughty* to look inside monad...
+
+\begin{code}
+nukeDeadBindings :: StgLiveVars -- All the *live* variables
+ -> Code
+
+nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage)
+ = freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage)
+ where
+ (dead_stk_slots, bs')
+ = dead_slots live_vars
+ [] []
+ [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
+
+ extra_free = sortLt (<) dead_stk_slots
+\end{code}
+
+Several boring auxiliary functions to do the dirty work.
+
+\begin{code}
+dead_slots :: StgLiveVars
+ -> [(Id,CgIdInfo)]
+ -> [VirtualSpOffset]
+ -> [(Id,CgIdInfo)]
+ -> ([VirtualSpOffset], [(Id,CgIdInfo)])
+
+-- dead_slots carries accumulating parameters for
+-- filtered bindings, dead slots
+dead_slots live_vars fbs ds []
+ = (ds, reverse fbs) -- Finished; rm the dups, if any
+
+dead_slots live_vars fbs ds ((v,i):bs)
+ | v `elementOfUniqSet` live_vars
+ = dead_slots live_vars ((v,i):fbs) ds bs
+ -- Live, so don't record it in dead slots
+ -- Instead keep it in the filtered bindings
+
+ | otherwise
+ = case i of
+ MkCgIdInfo _ _ stable_loc _
+ | is_stk_loc ->
+ dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
+ where
+ maybe_stk_loc = maybeStkLoc stable_loc
+ is_stk_loc = maybeToBool maybe_stk_loc
+ (Just offset) = maybe_stk_loc
+
+ _ -> dead_slots live_vars fbs ds bs
+ where
+
+ size :: Int
+ size = (getPrimRepSize . typePrimRep . idType) v
+
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgCase.lhs,v 1.18 1998/12/02 13:17:46 simonm Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
+module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre,
+ splitAlgTyConAppThroughNewTypes ) where
#include "HsVersions.h"
-import {-# SOURCE #-} CgExpr
+import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
import StgSyn
import AbsCSyn
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- magicIdPrimRep, getAmodeRep
+ getAmodeRep, nonemptyAbsC
)
-import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
+import CoreSyn ( isDeadBinder )
+import CgUpdate ( reserveSeqFrame )
+import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
bindNewPrimToAmode,
- rebindToAStack, rebindToBStack,
+ rebindToStack, getCAddrMode,
getCAddrModeAndInfo, getCAddrModeIfVolatile,
- idInfoToAmode
- )
-import CgCon ( buildDynCon, bindConArgs )
-import CgHeapery ( heapCheck, yield )
-import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
- ctrlReturnConvAlg,
- DataReturnConvention(..), CtrlReturnConvention(..),
- assignPrimOpResultRegs,
- makePrimOpArgsRobust
+ buildContLivenessMask, nukeDeadBindings
)
-import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
-import CgTailCall ( tailCallBusiness, performReturn )
-import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
-import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
- mkAltLabel
+import CgCon ( bindConArgs, bindUnboxedTupleComponents )
+import CgHeapery ( altHeapCheck, yield )
+import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
+ CtrlReturnConvention(..)
)
-import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
-import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-import CostCentre ( useCurrentCostCentre, CostCentre )
-import HeapOffs ( VirtualSpBOffset, VirtualHeapOffset )
-import Id ( idPrimRep, dataConTag, fIRST_TAG, ConTag,
- isDataCon, DataCon,
- idSetToList, GenId{-instance Uniquable,Eq-}, Id
+import CgStackery ( allocPrimStack, allocStackTop,
+ deAllocStackTop, freeStackSlots
)
-import Literal ( Literal )
-import Maybes ( catMaybes )
-import PrimOp ( primOpCanTriggerGC, PrimOp(..),
- primOpStackRequired, StackRequirement(..)
+import CgTailCall ( tailCallFun )
+import CgUsages ( getSpRelOffset, getRealSp )
+import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel,
+ mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
+ mkErrorStdEntryLabel, mkClosureTblLabel
)
-import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
- PrimRep(..)
- )
-import TyCon ( isEnumerationTyCon )
-import Type ( typePrimRep,
- splitAlgTyConApp, splitAlgTyConApp_maybe,
- Type
+import ClosureInfo ( mkLFArgument )
+import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
+import CostCentre ( CostCentre )
+import Id ( Id, idPrimRep )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
+ isUnboxedTupleCon, dataConType )
+import VarSet ( varSetElems )
+import Const ( Con(..), Literal )
+import PrimOp ( primOpOutOfLine, PrimOp(..) )
+import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
+import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
+ isNewTyCon, isAlgTyCon,
+ tyConDataCons, tyConFamilySize )
+import Type ( GenType(..), typePrimRep, splitAlgTyConApp, Type,
+ splitFunTys, applyTys )
import Unique ( Unique, Uniquable(..) )
-import Util ( sortLt, isIn, isn'tIn, zipEqual )
+import Maybes ( maybeToBool )
import Outputable
\end{code}
A more interesting situation is this:
-\begin{verbatim}
+ \begin{verbatim}
!A!;
...A...
case x# of
0# -> !B!; ...B...
default -> !C!; ...C...
-\end{verbatim}
+ \end{verbatim}
where \tr{!x!} indicates a possible heap-check point. The heap checks
in the alternatives {\em can} be omitted, in which case the topmost
In favour of omitting \tr{!B!}, \tr{!C!}:
-\begin{itemize}
-\item
-{\em May} save a heap overflow test,
+ - {\em May} save a heap overflow test,
if ...A... allocates anything. The other advantage
of this is that we can use relative addressing
from a single Hp to get at all the closures so allocated.
-\item
- No need to save volatile vars etc across the case
-\end{itemize}
+
+ - No need to save volatile vars etc across the case
Against:
-\begin{itemize}
-\item
- May do more allocation than reqd. This sometimes bites us
+ - May do more allocation than reqd. This sometimes bites us
badly. For example, nfib (ha!) allocates about 30\% more space if the
worst-casing is done, because many many calls to nfib are leaf calls
which don't need to allocate anything.
This never hurts us if there is only one alternative.
-\end{itemize}
*** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
cgCase :: StgExpr
-> StgLiveVars
-> StgLiveVars
- -> Unique
+ -> Id
+ -> SRT
-> StgCaseAlts
-> Code
\end{code}
-Several special cases for primitive operations.
-
+Several special cases for inline primitive operations.
\begin{code}
-cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
- | not (primOpCanTriggerGC op)
+cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt alts
+ | not (primOpOutOfLine op)
=
-- Get amodes for the arguments and results
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
let
- result_amodes = getPrimAppResultAmodes uniq alts
- liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
+ result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
in
-- Perform the operation
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- -- seq cannot happen here => no additional B Stack alloc
+ getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
absC (COpStmt result_amodes op
arg_amodes -- note: no liveness arg
- liveness_mask vol_regs) `thenC`
+ vol_regs) `thenC`
-- Scrutinise the result
- cgInlineAlts NoGC uniq alts
-
- | otherwise -- *Can* trigger GC
- = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
-
- -- Get amodes for the arguments and results, and assign to regs
- -- (Can-trigger-gc primops guarantee to have their (nonRobust)
- -- args in regs)
- let
- op_result_regs = assignPrimOpResultRegs op
-
- op_result_amodes = map CReg op_result_regs
-
- (op_arg_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust op arg_amodes
-
- liveness_arg = mkIntCLit liveness_mask
- in
- -- Tidy up in case GC happens...
-
- -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
- -- Reason: the arg_assts computed above may refer to some stack slots
- -- which are not live in the alts. So we mustn't use those slots
- -- to save volatile vars in!
- nukeDeadBindings live_in_whole_case `thenC`
- saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
-
- -- Allocate stack words for the prim-op itself,
- -- these are guaranteed to be ON TOP OF the stack.
- -- Currently this is used *only* by the seq# primitive op.
- let
- (a_req,b_req) = case (primOpStackRequired op) of
- NoStackRequired -> (0, 0)
- FixedStackRequired a b -> (a, b)
- VariableStackRequired -> (0, 0) -- i.e. don't care
- in
- allocAStackTop a_req `thenFC` \ a_slot ->
- allocBStackTop b_req `thenFC` \ b_slot ->
-
- getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
- -- a_req and b_req allocate stack space that is taken care of by the
- -- macros generated for the primops; thus, we there is no need to adjust
- -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
- -- currently all this is only used for SeqOp
- forkEval (if True {- a_req==0 && b_req==0 -}
- then eob_info
- else (EndOfBlockInfo (args_spa+a_req)
- (args_spb+b_req) sequel)) nopC
- (
- getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
- absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
- `thenC`
- returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
- Nothing{-no semi-tagging-}))
- `thenFC` \ new_eob_info ->
-
- -- Record the continuation info
- setEndOfBlockInfo new_eob_info (
-
- -- Now "return" to the inline alternatives; this will get
- -- compiled to a fall-through.
- let
- simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
-
- -- do_op_and_continue will be passed an amode for the continuation
- do_op_and_continue sequel
- = absC (COpStmt op_result_amodes
- op
- (pin_liveness op liveness_arg op_arg_amodes)
- liveness_mask
- [{-no vol_regs-}])
- `thenC`
-
- sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
-
- -- Note: we CJump even for algebraic data types,
- -- because cgInlineAlts always generates code, never a
- -- vector.
- in
- performReturn simultaneous_assts do_op_and_continue live_in_alts
- )
- where
- -- for all PrimOps except ccalls, we pin the liveness info
- -- on as the first "argument"
- -- ToDo: un-duplicate?
-
- pin_liveness (CCallOp _ _ _ _ _ _) _ args = args
- pin_liveness other_op liveness_arg args
- = liveness_arg :args
-
- vtbl_label = mkVecTblLabel uniq
- return_label = mkReturnPtLabel uniq
-
+ cgInlineAlts bndr alts
\end{code}
Another special case: scrutinising a primitive-typed variable. No
eliminate a heap check altogether.
\begin{code}
-cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
- = getArgAmode v `thenFC` \ amode ->
- cgPrimAltsGivenScrutinee NoGC amode alts deflt
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+ (StgPrimAlts ty alts deflt)
+
+ =
+ getCAddrMode v `thenFC` \amode ->
+
+ {-
+ Careful! we can't just bind the default binder to the same thing
+ as the scrutinee, since it might be a stack location, and having
+ two bindings pointing at the same stack locn doesn't work (it
+ confuses nukeDeadBindings). Hence, use a new temp.
+ -}
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToTemp bndr `thenFC` \deflt_amode ->
+ absC (CAssign deflt_amode amode)) `thenC`
+
+ cgPrimAlts NoGC amode alts deflt []
\end{code}
Special case: scrutinising a non-primitive variable.
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
-cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
- live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
+cgCase (StgApp fun args)
+ live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
=
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
- forkEval alts_eob_info
- nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
- setEndOfBlockInfo scrut_eob_info (
- tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
- )
+ allocStackTop retPrimRepSize `thenFC` \_ ->
+
+ forkEval alts_eob_info nopC (
+ deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alts)
+ `thenFC` \ scrut_eob_info ->
+
+ let real_scrut_eob_info =
+ if not_con_ty
+ then reserveSeqFrame scrut_eob_info
+ else scrut_eob_info
+ in
+
+ setEndOfBlockInfo real_scrut_eob_info (
+ tailCallFun fun fun_amode lf_info arg_amodes save_assts
+ )
+ where
+ not_con_ty = case (getScrutineeTyCon ty) of
+ Just _ -> False
+ other -> True
\end{code}
+Note about return addresses: we *always* push a return address, even
+if because of an optimisation we end up jumping direct to the return
+code (not through the address itself). The alternatives always assume
+that the return address is on the stack. The return address is
+required in case the alternative performs a heap check, since it
+encodes the liveness of the slots in the activation record.
+
+On entry to the case alternative, we can re-use the slot containing
+the return address immediately after the heap check. That's what the
+deAllocStackTop call is doing above.
+
Finally, here is the general case.
\begin{code}
-cgCase expr live_in_whole_case live_in_alts uniq alts
+cgCase expr live_in_whole_case live_in_alts bndr srt alts
= -- Figure out what volatile variables to save
nukeDeadBindings live_in_whole_case `thenC`
+
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
- -- Save those variables right now!
+ -- Save those variables right now!
absC save_assts `thenC`
+ -- generate code for the alts
forkEval alts_eob_info
- (nukeDeadBindings live_in_alts)
- (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
+ (
+ nukeDeadBindings live_in_alts `thenC`
+ allocStackTop retPrimRepSize -- space for retn address
+ `thenFC` \_ -> nopC
+ )
+ (deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
+
+ let real_scrut_eob_info =
+ if not_con_ty
+ then reserveSeqFrame scrut_eob_info
+ else scrut_eob_info
+ in
+
+ setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
- setEndOfBlockInfo scrut_eob_info (cgExpr expr)
+ where
+ not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
+ Just _ -> False
+ other -> True
+\end{code}
+
+There's a lot of machinery going on behind the scenes to manage the
+stack pointer here. forkEval takes the virtual Sp and free list from
+the first argument, and turns that into the *real* Sp for the second
+argument. It also uses this virtual Sp as the args-Sp in the EOB info
+returned, so that the scrutinee will trim the real Sp back to the
+right place before doing whatever it does.
+ --SDM (who just spent an hour figuring this out, and didn't want to
+ forget it).
+
+Why don't we push the return address just before evaluating the
+scrutinee? Because the slot reserved for the return address might
+contain something useful, so we wait until performing a tail call or
+return before pushing the return address (see
+CgTailCall.pushReturnAddress).
+
+This also means that the environment doesn't need to know about the
+free stack slot for the return address (for generating bitmaps),
+because we don't reserve it until just before the eval.
+
+TODO!! Problem: however, we have to save the current cost centre
+stack somewhere, because at the eval point the current CCS might be
+different. So we pick a free stack slot and save CCCS in it. The
+problem with this is that this slot isn't recorded as free/unboxed in
+the environment, so a case expression in the scrutinee will have the
+wrong bitmap attached. Fortunately we don't ever seem to see
+case-of-case at the back end. One solution might be to shift the
+saved CCS to the correct place in the activation record just before
+the jump.
+ --SDM
+
+(one consequence of the above is that activation records on the stack
+don't follow the layout of closures when we're profiling. The CCS
+could be anywhere within the record).
+
+\begin{code}
+alts_ty (StgAlgAlts ty _ _) = ty
+alts_ty (StgPrimAlts ty _ _) = ty
\end{code}
%************************************************************************
-- Anyway, cgInlineAlts is now capable of handling all cases;
-- it's only this function which is being wimpish.
-getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
+getPrimAppResultAmodes uniq (StgAlgAlts ty alts
+ (StgBindDefault rhs))
| isEnumerationTyCon spec_tycon = [tag_amode]
- | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
+ | otherwise = pprPanic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default" (ppr uniq <+> ppr rhs)
where
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
tag_amode = CTemp uniq IntRep
(spec_tycon, _, _) = splitAlgTyConApp ty
+\end{code}
+If we don't have a default case, we could be scrutinising an unboxed
+tuple, or an enumeration type...
+
+\begin{code}
getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Default is either StgNoDefault or StgBindDefault with unused binder
- = case alts of
- [_] -> arg_amodes -- No need for a tag
- other -> tag_amode : arg_amodes
- where
- -- A temporary variable to hold the tag; this is unaffected by GC because
- -- the heap-checks in the branches occur after the switch
- tag_amode = CTemp uniq IntRep
- -- Sort alternatives into canonical order; there must be a complete
- -- set because there's no default case.
- sorted_alts = sortLt lt alts
- (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
+ | isEnumerationTyCon tycon = [CTemp uniq IntRep]
- arg_amodes :: [CAddrMode]
+ | isUnboxedTupleTyCon tycon =
+ case alts of
+ [(con, args, use_mask, rhs)] ->
+ [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
+ _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
- -- Turn them into amodes
- arg_amodes = concat (map mk_amodes sorted_alts)
- mk_amodes (con, args, use_mask, rhs)
- = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
+ | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
+
+ where (tycon, _, _) = splitAlgTyConApp ty
\end{code}
-The situation is simpler for primitive
-results, because there is only one!
+The situation is simpler for primitive results, because there is only
+one!
\begin{code}
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
is some evaluation to be done.
\begin{code}
-cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
- -> Unique
+cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
+ -> Id
+ -> SRT -- SRT for the continuation
-> StgCaseAlts
- -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
- -- so that we can duplicate it without risk of
- -- duplicating code
+ -> FCode Sequel -- Any addr modes inside are guaranteed
+ -- to be a label so that we can duplicate it
+ -- without risk of duplicating code
+
+cgEvalAlts cc_slot bndr srt alts
+ =
+ let uniq = getUnique bndr in
-cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
- = -- Generate the instruction to restore cost centre, if any
+ -- Generate the instruction to restore cost centre, if any
restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+ -- get the stack liveness for the info table (after the CC slot has
+ -- been freed - this is important).
+ buildContLivenessMask uniq `thenFC` \ liveness_mask ->
+
+ case alts of
+
+ -- algebraic alts ...
+ (StgAlgAlts ty alts deflt) ->
+
+ -- bind the default binder (it covers all the alternatives)
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToReg bndr node mkLFArgument) `thenC`
+
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
-- Reason: if not, then it costs extra to label the
--
-- which is worse than having the alt code in the switch statement
- let
- (spec_tycon, _, _) = splitAlgTyConApp ty
-
- use_labelled_alts
- = case ctrlReturnConvAlg spec_tycon of
- VectoredReturn _ -> True
- _ -> False
-
- semi_tagged_stuff
- = if not use_labelled_alts then
- Nothing -- no semi-tagging info
- else
- cgSemiTaggedAlts uniq alts deflt -- Just <something>
- in
- cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
- `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
-
- mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
-
- returnFC (CaseAlts return_vec semi_tagged_stuff)
-
-cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
- = -- Generate the instruction to restore cost centre, if any
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-
- -- Generate the switch
- getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
+ let tycon_info = getScrutineeTyCon ty
+ is_alg = maybeToBool tycon_info
+ Just spec_tycon = tycon_info
+ in
+
+ -- deal with the unboxed tuple case
+ if is_alg && isUnboxedTupleTyCon spec_tycon then
+ case alts of
+ [alt] -> let lbl = mkReturnInfoLabel uniq in
+ cgUnboxedTupleAlt lbl cc_restore True alt
+ `thenFC` \ abs_c ->
+ getSRTLabel `thenFC` \srt_label ->
+ absC (CRetDirect uniq abs_c (srt_label, srt)
+ liveness_mask) `thenC`
+ returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
+ _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
+
+ -- normal algebraic (or polymorphic) case alternatives
+ else let
+ ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
+ | otherwise = UnvectoredReturn 0
+
+ use_labelled_alts = case ret_conv of
+ VectoredReturn _ -> True
+ _ -> False
+
+ semi_tagged_stuff
+ = if use_labelled_alts then
+ cgSemiTaggedAlts bndr alts deflt -- Just <something>
+ else
+ Nothing -- no semi-tagging info
+
+ in
+ cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts (not is_alg)
+ alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
+
+ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
+ ret_conv `thenFC` \ return_vec ->
+
+ returnFC (CaseAlts return_vec semi_tagged_stuff)
+
+ -- primitive alts...
+ (StgPrimAlts ty alts deflt) ->
+
+ -- Generate the switch
+ getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
+
+ -- Generate the labelled block, starting with restore-cost-centre
+ getSRTLabel `thenFC` \srt_label ->
+ absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
+ (srt_label,srt) liveness_mask) `thenC`
- -- Generate the labelled block, starting with restore-cost-centre
- absC (CRetUnVector vtbl_label
- (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
- `thenC`
-- Return an amode for the block
- returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
- where
- vtbl_label = mkVecTblLabel uniq
- return_label = mkReturnPtLabel uniq
+ returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing)
\end{code}
\begin{code}
-cgInlineAlts :: GCFlag -> Unique
+cgInlineAlts :: Id
-> StgCaseAlts
-> Code
\end{code}
must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
emitted). Hence, the new Bool arg to cgAlgAltRhs.
-First case: algebraic case, exactly one alternative, no default.
-In this case the primitive op will not have set a temporary to the
-tag, so we shouldn't generate a switch statment. Instead we just
-do the right thing.
+First case: primitive op returns an unboxed tuple.
+
+\begin{code}
+cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
+ | isUnboxedTupleCon con
+ = -- no heap check, no yield, just get in there and do it.
+ mapFCs bindNewToTemp args `thenFC` \ _ ->
+ cgExpr rhs
+
+ | otherwise
+ = panic "cgInlineAlts: single alternative, not an unboxed tuple"
+\end{code}
+
+Hack: to deal with
+
+ case <# x y of z {
+ DEFAULT -> ...
+ }
\begin{code}
-cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
+cgInlineAlts bndr (StgAlgAlts ty [] (StgBindDefault rhs))
+ = bindNewToTemp bndr `thenFC` \amode ->
+ let
+ (tycon, _, _) = splitAlgTyConApp ty
+ closure_lbl = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) amode PtrRep
+ in
+ absC (CAssign amode closure_lbl) `thenC`
+ cgExpr rhs
\end{code}
Second case: algebraic case, several alternatives.
Tag is held in a temporary.
\begin{code}
-cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
- = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
- ty alts deflt
- False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
+cgInlineAlts bndr (StgAlgAlts ty alts deflt)
+ = cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
+ False{-not poly case-} alts deflt
+ False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
tag_amode = CTemp uniq IntRep
+ uniq = getUnique bndr
\end{code}
Third (real) case: primitive result type.
\begin{code}
-cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
- = cgPrimAlts gc_flag uniq ty alts deflt
+cgInlineAlts bndr (StgPrimAlts ty alts deflt)
+ = cgPrimInlineAlts bndr ty alts deflt
\end{code}
-> Unique
-> AbstractC -- Restore-cost-centre instruction
-> Bool -- True <=> branches must be labelled
- -> Type -- From the case statement
- -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
- -> StgCaseDefault -- The default
+ -> Bool -- True <=> polymorphic case
+ -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
+ -> StgCaseDefault -- The default
-> Bool -- Context switch at alts?
-> FCode ([(ConTag, AbstractC)], -- The branches
AbstractC -- The default case
)
-\end{code}
-The case with a default which has a binder is different. We need to
-pick all the constructors which aren't handled explicitly by an
-alternative, and which return their results in registers, allocate
-them explicitly in the heap, and jump to a join point for the default
-case.
-
-OLD: All of this only works if a heap-check is required anyway, because
-otherwise it isn't safe to allocate.
-
-NEW (July 94): now false! It should work regardless of gc_flag,
-because of the extra_branches argument now added to forkAlts.
-
-We put a heap-check at the join point, for the benefit of constructors
-which don't need to do allocation. This means that ones which do need
-to allocate may end up doing two heap-checks; but that's just too bad.
-(We'd need two join labels otherwise. ToDo.)
-
-It's all pretty turgid anyway.
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc semi_tagging
- ty alts deflt@(StgBindDefault binder True{-used-} _)
- emit_yield{-should a yield macro be emitted?-}
- = let
- extra_branches :: [FCode (ConTag, AbstractC)]
- extra_branches = catMaybes (map mk_extra_branch default_cons)
-
- must_label_default = semi_tagging || not (null extra_branches)
- in
- forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
- extra_branches
- (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
- where
-
- default_join_lbl = mkDefaultLabel uniq
- jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
-
- (spec_tycon, _, spec_cons) = splitAlgTyConApp ty
-
- alt_cons = [ con | (con,_,_,_) <- alts ]
-
- default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
- spec_con `not_elem` alt_cons ] -- Not handled explicitly
- where
- not_elem = isn'tIn "cgAlgAlts"
-
- -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
- -- The "maybe" is because con may return in heap, in which case there is
- -- nothing to do. Otherwise, we have a special case for a nullary constructor,
- -- but in the general case we do an allocation and heap-check.
-
- mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
-
- mk_extra_branch con
- = ASSERT(isDataCon con)
- case dataReturnConvAlg con of
- ReturnInHeap -> Nothing
- ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
- returnFC (tag, abs_c)
- )
- where
- lf_info = mkConLFInfo con
- tag = dataConTag con
-
- -- alloc_code generates code to allocate constructor con, whose args are
- -- in the arguments to alloc_code, assigning the result to Node.
- alloc_code :: [MagicId] -> Code
-
- alloc_code regs
- = possibleHeapCheck gc_flag regs False (
- buildDynCon binder useCurrentCostCentre con
- (map CReg regs) (all zero_size regs)
- `thenFC` \ idinfo ->
- idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
-
- absC (CAssign (CReg node) amode) `thenC`
- absC jump_instruction
- )
- where
- zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
-\end{code}
-
-Now comes the general case
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
- {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
+cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
emit_yield{-should a yield macro be emitted?-}
= forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
- [{- No "extra branches" -}]
- (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
+ (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
\end{code}
\begin{code}
cgAlgDefault :: GCFlag
+ -> Bool -- could be a function-typed result?
-> Unique -> AbstractC -> Bool -- turgid state...
- -> StgCaseDefault -- input
+ -> StgCaseDefault -- input
-> Bool
- -> FCode AbstractC -- output
+ -> FCode AbstractC -- output
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- StgNoDefault _
+cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch StgNoDefault _
= returnFC AbsCNop
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- (StgBindDefault _ False{-binder not used-} rhs)
- emit_yield{-should a yield macro be emitted?-}
-
- = getAbsC (absC restore_cc `thenC`
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
- then yield [] False
- else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
- let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
- | otherwise = abs_c
- in
- returnFC final_abs_c
- where
- lbl = mkDefaultLabel uniq
-
-
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- (StgBindDefault binder True{-binder used-} rhs)
+cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch
+ (StgBindDefault rhs)
emit_yield{-should a yield macro be emitted?-}
- = -- We have arranged that Node points to the thing, even
- -- even if we return in registers
- bindNewToReg binder node mkLFArgument `thenC`
+ = -- We have arranged that Node points to the thing
getAbsC (absC restore_cc `thenC`
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
+ (if opt_GranMacros && emit_yield
then yield [node] False
else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag [node] False (cgExpr rhs)
+ possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
-- Node is live, but doesn't need to point at the thing itself;
-- it's ok for Node to point to an indirection or FETCH_ME
-- Hence no need to re-enter Node.
) `thenFC` \ abs_c ->
let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
+ final_abs_c | must_label_branch = CCodeBlock lbl abs_c
| otherwise = abs_c
in
returnFC final_abs_c
cgAlgAlt :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state
-> Bool -- Context switch at alts?
- -> (Id, [Id], [Bool], StgExpr)
+ -> (DataCon, [Id], [Bool], StgExpr)
-> FCode (ConTag, AbstractC)
cgAlgAlt gc_flag uniq restore_cc must_label_branch
emit_yield{-should a yield macro be emitted?-}
(con, args, use_mask, rhs)
= getAbsC (absC restore_cc `thenC`
- cgAlgAltRhs gc_flag con args use_mask rhs
- emit_yield
+ (if opt_GranMacros && emit_yield
+ then yield [node] True -- XXX live regs wrong
+ else absC AbsCNop) `thenC`
+ (case gc_flag of
+ NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
+ GCMayHappen -> bindConArgs con args
+ ) `thenC`
+ possibleHeapCheck gc_flag False [node] [] Nothing (
+ cgExpr rhs)
) `thenFC` \ abs_c ->
let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
+ final_abs_c | must_label_branch = CCodeBlock lbl abs_c
| otherwise = abs_c
in
returnFC (tag, final_abs_c)
tag = dataConTag con
lbl = mkAltLabel uniq tag
-cgAlgAltRhs :: GCFlag
- -> Id
- -> [Id]
- -> [Bool]
- -> StgExpr
- -> Bool -- context switch?
- -> Code
-cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
- = let
- (live_regs, node_reqd)
- = case (dataReturnConvAlg con) of
- ReturnInHeap -> ([], True)
- ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
- -- Pick the live registers using the use_mask
- -- Doing so is IMPORTANT, because with semi-tagging
- -- enabled only the live registers will have valid
- -- pointers in them.
- in
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
- then yield live_regs node_reqd
- else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag live_regs node_reqd (
- (case gc_flag of
- NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
- nopC
- GCMayHappen -> bindConArgs con args
- ) `thenC`
- cgExpr rhs
+cgUnboxedTupleAlt
+ :: CLabel -- label of the alternative
+ -> AbstractC -- junk
+ -> Bool -- ctxt switch
+ -> (DataCon, [Id], [Bool], StgExpr) -- alternative
+ -> FCode AbstractC
+
+cgUnboxedTupleAlt lbl restore_cc emit_yield (con,args,use_mask,rhs)
+ = getAbsC (
+ absC restore_cc `thenC`
+
+ bindUnboxedTupleComponents args
+ `thenFC` \ (live_regs,tags,stack_res) ->
+ (if opt_GranMacros && emit_yield
+ then yield live_regs True -- XXX live regs wrong?
+ else absC AbsCNop) `thenC`
+ let
+ -- ToDo: could maybe use Nothing here if stack_res is False
+ -- since the heap-check can just return to the top of the
+ -- stack.
+ ret_addr = Just lbl
+ in
+
+ -- free up stack slots containing tags,
+ freeStackSlots (map fst tags) `thenC`
+
+ -- generate a heap check if necessary
+ possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
+
+ -- and finally the code for the alternative
+ cgExpr rhs)
)
\end{code}
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: Unique
- -> [(Id, [Id], [Bool], StgExpr)]
+cgSemiTaggedAlts :: Id
+ -> [(DataCon, [Id], [Bool], StgExpr)]
-> GenStgCaseDefault Id Id
-> SemiTaggingStuff
-cgSemiTaggedAlts uniq alts deflt
+cgSemiTaggedAlts binder alts deflt
= Just (map st_alt alts, st_deflt deflt)
where
+ uniq = getUnique binder
+
st_deflt StgNoDefault = Nothing
- st_deflt (StgBindDefault binder binder_used _)
- = Just (if binder_used then Just binder else Nothing,
+ st_deflt (StgBindDefault _)
+ = Just (Just binder,
(CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
mkDefaultLabel uniq)
)
st_alt (con, args, use_mask, _)
- = case (dataReturnConvAlg con) of
-
- ReturnInHeap ->
- -- Ha! Nothing to do; Node already points to the thing
- (con_tag,
- (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
- [mkIntCLit (length args)], -- how big the thing in the heap is
+ = -- Ha! Nothing to do; Node already points to the thing
+ (con_tag,
+ (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
+ [mkIntCLit (length args)], -- how big the thing in the heap is
join_label)
)
-
- ReturnInRegs regs ->
- -- We have to load the live registers from the constructor
- -- pointed to by Node.
- let
- (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
-
- used_regs = selectByMask use_mask regs
-
- used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
- reg `is_elem` used_regs]
-
- is_elem = isIn "cgSemiTaggedAlts"
- in
- (con_tag,
- (mkAbstractCs [
- CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
- [mkIntCLit (length regs_w_offsets),
- mkIntCLit (length used_regs_w_offsets)],
- CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
- join_label))
where
con_tag = dataConTag con
join_label = mkAltLabel uniq con_tag
-
- move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
- move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
\end{code}
%************************************************************************
%* *
%************************************************************************
-@cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
-alternatives of a primitive @case@, given an addressing mode for the
-thing to scrutinise. It also keeps track of the maximum stack depth
-encountered down any branch.
+@cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
+for dealing with the alternatives of a primitive @case@, given an
+addressing mode for the thing to scrutinise. It also keeps track of
+the maximum stack depth encountered down any branch.
As usual, no binders in the alternatives are yet bound.
\begin{code}
-cgPrimAlts :: GCFlag
- -> Unique
- -> Type
- -> [(Literal, StgExpr)] -- Alternatives
- -> StgCaseDefault -- Default
- -> Code
-
-cgPrimAlts gc_flag uniq ty alts deflt
- = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
- where
- -- A temporary variable, or standard register, to hold the result
- scrutinee = case gc_flag of
- NoGC -> CTemp uniq kind
- GCMayHappen -> CReg (dataReturnConvPrim kind)
+cgPrimInlineAlts bndr ty alts deflt
+ = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
+ where
+ uniq = getUnique bndr
+ kind = typePrimRep ty
- kind = typePrimRep ty
+cgPrimEvalAlts bndr ty alts deflt
+ = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
+ where
+ reg = dataReturnConvPrim kind
+ kind = typePrimRep ty
+cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
+ = -- first bind the default if necessary
+ (if isDeadBinder bndr
+ then nopC
+ else bindNewPrimToAmode bndr scrutinee) `thenC`
+ cgPrimAlts gc_flag scrutinee alts deflt regs
+
+cgPrimAlts gc_flag scrutinee alts deflt regs
+ = forkAlts (map (cgPrimAlt gc_flag regs) alts)
+ (cgPrimDefault gc_flag regs deflt)
+ `thenFC` \ (alt_absCs, deflt_absC) ->
-cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
- = forkAlts (map (cgPrimAlt gc_flag) alts)
- [{- No "extra branches" -}]
- (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
absC (CSwitch scrutinee alt_absCs deflt_absC)
- -- CSwitch does sensible things with one or zero alternatives
+ -- CSwitch does sensible things with one or zero alternatives
cgPrimAlt :: GCFlag
- -> (Literal, StgExpr) -- The alternative
+ -> [MagicId] -- live registers
+ -> (Literal, StgExpr) -- The alternative
-> FCode (Literal, AbstractC) -- Its compiled form
-cgPrimAlt gc_flag (lit, rhs)
+cgPrimAlt gc_flag regs (lit, rhs)
= getAbsC rhs_code `thenFC` \ absC ->
returnFC (lit,absC)
where
- rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
+ rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
cgPrimDefault :: GCFlag
- -> CAddrMode -- Scrutinee
+ -> [MagicId] -- live registers
-> StgCaseDefault
-> FCode AbstractC
-cgPrimDefault gc_flag scrutinee StgNoDefault
+cgPrimDefault gc_flag regs StgNoDefault
= panic "cgPrimDefault: No default in prim case"
-cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
- = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
-
-cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
- = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
- where
- regs = if isFollowableRep (getAmodeRep scrutinee) then
- [node] else []
-
- rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
- cgExpr rhs
+cgPrimDefault gc_flag regs (StgBindDefault rhs)
+ = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
\end{code}
\begin{code}
saveVolatileVarsAndRegs
- :: StgLiveVars -- Vars which should be made safe
+ :: StgLiveVars -- Vars which should be made safe
-> FCode (AbstractC, -- Assignments to do the saves
- EndOfBlockInfo, -- New sequel, recording where the return
- -- address now is
- Maybe VirtualSpBOffset) -- Slot for current cost centre
+ EndOfBlockInfo, -- sequel for the alts
+ Maybe VirtualSpOffset) -- Slot for current cost centre
saveVolatileVarsAndRegs vars
- = saveVolatileVars vars `thenFC` \ var_saves ->
- saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
- saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
- returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
- new_eob_info,
+ = saveVolatileVars vars `thenFC` \ var_saves ->
+ saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
+ getEndOfBlockInfo `thenFC` \ eob_info ->
+ returnFC (mkAbstractCs [var_saves, cc_save],
+ eob_info,
maybe_cc_slot)
-> FCode AbstractC -- Assignments to to the saves
saveVolatileVars vars
- = save_em (idSetToList vars)
+ = save_em (varSetElems vars)
where
save_em [] = returnFC AbsCNop
returnFC (abs_c `mkAbsCStmts` abs_cs)
save_var var vol_amode
- | isFollowableRep kind
- = allocAStack `thenFC` \ a_slot ->
- rebindToAStack var a_slot `thenC`
- getSpARelOffset a_slot `thenFC` \ spa_rel ->
- returnFC (CAssign (CVal spa_rel kind) vol_amode)
- | otherwise
- = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
- rebindToBStack var b_slot `thenC`
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- returnFC (CAssign (CVal spb_rel kind) vol_amode)
+ = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
+ rebindToStack var slot `thenC`
+ getSpRelOffset slot `thenFC` \ sp_rel ->
+ returnFC (CAssign (CVal sp_rel kind) vol_amode)
where
kind = getAmodeRep vol_amode
-
-saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
-saveReturnAddress
- = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
-
- -- See if it is volatile
- case sequel of
- InRetReg -> -- Yes, it's volatile
- allocBStack retPrimRepSize `thenFC` \ b_slot ->
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
-
- returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
- CAssign (CVal spb_rel RetRep) (CReg RetReg))
-
- UpdateCode _ -> -- It's non-volatile all right, but we still need
- -- to allocate a B-stack slot for it, *solely* to make
- -- sure that update frames for different values do not
- -- appear adjacent on the B stack. This makes sure
- -- that B-stack squeezing works ok.
- -- See note below
- allocBStack retPrimRepSize `thenFC` \ b_slot ->
- returnFC (eob_info, AbsCNop)
-
- other -> -- No, it's non-volatile, so do nothing
- returnFC (eob_info, AbsCNop)
\end{code}
-Note about B-stack squeezing. Consider the following:`
-
- y = [...] \u [] -> ...
- x = [y] \u [] -> case y of (a,b) -> a
-
-The code for x will push an update frame, and then enter y. The code
-for y will push another update frame. If the B-stack-squeezer then
-wakes up, it will see two update frames right on top of each other,
-and will combine them. This is WRONG, of course, because x's value is
-not the same as y's.
-
-The fix implemented above makes sure that we allocate an (unused)
-B-stack slot before entering y. You can think of this as holding the
-saved value of RetAddr, which (after pushing x's update frame will be
-some update code ptr). The compiler is clever enough to load the
-static update code ptr into RetAddr before entering ~a~, but the slot
-is still there to separate the update frames.
+---------------------------------------------------------------------------
When we save the current cost centre (which is done for lexical
-scoping), we allocate a free B-stack location, and return (a)~the
+scoping), we allocate a free stack location, and return (a)~the
virtual offset of the location, to pass on to the alternatives, and
(b)~the assignment to do the save (just as for @saveVolatileVars@).
\begin{code}
saveCurrentCostCentre ::
- FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
- -- Nothing if not lexical CCs
+ FCode (Maybe VirtualSpOffset, -- Where we decide to store it
AbstractC) -- Assignment to save it
- -- AbsCNop if not lexical CCs
saveCurrentCostCentre
- = let
- doing_profiling = opt_SccProfilingOn
- in
- if not doing_profiling then
+ = if not opt_SccProfilingOn then
returnFC (Nothing, AbsCNop)
else
- allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- returnFC (Just b_slot,
- CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
+ allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
+ getSpRelOffset slot `thenFC` \ sp_rel ->
+ returnFC (Just slot,
+ CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
-restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
restoreCurrentCostCentre Nothing
= returnFC AbsCNop
-restoreCurrentCostCentre (Just b_slot)
- = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- freeBStkSlot b_slot `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
- -- we use the RESTORE_CCC macro, rather than just
+restoreCurrentCostCentre (Just slot)
+ = getSpRelOffset slot `thenFC` \ sp_rel ->
+ freeStackSlots [slot] `thenC`
+ returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+ -- we use the RESTORE_CCCS macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCC
-- has some sanity-checking in it.
\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-return-vec]{Building a return vector}
\begin{code}
mkReturnVector :: Unique
- -> Type
-> [(ConTag, AbstractC)] -- Branch codes
-> AbstractC -- Default case
+ -> SRT -- continuation's SRT
+ -> Liveness -- stack liveness
+ -> CtrlReturnConvention
-> FCode CAddrMode
-mkReturnVector uniq ty tagged_alt_absCs deflt_absC
- = let
- (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg tycon) of {
-
- UnvectoredReturn _ ->
- (CUnVecLbl ret_label vtbl_label,
- absC (CRetUnVector vtbl_label
- (CLabelledCode ret_label
- (mkAlgAltsCSwitch (CReg TagReg)
- tagged_alt_absCs
- deflt_absC))));
+mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
+ = getSRTLabel `thenFC` \srt_label ->
+ let
+ srt_info = (srt_label, srt)
+
+ (return_vec_amode, vtbl_body) = case ret_conv of {
+
+ -- might be a polymorphic case...
+ UnvectoredReturn 0 ->
+ ASSERT(null tagged_alt_absCs)
+ (CLbl ret_label RetRep,
+ absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
+
+ UnvectoredReturn n ->
+ -- find the tag explicitly rather than using tag_reg for now.
+ -- on architectures with lots of regs the tag will be loaded
+ -- into tag_reg by the code doing the returning.
+ let
+ tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
+ in
+ (CLbl ret_label RetRep,
+ absC (CRetDirect uniq
+ (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
+ (srt_label, srt)
+ liveness));
+
VectoredReturn table_size ->
- (CLbl vtbl_label DataPtrRep,
- absC (CRetVector vtbl_label
- -- must restore cc before each alt, if required
- (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
- deflt_absC))
-
--- Leave nops and comments in for now; they are eliminated
--- lazily as it's printed.
--- (case (nonemptyAbsC deflt_absC) of
--- Nothing -> AbsCNop
--- Just def -> def)
+ let
+ (vector_table, alts_absC) =
+ unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
+
+ ret_vector = CRetVector vtbl_label
+ vector_table
+ (srt_label, srt) liveness
+ in
+ (CLbl vtbl_label DataPtrRep,
+ -- alts come first, because we don't want to declare all the symbols
+ absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
+ )
} in
vtbl_body `thenC`
-- )
where
- (tycon,_,_) = case splitAlgTyConApp_maybe ty of -- *must* be a real "data" type constructor
- Just xx -> xx
- Nothing -> pprPanic "ERROR: can't generate code for polymorphic case"
- (vcat [text "probably a mis-use of `seq' or `par';",
- text "the User's Guide has more details.",
- text "Offending type:" <+> ppr ty
- ])
-
vtbl_label = mkVecTblLabel uniq
- ret_label = mkReturnPtLabel uniq
+ ret_label = mkReturnInfoLabel uniq
+
+ deflt_lbl =
+ case nonemptyAbsC deflt_absC of
+ -- the simplifier might have eliminated a case
+ Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
+ Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
- mk_vector_entry :: ConTag -> Maybe CAddrMode
+ mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
mk_vector_entry tag
= case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
- [] -> Nothing
- [absC] -> Just (CCode absC)
+ [] -> (deflt_lbl, AbsCNop)
+ [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
_ -> panic "mkReturnVector: too many"
\end{code}
%* *
%************************************************************************
-@possibleHeapCheck@ tests a flag passed in to decide whether to
-do a heap check or not.
+@possibleHeapCheck@ tests a flag passed in to decide whether to do a
+heap check or not. These heap checks are always in a case
+alternative, so we use altHeapCheck.
\begin{code}
-possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
+possibleHeapCheck
+ :: GCFlag
+ -> Bool -- True <=> algebraic case
+ -> [MagicId] -- live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> Maybe CLabel -- return address
+ -> Code -- continuation
+ -> Code
-possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
-possibleHeapCheck NoGC _ _ code = code
+possibleHeapCheck GCMayHappen is_alg regs tags lbl code
+ = altHeapCheck is_alg regs tags AbsCNop lbl code
+possibleHeapCheck NoGC _ _ tags lbl code
+ = code
\end{code}
-Select a restricted set of registers based on a usage mask.
+splitTyConAppThroughNewTypes is like splitAlgTyConApp_maybe except
+that it looks through newtypes in addition to synonyms. It's
+useful in the back end where we're not interested in newtypes
+anymore.
+
+Sometimes, we've thrown away the constructors during pruning in the
+renamer. In these cases, we emit a warning and fall back to using a
+SEQ_FRAME to evaluate the case scrutinee.
\begin{code}
-selectByMask [] [] = []
-selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
-selectByMask (False:ms) (x:xs) = selectByMask ms xs
+getScrutineeTyCon :: Type -> Maybe TyCon
+getScrutineeTyCon ty =
+ case (splitAlgTyConAppThroughNewTypes ty) of
+ Nothing -> Nothing
+ Just (tc,_) ->
+ if not (isAlgTyCon tc) then Just tc else
+ case (tyConFamilySize tc) of
+ 0 -> pprTrace "Warning" (hcat [
+ text "constructors for ",
+ ppr tc,
+ text " not available.\n\tUse -fno-prune-tydecls to fix."
+ ]) Nothing
+ _ -> Just tc
+
+splitAlgTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type])
+splitAlgTyConAppThroughNewTypes (TyConApp tc tys)
+ | isNewTyCon tc =
+ case (tyConDataCons tc) of
+ [con] -> let ([ty], _) = splitFunTys
+ (applyTys (dataConType con) tys)
+ in splitAlgTyConAppThroughNewTypes ty
+ _ -> Nothing
+ | otherwise = Just (tc, tys)
+
+splitAlgTyConAppThroughNewTypes (NoteTy _ ty) =
+ splitAlgTyConAppThroughNewTypes ty
+splitAlgTyConAppThroughNewTypes other = Nothing
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgClosure.lhs,v 1.20 1998/12/02 13:17:47 simonm Exp $
%
\section[CgClosure]{Code generation for closures}
@CgCon@, which deals with constructors.
\begin{code}
-module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
+module CgClosure ( cgTopRhsClosure,
+ cgStdRhsClosure,
+ cgRhsClosure,
+ closureCodeBody ) where
#include "HsVersions.h"
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getCAddrMode, getArgAmodes,
getCAddrModeAndInfo, bindNewToNode,
- bindNewToAStack, bindNewToBStack,
+ bindNewToStack,
bindNewToReg, bindArgsToRegs,
stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
-import Constants ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
-import CgHeapery ( allocDynClosure, heapCheck
- , heapCheckOnly, fetchAndReschedule, yield -- HWL
- )
-import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg,
- CtrlReturnConvention(..), DataReturnConvention(..)
+import CgHeapery ( allocDynClosure,
+ fetchAndReschedule, yield, -- HWL
+ fastEntryChecks, thunkChecks
)
-import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
- adjustRealSps
+import CgStackery ( adjustRealSp, mkTaggedVirtStkOffsets, freeStackSlots )
+import CgUsages ( setRealAndVirtualSp, getVirtSp,
+ getSpRelOffset, getHpRelOffset
)
-import CgUsages ( getVirtSps, setRealAndVirtualSps,
- getSpARelOffset, getSpBRelOffset,
- getHpRelOffset
- )
-import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
- mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
- mkErrorStdEntryLabel, mkRednCountsLabel
+import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
+ mkRednCountsLabel, mkStdEntryLabel
)
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
-import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
- noCostCentreAttached, costsAreSubsumed,
- isCafCC, isDictCC, overheadCostCentre, showCostCentre,
- CostCentre
- )
-import HeapOffs ( VirtualHeapOffset )
-import Id ( idType, idPrimRep,
- showId, getIdStrictness, dataConTag,
- emptyIdSet,
- Id
- )
+import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn )
+import CostCentre
+import Id ( Id, idName, idType, idPrimRep )
+import Name ( Name )
import ListSetOps ( minusList )
-import Maybes ( maybeToBool )
-import PrimRep ( isFollowableRep, PrimRep(..) )
-import TyCon ( isPrimTyCon, tyConDataCons )
+import PrimRep ( PrimRep(..) )
import Type ( showTypeCategory )
import Util ( isIn )
+import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\begin{code}
cgTopRhsClosure :: Id
- -> CostCentre -- Optional cost centre annotation
+ -> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
+ -> SRT
-> [Id] -- Args
-> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure name cc binder_info args body lf_info
+cgTopRhsClosure id ccs binder_info srt args body lf_info
= -- LAY OUT THE OBJECT
let
closure_info = layOutStaticNoFVClosure name lf_info
in
- -- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (closureCodeBody binder_info closure_info
- cc args body)
- `thenC`
-
- -- BUILD VAP INFO TABLES IF NECESSARY
- let
- bind_the_fun = addBindC name cg_id_info -- It's global!
- in
- cgVapInfoTables TopLevel bind_the_fun binder_info name args lf_info
- `thenC`
-
-- BUILD THE OBJECT (IF NECESSARY)
- (if staticClosureRequired name binder_info lf_info
- then
- let
- cost_centre = mkCCostCentre cc
- in
- absC (CStaticClosure
+ ({- if staticClosureRequired name binder_info lf_info
+ then -}
+ (if opt_SccProfilingOn
+ then
+ absC (CStaticClosure
closure_label -- Labelled with the name on lhs of defn
closure_info
- cost_centre
+ (mkCCostCentreStack ccs)
[]) -- No fields
- else
- nopC
+ else
+ absC (CStaticClosure
+ closure_label -- Labelled with the name on lhs of defn
+ closure_info
+ (panic "absent cc")
+ []) -- No fields
+ )
+
+ {- else
+ nopC -}
+ `thenC`
+
+ -- GENERATE THE INFO TABLE (IF NECESSARY)
+ forkClosureBody (closureCodeBody binder_info srt closure_info
+ ccs args body)
+
) `thenC`
- returnFC (name, cg_id_info)
+ returnFC (id, cg_id_info)
where
+ name = idName id
closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
+ cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
\end{code}
%********************************************************
For closures with free vars, allocate in heap.
-===================== OLD PROBABLY OUT OF DATE COMMENTS =============
-
--- Closures which (a) have no fvs and (b) have some args (i.e.
--- combinator functions), are allocated statically, just as if they
--- were top-level closures. We can't get a space leak that way
--- (because they are HNFs) and it saves allocation.
-
--- Lexical Scoping: Problem
--- These top level function closures will be inherited, possibly
--- to a different cost centre scope set before entering.
-
--- Evaluation Scoping: ok as already in HNF
-
--- Should rely on floating mechanism to achieve this floating to top level.
--- As let floating will avoid floating which breaks cost centre attribution
--- everything will be OK.
-
--- Disabled: because it breaks lexical-scoped cost centre semantics.
--- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
--- = cgTopRhsClosure binder cc bi upd_flag args body
-
-===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
-
\begin{code}
-cgRhsClosure :: Id
- -> CostCentre -- Optional cost centre annotation
- -> StgBinderInfo
- -> [Id] -- Free vars
- -> [Id] -- Args
- -> StgExpr
- -> LambdaFormInfo
- -> FCode (Id, CgIdInfo)
-
-cgRhsClosure binder cc binder_info fvs args body lf_info
- | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
- -- ToDo: check non-primitiveness (ASSERT)
+cgStdRhsClosure
+ :: Id
+ -> CostCentreStack -- Optional cost centre annotation
+ -> StgBinderInfo
+ -> SRT -- SRT info
+ -> [Id] -- Free vars
+ -> [Id] -- Args
+ -> StgExpr
+ -> LambdaFormInfo
+ -> [StgArg] -- payload
+ -> FCode (Id, CgIdInfo)
+
+cgStdRhsClosure binder cc binder_info srt fvs args body lf_info payload
+ -- AHA! A STANDARD-FORM THUNK
= (
-- LAY OUT THE OBJECT
- getArgAmodes std_thunk_payload `thenFC` \ amodes ->
+ getArgAmodes payload `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeRep amodes lf_info
+ = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
in
returnFC (binder, heapIdInfo binder heap_offset lf_info)
where
- maybe_std_thunk = getStandardFormThunkInfo lf_info
- Just std_thunk_payload = maybe_std_thunk
+ is_std_thunk = isStandardFormThunk lf_info
\end{code}
Here's the general case.
+
\begin{code}
-cgRhsClosure binder cc binder_info fvs args body lf_info
+cgRhsClosure :: Id
+ -> CostCentreStack -- Optional cost centre annotation
+ -> StgBinderInfo
+ -> SRT -- SRT info
+ -> [Id] -- Free vars
+ -> [Id] -- Args
+ -> StgExpr
+ -> LambdaFormInfo
+ -> FCode (Id, CgIdInfo)
+
+cgRhsClosure binder cc binder_info srt fvs args body lf_info
= (
-- LAY OUT THE OBJECT
--
bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
(closure_info, bind_details)
- = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
+ = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
nopC) `thenC`
-- Compile the body
- closureCodeBody binder_info closure_info cc args body
+ closureCodeBody binder_info srt closure_info cc args body
) `thenC`
- -- BUILD VAP INFO TABLES IF NECESSARY
- cgVapInfoTables NotTopLevel nopC binder_info binder args lf_info
- `thenC`
-
-- BUILD THE OBJECT
let
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
returnFC (binder, heapIdInfo binder heap_offset lf_info)
\end{code}
-@cgVapInfoTables@ generates both Vap info tables, if they are required
-at all. It calls @cgVapInfoTable@ to generate each Vap info table,
-along with its entry code.
-
-\begin{code}
--- Don't generate Vap info tables for thunks; only for functions
-cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
- = nopC
-
-cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
- = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
- (if stdVapRequired binder_info then
- cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
- else
- nopC
- ) `thenC`
-
- -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
- (if noUpdVapRequired binder_info then
- cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
- else
- nopC
- )
-
- where
- fun_in_payload = case top_level of
- TopLevel -> False
- NotTopLevel -> True
-
-
-cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
- | closureReturnsUnpointedType closure_info
- -- Don't build Vap info tables etc for
- -- a function whose result is an unboxed type,
- -- because we can never have thunks with such a type.
- = nopC
-
- | otherwise
- = forkClosureBody (
-
- -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
- -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
- perhaps_bind_the_fun `thenC`
- mapCs bind_fv payload_bind_details `thenC`
-
- -- Generate the info table and code
- closureCodeBody NoStgBinderInfo
- closure_info
- useCurrentCostCentre
- [] -- No args; it's a thunk
- vap_entry_rhs
- )
- where
- -- The vap_entry_rhs is a manufactured STG expression which
- -- looks like the RHS of any binding which is going to use the vap-entry
- -- point of the function. Each of these bindings will look like:
- --
- -- x = [a,b,c] \upd [] -> f a b c
- --
- -- If f is not top-level, then f is one of the free variables too,
- -- hence "payload_ids" isn't the same as "arg_ids".
- --
- stg_args = map StgVarArg args
- vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
- -- Empty live vars
-
- arg_ids_w_info = [(name,mkLFArgument) | name <- args]
- payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
- | otherwise = arg_ids_w_info
-
- payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
- | otherwise = args
-
- vap_lf_info = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
- -- It's not top level, even if we're currently compiling a top-level
- -- function, because any VAP *use* of this function will be for a
- -- local thunk, thus
- -- let x = f p q -- x isn't top level!
- -- in ...
-
- get_kind (id, info) = idPrimRep id
-
- payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
- (closure_info, payload_bind_details) = layOutDynClosure
- fun
- get_kind payload_ids_w_info
- vap_lf_info
- -- The dodgy thing is that we use the "fun" as the
- -- Id to give to layOutDynClosure. This Id gets embedded in
- -- the closure_info it returns. But of course, the function doesn't
- -- have the right type to match the Vap closure. Never mind,
- -- a hack in closureType spots the special case. Otherwise that
- -- Id is just used for label construction, which is OK.
-
- bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
-\end{code}
%************************************************************************
%* *
\subsection[code-for-closures]{The code for closures}
\begin{code}
closureCodeBody :: StgBinderInfo
- -> ClosureInfo -- Lots of information about this closure
- -> CostCentre -- Optional cost centre attached to closure
+ -> SRT
+ -> ClosureInfo -- Lots of information about this closure
+ -> CostCentreStack -- Optional cost centre attached to closure
-> [Id]
-> StgExpr
-> Code
are the same.
\begin{code}
-closureCodeBody binder_info closure_info cc [] body
+closureCodeBody binder_info srt closure_info cc [] body
= -- thunks cannot have a primitive type!
-#ifdef DEBUG
- let
- (has_tycon, tycon)
- = case (closureType closure_info) of
- Nothing -> (False, panic "debug")
- Just (tc,_,_) -> (True, tc)
- in
- if has_tycon && isPrimTyCon tycon then
- pprPanic "closureCodeBody:thunk:prim type!" (ppr tycon)
- else
-#endif
getAbsC body_code `thenFC` \ body_absC ->
moduleName `thenFC` \ mod_name ->
+ getSRTLabel `thenFC` \ srt_label ->
absC (CClosureInfoAndCode closure_info body_absC Nothing
- stdUpd (cl_descr mod_name)
- (dataConLiveness closure_info))
+ (srt_label, srt) (cl_descr mod_name))
where
- cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
+ cl_descr mod_name = closureDescription mod_name (closureName closure_info)
- body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
- body_code = profCtrC SLIT("ENT_THK") [] `thenC`
- thunkWrapper closure_info (
+ body_label = entryLabelFromCI closure_info
+ body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
+ thunkWrapper closure_info body_label (
-- We only enter cc after setting up update so that cc
-- of enclosing scope will be recorded in update frame
-- CAF/DICT functions will be subsumed by this enclosing cc
enterCostCentreCode closure_info cc IsThunk `thenC`
cgExpr body)
-
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
\end{code}
If there is {\em at least one argument}, then this closure is in
Node points to closure is available. -- HWL
\begin{code}
-closureCodeBody binder_info closure_info cc all_args body
- = getEntryConvention id lf_info
+closureCodeBody binder_info srt closure_info cc all_args body
+ = getEntryConvention name lf_info
(map idPrimRep all_args) `thenFC` \ entry_conv ->
+
+ -- get the current virtual Sp (it might not be zero, eg. if we're
+ -- compiling a let-no-escape).
+ getVirtSp `thenFC` \vSp ->
let
-- Figure out what is needed and what isn't
- slow_code_needed = slowFunEntryCodeRequired id binder_info entry_conv
- info_table_needed = funInfoTableRequired id binder_info lf_info
- -- Arg mapping for standard (slow) entry point; all args on stack
- (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
- = mkVirtStkOffsets
- 0 0 -- Initial virtual SpA, SpB
- idPrimRep
- all_args
+ -- SDM: need everything for now in case the heap/stack check refers
+ -- to it. (ToDo)
+ slow_code_needed = True
+ --slowFunEntryCodeRequired name binder_info entry_conv
+ info_table_needed = True
+ --funInfoTableRequired name binder_info lf_info
+
+ -- Arg mapping for standard (slow) entry point; all args on stack,
+ -- with tagging.
+ (sp_all_args, arg_offsets, arg_tags)
+ = mkTaggedVirtStkOffsets vSp idPrimRep all_args
-- Arg mapping for the fast entry point; as many args as poss in
-- registers; the rest on the stack
-- arg_regs are the registers used for arg passing
-- stk_args are the args which are passed on the stack
--
+ -- Args passed on the stack are tagged, but the tags may not
+ -- actually be present (just gaps) if the function is called
+ -- by jumping directly to the fast entry point.
+ --
arg_regs = case entry_conv of
DirectEntry lbl arity regs -> regs
- ViaNode | is_concurrent -> []
- other -> panic "closureCodeBody:arg_regs"
+ other -> panic "closureCodeBody:arg_regs"
num_arg_regs = length arg_regs
(reg_args, stk_args) = splitAt num_arg_regs all_args
- (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
- = mkVirtStkOffsets
- 0 0 -- Initial virtual SpA, SpB
- idPrimRep
- stk_args
+ (sp_stk_args, stk_offsets, stk_tags)
+ = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
-- HWL; Note: empty list of live regs in slow entry code
-- Old version (reschedule combined with heap check);
--slow_entry_code = forceHeapCheck [] True slow_entry_code'
slow_entry_code
- = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
+ = profCtrC SLIT("TICK_ENT_FUN_STD") [] `thenC`
- -- Bind args, and record expected position of stk ptrs
- mapCs bindNewToAStack all_bxd_w_offsets `thenC`
- mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
- setRealAndVirtualSps spA_all_args spB_all_args `thenC`
+ -- Bind args, and record expected position of stk ptrs
+ mapCs bindNewToStack arg_offsets `thenC`
+ setRealAndVirtualSp sp_all_args `thenC`
- argSatisfactionCheck closure_info all_args `thenC`
+ argSatisfactionCheck closure_info `thenC`
-- OK, so there are enough args. Now we need to stuff as
-- many of them in registers as the fast-entry code
- -- expects Note that the zipWith will give up when it hits
+ -- expects. Note that the zipWith will give up when it hits
-- the end of arg_regs.
- mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
- absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
+ mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
+ absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
+ `thenC`
-- Now adjust real stack pointers
- adjustRealSps spA_stk_args spB_stk_args `thenC`
+ adjustRealSp sp_stk_args `thenC`
absC (CFallThrough (CLbl fast_label CodePtrRep))
-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
fast_entry_code
- = profCtrC SLIT("ENT_FUN_DIRECT") [
- CLbl (mkRednCountsLabel id) PtrRep,
- CString (_PK_ (showId id)),
+ = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
+ CLbl (mkRednCountsLabel name) PtrRep,
+ CString (_PK_ (showSDoc (ppr name))),
mkIntCLit stg_arity, -- total # of args
- mkIntCLit spA_stk_args, -- # passed on A stk
- mkIntCLit spB_stk_args, -- B stk (rest in regs)
+ mkIntCLit sp_stk_args, -- # passed on stk
CString (_PK_ (map (showTypeCategory . idType) all_args)),
CString SLIT(""), CString SLIT("")
] `thenC`
-- Bind args to regs/stack as appropriate, and
- -- record expected position of sps
+ -- record expected position of sps.
bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
- mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
- setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
+ mapCs bindNewToStack stk_offsets `thenC`
+ setRealAndVirtualSp sp_stk_args `thenC`
+
+ -- free up the stack slots containing tags
+ freeStackSlots (map fst stk_tags) `thenC`
-- Enter the closures cc, if required
enterCostCentreCode closure_info cc IsFunction `thenC`
-- Do the business
- funWrapper closure_info arg_regs (cgExpr body)
+ funWrapper closure_info arg_regs stk_tags slow_label (cgExpr body)
in
-- Make a labelled code-block for the slow and fast entry code
forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
`thenFC` \ slow_abs_c ->
forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
moduleName `thenFC` \ mod_name ->
+ getSRTLabel `thenFC` \ srt_label ->
-- Now either construct the info table, or put the fast code in alone
-- (We never have slow code without an info table)
+ -- XXX probably need the info table and slow entry code in case of
+ -- a heap check failure.
absC (
if info_table_needed then
CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
- stdUpd (cl_descr mod_name)
- (dataConLiveness closure_info)
+ (srt_label, srt) (cl_descr mod_name)
else
CCodeBlock fast_label fast_abs_c
)
where
- is_concurrent = opt_ForConcurrent
stg_arity = length all_args
lf_info = closureLFInfo closure_info
- cl_descr mod_name = closureDescription mod_name id all_args body
+ cl_descr mod_name = closureDescription mod_name name
-- Manufacture labels
- id = closureId closure_info
- fast_label = mkFastEntryLabel id stg_arity
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
-
-{- OLD... see note at end of file
- wrapper_maybe = get_ultimate_wrapper Nothing id
- where
- get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
- = case myWrapperMaybe x of
- Nothing -> deflt
- Just xx -> get_ultimate_wrapper (Just xx) xx
-
- show_wrapper_name Nothing = ""
- show_wrapper_name (Just xx) = showId xx
-
- show_wrapper_arg_kinds Nothing = ""
- show_wrapper_arg_kinds (Just xx)
- = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
- Nothing -> ""
- Just str -> str
--}
+ name = closureName closure_info
+ fast_label = mkFastEntryLabel name stg_arity
+ slow_label = mkStdEntryLabel name
\end{code}
For lexically scoped profiling we have to load the cost centre from
deriving Eq
--#endif
-enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
+enterCostCentreCode :: ClosureInfo -> CostCentreStack -> IsThunk -> Code
-enterCostCentreCode closure_info cc is_thunk
- = costCentresFlag `thenFC` \ profiling_on ->
- if not profiling_on then
+enterCostCentreCode closure_info ccs is_thunk
+ = if not opt_SccProfilingOn then
nopC
else
- ASSERT(not (noCostCentreAttached cc))
+ ASSERT(not (noCCSAttached ccs))
- if costsAreSubsumed cc then
+ if isSubsumedCCS ccs then
--ASSERT(isToplevClosure closure_info)
--ASSERT(is_thunk == IsFunction)
- (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr (is_thunk == IsFunction){-, ppr closure_info-}, text (showCostCentre False cc)])) $
- costCentresC SLIT("ENTER_CC_FSUB") []
+ (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x
+ else pprTrace "enterCostCenterCode:" (hsep [ppr (is_thunk == IsFunction),
+ ppr ccs])) $
+ costCentresC SLIT("ENTER_CCS_FSUB") []
- else if currentOrSubsumedCosts cc then
- -- i.e. current; subsumed dealt with above
+ else if isCurrentCCS ccs then
-- get CCC out of the closure, where we put it when we alloc'd
case is_thunk of
- IsThunk -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
- IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]
+ IsThunk -> costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
+ IsFunction -> costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
- else if isCafCC cc && isToplevClosure closure_info then
+ else if isCafCCS ccs && isToplevClosure closure_info then
ASSERT(is_thunk == IsThunk)
- costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
+ costCentresC SLIT("ENTER_CCS_CAF") c_ccs
else -- we've got a "real" cost centre right here in our hands...
case is_thunk of
- IsThunk -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
- IsFunction -> if isCafCC cc || isDictCC cc
- then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
- else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
+ IsThunk -> costCentresC SLIT("ENTER_CCS_T") c_ccs
+ IsFunction -> if isCafCCS ccs-- || isDictCC ccs
+ then costCentresC SLIT("ENTER_CCS_FCAF") c_ccs
+ else costCentresC SLIT("ENTER_CCS_FLOAD") c_ccs
+ where
+ c_ccs = [mkCCostCentreStack ccs]
\end{code}
%************************************************************************
are expected.
\begin{code}
-argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
-
-argSatisfactionCheck closure_info [] = nopC
+argSatisfactionCheck :: ClosureInfo -> Code
-argSatisfactionCheck closure_info args
- = -- safest way to determine which stack last arg will be on:
- -- look up CAddrMode that last arg is bound to;
- -- getAmodeRep;
- -- check isFollowableRep.
+argSatisfactionCheck closure_info
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+ = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
let
emit_gran_macros = opt_GranMacros
else yield [] node_points
else absC AbsCNop) `thenC`
- getCAddrMode (last args) `thenFC` \ last_amode ->
-
- if (isFollowableRep (getAmodeRep last_amode)) then
- getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
+ getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
let
- a_rel_int = spARelToInt spA off
- a_rel_arg = mkIntCLit a_rel_int
+ off = I# sp
+ rel_arg = mkIntCLit off
in
- ASSERT(a_rel_int /= 0)
+ ASSERT(off /= 0)
if node_points then
- absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
+ absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
- else
- getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
- let
- b_rel_int = spBRelToInt spB off
- b_rel_arg = mkIntCLit b_rel_int
- in
- ASSERT(b_rel_int /= 0)
- if node_points then
- absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
- else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
where
-- We must tell the arg-satis macro whether Node is pointing to
-- the closure or not. If it isn't so pointing, then we give to
%************************************************************************
\begin{code}
-thunkWrapper:: ClosureInfo -> Code -> Code
-thunkWrapper closure_info thunk_code
+thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
+thunkWrapper closure_info label thunk_code
= -- Stack and heap overflow checks
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+ nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
let
emit_gran_macros = opt_GranMacros
else yield [] node_points
else absC AbsCNop) `thenC`
- stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
-
- -- heapCheck must be after stackCheck: if stchk fails
- -- new stack space is allocated from the heap which
- -- would violate any previous heapCheck
-
- heapCheck [] node_points ( -- heapCheck *encloses* the rest
- -- The "[]" says there are no live argument registers
+ -- stack and/or heap checks
+ thunkChecks label node_points (
-- Overwrite with black hole if necessary
- blackHoleIt closure_info `thenC`
+ blackHoleIt closure_info node_points `thenC`
setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-- Finally, do the business
thunk_code
- )))
+ ))
funWrapper :: ClosureInfo -- Closure whose code body this is
-> [MagicId] -- List of argument registers (if any)
+ -> [(VirtualSpOffset,Int)] -- tagged stack slots
+ -> CLabel -- slow entry point for heap check ret.
-> Code -- Body of function being compiled
-> Code
-funWrapper closure_info arg_regs fun_body
+funWrapper closure_info arg_regs stk_tags slow_label fun_body
= -- Stack overflow check
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
let
then yield arg_regs node_points
else absC AbsCNop) `thenC`
- stackCheck closure_info arg_regs node_points (
- -- stackCheck *encloses* the rest
-
- heapCheck arg_regs node_points (
- -- heapCheck *encloses* the rest
+ -- heap and/or stack checks
+ fastEntryChecks arg_regs stk_tags slow_label node_points (
-- Finally, do the business
fun_body
- ))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
-%* *
-%************************************************************************
-
-Assumption: virtual and real stack pointers are currently exactly aligned.
-
-\begin{code}
-stackCheck :: ClosureInfo
- -> [MagicId] -- Live registers
- -> Bool -- Node required to point after check?
- -> Code
- -> Code
-
-stackCheck closure_info regs node_reqd code
- = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
-
- getVirtSps `thenFC` \ (vSpA, vSpB) ->
-
- let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
- b_headroom_reqd = bHw - vSpB
- in
-
- absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
- AbsCNop
- else
- CMacroStmt STK_CHK [mkIntCLit liveness_mask,
- mkIntCLit a_headroom_reqd,
- mkIntCLit b_headroom_reqd,
- mkIntCLit vSpA,
- mkIntCLit vSpB,
- mkIntCLit (if returns_prim_type then 1 else 0),
- mkIntCLit (if node_reqd then 1 else 0)]
- )
- -- The test is *inside* the absC, to avoid black holes!
-
- `thenC` code
)
- where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsMask all_regs
-
- returns_prim_type = closureReturnsUnpointedType closure_info
\end{code}
+
%************************************************************************
%* *
\subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
\begin{code}
-blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
-blackHoleIt closure_info
- = noBlackHolingFlag `thenFC` \ no_black_holing ->
-
- if (blackHoleOnEntry no_black_holing closure_info)
+blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for thunks
+blackHoleIt closure_info node_points
+ = if blackHoleOnEntry closure_info && node_points
then
absC (if closureSingleEntry(closure_info) then
CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
else
CMacroStmt UPD_BH_UPDATABLE [CReg node])
- -- Node always points to it; see stg-details
else
nopC
\end{code}
setupUpdate closure_info code
= if (closureUpdReqd closure_info) then
link_caf_if_needed `thenFC` \ update_closure ->
- pushUpdateFrame update_closure vector code
+ pushUpdateFrame update_closure code
else
- profCtrC SLIT("UPDF_OMITTED") [] `thenC`
+ profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
code
where
link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
-- Alloc black hole specifying CC_HDR(Node) as the cost centre
-- Hack Warning: Using a CLitLit to get CAddrMode !
let
- use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
+ use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
blame_cc = use_cc
in
allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
absC (CMacroStmt UPD_CAF [CReg node, amode])
`thenC`
returnFC amode
-
- vector
- = case (closureType closure_info) of
- Nothing -> CReg StdUpdRetVecReg
- Just (spec_tycon, _, spec_datacons) ->
- case (ctrlReturnConvAlg spec_tycon) of
- UnvectoredReturn 1 ->
- let
- spec_data_con = head spec_datacons
- only_tag = dataConTag spec_data_con
-
- direct = case (dataReturnConvAlg spec_data_con) of
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
- ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
-
- vectored = mkStdUpdVecTblLabel spec_tycon
- in
- CUnVecLbl direct vectored
-
- UnvectoredReturn _ -> CReg StdUpdRetVecReg
- VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
\end{code}
%************************************************************************
\begin{code}
closureDescription :: FAST_STRING -- Module
- -> Id -- Id of closure binding
- -> [Id] -- Args
- -> StgExpr -- Body
+ -> Name -- Id of closure binding
-> String
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
-closureDescription mod_name name args body
+closureDescription mod_name name
= showSDoc (
hcat [char '<',
ptext mod_name,
\end{code}
\begin{code}
-chooseDynCostCentres cc args fvs body
+chooseDynCostCentres ccs args fvs body
= let
use_cc -- cost-centre we record in the object
- = if currentOrSubsumedCosts cc
+ = if currentOrSubsumedCCS ccs
then CReg CurCostCentre
- else mkCCostCentre cc
+ else mkCCostCentreStack ccs
blame_cc -- cost-centre on whom we blame the allocation
= case (args, fvs, body) of
- ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
+ ([], [just1], StgApp fun [{-no args-}])
| just1 == fun
- -> mkCCostCentre overheadCostCentre
+ -> mkCCostCentreStack overheadCCS
_ -> use_cc
-- if it's an utterly trivial RHS, then it must be
-- one introduced by boxHigherOrderArgs for profiling,
-- so we charge it to "OVERHEAD".
+
+ -- This looks like a HACK to me --SDM
in
(use_cc, blame_cc)
\end{code}
%
-% (c) The GRASP Project, Glasgow University, 1992-1996
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[CgCon]{Code generation for constructors}
\begin{code}
module CgCon (
cgTopRhsCon, buildDynCon,
- bindConArgs,
+ bindConArgs, bindUnboxedTupleComponents,
cgReturnDataCon
) where
import AbsCSyn
import StgSyn
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import AbsCUtils ( getAmodeRep )
import CgBindery ( getArgAmodes, bindNewToNode,
bindArgsToRegs, newTempAmodeAndIdInfo,
idInfoToAmode, stableAmodeIdInfo,
- heapIdInfo, CgIdInfo
+ heapIdInfo, CgIdInfo, bindNewToStack
)
+import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots )
+import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp )
import CgClosure ( cgTopRhsClosure )
+import CgRetConv ( assignRegs )
import Constants ( mAX_INTLIKE, mIN_INTLIKE )
import CgHeapery ( allocDynClosure )
-import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
-import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CLabel ( mkClosureLabel, mkStaticClosureLabel,
- mkConInfoTableLabel, mkPhantomInfoTableLabel
- )
+import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall,
+ mkUnboxedTupleReturnCode )
+import CLabel ( mkClosureLabel, mkStaticClosureLabel )
import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
layOutStaticClosure
)
-import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre,
- dontCareCostCentre, CostCentre
- )
-import Id ( idPrimRep, dataConTag, dataConTyCon,
- isDataCon, DataCon,
- emptyIdSet, Id
- )
-import Literal ( Literal(..) )
-import Maybes ( maybeToBool )
+import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
+ currentCCS )
+import DataCon ( DataCon, dataConName, dataConTag, dataConTyCon,
+ isUnboxedTupleCon )
+import MkId ( mkDataConId )
+import Id ( Id, idName, idType, idPrimRep )
+import Const ( Con(..), Literal(..) )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import TyCon ( TyCon{-instance Uniquable-} )
-import Util ( isIn, zipWithEqual, panic, assertPanic )
+import PrimRep ( PrimRep(..) )
+import BasicTypes ( TopLevelFlag(..) )
+import Util
\end{code}
%************************************************************************
-> FCode (Id, CgIdInfo)
\end{code}
-Special Case:
-Constructors some of whose arguments are of \tr{Float#} or
-\tr{Double#} type, {\em or} which are ``lit lits'' (which are given
-\tr{Addr#} type).
+Special Case: Constructors some of whose arguments are of \tr{Double#}
+type, {\em or} which are ``lit lits'' (which are given \tr{Addr#}
+type).
-These ones have to be compiled as re-entrant thunks rather than closures,
-because we can't figure out a way to persuade C to allow us to initialise a
-static closure with Floats and Doubles!
-Thus, for \tr{x = 2.0} (defaults to Double), we get:
+These ones have to be compiled as re-entrant thunks rather than
+closures, because we can't figure out a way to persuade C to allow us
+to initialise a static closure with Doubles! Thus, for \tr{x = 2.0}
+(defaults to Double), we get:
\begin{verbatim}
-- The STG syntax:
Here, then is the implementation: just pretend it's a non-updatable
thunk. That is, instead of
- x = F# 3.455#
+ x = D# 3.455#
pretend we've seen
- x = [] \n [] -> F# 3.455#
+ x = [] \n [] -> D# 3.455#
\begin{code}
-top_cc = dontCareCostCentre -- out here to avoid a cgTopRhsCon CAF (sigh)
-top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data
+top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
-cgTopRhsCon name con args all_zero_size_args
- | any (isFloatingRep . getArgPrimRep) args
- || any isLitLitArg args
- = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
+cgTopRhsCon bndr con args all_zero_size_args
+ | any isLitLitArg args
+ = cgTopRhsClosure bndr dontCareCCS NoStgBinderInfo NoSRT [] body lf_info
where
- body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
- lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant []
+ body = StgCon (DataCon con) args rhs_ty
+ lf_info = mkClosureLFInfo bndr TopLevel [] ReEntrant []
+ rhs_ty = idType bndr
\end{code}
OK, so now we have the general case.
\begin{code}
-cgTopRhsCon name con args all_zero_size_args
+cgTopRhsCon id con args all_zero_size_args
= (
- ASSERT(isDataCon con)
-
-- LAY IT OUT
getArgAmodes args `thenFC` \ amodes ->
(closure_info, amodes_w_offsets)
= layOutStaticClosure name getAmodeRep amodes lf_info
in
- -- HWL: In 0.22 there was a heap check in here that had to be changed.
- -- CHECK if having no heap check is ok for GrAnSim here!!!
-- BUILD THE OBJECT
absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info -- Closure is static
+ closure_label -- Labelled with the name on lhs of defn
+ closure_info -- Closure is static
top_ccc
- (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
+ (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
) `thenC`
-- RETURN
- returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
+ returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
where
con_tycon = dataConTyCon con
lf_info = mkConLFInfo con
closure_label = mkClosureLabel name
+ name = idName id
\end{code}
-The general case is:
-\begin{verbatim}
--- code:
- data Foo = MkFoo
- x = MkFoo
-
--- STG code:
-STG syntax:
- Main.x = Main.MkFoo []
-
--- interesting parts of the C Code:
-
--- closure for "x":
- SET_STATIC_HDR(Main_x_closure,Main_MkFoo_static,CC_DATA,,EXTDATA_RO)
- };
--- entry code for "x":
- STGFUN(Main_x_entry) {
- Node=(W_)(Main_x_closure);
- STGJUMP(Main_MkFoo_entry);
- }
-\end{verbatim}
-
-Observe: (1)~We create a static closure for \tr{x}, {\em reusing} the
-regular \tr{MkFoo} info-table and entry code. (2)~However: the
-\tr{MkFoo} code expects Node to be set, but the caller of \tr{x_entry}
-will not have set it. Therefore, the whole point of \tr{x_entry} is
-to set node (and then call the shared \tr{MkFoo} entry code).
-
-Special Case:
-For top-level Int/Char constants. We get entry-code fragments of the form:
-
-\begin{verbatim}
--- code:
- y = 1
-
--- entry code for "y":
- STGFUN(Main_y_entry) {
- Node=(W_)(Main_y_closure);
- STGJUMP(I#_entry);
- }
-\end{verbatim}
-
-This is pretty tiresome: we {\em know} what the constant is---we'd
-rather just return it. We end up with something that's a hybrid
-between the Float/Double and general cases: (a)~like Floats/Doubles,
-the entry-code returns the value immediately; (b)~like the general
-case, we share the data-constructor's std info table. So, what we
-want is:
-\begin{verbatim}
--- code:
- z = 1
-
--- STG code:
-STG syntax:
- Main.z = I# [1#]
-
--- interesting parts of the C Code:
-
--- closure for "z" (shares I# info table):
- SET_STATIC_HDR(Main_z_closure,I#_static,CC_DATA,,EXTDATA_RO)
- };
--- entry code for "z" (do the business directly):
- STGFUN(Main_z_entry) {
- P_ u1702;
- Ret1=1;
- u1702=(P_)*SpB;
- SpB=SpB-1;
- JMP_(u1702[0]);
- }
-\end{verbatim}
-
-This blob used to be in cgTopRhsCon, but I don't see how we can jump
-direct to the named code for a constructor; any external entries will
-be via Node. Generating all this extra code is a real waste for big
-static data structures. So I've nuked it. SLPJ Sept 94
-
%************************************************************************
%* *
%* non-top-level constructors *
\begin{code}
buildDynCon :: Id -- Name of the thing to which this constr will
-- be bound
- -> CostCentre -- Where to grab cost centre from;
- -- current CC if currentOrSubsumedCosts
+ -> CostCentreStack -- Where to grab cost centre from;
+ -- current CCS if currentOrSubsumedCCS
-> DataCon -- The data constructor
-> [CAddrMode] -- Its args
-> Bool -- True <=> all args (if any) are
\begin{code}
buildDynCon binder cc con args all_zero_size_args@True
- = ASSERT(isDataCon con)
- returnFC (stableAmodeIdInfo binder
- (CLbl (mkStaticClosureLabel con) PtrRep)
+ = returnFC (stableAmodeIdInfo binder
+ (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep)
(mkConLFInfo con))
\end{code}
buildDynCon binder cc con [arg_amode] all_zero_size_args@False
| maybeCharLikeCon con
- = ASSERT(isDataCon con)
- absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
+ = absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
returnFC temp_id_info
| maybeIntLikeCon con && in_range_int_lit arg_amode
- = ASSERT(isDataCon con)
- returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
+ = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
where
(temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
- in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE &&
- val >= mIN_INTLIKE
+ in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
in_range_int_lit other_amode = False
+
+ tycon = dataConTyCon con
\end{code}
Now the general case.
\begin{code}
-buildDynCon binder cc con args all_zero_size_args@False
- = ASSERT(isDataCon con)
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
- returnFC (heapIdInfo binder hp_off (mkConLFInfo con))
+buildDynCon binder ccs con args all_zero_size_args@False
+ = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
+ returnFC (heapIdInfo binder hp_off lf_info)
where
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeRep args (mkConLFInfo con)
+ = layOutDynClosure (idName binder) getAmodeRep args lf_info
+ lf_info = mkConLFInfo con
use_cc -- cost-centre to stick in the object
- = if currentOrSubsumedCosts cc
+ = if currentOrSubsumedCCS ccs
then CReg CurCostCentre
- else mkCCostCentre cc
+ else mkCCostCentreStack ccs
blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
\end{code}
found a $con$.
\begin{code}
-bindConArgs :: DataCon -> [Id] -> Code
+bindConArgs
+ :: DataCon -> [Id] -- Constructor and args
+ -> Code
+
bindConArgs con args
- = ASSERT(isDataCon con)
- case (dataReturnConvAlg con) of
- ReturnInRegs rs -> bindArgsToRegs args rs
- ReturnInHeap ->
- let
- (_, args_w_offsets) = layOutDynCon con idPrimRep args
- in
- mapCs bind_arg args_w_offsets
+ = ASSERT(not (isUnboxedTupleCon con))
+ mapCs bind_arg args_w_offsets
where
bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
+ (_, args_w_offsets) = layOutDynCon con idPrimRep args
\end{code}
+Unboxed tuples are handled slightly differently - the object is
+returned in registers and on the stack instead of the heap.
+
+\begin{code}
+bindUnboxedTupleComponents
+ :: [Id] -- args
+ -> FCode ([MagicId], -- regs assigned
+ [(VirtualSpOffset,Int)], -- tag slots
+ Bool) -- any components on stack?
+
+bindUnboxedTupleComponents args
+ = -- Assign as many components as possible to registers
+ let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args)
+ (reg_args, stk_args) = splitAt (length arg_regs) args
+ in
+
+ -- Allocate the rest on the stack (ToDo: separate out pointers)
+ getVirtSp `thenFC` \ vsp ->
+ getRealSp `thenFC` \ rsp ->
+ let (top_sp, stk_offsets, tags) =
+ mkTaggedVirtStkOffsets rsp idPrimRep stk_args
+ in
+
+ -- The stack pointer points to the last stack-allocated component
+ setRealAndVirtualSp top_sp `thenC`
+
+ -- need to explicitly free any empty slots we just jumped over
+ (if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
+
+ bindArgsToRegs reg_args arg_regs `thenC`
+ mapCs bindNewToStack stk_offsets `thenC`
+ returnFC (arg_regs,tags, not (null stk_offsets))
+\end{code}
%************************************************************************
%* *
Note: it's the responsibility of the @cgReturnDataCon@ caller to be
sure the @amodes@ passed don't conflict with each other.
\begin{code}
-cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> Code
-cgReturnDataCon con amodes all_zero_size_args live_vars
- = ASSERT(isDataCon con)
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+cgReturnDataCon con amodes all_zero_size_args
+ = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
case sequel of
-- then we should simply jump to the default join point;
--
-- if the default is a bind-default (ie does use y), we
- -- should return the constructor IN THE HEAP, pointed to by Node,
- -- **regardless** of the return convention of the constructor C.
+ -- should return the constructor in the heap,
+ -- pointed to by Node.
case maybe_deflt_binder of
Just binder ->
- buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args
+ ASSERT(not (isUnboxedTupleCon con))
+ buildDynCon binder currentCCS con amodes all_zero_size_args
`thenFC` \ idinfo ->
idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
- performReturn (move_to_reg amode node) jump_to_join_point live_vars
+ performReturn (move_to_reg amode node) jump_to_join_point
Nothing ->
- performReturn AbsCNop {- No reg assts -} jump_to_join_point live_vars
+ performReturn AbsCNop {- No reg assts -} jump_to_join_point
where
is_elem = isIn "cgReturnDataCon"
jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
-- Ignore the sequel: we've already looked at it above
- other_sequel -> -- The usual case
- case (dataReturnConvAlg con) of
+ other_sequel -- The usual case
- ReturnInHeap ->
+ | isUnboxedTupleCon con ->
+ -- Return unboxed tuple in registers
+ let (ret_regs, leftovers) =
+ assignRegs [] (map getAmodeRep amodes)
+ in
+ doTailCall amodes ret_regs
+ mkUnboxedTupleReturnCode
+ (length leftovers) {- fast args arity -}
+ AbsCNop {-no pending assigments-}
+ Nothing {-not a let-no-escape-}
+ False {-node doesn't point-}
+
+ | otherwise ->
-- BUILD THE OBJECT IN THE HEAP
-- The first "con" says that the name bound to this
-- closure is "con", which is a bit of a fudge, but it only
- -- affects profiling (ToDo?)
- buildDynCon con useCurrentCostCentre con amodes all_zero_size_args
+ -- affects profiling
+
+ -- This Id is also used to get a unique for a
+ -- temporary variable, if the closure is a CHARLIKE.
+ -- funilly enough, this makes the unique always come
+ -- out as '54' :-)
+ buildDynCon (mkDataConId con) currentCCS
+ con amodes all_zero_size_args
`thenFC` \ idinfo ->
idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
- -- MAKE NODE POINT TO IT
- let reg_assts = move_to_reg amode node
- info_lbl = mkConInfoTableLabel con
- in
-- RETURN
- profCtrC SLIT("RET_NEW_IN_HEAP") [mkIntCLit (length amodes)] `thenC`
-
- performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
+ profCtrC SLIT("TICK_RET_CON") [mkIntCLit (length amodes)] `thenC`
+ -- could use doTailCall here.
+ performReturn (move_to_reg amode node)
+ (mkStaticAlgReturnCode con)
- ReturnInRegs regs ->
- let
- reg_assts = mkAbstractCs (zipWithEqual "move_to_reg" move_to_reg amodes regs)
- info_lbl = mkPhantomInfoTableLabel con
- in
- profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
-
- performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
where
+ con_name = dataConName con
+
move_to_reg :: CAddrMode -> MagicId -> AbstractC
move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CgConTbls]{Info tables and update bits for constructors}
import AbsCSyn
import CgMonad
-import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
-import Constants ( uF_UPDATEE )
-import CgHeapery ( heapCheck, allocDynClosure )
-import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
- CtrlReturnConvention(..),
- DataReturnConvention(..)
- )
+import StgSyn ( SRT(..) )
+import AbsCUtils ( mkAbstractCs )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabel ( mkConEntryLabel, mkStaticClosureLabel,
- mkConUpdCodePtrVecLabel,
- mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel
- )
+import CLabel ( mkConEntryLabel, mkStaticClosureLabel )
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
- layOutPhantomClosure, closurePtrsSize,
- fitsMinUpdSize, mkConLFInfo,
- infoTableLabelFromCI, dataConLiveness,
- ClosureInfo
+ mkConLFInfo, ClosureInfo
)
-import CostCentre ( dontCareCostCentre, CostCentre )
+import CostCentre ( dontCareCCS )
import FiniteMap ( fmToList, FiniteMap )
-import HeapOffs ( zeroOff, VirtualHeapOffset )
-import Id ( dataConTag, dataConRawArgTys,
- dataConNumFields, fIRST_TAG,
- emptyIdSet,
- GenId{-instance NamedThing-}, Id
- )
+import DataCon ( DataCon, dataConTag, dataConName, dataConRawArgTys )
+import Const ( Con(..) )
import Name ( getOccString )
import PrimRep ( getPrimRepSize, PrimRep(..) )
-import TyCon ( tyConDataCons, mkSpecTyCon, TyCon )
+import TyCon ( tyConDataCons, TyCon )
import Type ( typePrimRep, Type )
-import Util ( panic )
-
-mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)"
+import BasicTypes ( TopLevelFlag(..) )
+import Outputable
\end{code}
For every constructor we generate the following info tables:
A static info table, for static instances of the constructor,
- For constructors which return in registers (and only them),
- an "inregs" info table. This info table is rather emaciated;
- it only contains update code and tag.
-
Plus:
\begin{tabular}{lll}
Possible info tables for constructor con:
\begin{description}
-\item[@con_info@:]
+\item[@_con_info@:]
Used for dynamically let(rec)-bound occurrences of
the constructor, and for updates. For constructors
which are int-like, char-like or nullary, when GC occurs,
the closure tries to get rid of itself.
-\item[@con_inregs_info@:]
-Used when returning a new constructor in registers.
-Only for return-in-regs constructors.
-Macro: @INREGS_INFO_TABLE@.
-
-\item[@con_static_info@:]
+\item[@_static_info@:]
Static occurrences of the constructor
macro: @STATIC_INFO_TABLE@.
\end{description}
For zero-arity constructors, \tr{con}, we also generate a static closure:
\begin{description}
-\item[@con_closure@:]
+\item[@_closure@:]
A single static copy of the (zero-arity) constructor itself.
\end{description}
-> AbstractC -- output
genStaticConBits comp_info gen_tycons tycon_specs
- = -- for each type constructor:
+ = ASSERT( null (fmToList tycon_specs) )
+ -- We don't do specialised type constructors any more
+
+ -- for each type constructor:
-- grab all its data constructors;
-- for each one, generate an info table
-- for each specialised type constructor
-- since they may be duplicated in other modules
mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
- `mkAbsCStmts`
- mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
- | (imported_spec, spec) <- specs,
- -- no code generated if spec is imported
- not imported_spec
- ]
- | (tc, specs) <- fmToList tycon_specs ]
where
gen_for_tycon :: TyCon -> AbstractC
gen_for_tycon tycon
- = mkAbstractCs (map (genConInfo comp_info tycon) data_cons)
- `mkAbsCStmts`
- maybe_tycon_vtbl
- where
- data_cons = tyConDataCons tycon
- tycon_upd_label = mkStdUpdVecTblLabel tycon
-
- maybe_tycon_vtbl =
- case ctrlReturnConvAlg tycon of
- UnvectoredReturn 1 -> CRetUnVector tycon_upd_label
- (mk_upd_label tycon (head data_cons))
- UnvectoredReturn _ -> AbsCNop
- VectoredReturn _ -> CFlatRetVector tycon_upd_label
- (map (mk_upd_label tycon) data_cons)
- ------------------
- gen_for_spec_tycon :: TyCon -> [Maybe Type] -> AbstractC
-
- gen_for_spec_tycon tycon ty_maybes
- = mkAbstractCs (map (genConInfo comp_info spec_tycon) spec_data_cons)
- `mkAbsCStmts`
- maybe_spec_tycon_vtbl
- where
- data_cons = tyConDataCons tycon
-
- spec_tycon = mkSpecTyCon tycon ty_maybes
- spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons
-
- spec_tycon_upd_label = mkStdUpdVecTblLabel spec_tycon
-
- maybe_spec_tycon_vtbl =
- case ctrlReturnConvAlg spec_tycon of
- UnvectoredReturn 1 -> CRetUnVector spec_tycon_upd_label
- (mk_upd_label spec_tycon (head spec_data_cons))
- UnvectoredReturn _ -> AbsCNop
- VectoredReturn _ -> CFlatRetVector spec_tycon_upd_label
- (map (mk_upd_label spec_tycon) spec_data_cons)
- ------------------
- mk_upd_label tycon con
- = CLbl
- (case (dataReturnConvAlg con) of
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
- ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag)
- CodePtrRep
- where
- tag = dataConTag con
+ = mkAbstractCs (map (genConInfo comp_info tycon) (tyConDataCons tycon))
\end{code}
%************************************************************************
static closure, for a constructor.
\begin{code}
-genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC
+genConInfo :: CompilationInfo -> TyCon -> DataCon -> AbstractC
genConInfo comp_info tycon data_con
= mkAbstractCs [
CSplitMarker,
- inregs_upd_maybe,
closure_code,
static_code,
closure_maybe]
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
-- info-table contains the information we need.
- (static_ci,_) = layOutStaticClosure data_con typePrimRep arg_tys (mkConLFInfo data_con)
+ (static_ci,_) = layOutStaticClosure con_name typePrimRep arg_tys
+ (mkConLFInfo data_con)
body = (initC comp_info (
- profCtrC SLIT("ENT_CON") [CReg node] `thenC`
+ profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
body_code))
entry_addr = CLbl entry_label CodePtrRep
con_descr = getOccString data_con
- closure_code = CClosureInfoAndCode closure_info body Nothing
- stdUpd con_descr
- (dataConLiveness closure_info)
- static_code = CClosureInfoAndCode static_ci body Nothing
- stdUpd con_descr
- (dataConLiveness static_ci)
+ -- Don't need any dynamic closure code for zero-arity constructors
+ closure_code = if zero_arity_con then
+ AbsCNop
+ else
+ CClosureInfoAndCode closure_info body Nothing
+ srt_info con_descr
- inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con
+ srt_info = (error "genConInfo: no srt label", NoSRT)
- stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep
+ static_code = CClosureInfoAndCode static_ci body Nothing
+ srt_info con_descr
- tag = dataConTag data_con
+ tag = dataConTag data_con
- cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
+ cost_centre = mkCCostCentreStack dontCareCCS -- not worried about static data costs
-- For zero-arity data constructors, or, more accurately,
-- those which only have VoidRep args (or none):
-- We make the closure too (not just info tbl), so that we can share
-- one copy throughout.
- closure_maybe = if not (all zero_size arg_tys) then
+ closure_maybe = if not zero_arity_con then
AbsCNop
else
CStaticClosure closure_label -- Label for closure
static_ci -- Info table
cost_centre
- [{-No args! A slight lie for constrs with VoidRep args-}]
+ [{-No args! A slight lie for constrs
+ with VoidRep args-}]
zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0
+ zero_arity_con = all zero_size arg_tys
+
arg_tys = dataConRawArgTys data_con
- entry_label = mkConEntryLabel data_con
- closure_label = mkStaticClosureLabel data_con
+ entry_label = mkConEntryLabel con_name
+ closure_label = mkStaticClosureLabel con_name
+ con_name = dataConName data_con
\end{code}
-The entry code for a constructor now loads the info ptr by indirecting
-node. The alternative is to load the info ptr in the enter-via-node
-sequence. There's is a trade-off here:
-
- * If the architecture can perform an indirect jump through a
- register in one instruction, or if the info ptr is not a
- real register, then *not* loading the info ptr on an enter
- is a win.
-
- * If the enter-via-node code is identical whether we load the
- info ptr or not, then doing it is a win (it means we don't
- have to do it here).
-
-However, the gratuitous load here is miniscule compared to the
-gratuitous loads of the info ptr on each enter, so we go for the first
-option.
-
--- Simon M. (6/5/96)
-
\begin{code}
-mkConCodeAndInfo :: Id -- Data constructor
+mkConCodeAndInfo :: DataCon -- Data constructor
-> (ClosureInfo, Code) -- The info table
mkConCodeAndInfo con
- = case (dataReturnConvAlg con) of
+ = let
+ arg_tys = dataConRawArgTys con
- ReturnInRegs regs ->
- let
- (closure_info, regs_w_offsets)
- = layOutDynCon con magicIdPrimRep regs
-
- body_code
- = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
-
- performReturn (mkAbstractCs (load_infoptr : map move_to_reg regs_w_offsets))
- (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyIdSet{-no live vars-}
- in
- (closure_info, body_code)
-
- ReturnInHeap ->
- let
- arg_tys = dataConRawArgTys con
-
- (closure_info, arg_things)
+ (closure_info, arg_things)
= layOutDynCon con typePrimRep arg_tys
- body_code
+ body_code
= -- NB: We don't set CC when entering data (WDP 94/06)
- profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
+ profCtrC SLIT("TICK_RET_OLD")
+ [mkIntCLit (length arg_things)] `thenC`
- performReturn (mkAbstractCs [load_infoptr]) -- Ptr to thing already in Node
- (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyIdSet{-no live vars-}
+ performReturn AbsCNop -- Ptr to thing already in Node
+ (mkStaticAlgReturnCode con)
in
(closure_info, body_code)
-
- where
- move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
- move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
-
- load_infoptr
- = CAssign (CReg infoptr) (CMacroExpr DataPtrRep INFO_PTR [CReg node])
\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgConTbls-updates]{Generating update bits for constructors}
-%* *
-%************************************************************************
-
-Generate the "phantom" info table and update code, iff the constructor returns in regs
-
-\begin{code}
-
-genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
-
-genPhantomUpdInfo comp_info tycon data_con
- = case (dataReturnConvAlg data_con) of
-
- ReturnInHeap -> AbsCNop -- No need for a phantom update
-
- ReturnInRegs regs ->
- let
- phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
- upd_code con_descr
- (dataConLiveness phantom_ci)
-
- phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
-
- con_descr = getOccString data_con
-
- con_arity = dataConNumFields data_con
-
- upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
- upd_label = mkConUpdCodePtrVecLabel tycon tag
- tag = dataConTag data_con
-
- updatee = CVal (SpBRel 0 (- uF_UPDATEE)) PtrRep
-
- perform_return = mkAbstractCs
- [
- CMacroStmt POP_STD_UPD_FRAME [],
- CReturn (CReg RetReg) return_info
- ]
-
- return_info =
- case (ctrlReturnConvAlg tycon) of
- UnvectoredReturn _ -> DirectReturn
- VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
-
- -- Determine cost centre for the updated closures CC (and allocation)
- -- CCC for lexical (now your only choice)
- use_cc = CReg CurCostCentre -- what to put in the closure
- blame_cc = use_cc -- who to blame for allocation
-
- do_move (reg, virt_offset) =
- CAssign (CVal (NodeRel virt_offset) (magicIdPrimRep reg)) (CReg reg)
-
-
- -- Code for building a new constructor in place over the updatee
- overwrite_code
- = profCtrC SLIT("UPD_CON_IN_PLACE")
- [mkIntCLit (length regs_w_offsets)] `thenC`
- absC (mkAbstractCs
- [
- CAssign (CReg node) updatee,
-
- -- Tell the storage mgr that we intend to update in place
- -- This may (in complicated mgrs eg generational) cause gc,
- -- and it may modify Node to point to another place to
- -- actually update into.
- CMacroStmt upd_inplace_macro [liveness_mask],
-
- -- Initialise the closure pointed to by node
- CInitHdr closure_info (NodeRel zeroOff) use_cc True,
- mkAbstractCs (map do_move regs_w_offsets),
- if con_arity /= 0 then
- CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
- else
- AbsCNop
- ])
-
- upd_inplace_macro = if closurePtrsSize closure_info == 0
- then UPD_INPLACE_NOPTRS
- else UPD_INPLACE_PTRS
-
- -- Code for allocating a new constructor in the heap
- alloc_code
- = let
- amodes_w_offsets = [ (CReg r, o) | (r,o) <- regs_w_offsets ]
- in
- -- Allocate and build closure specifying upd_new_w_regs
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- `thenFC` \ hp_offset ->
- getHpRelOffset hp_offset `thenFC` \ hp_rel ->
- let
- amode = CAddr hp_rel
- in
- profCtrC SLIT("UPD_CON_IN_NEW")
- [mkIntCLit (length amodes_w_offsets)] `thenC`
- absC (mkAbstractCs
- [ CMacroStmt UPD_IND [updatee, amode],
- CAssign (CReg node) amode,
- CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
- ])
-
- (closure_info, regs_w_offsets) = layOutDynCon data_con magicIdPrimRep regs
- info_label = infoTableLabelFromCI closure_info
- liveness_mask = mkIntCLit (mkLiveRegsMask (node:regs))
-
- build_closure =
- if fitsMinUpdSize closure_info then
- initC comp_info overwrite_code
- else
- initC comp_info (heapCheck regs False alloc_code)
-
- in CClosureUpdInfo phantom_itbl
-
-\end{code}
-
_interface_ CgExpr 1
_exports_
-CgExpr cgExpr getPrimOpArgAmodes;
+CgExpr cgExpr;
_declarations_
1 cgExpr _:_ StgSyn.StgExpr -> CgMonad.Code ;;
-1 getPrimOpArgAmodes _:_ PrimOp.PrimOp -> [StgSyn.StgArg] -> CgMonad.FCode [AbsCSyn.CAddrMode] ;;
--- /dev/null
+__interface CgExpr 1 0 where
+__export CgExpr cgExpr;
+1 cgExpr :: StgSyn.StgExpr -> CgMonad.Code ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgExpr.lhs,v 1.15 1998/12/02 13:17:49 simonm Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgExpr ( cgExpr, getPrimOpArgAmodes ) where
+module CgExpr ( cgExpr ) where
#include "HsVersions.h"
-import Constants ( mAX_SPEC_SELECTEE_SIZE )
+import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
import StgSyn
import CgMonad
import AbsCSyn
-
-import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
-import CgBindery ( getArgAmodes, getCAddrModeAndInfo, CgIdInfo )
-import CgCase ( cgCase, saveVolatileVarsAndRegs )
-import CgClosure ( cgRhsClosure )
+import CLabel ( mkClosureTblLabel )
+
+import SMRep ( fixedHdrSize )
+import CgBindery ( getArgAmodes, CgIdInfo, nukeDeadBindings )
+import CgCase ( cgCase, saveVolatileVarsAndRegs,
+ restoreCurrentCostCentre,
+ splitAlgTyConAppThroughNewTypes )
+import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
-import CgHeapery ( allocHeap )
import CgLetNoEscape ( cgLetNoEscapeClosure )
-import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
- DataReturnConvention(..), CtrlReturnConvention(..),
- assignPrimOpResultRegs, makePrimOpArgsRobust
+import CgRetConv ( dataReturnConvPrim )
+import CgTailCall ( cgTailCall, performReturn, performPrimReturn,
+ mkDynamicAlgReturnCode, mkPrimReturnCode,
+ tailCallPrimOp, returnUnboxedTuple
)
-import CgTailCall ( cgTailCall, performReturn,
- mkDynamicAlgReturnCode, mkPrimReturnCode
- )
-import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo,
- layOutDynCon )
+import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
+ mkApLFInfo, layOutDynCon )
import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
-import HeapOffs ( VirtualSpBOffset, intOffsetIntoGoods )
-import Id ( dataConTyCon, idPrimRep, getIdArity,
- mkIdSet, unionIdSets, GenId{-instance Outputable-},
- Id
- )
+import Id ( idPrimRep, idType, Id )
+import VarSet
+import DataCon ( DataCon, dataConTyCon )
+import Const ( Con(..) )
import IdInfo ( ArityInfo(..) )
-import Name ( isLocallyDefined )
-import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
+import PrimOp ( primOpOutOfLine,
getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
)
-import PrimRep ( getPrimRepSize, PrimRep(..) )
-import TyCon ( tyConDataCons, maybeTyConSingleCon )
+import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
+import TyCon ( maybeTyConSingleCon,
+ isUnboxedTupleTyCon, isEnumerationTyCon )
+import Type ( Type, typePrimRep )
import Maybes ( assocMaybe, maybeToBool )
-import Util ( isIn )
+import Unique ( mkBuiltinUnique )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import Outputable
\end{code}
@(STGApp (StgLitArg 42) [])@.
\begin{code}
-cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
+cgExpr (StgApp fun args) = cgTailCall fun args
\end{code}
%********************************************************
%********************************************************
\begin{code}
-cgExpr (StgCon con args live_vars)
+cgExpr (StgCon (DataCon con) args res_ty)
= getArgAmodes args `thenFC` \ amodes ->
- cgReturnDataCon con amodes (all zero_size args) live_vars
+ cgReturnDataCon con amodes (all zero_size args)
where
zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
\end{code}
+Literals are similar to constructors; they return by putting
+themselves in an appropriate register and returning to the address on
+top of the stack.
+
+\begin{code}
+cgExpr (StgCon (Literal lit) args res_ty)
+ = ASSERT( null args )
+ performPrimReturn (CLit lit)
+\end{code}
+
+
%********************************************************
%* *
%* STG PrimApps (unboxed primitive ops) *
Here is where we insert real live machine instructions.
+NOTE about _ccall_GC_:
+
+A _ccall_GC_ is treated as an out-of-line primop for the case
+expression code, because we want a proper stack frame on the stack
+when we perform it. When we get here, however, we need to actually
+perform the call, so we treat it an an inline primop.
+
\begin{code}
-cgExpr x@(StgPrim op args live_vars)
+cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
+ = primRetUnboxedTuple op args res_ty
+
+cgExpr x@(StgCon (PrimOp op) args res_ty)
+ | primOpOutOfLine op = tailCallPrimOp op args
+ | otherwise
= ASSERT(op /= SeqOp) -- can't handle SeqOp
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
- let
- result_regs = assignPrimOpResultRegs op
- result_amodes = map CReg result_regs
- may_gc = primOpCanTriggerGC op
- dyn_tag = head result_amodes
- -- The tag from a primitive op returning an algebraic data type
- -- is returned in the first result_reg_amode
- in
- (if may_gc then
- -- Use registers for args, and assign args to the regs
- -- (Can-trigger-gc primops guarantee to have their args in regs)
- let
- (arg_robust_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust op arg_amodes
-
- liveness_arg = mkIntCLit liveness_mask
- in
- returnFC (
- arg_assts,
- COpStmt result_amodes op
- (pin_liveness op liveness_arg arg_robust_amodes)
- liveness_mask
- [{-no vol_regs-}]
- )
- else
- -- Use args from their current amodes.
- let
- liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
- in
- returnFC (
- COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
- AbsCNop
- )
- ) `thenFC` \ (do_before_stack_cleanup,
- do_just_before_jump) ->
+
+ getArgAmodes args `thenFC` \ arg_amodes ->
case (getPrimOpResultInfo op) of
ReturnsPrim kind ->
- performReturn do_before_stack_cleanup
- (\ sequel -> robustifySequel may_gc sequel
- `thenFC` \ (ret_asst, sequel') ->
- absC (ret_asst `mkAbsCStmts` do_just_before_jump)
- `thenC`
- mkPrimReturnCode sequel')
- live_vars
-
- ReturnsAlg tycon ->
- profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields] `thenC`
-
- performReturn do_before_stack_cleanup
- (\ sequel -> robustifySequel may_gc sequel
- `thenFC` \ (ret_asst, sequel') ->
- absC (mkAbstractCs [ret_asst,
- do_just_before_jump,
- info_ptr_assign])
- -- Must load info ptr here, not in do_just_before_stack_cleanup,
- -- because the info-ptr reg clashes with argument registers
- -- for the primop
- `thenC`
- mkDynamicAlgReturnCode tycon dyn_tag sequel')
- live_vars
- where
-
- -- Here, the destination _can_ be an update frame, so we need to make sure that
- -- infoptr (R2) is loaded with the constructor's info ptr.
-
- info_ptr_assign = CAssign (CReg infoptr) info_lbl
-
- info_lbl
- = case (ctrlReturnConvAlg tycon) of
- VectoredReturn _ -> vec_lbl
- UnvectoredReturn _ -> dir_lbl
-
- vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
- dyn_tag DataPtrRep
-
- data_con = head (tyConDataCons tycon)
-
- (dir_lbl, num_of_fields)
- = case (dataReturnConvAlg data_con) of
- ReturnInRegs rs
- -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
- mkIntCLit (length rs)) -- for ticky-ticky only
-
- ReturnInHeap
- -> pprPanic "CgExpr: can't return prim in heap:" (ppr data_con)
- -- Never used, and no point in generating
- -- the code for it!
- where
- -- for all PrimOps except ccalls, we pin the liveness info
- -- on as the first "argument"
- -- ToDo: un-duplicate?
-
- pin_liveness (CCallOp _ _ _ _ _ _) _ args = args
- pin_liveness other_op liveness_arg args
- = liveness_arg :args
-
- -- We only need to worry about the sequel when we may GC and the
- -- sequel is OnStack. If that's the case, arrange to pull the
- -- sequel out into RetReg before performing the primOp.
-
- robustifySequel True sequel@(OnStack _) =
- sequelToAmode sequel `thenFC` \ amode ->
- returnFC (CAssign (CReg RetReg) amode, InRetReg)
- robustifySequel _ sequel = returnFC (AbsCNop, sequel)
+ let result_amode = CReg (dataReturnConvPrim kind) in
+ performReturn
+ (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
+ (\ sequel -> mkPrimReturnCode sequel)
+
+ -- otherwise, must be returning an enumerated type (eg. Bool).
+ -- we've only got the tag in R2, so we have to load the constructor
+ -- itself into R1.
+
+ ReturnsAlg tycon
+ | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
+
+
+ | isEnumerationTyCon tycon ->
+ performReturn
+ (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
+ (\ sequel ->
+ absC (CAssign (CReg node) closure_lbl) `thenC`
+ mkDynamicAlgReturnCode tycon dyn_tag sequel)
+
+ where
+ -- Pull a unique out of thin air to put the tag in.
+ -- It shouldn't matter if this overlaps with anything - we're
+ -- about to return anyway.
+ dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
+
+ closure_lbl = CTableEntry
+ (CLbl (mkClosureTblLabel tycon) PtrRep)
+ dyn_tag PtrRep
+
\end{code}
%********************************************************
module, @CgCase@.
\begin{code}
-cgExpr (StgCase expr live_vars save_vars uniq alts)
- = cgCase expr live_vars save_vars uniq alts
+cgExpr (StgCase expr live_vars save_vars bndr srt alts)
+ = cgCase expr live_vars save_vars bndr srt alts
\end{code}
nukeDeadBindings live_in_whole_let `thenC`
saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
-
- -- ToDo: cost centre???
+ -- ToDo: cost centre???
+ restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
-- Save those variables right now!
absC save_assts `thenC`
%* SCC Expressions *
%* *
%********************************************************
-\subsection[scc-codegen]{Converting StgSCC}
SCC expressions are treated specially. They set the current cost
centre.
\begin{code}
-cgExpr (StgSCC ty cc expr)
+cgExpr (StgSCC cc expr)
= ASSERT(sccAbleCostCentre cc)
costCentresC
(if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
where
zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
-cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
- = cgRhsClosure name cc bi fvs args body lf_info
- where
- lf_info = mkRhsLFInfo fvs upd_flag args body
-
+cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
+ = mkRhsClosure name cc bi srt fvs upd_flag args body
+cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
+ = mkRhsClosure name cc bi srt fvs upd_flag args body
\end{code}
-mkRhsLFInfo looks for two special forms of the right-hand side:
+mkRhsClosure looks for two special forms of the right-hand side:
a) selector thunks.
- b) VAP thunks
+ b) AP thunks
If neither happens, it just calls mkClosureLFInfo. You might think
-that mkClosureLFInfo should do all this, but
-
- (a) it seems wrong for the latter to look at the structure
- of an expression
-
- [March 97: item (b) is no longer true, but I've left mkRhsLFInfo here
- anyway because of (a).]
-
- (b) mkRhsLFInfo has to be in the monad since it looks up in
- the environment, and it's very tiresome for mkClosureLFInfo to
- be. Apart from anything else it would make a loop between
- CgBindery and ClosureInfo.
+that mkClosureLFInfo should do all this, but it seems wrong for the
+latter to look at the structure of an expression
Selectors
~~~~~~~~~
We look at the body of the closure to see if it's a selector---turgid,
but nothing deep. We are looking for a closure of {\em exactly} the
form:
-\begin{verbatim}
+
... = [the_fv] \ u [] ->
case the_fv of
con a_1 ... a_n -> a_i
-\end{verbatim}
+
\begin{code}
-mkRhsLFInfo [the_fv] -- Just one free var
- Updatable -- Updatable thunk
+mkRhsClosure bndr cc bi srt
+ [the_fv] -- Just one free var
+ upd_flag -- Updatable thunk
[] -- A thunk
- (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
- _ _ _ -- ignore live vars and uniq...
+ body@(StgCase (StgApp scrutinee [{-no args-}])
+ _ _ _ _ -- ignore uniq, etc.
(StgAlgAlts case_ty
[(con, params, use_mask,
- (StgApp (StgVarArg selectee) [{-no args-}] _))]
+ (StgApp selectee [{-no args-}]))]
StgNoDefault))
| the_fv == scrutinee -- Scrutinee is the only free variable
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
- && maybeToBool offset_into_int_maybe
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
- = -- ASSERT(is_single_constructor) -- Should be true, but causes error for SpecTyCon
- mkSelectorLFInfo scrutinee con offset_into_int
+ = ASSERT(is_single_constructor)
+ cgStdRhsClosure bndr cc bi srt [the_fv] [] body lf_info [StgVarArg the_fv]
where
+ lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
+ (isUpdatable upd_flag)
(_, params_w_offsets) = layOutDynCon con idPrimRep params
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
- offset_into_int_maybe = intOffsetIntoGoods the_offset
- Just offset_into_int = offset_into_int_maybe
+ offset_into_int = the_offset - fixedHdrSize
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
tycon = dataConTyCon con
\end{code}
-Vap thunks
-~~~~~~~~~~
-Same kind of thing, looking for vector-apply thunks, of the form:
+Ap thunks
+~~~~~~~~~
- x = [...] \ .. [] -> f a1 .. an
+A more generic AP thunk of the form
-where f has arity n. We rely on the arity info inside the Id being correct.
+ x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
+
+A set of these is compiled statically into the RTS, so we just use
+those. We could extend the idea to thunks where some of the x_i are
+global ids (and hence not free variables), but this would entail
+generating a larger thunk. It might be an option for non-optimising
+compilation, though.
+
+We only generate an Ap thunk if all the free variables are pointers,
+for semi-obvious reasons.
\begin{code}
-mkRhsLFInfo fvs
+mkRhsClosure bndr cc bi srt
+ fvs
upd_flag
[] -- No args; a thunk
- (StgApp (StgVarArg fun_id) args _)
- | isLocallyDefined fun_id -- Must be defined in this module
- = -- Get the arity of the fun_id. It's guaranteed to be correct (by setStgVarInfo).
- let
- arity_maybe = case getIdArity fun_id of
- ArityExactly n -> Just n
- other -> Nothing
- in
- case arity_maybe of
- Just arity
- | arity > 0 && -- It'd better be a function!
- arity == length args -- Saturated application
- -> -- Ha! A VAP thunk
- mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap
-
- other -> mkClosureLFInfo False{-not top level-} fvs upd_flag []
- where
- -- If the function is a free variable then it must be stored
- -- in the thunk too; if it isn't a free variable it must be
- -- because it's constant, so it doesn't need to be stored in the thunk
- store_fun_in_vap = fun_id `is_elem` fvs
- is_elem = isIn "mkClosureLFInfo"
+ body@(StgApp fun_id args)
+
+ | length args + 1 == arity
+ && all isFollowableRep (map idPrimRep fvs)
+ && isUpdatable upd_flag
+ && arity <= mAX_SPEC_AP_SIZE
+
+ -- Ha! an Ap thunk
+ = cgStdRhsClosure bndr cc bi srt fvs [] body lf_info payload
+
+ where
+ lf_info = mkApLFInfo (idType bndr) upd_flag arity
+ -- the payload has to be in the correct order, hence we can't
+ -- just use the fvs.
+ payload = StgVarArg fun_id : args
+ arity = length fvs
\end{code}
The default case
~~~~~~~~~~~~~~~~
\begin{code}
-mkRhsLFInfo fvs upd_flag args body
- = mkClosureLFInfo False{-not top level-} fvs upd_flag args
+mkRhsClosure bndr cc bi srt fvs upd_flag args body
+ = cgRhsClosure bndr cc bi srt fvs args body lf_info
+ where lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
\end{code}
%********************************************************
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
- = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
+ = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
+ NonRecursive binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
= fixC (\ new_bindings ->
addBindsC new_bindings `thenC`
- listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
- maybe_cc_slot b e | (b,e) <- pairs ]
+ listFCs [ cgLetNoEscapeRhs full_live_in_rhss
+ rhs_eob_info maybe_cc_slot Recursive b e
+ | (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
addBindsC new_bindings
where
-- We add the binders to the live-in-rhss set so that we don't
-- delete the bindings for the binder from the environment!
- full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs])
+ full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
cgLetNoEscapeRhs
:: StgLiveVars -- Live in rhss
-> EndOfBlockInfo
- -> Maybe VirtualSpBOffset
+ -> Maybe VirtualSpOffset
+ -> RecFlag
-> Id
-> StgRhs
-> FCode (Id, CgIdInfo)
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
- (StgRhsClosure cc bi _ upd_flag args body)
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
+ (StgRhsClosure cc bi srt _ upd_flag args body)
= -- We could check the update flag, but currently we don't switch it off
-- for let-no-escaped things, so we omit the check too!
-- case upd_flag of
-- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
-- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
- cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
+ cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
-- For a constructor RHS we want to generate a single chunk of code which
-- can be jumped to from many places, which will return the constructor.
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
(StgRhsCon cc con args)
- = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
+ = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
[] --No args; the binder is data structure, not a function
- (StgCon con args full_live_in_rhss)
+ (StgCon (DataCon con) args (idType binder))
\end{code}
-Some PrimOps require a {\em fixed} amount of heap allocation. Rather
-than tidy away ready for GC and do a full heap check, we simply
-allocate a completely uninitialised block in-line, just like any other
-thunk/constructor allocation, and pass it to the PrimOp as its first
-argument. Remember! The PrimOp is entirely responsible for
-initialising the object. In particular, the PrimOp had better not
-trigger GC before it has filled it in, and even then it had better
-make sure that the GC can find the object somehow.
+Little helper for primitives that return unboxed tuples.
-Main current use: allocating SynchVars.
\begin{code}
-getPrimOpArgAmodes op args
- = getArgAmodes args `thenFC` \ arg_amodes ->
-
- case primOpHeapReq op of
- FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
- returnFC (amode : arg_amodes)
-
- _ -> returnFC arg_amodes
+primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
+primRetUnboxedTuple op args res_ty
+ = let Just (tc,ty_args) = splitAlgTyConAppThroughNewTypes res_ty
+ prim_reps = map typePrimRep ty_args
+ temp_uniqs = map mkBuiltinUnique [0..length ty_args]
+ temp_amodes = zipWith CTemp temp_uniqs prim_reps
+ in
+ returnUnboxedTuple temp_amodes
+ (getArgAmodes args `thenFC` \ arg_amodes ->
+ absC (COpStmt temp_amodes op arg_amodes []))
\end{code}
-
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgHeapery.lhs,v 1.10 1998/12/02 13:17:50 simonm Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
module CgHeapery (
- heapCheck,
+ fastEntryChecks, altHeapCheck, thunkChecks,
allocHeap, allocDynClosure
-- new functions, basically inserting macro calls into Code -- HWL
- , heapCheckOnly, fetchAndReschedule, yield
+ ,fetchAndReschedule, yield
) where
#include "HsVersions.h"
import AbsCSyn
+import CLabel
import CgMonad
+import CgStackery ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
+import SMRep ( fixedHdrSize, getSMRepStr )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
+import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
)
-import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize,
- slopSize, allocProfilingMsg, closureKind, ClosureInfo
- )
-import HeapOffs ( isZeroOff, addOff, intOff,
- VirtualHeapOffset, HeapOffset
+import ClosureInfo ( closureSize, closureGoodStuffSize,
+ slopSize, allocProfilingMsg, ClosureInfo,
+ closureSMRep
)
-import PrimRep ( PrimRep(..) )
+import PrimRep ( PrimRep(..), isFollowableRep )
+import Util ( panic )
+import CmdLineOpts ( opt_SccProfilingOn )
+import GlaExts
+
+#ifdef DEBUG
+import PprAbsC ( pprMagicId ) -- tmp
+import Outputable -- tmp
+#endif
\end{code}
%************************************************************************
closures. If fetching is necessary (i.e. current closure is not local) then
an automatic context switch is done.
+-----------------------------------------------------------------------------
+A heap/stack check at a fast entry point.
+
\begin{code}
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
-heapCheck = heapCheck' False
+fastEntryChecks
+ :: [MagicId] -- Live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> CLabel -- return point
+ -> Bool -- node points to closure
+ -> Code
+ -> Code
-heapCheckOnly :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+fastEntryChecks regs tags ret node_points code
+ = mkTagAssts tags `thenFC` \tag_assts ->
+ getFinalStackHW (\ spHw ->
+ getRealSp `thenFC` \ sp ->
+ let stk_words = spHw - sp in
+ initHeapUsage (\ hp_words ->
-heapCheckOnly = heapCheck' False
+ ( if all_pointers then -- heap checks are quite easy
+ absC (checking_code stk_words hp_words tag_assts
+ free_reg (length regs))
--- May be emit context switch and emit heap check macro
+ else -- they are complicated
-heapCheck' :: Bool -- context switch here?
- -> [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+ -- save all registers on the stack and adjust the stack pointer.
+ -- ToDo: find the initial all-pointer segment and don't save them.
+
+ mkTaggedStkAmodes sp addrmode_regs
+ `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
+
+ -- only let the extra stack assignments affect the stack
+ -- high water mark if we were doing a stack check anyway;
+ -- otherwise we end up generating unnecessary stack checks.
+ -- Careful about knot-tying loops!
+ let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
+ then new_sp - sp
+ else stk_words
+ in
+
+ let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
+
+ absC (checking_code real_stk_words hp_words
+ (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
+ adjust_sp])
+ (CReg node) 0)
+
+ ) `thenC`
+
+ setRealHp hp_words `thenC`
+ code))
-heapCheck' do_context_switch regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
where
+
+ checking_code stk hp assts ret regs
+ | node_points = do_checks_np stk hp assts (regs+1) -- ret not required
+ | otherwise = do_checks stk hp assts ret regs
+
+ -- When node points to the closure for the function:
+
+ do_checks_np
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
+ -> Int -- number of pointer registers live
+ -> AbstractC
+ do_checks_np 0 0 _ _ = AbsCNop
+ do_checks_np 0 hp_words tag_assts ptrs =
+ CCheck HP_CHK_NP [
+ mkIntCLit hp_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks_np stk_words 0 tag_assts ptrs =
+ CCheck STK_CHK_NP [
+ mkIntCLit stk_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks_np stk_words hp_words tag_assts ptrs =
+ CCheck HP_STK_CHK_NP [
+ mkIntCLit stk_words,
+ mkIntCLit hp_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+
+ -- When node doesn't point to the closure (we need an explicit retn addr)
+
+ do_checks
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
+ -> CAddrMode -- a register to hold the retn addr.
+ -> Int -- number of pointer registers live
+ -> AbstractC
+
+ do_checks 0 0 _ _ _ = AbsCNop
+ do_checks 0 hp_words tag_assts ret_reg ptrs =
+ CCheck HP_CHK [
+ mkIntCLit hp_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks stk_words 0 tag_assts ret_reg ptrs =
+ CCheck STK_CHK [
+ mkIntCLit stk_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks stk_words hp_words tag_assts ret_reg ptrs =
+ CCheck HP_STK_CHK [
+ mkIntCLit stk_words,
+ mkIntCLit hp_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+
+ free_reg = case length regs + 1 of
+ IBOX(x) -> CReg (VanillaReg PtrRep x)
+
+ all_pointers = all pointer regs
+ pointer (VanillaReg rep _) = isFollowableRep rep
+ pointer _ = False
+
+ addrmode_regs = map CReg regs
+
+-- Checking code for thunks is just a special case of fast entry points:
+
+thunkChecks :: CLabel -> Bool -> Code -> Code
+thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
+\end{code}
- do_heap_chk :: HeapOffset -> Code
- do_heap_chk words_required
- =
- -- HWL:: absC (CComment "Forced heap check --- HWL") `thenC`
- --absC (if do_context_switch
- -- then context_switch_code
- -- else AbsCNop) `thenC`
-
- absC (if do_context_switch && not (isZeroOff words_required)
- then context_switch_code
- else AbsCNop) `thenC`
- absC (if isZeroOff(words_required)
- then AbsCNop
- else checking_code) `thenC`
+Heap checks in a case alternative are nice and easy, provided this is
+a bog-standard algebraic case. We have in our hand:
- -- HWL was here:
- -- For GrAnSim we want heap checks even if no heap is allocated in
- -- the basic block to make context switches possible.
- -- So, the if construct has been replaced by its else branch.
+ * one return address, on the stack,
+ * one return value, in Node.
- -- The test is *inside* the absC, to avoid black holes!
+the canned code for this heap check failure just pushes Node on the
+stack, saying 'EnterGHC' to return. The scheduler will return by
+entering the top value on the stack, which in turn will return through
+the return address, getting us back to where we were. This is
+therefore only valid if the return value is *lifted* (just being
+boxed isn't good enough). Only a PtrRep will do.
- -- Now we have set up the real heap pointer and checked there is
- -- enough space. It remains only to reflect this in the environment
+For primitive returns, we have an unlifted value in some register
+(either R1 or FloatReg1 or DblReg1). This means using specialised
+heap-check code for these cases.
- setRealHp words_required
+For unboxed tuple returns, there are an arbitrary number of possibly
+unboxed return values, some of which will be in registers, and the
+others will be on the stack, with gaps left for tagging the unboxed
+objects. If a heap check is required, we need to fill in these tags.
- -- The "word_required" here is a fudge.
- -- *** IT DEPENDS ON THE DIRECTION ***, and on
- -- whether the Hp is moved the whole way all
- -- at once or not.
- where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsMask all_regs
+The code below will cover all cases for the x86 architecture (where R1
+is the only VanillaReg ever used). For other architectures, we'll
+have to do something about saving and restoring the other registers.
- maybe_context_switch = if do_context_switch
- then context_switch_code
- else AbsCNop
+\begin{code}
+altHeapCheck
+ :: Bool -- is an algebraic alternative
+ -> [MagicId] -- live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> AbstractC
+ -> Maybe CLabel -- ret address if not on top of stack.
+ -> Code
+ -> Code
+
+-- unboxed tuple alternatives and let-no-escapes (the two most annoying
+-- constructs to generate code for!):
+
+altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
+ = mkTagAssts tags `thenFC` \tag_assts1 ->
+ let tag_assts = mkAbstractCs [fail_code, tag_assts1]
+ in
+ initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
+ where
+ do_heap_chk words_required tag_assts
+ = absC (if words_required == 0
+ then AbsCNop
+ else checking_code tag_assts) `thenC`
+ setRealHp words_required
- context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [
- mkIntCLit liveness_mask,
- mkIntCLit (if node_reqd then 1 else 0)]
+ where
+ non_void_regs = filter (/= VoidReg) regs
+
+ checking_code tag_assts =
+ case non_void_regs of
+
+ -- this will cover all cases for x86
+ [VanillaReg rep ILIT(1)]
+
+ | isFollowableRep rep ->
+ CCheck HP_CHK_UT_ALT
+ [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
+ CReg (VanillaReg RetRep ILIT(2)),
+ CLbl ret_addr RetRep]
+ tag_assts
+
+ | otherwise ->
+ CCheck HP_CHK_UT_ALT
+ [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
+ CReg (VanillaReg RetRep ILIT(2)),
+ CLbl ret_addr RetRep]
+ tag_assts
+
+ several_regs ->
+ let liveness = mkRegLiveness several_regs
+ in
+ CCheck HP_CHK_GEN
+ [mkIntCLit words_required,
+ mkIntCLit (IBOX(word2Int# liveness)),
+ CLbl ret_addr RetRep]
+ tag_assts
+
+-- normal algebraic and primitive case alternatives:
+
+altHeapCheck is_fun regs [] AbsCNop Nothing code
+ = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+ where
+ do_heap_chk :: HeapOffset -> Code
+ do_heap_chk words_required
+ = absC (if words_required == 0
+ then AbsCNop
+ else checking_code) `thenC`
+ setRealHp words_required
- -- Good old heap check (excluding context switch)
- checking_code = CMacroStmt HEAP_CHK [
- mkIntCLit liveness_mask,
- COffset words_required,
- mkIntCLit (if node_reqd then 1 else 0)]
+ where
+ non_void_regs = filter (/= VoidReg) regs
+
+ checking_code =
+ case non_void_regs of
+
+ -- No regs live: probably a Void return
+ [] ->
+ CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
+
+ -- The SEQ case (polymophic/function typed case branch)
+ [VanillaReg rep ILIT(1)]
+ | rep == PtrRep
+ && is_fun ->
+ CCheck HP_CHK_SEQ_NP
+ [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
+ AbsCNop
+
+ -- R1 is lifted (the common case)
+ [VanillaReg rep ILIT(1)]
+ | rep == PtrRep ->
+ CCheck HP_CHK_NP
+ [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
+ AbsCNop
+
+ -- R1 is boxed, but unlifted
+ | isFollowableRep rep ->
+ CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
+
+ -- R1 is unboxed
+ | otherwise ->
+ CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
+
+ -- FloatReg1
+ [FloatReg ILIT(1)] ->
+ CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
+
+ -- DblReg1
+ [DoubleReg ILIT(1)] ->
+ CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
+
+ -- LngReg1
+ [LongReg _ ILIT(1)] ->
+ CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
+
+#ifdef DEBUG
+ _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
+#endif
+
+-- build up a bitmap of the live pointer registers
+
+mkRegLiveness :: [MagicId] -> Word#
+mkRegLiveness [] = int2Word# 0#
+mkRegLiveness (VanillaReg rep i : regs)
+ | isFollowableRep rep = ((int2Word# 1#) `shiftL#` (i -# 1#))
+ `or#` mkRegLiveness regs
+ | otherwise = mkRegLiveness regs
-- Emit macro for simulating a fetch and then reschedule
else absC AbsCNop
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsMask all_regs
+ liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
mkIntCLit liveness_mask,
yield_code
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsMask all_regs
+ liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
\end{code}
-- FIND THE OFFSET OF THE INFO-PTR WORD
-- virtHp points to last allocated word, ie 1 *before* the
-- info-ptr word of new object.
- let info_offset = addOff virtHp (intOff 1)
+ let info_offset = virtHp + 1
-- do_move IS THE ASSIGNMENT FUNCTION
do_move (amode, offset_from_start)
- = CAssign (CVal (HpRel realHp
- (info_offset `addOff` offset_from_start))
+ = CAssign (CVal (hpRel realHp
+ (info_offset + offset_from_start))
(getAmodeRep amode))
amode
in
-- SAY WHAT WE ARE ABOUT TO DO
profCtrC (allocProfilingMsg closure_info)
- [COffset (closureHdrSize closure_info),
+ [mkIntCLit fixedHdrSize,
mkIntCLit (closureGoodStuffSize closure_info),
mkIntCLit slop_size,
- COffset closure_size] `thenC`
+ mkIntCLit closure_size] `thenC`
-- GENERATE THE CODE
absC ( mkAbstractCs (
- [ CInitHdr closure_info (HpRel realHp info_offset) use_cc False ]
+ [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
++ (map do_move amodes_with_offsets))) `thenC`
-- GENERATE CC PROFILING MESSAGES
- costCentresC SLIT("CC_ALLOC") [blame_cc,
- COffset closure_size,
- CLitLit (_PK_ (closureKind closure_info)) IntRep]
+ costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
+ -- CLitLit (_PK_ type_str) IntRep] -- not necessary? --SDM
`thenC`
-- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp `addOff` closure_size) `thenC`
+ setVirtHp (virtHp + closure_size) `thenC`
-- RETURN PTR TO START OF OBJECT
returnFC info_offset
where
closure_size = closureSize closure_info
slop_size = slopSize closure_info
+ type_str = getSMRepStr (closureSMRep closure_info)
+
+-- Avoid hanging on to anything in the CC field when we're not profiling.
+
+cInitHdr closure_info amode cc
+ | opt_SccProfilingOn = CInitHdr closure_info amode cc
+ | otherwise = CInitHdr closure_info amode (panic "absent cc")
+
\end{code}
%************************************************************************
allocHeap space
= getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
- let block_start = addOff virtHp (intOff 1)
+ let block_start = virtHp + 1
in
-- We charge the allocation to "PRIM" (which is probably right)
- profCtrC SLIT("ALLOC_PRIM2") [COffset space] `thenC`
+ profCtrC SLIT("ALLOC_PRIM2") [mkIntCLit space] `thenC`
-- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp `addOff` space) `thenC`
+ setVirtHp (virtHp + space) `thenC`
-- RETURN PTR TO START OF OBJECT
- returnFC (CAddr (HpRel realHp block_start))
+ returnFC (CAddr (hpRel realHp block_start))
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+% $Id: CgLetNoEscape.lhs,v 1.11 1998/12/02 13:17:50 simonm Exp $
%
%********************************************************
%* *
import StgSyn
import CgMonad
import AbsCSyn
+import CLabel ( CLabel )
import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
- bindNewToAStack, bindNewToBStack,
- CgIdInfo
+ bindNewToStack, buildContLivenessMask, CgIdInfo,
+ nukeDeadBindings
)
-import CgHeapery ( heapCheck )
+import CgHeapery ( altHeapCheck )
import CgRetConv ( assignRegs )
-import CgStackery ( mkVirtStkOffsets )
-import CgUsages ( setRealAndVirtualSps, getVirtSps )
-import CLabel ( mkStdEntryLabel )
+import CgStackery ( mkTaggedVirtStkOffsets,
+ allocStackTop, deAllocStackTop, freeStackSlots )
+import CgUsages ( setRealAndVirtualSp, getRealSp, getSpRelOffset )
+import CLabel ( mkReturnPtLabel )
import ClosureInfo ( mkLFLetNoEscape )
-import CostCentre ( CostCentre )
-import HeapOffs ( VirtualSpBOffset )
+import CostCentre ( CostCentreStack )
import Id ( idPrimRep, Id )
+import Var ( idUnique )
+import PrimRep ( PrimRep(..), retPrimRepSize )
+import BasicTypes ( RecFlag(..) )
\end{code}
%************************************************************************
if ... then x else ...
\end{verbatim}
@x@ is used twice (so we probably can't unfold it), but when it is
-entered, the stack is deeper than it was then the definition of @x@
+entered, the stack is deeper than it was when the definition of @x@
happened. Specifically, if instead of allocating a closure for @x@,
we saved all @x@'s fvs on the stack, and remembered the stack depth at
that moment, then whenever we enter @x@ we can simply set the stack
\begin{code}
cgLetNoEscapeClosure
:: Id -- binder
- -> CostCentre -- NB: *** NOT USED *** ToDo (WDP 94/06)
+ -> CostCentreStack -- NB: *** NOT USED *** ToDo (WDP 94/06)
-> StgBinderInfo -- NB: ditto
- -> StgLiveVars -- variables live in RHS, including the binders
+ -> SRT
+ -> StgLiveVars -- variables live in RHS, including the binders
-- themselves in the case of a recursive group
-> EndOfBlockInfo -- where are we going to?
- -> Maybe VirtualSpBOffset -- Slot for current cost centre
+ -> Maybe VirtualSpOffset -- Slot for current cost centre
+ -> RecFlag -- is the binding recursive?
-> [Id] -- args (as in \ args -> body)
-> StgExpr -- body (as in above)
-> FCode (Id, CgIdInfo)
-- ToDo: deal with the cost-centre issues
-cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
+cgLetNoEscapeClosure
+ binder cc binder_info srt full_live_in_rhss
+ rhs_eob_info cc_slot rec args body
= let
arity = length args
- lf_info = mkLFLetNoEscape arity full_live_in_rhss{-used???-}
+ lf_info = mkLFLetNoEscape arity
+ uniq = idUnique binder
+ lbl = mkReturnPtLabel uniq
in
+
+ -- saveVolatileVarsAndRegs done earlier in cgExpr.
+
forkEvalHelp
rhs_eob_info
- (nukeDeadBindings full_live_in_rhss)
- (forkAbsC (cgLetNoEscapeBody args body))
- `thenFC` \ (vA, vB, code) ->
- let
- label = mkStdEntryLabel binder -- arity
- in
- absC (CCodeBlock label code) `thenC`
- returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info)
+
+ (allocStackTop retPrimRepSize `thenFC` \_ ->
+ nukeDeadBindings full_live_in_rhss)
+
+ (deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ buildContLivenessMask uniq `thenFC` \ liveness ->
+ forkAbsC (cgLetNoEscapeBody binder cc args body lbl)
+ `thenFC` \ code ->
+ getSRTLabel `thenFC` \ srt_label ->
+ absC (CRetDirect uniq code (srt_label,srt) liveness)
+ `thenC` returnFC ())
+ `thenFC` \ (vSp, _) ->
+
+ returnFC (binder, letNoEscapeIdInfo binder vSp lf_info)
\end{code}
\begin{code}
-cgLetNoEscapeBody :: [Id] -- Args
+cgLetNoEscapeBody :: Id
+ -> CostCentreStack
+ -> [Id] -- Args
-> StgExpr -- Body
+ -> CLabel -- Entry label
-> Code
-cgLetNoEscapeBody all_args rhs
- = getVirtSps `thenFC` \ (vA, vB) ->
- let
+cgLetNoEscapeBody binder cc all_args body lbl
+ =
+ -- this is where the stack frame lives:
+ getRealSp `thenFC` \sp ->
+
+ let
arg_kinds = map idPrimRep all_args
(arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
(reg_args, stk_args) = splitAt (length arg_regs) all_args
- -- stk_args is the args which are passed on the stack at the fast-entry point
- -- Using them, we define the stack layout
- (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
- = mkVirtStkOffsets
- vA vB -- Initial virtual SpA, SpB
- idPrimRep
- stk_args
- in
+ (sp_stk_args, stk_offsets, stk_tags)
+ = mkTaggedVirtStkOffsets sp idPrimRep stk_args
+ in
-- Bind args to appropriate regs/stk locns
- bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
- mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
- setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
+ bindArgsToRegs reg_args arg_regs `thenC`
+ mapCs bindNewToStack stk_offsets `thenC`
+ setRealAndVirtualSp sp_stk_args `thenC`
+
+ -- free up the stack slots containing tags, and the slot
+ -- containing the return address (really frame header).
+ -- c.f. CgCase.cgUnboxedTupleAlt.
+ freeStackSlots (sp : map fst stk_tags) `thenC`
-{- ToDo: NOT SURE ABOUT COST CENTRES!
-- Enter the closures cc, if required
- lexEnterCCcode closure_info maybe_cc `thenC`
--}
+ --enterCostCentreCode closure_info cc IsFunction `thenC`
- -- [No need for stack check; forkEvalHelp dealt with that]
+ -- fill in the frame header only if we fail a heap check:
+ -- otherwise it isn't needed.
+ getSpRelOffset sp `thenFC` \sp_rel ->
+ let frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
+ in
-- Do heap check [ToDo: omit for non-recursive case by recording in
-- in envt and absorbing at call site]
- heapCheck arg_regs False {- Node doesn't point to it -} (
- -- heapCheck *encloses* the rest
+ altHeapCheck False arg_regs stk_tags frame_hdr_asst (Just lbl) (
+ cgExpr body
+ )
- -- Compile the body
- cgExpr rhs
- )
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgMonad.lhs,v 1.15 1998/12/02 13:17:50 simonm Exp $
%
\section[CgMonad]{The code generation monad}
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- AStackUsage, BStackUsage, HeapUsage,
- StubFlag,
- isStubbed,
-
- nukeDeadBindings, getUnstubbedAStackSlots,
+ setSRTLabel, getSRTLabel,
--- addFreeASlots, -- no need to export it
- addFreeBSlots, -- ToDo: Belong elsewhere
+ StackUsage, HeapUsage,
- noBlackHolingFlag,
profCtrC,
- costCentresC, costCentresFlag, moduleName,
+ costCentresC, moduleName,
Sequel(..), -- ToDo: unabstract?
sequelToAmode,
#include "HsVersions.h"
-import List ( nub )
-
-import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeAStkLoc, maybeBStkLoc, nukeVolatileBinds )
-import {-# SOURCE #-} CgUsages
+import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeStkLoc, nukeVolatileBinds )
+import {-# SOURCE #-} CgUsages ( getSpRelOffset )
import AbsCSyn
import AbsCUtils ( mkAbsCStmts )
-import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
- opt_OmitBlackHoling
- )
-import HeapOffs ( maxOff,
- VirtualSpAOffset, VirtualSpBOffset,
- HeapOffset
- )
-import CLabel ( CLabel )
-import Id ( idType,
- nullIdEnv, mkIdEnv, addOneToIdEnv,
- modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv,
- ConTag, GenId{-instance Outputable-},
- Id
- )
-import Literal ( Literal )
-import Maybes ( maybeToBool )
+import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
+import CLabel ( CLabel, mkUpdEntryLabel )
+import DataCon ( ConTag )
+import Id ( Id )
+import VarEnv
import PrimRep ( getPrimRepSize, PrimRep(..) )
import StgSyn ( StgLiveVars )
-import Type ( typePrimRep )
-import UniqSet ( elementOfUniqSet )
-import Util ( sortLt )
import Outputable
infixr 9 `thenC` -- Right-associative!
CgBindings -- [Id -> info] : static environment
+ CLabel -- label of the current SRT
+
EndOfBlockInfo -- Info for stuff to do at end of basic block:
\begin{code}
data EndOfBlockInfo
= EndOfBlockInfo
- VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
+ VirtualSpOffset -- Args Sp: trim the stack to this point at a
-- return; push arguments starting just
-- above this point on a tail call.
- -- This is therefore the A-stk ptr as seen
+ -- This is therefore the stk ptr as seen
-- by a case alternative.
-
- -- Args SpA is used when we want to stub any
- -- currently-unstubbed dead A-stack (ptr)
- -- slots; we want to know what SpA in the
- -- continuation is so that we don't stub any
- -- slots which are off the top of the
- -- continuation's stack!
-
- VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
- -- Two main differences:
- -- 1. If Sequel isn't OnStack, then Args SpB points
- -- just below the slot in which the return address
- -- should be put. In effect, the Sequel
- -- is a pending argument. If it is
- -- OnStack, Args SpB
- -- points to the top word of the return
- -- address.
- --
- -- 2. It ain't used for stubbing because there are
- -- no ptrs on B stk.
Sequel
-initEobInfo = EndOfBlockInfo 0 0 InRetReg
+initEobInfo = EndOfBlockInfo 0 (OnStack 0)
\end{code}
Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
\begin{code}
data Sequel
- = InRetReg -- The continuation is in RetReg
-
- | OnStack VirtualSpBOffset
- -- Continuation is on the stack, at the
+ = OnStack
+ VirtualSpOffset -- Continuation is on the stack, at the
-- specified location
- | UpdateCode CAddrMode -- May be standard update code, or might be
- -- the data-type-specific one.
+ | UpdateCode
| CaseAlts
CAddrMode -- Jump to this; if the continuation is for a vectored
-- addressing mode (I think)
SemiTaggingStuff
+ | SeqFrame -- like CaseAlts but push a seq frame too.
+ CAddrMode
+ SemiTaggingStuff
+
type SemiTaggingStuff
= Maybe -- Maybe[1] we don't have any semi-tagging stuff...
([(ConTag, JoinDetails)], -- Alternatives
-- DIRE WARNING.
-- The OnStack case of sequelToAmode delivers an Amode which is only
-- valid just before the final control transfer, because it assumes
--- that SpB is pointing to the top word of the return address. This
+-- that Sp is pointing to the top word of the return address. This
-- seems unclean but there you go.
sequelToAmode :: Sequel -> FCode CAddrMode
-sequelToAmode (OnStack virt_spb_offset)
- = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
- returnFC (CVal spb_rel RetRep)
+sequelToAmode (OnStack virt_sp_offset)
+ = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
+ returnFC (CVal sp_rel RetRep)
-sequelToAmode InRetReg = returnFC (CReg RetReg)
---Andy/Simon's patch:
---WAS: sequelToAmode (UpdateCode amode) = returnFC amode
-sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
+sequelToAmode UpdateCode = returnFC (CLbl mkUpdEntryLabel CodePtrRep)
sequelToAmode (CaseAlts amode _) = returnFC amode
-\end{code}
-
-See the NOTES about the details of stack/heap usage tracking.
+sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
-\begin{code}
type CgStksAndHeapUsage -- stacks and heap usage information
- = (AStackUsage, -- A-stack usage
- BStackUsage, -- B-stack usage
- HeapUsage)
-
-type AStackUsage =
- (Int, -- virtSpA: Virtual offset of topmost allocated slot
- [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
- Int, -- realSpA: Virtual offset of real stack pointer
- Int) -- hwSpA: Highest value ever taken by virtSp
+ = (StackUsage, HeapUsage)
-data StubFlag = Stubbed | NotStubbed
-
-isStubbed Stubbed = True -- so the type can be abstract
-isStubbed NotStubbed = False
-
-type BStackUsage =
- (Int, -- virtSpB: Virtual offset of topmost allocated slot
- [Int], -- freeB: List of free slots, in increasing order
- Int, -- realSpB: Virtual offset of real stack pointer
- Int) -- hwSpB: Highest value ever taken by virtSp
+type StackUsage =
+ (Int, -- virtSp: Virtual offset of topmost allocated slot
+ [Int], -- free: List of free slots, in increasing order
+ Int, -- realSp: Virtual offset of real stack pointer
+ Int) -- hwSp: Highest value ever taken by virtSp
type HeapUsage =
- (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
+ (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
HeapOffset) -- realHp: Virtual offset of real heap ptr
\end{code}
+
NB: absolutely every one of the above Ints is really
a VirtualOffset of some description (the code generator
-works entirely in terms of VirtualOffsets; see NOTES).
+works entirely in terms of VirtualOffsets).
Initialisation.
\begin{code}
-initialStateC = MkCgState AbsCNop nullIdEnv initUsage
+initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
initUsage :: CgStksAndHeapUsage
-initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
+initUsage = ((0,[],0,0), (initVirtHp, initRealHp))
initVirtHp = panic "Uninitialised virtual Hp"
initRealHp = panic "Uninitialised real Hp"
\end{code}
-@envInitForAlternatives@ initialises the environment for a case alternative,
+"envInitForAlternatives" initialises the environment for a case alternative,
assuming that the alternative is entered after an evaluation.
This involves:
-\begin{itemize}
-\item
-zapping any volatile bindings, which aren't valid.
-\item
-zapping the heap usage. It should be restored by a heap check.
-\item
-setting the virtual AND real stack pointer fields to the given virtual stack offsets.
-this doesn't represent any {\em code}; it is a prediction of where the
-real stack pointer will be when we come back from the case analysis.
-\item
-BUT LEAVING the rest of the stack-usage info because it is all valid.
-In particular, we leave the tail stack pointers unchanged, becuase the
-alternative has to de-allocate the original @case@ expression's stack.
-\end{itemize}
+
+ - zapping any volatile bindings, which aren't valid.
+
+ - zapping the heap usage. It should be restored by a heap check.
+
+ - setting the virtual AND real stack pointer fields to the given
+ virtual stack offsets. this doesn't represent any {\em code}; it is a
+ prediction of where the real stack pointer will be when we come back
+ from the case analysis.
+
+ - BUT LEAVING the rest of the stack-usage info because it is all
+ valid. In particular, we leave the tail stack pointers unchanged,
+ becuase the alternative has to de-allocate the original @case@
+ expression's stack. \end{itemize}
@stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
marks found in $e_2$.
\begin{code}
stateIncUsage :: CgState -> CgState -> CgState
-stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
- (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
+stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
+ (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
= MkCgState abs_c
bs
- ((vA,fA,rA,hA1 `max` hA2),
- (vB,fB,rB,hB1 `max` hB2),
- (vH1 `maxOff` vH2, rH1))
+ ((v,f,r,h1 `max` h2),
+ (vH1 `max` vH2, rH1))
\end{code}
%************************************************************************
initC :: CompilationInfo -> Code -> AbstractC
initC cg_info code
- = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
+ = case (code (MkCgInfoDown
+ cg_info
+ (error "initC: statics")
+ (error "initC: srt")
+ initEobInfo)
initialStateC) of
MkCgState abc _ _ -> abc
forkClosureBody :: Code -> Code
forkClosureBody code
- (MkCgInfoDown cg_info statics _)
+ (MkCgInfoDown cg_info statics srt _)
(MkCgState absC_in binds un_usage)
= MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
where
fork_state = code body_info_down initialStateC
MkCgState absC_fork _ _ = fork_state
- body_info_down = MkCgInfoDown cg_info statics initEobInfo
+ body_info_down = MkCgInfoDown cg_info statics srt initEobInfo
forkStatics :: FCode a -> FCode a
-forkStatics fcode (MkCgInfoDown cg_info _ _)
+forkStatics fcode (MkCgInfoDown cg_info _ srt _)
(MkCgState absC_in statics un_usage)
= (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
where
(result, state) = fcode rhs_info_down initialStateC
MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
-- above or it becomes too strict!
- rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
+ rhs_info_down = MkCgInfoDown cg_info statics srt initEobInfo
forkAbsC :: Code -> FCode AbstractC
forkAbsC code info_down (MkCgState absC1 bs usage)
= (absC2, new_state)
where
- MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
+ MkCgState absC2 _ ((_, _, _,h2), _) =
code info_down (MkCgState AbsCNop bs usage)
- ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
+ ((v, f, r, h1), heap_usage) = usage
- new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
+ new_usage = ((v, f, r, h1 `max` h2), heap_usage)
new_state = MkCgState absC1 bs new_usage
\end{code}
- the worst stack high-water mark is incorporated
- the virtual Hp is moved on to the worst virtual Hp for the branches
-The "extra branches" arise from handling the default case:
-
- case f x of
- C1 a b -> e1
- z -> e2
-
-Here we in effect expand to
-
- case f x of
- C1 a b -> e1
- C2 c -> let z = C2 c in JUMP(default)
- C3 d e f -> let z = C2 d e f in JUMP(default)
-
- default: e2
-
-The stuff for C2 and C3 are the extra branches. They are
-handled differently by forkAlts, because their
-heap usage is joined onto that for the default case.
-
\begin{code}
-forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
+forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
-forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
- = ((extra_branch_results ++ branch_results , deflt_result), out_state)
+forkAlts branch_fcodes deflt_fcode info_down in_state
+ = ((branch_results , deflt_result), out_state)
where
compile fc = fc info_down in_state
- (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
- (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
+ (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
- -- The "in_state" for the default branch is got by worst-casing the
- -- heap usages etc from the "extra_branches"
- default_in_state = foldl stateIncUsage in_state extra_branch_out_states
- (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
+ (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
- out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
+ out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
-- NB foldl. in_state is the *left* argument to stateIncUsage
\end{code}
@forkEval@ takes two blocks of code.
-\begin{itemize}
-\item The first meddles with the environment to set it up as expected by
- the alternatives of a @case@ which does an eval (or gc-possible primop).
-\item The second block is the code for the alternatives.
- (plus info for semi-tagging purposes)
-\end{itemize}
-@forkEval@ picks up the virtual stack pointers and stubbed stack slots
-as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
-the caller to use, together with whatever value is returned by the second block.
+
+ - The first meddles with the environment to set it up as expected by
+ the alternatives of a @case@ which does an eval (or gc-possible primop).
+ - The second block is the code for the alternatives.
+ (plus info for semi-tagging purposes)
+
+@forkEval@ picks up the virtual stack pointer and returns a suitable
+@EndOfBlockInfo@ for the caller to use, together with whatever value
+is returned by the second block.
It uses @initEnvForAlternatives@ to initialise the environment, and
@stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
-> FCode EndOfBlockInfo -- The new end of block info
forkEval body_eob_info env_code body_code
- = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
- returnFC (EndOfBlockInfo vA vB sequel)
+ = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
+ returnFC (EndOfBlockInfo v sequel)
forkEvalHelp :: EndOfBlockInfo -- For the body
-> Code -- Code to set environment
-> FCode a -- The code to do after the eval
- -> FCode (Int, -- SpA
- Int, -- SpB
+ -> FCode (Int, -- Sp
a) -- Result of the FCode
forkEvalHelp body_eob_info env_code body_code
- info_down@(MkCgInfoDown cg_info statics _) state
- = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
+ info_down@(MkCgInfoDown cg_info statics srt _) state
+ = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
where
- info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
-
- (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
- -- These vA and fA things are now set up as the body code expects them
+ info_down_for_body = MkCgInfoDown cg_info statics srt body_eob_info
- state_at_end_return :: CgState
+ (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
+ -- These v and f things are now set up as the body code expects them
- (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
-
- state_for_body :: CgState
+ (value_returned, state_at_end_return)
+ = body_code info_down_for_body state_for_body
state_for_body = MkCgState AbsCNop
(nukeVolatileBinds binds)
- ((vA,stubbed_fA,vA,vA), -- Set real and hwms
- (vB,fB,vB,vB), -- to virtual ones
+ ((v,f,v,v),
(initVirtHp, initRealHp))
- stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
- -- In the branch, all free locations will have been stubbed
-
stateIncUsageEval :: CgState -> CgState -> CgState
-stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
- (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
+stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
+ (MkCgState absC2 _ ((_,_,_,h2), _))
= MkCgState (absC1 `AbsCStmts` absC2)
-- The AbsC coming back should consist only of nested declarations,
-- notably of the return vector!
bs
- ((vA,fA,rA,hA1 `max` hA2),
- (vB,fB,rB,hB1 `max` hB2),
- heap_usage)
+ ((v,f,r,h1 `max` h2), heap_usage)
-- We don't max the heap high-watermark because stateIncUsageEval is
-- used only in forkEval, which in turn is only used for blocks of code
-- which do their own heap-check.
{- Try to avoid adding too many special compilation strategies here.
It's better to modify the header files as necessary for particular
targets, so that we can get away with as few variants of .hc files
- as possible. 'ForConcurrent' is somewhat special anyway, as it
- changes entry conventions pretty significantly.
+ as possible.
-}
\end{code}
getAbsC code info_down (MkCgState absC binds usage)
= (absC2, MkCgState absC binds2 usage2)
where
- (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
-\end{code}
-
-\begin{code}
-noBlackHolingFlag, costCentresFlag :: FCode Bool
-
-noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
-costCentresFlag _ state = (opt_SccProfilingOn, state)
+ (MkCgState absC2 binds2 usage2)
+ = code info_down (MkCgState AbsCNop binds usage)
\end{code}
\begin{code}
moduleName :: FCode FAST_STRING
-moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
+moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _) state
= (mod_name, state)
\end{code}
\begin{code}
setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
-setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
- = code (MkCgInfoDown c_info statics eob_info) state
+setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt _) state
+ = code (MkCgInfoDown c_info statics srt eob_info) state
getEndOfBlockInfo :: FCode EndOfBlockInfo
-getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
+getEndOfBlockInfo (MkCgInfoDown c_info statics _ eob_info) state
= (eob_info, state)
\end{code}
+\begin{code}
+getSRTLabel :: FCode CLabel
+getSRTLabel (MkCgInfoDown _ _ srt _) state
+ = (srt, state)
+
+setSRTLabel :: CLabel -> Code -> Code
+setSRTLabel srt code (MkCgInfoDown c_info statics _ eob_info) state
+ = code (MkCgInfoDown c_info statics srt eob_info) state
+\end{code}
+
%************************************************************************
%* *
\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
%************************************************************************
There are three basic routines, for adding (@addBindC@), modifying
-(@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
-is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
-on the end of each function name).
+(@modifyBindC@) and looking up (@lookupBindC@) bindings.
A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
The name should not already be bound. (nice ASSERT, eh?)
+
\begin{code}
addBindC :: Id -> CgIdInfo -> Code
addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
- = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
-\end{code}
+ = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
-\begin{code}
addBindsC :: [(Id, CgIdInfo)] -> Code
addBindsC new_bindings info_down (MkCgState absC binds usage)
= MkCgState absC new_binds usage
where
- new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
+ new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
binds
new_bindings
-\end{code}
-\begin{code}
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
- = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
-\end{code}
+ = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
-Lookup is expected to find a binding for the @Id@.
-\begin{code}
lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
+lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _)
state@(MkCgState absC local_binds usage)
= (val, state)
where
- val = case (lookupIdEnv local_binds name) of
+ val = case (lookupVarEnv local_binds name) of
Nothing -> try_static
Just this -> this
- try_static = case (lookupIdEnv static_binds name) of
- Just this -> this
- Nothing
- -> pprPanic "lookupBindC:no info!\n"
- (vcat [
- hsep [ptext SLIT("for:"), ppr name],
- ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
- ptext SLIT("static binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
- ptext SLIT("local binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
- ])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgMonad-deadslots]{Finding dead stack slots}
-%* *
-%************************************************************************
-
-@nukeDeadBindings@ does the following:
-\begin{itemize}
-\item Removes all bindings from the environment other than those
- for variables in the argument to @nukeDeadBindings@.
-\item Collects any stack slots so freed, and returns them to the appropriate
- stack free list.
-\item Moves the virtual stack pointers to point to the topmost used
- stack locations.
-\end{itemize}
-
-Find dead slots on the stacks *and* remove bindings for dead variables
-from the bindings.
-
-You can have multi-word slots on the B stack; if dead, such a slot
-will be reported as {\em several} offsets (one per word).
-
-NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
-set, so that no stack-stubbing will take place.
-
-Probably *naughty* to look inside monad...
-
-\begin{code}
-nukeDeadBindings :: StgLiveVars -- All the *live* variables
- -> Code
-nukeDeadBindings
- live_vars
- info_down
- state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
- (vsp_b, free_b, real_b, hw_b),
- heap_usage))
- = MkCgState abs_c (mkIdEnv bs') new_usage
- where
- new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
- (new_vsp_b, new_free_b, real_b, hw_b),
- heap_usage)
-
- (dead_a_slots, dead_b_slots, bs')
- = dead_slots live_vars
- [] [] []
- [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
-
- extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
- extra_free_b = sortLt (<) dead_b_slots
-
- (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
- (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
-
-getUnstubbedAStackSlots
- :: VirtualSpAOffset -- Ignore slots bigger than this
- -> FCode [VirtualSpAOffset] -- Return the list of slots found
-
-getUnstubbedAStackSlots tail_spa
- info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
- = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
-\end{code}
-
-Several boring auxiliary functions to do the dirty work.
-
-\begin{code}
-dead_slots :: StgLiveVars
- -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
- -> [(Id,CgIdInfo)]
- -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
-
--- dead_slots carries accumulating parameters for
--- filtered bindings, dead a and b slots
-dead_slots live_vars fbs das dbs []
- = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
-
-dead_slots live_vars fbs das dbs ((v,i):bs)
- | v `elementOfUniqSet` live_vars
- = dead_slots live_vars ((v,i):fbs) das dbs bs
- -- Live, so don't record it in dead slots
- -- Instead keep it in the filtered bindings
-
- | otherwise
- = case i of
- MkCgIdInfo _ _ stable_loc _
- | is_Astk_loc ->
- dead_slots live_vars fbs (offsetA : das) dbs bs
-
- | is_Bstk_loc ->
- dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
- where
- maybe_Astk_loc = maybeAStkLoc stable_loc
- is_Astk_loc = maybeToBool maybe_Astk_loc
- (Just offsetA) = maybe_Astk_loc
-
- maybe_Bstk_loc = maybeBStkLoc stable_loc
- is_Bstk_loc = maybeToBool maybe_Bstk_loc
- (Just offsetB) = maybe_Bstk_loc
-
- _ -> dead_slots live_vars fbs das dbs bs
- where
- size :: Int
- size = (getPrimRepSize . typePrimRep . idType) v
-
--- addFreeSlots expects *both* args to be in increasing order
-addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
-addFreeASlots = addFreeSlots fst
-
-addFreeBSlots :: [Int] -> [Int] -> [Int]
-addFreeBSlots = addFreeSlots id
-
-addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
-
-addFreeSlots get_offset cs [] = cs
-addFreeSlots get_offset [] ns = ns
-addFreeSlots get_offset (c:cs) (n:ns)
- = if off_c < off_n then
- (c : addFreeSlots get_offset cs (n:ns))
- else if off_c > off_n then
- (n : addFreeSlots get_offset (c:cs) ns)
- else
- panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
- where
- off_c = get_offset c
- off_n = get_offset n
-
-trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
-
-trim get_offset current_sp free_slots
- = try current_sp (reverse free_slots)
- where
- try csp [] = (csp, [])
- try csp (slot:slots)
- = if csp < slot_off then
- try csp slots -- Free slot off top of stk; ignore
-
- else if csp == slot_off then
- try (csp-1) slots -- Free slot at top of stk; trim
-
- else
- (csp, reverse (slot:slots)) -- Otherwise gap; give up
- where
- slot_off = get_offset slot
+ try_static =
+ case (lookupVarEnv static_binds name) of
+ Just this -> this
+ Nothing
+ -> pprPanic "lookupBindC:no info!\n"
+ (vcat [
+ hsep [ptext SLIT("for:"), ppr name],
+ ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
+ ptext SLIT("static binds for:"),
+ vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
+ ptext SLIT("local binds for:"),
+ vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ]
+ ])
\end{code}
%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1998
+%
+% $Id: CgRetConv.lhs,v 1.15 1998/12/02 13:17:51 simonm Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
\begin{code}
module CgRetConv (
- CtrlReturnConvention(..), DataReturnConvention(..),
-
+ CtrlReturnConvention(..),
ctrlReturnConvAlg,
- dataReturnConvAlg,
-
dataReturnConvPrim,
-
- assignPrimOpResultRegs,
- makePrimOpArgsRobust,
- assignRegs
+ assignRegs, assignAllRegs
) where
#include "HsVersions.h"
import AbsCSyn -- quite a few things
-import AbsCUtils ( mkAbstractCs, getAmodeRep,
- amodeCanSurviveGC
- )
import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
mAX_Vanilla_REG, mAX_Float_REG,
- mAX_Double_REG, mAX_Long_REG
- )
-import CmdLineOpts ( opt_ReturnInRegsThreshold )
-import Id ( isDataCon, dataConRawArgTys,
- DataCon, GenId{-instance Eq-},
- Id
+ mAX_Double_REG,
+ mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
+ mAX_Real_Double_REG,
+ mAX_Long_REG
)
import Maybes ( catMaybes )
-import PprType ( TyCon{-instance Outputable-} )
-import PrimOp ( primOpCanTriggerGC,
- getPrimOpResultInfo, PrimOpResultInfo(..),
- PrimOp{-instance Outputable-}
- )
-import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..) )
-import TyCon ( tyConDataCons, tyConFamilySize )
-import Type ( typePrimRep )
-import Util ( zipWithEqual, mapAccumL, isn'tIn )
+import DataCon ( dataConRawArgTys, DataCon )
+import PrimOp ( PrimOp{-instance Outputable-} )
+import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
+import TyCon ( TyCon, tyConDataCons, tyConFamilySize )
+import Type ( Type, typePrimRep, isUnLiftedType,
+ splitAlgTyConApp_maybe )
+import Util ( isn'tIn )
+
import Outputable
\end{code}
| UnvectoredReturn Int -- family size
\end{code}
-A @DataReturnConvention@ says how the data for a particular
-data-constructor is returned.
-\begin{code}
-data DataReturnConvention
- = ReturnInHeap
- | ReturnInRegs [MagicId]
-\end{code}
-The register assignment given by a @ReturnInRegs@ obeys three rules:
-\begin{itemize}
-\item R1 is dead.
-\item R2 points to the info table for the phantom constructor
-\item The list of @MagicId@ is in the same order as the arguments
- to the constructor.
-\end{itemize}
-
-
%************************************************************************
%* *
\subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
ctrlReturnConvAlg tycon
= case (tyConFamilySize tycon) of
- 0 -> pprTrace "ctrlReturnConvAlg:" (ppr tycon) $
- UnvectoredReturn 0 -- e.g., w/ "data Bin"
-
+ 0 -> panic "ctrlRetConvAlg"
size -> -- we're supposed to know...
if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
VectoredReturn size
UnvectoredReturn size
\end{code}
-@dataReturnConvAlg@ determines the return conventions from the
-(possibly specialised) data constructor.
-
-(See also @getDataConReturnConv@ (in @Id@).) We grab the types
-of the data constructor's arguments. We feed them and a list of
-available registers into @assign_reg@, which sequentially assigns
-registers of the appropriate types to the arguments, based on the
-types. If @assign_reg@ runs out of a particular kind of register,
-then it gives up, returning @ReturnInHeap@.
-
-\begin{code}
-dataReturnConvAlg :: DataCon -> DataReturnConvention
-
-dataReturnConvAlg data_con
- = ASSERT2(isDataCon data_con, (ppr data_con))
- case leftover_kinds of
- [] -> ReturnInRegs reg_assignment
- other -> ReturnInHeap -- Didn't fit in registers
- where
- arg_tys = dataConRawArgTys data_con
-
- (reg_assignment, leftover_kinds)
- = assignRegs [node, infoptr] -- taken...
- (map typePrimRep arg_tys)
-\end{code}
-
%************************************************************************
%* *
\subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
%* *
%************************************************************************
-WARNING! If you add a return convention which can return a pointer,
-make sure you alter CgCase (cgPrimDefault) to generate the right sort
-of heap check!
\begin{code}
dataReturnConvPrim :: PrimRep -> MagicId
dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1)
+dataReturnConvPrim WeakPtrRep = VanillaReg WeakPtrRep ILIT(1)
#ifdef DEBUG
dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep"
#endif
\end{code}
-%********************************************************
-%* *
-\subsection[primop-stuff]{Argument and return conventions for Prim Ops}
-%* *
-%********************************************************
-
-\begin{code}
-assignPrimOpResultRegs
- :: PrimOp -- The constructors in canonical order
- -> [MagicId] -- The return regs all concatenated to together,
- -- (*including* one for the tag if necy)
-
-assignPrimOpResultRegs op
- = case (getPrimOpResultInfo op) of
-
- ReturnsPrim kind -> [dataReturnConvPrim kind]
-
- ReturnsAlg tycon
- -> let
- cons = tyConDataCons tycon
- result_regs = concat (map get_return_regs cons)
- in
- -- As R1 is dead, it can hold the tag if necessary
- case cons of
- [_] -> result_regs
- other -> (VanillaReg IntRep ILIT(1)) : result_regs
- where
- get_return_regs con
- = case (dataReturnConvAlg con) of
- ReturnInRegs regs -> regs
- ReturnInHeap -> panic "getPrimOpAlgResultRegs"
-\end{code}
-
-@assignPrimOpArgsRobust@ is used only for primitive ops which may
-trigger GC. [MAYBE (WDP 94/05)] For these, we pass all (nonRobust)
-arguments in registers. This function assigns them and tells us which
-of those registers are now live (because we've shoved a followable
-argument into it).
-
-Bug: it is assumed that robust amodes cannot contain pointers. This
-seems reasonable but isn't true. For example, \tr{Array#}'s
-\tr{ForeignObj#}'s are pointers. (This is only known to bite on
-\tr{_ccall_GC_} with a ForeignObj argument.)
-
-See after for some ADR comments...
-
-\begin{code}
-makePrimOpArgsRobust
- :: PrimOp
- -> [CAddrMode] -- Arguments
- -> ([CAddrMode], -- Arg registers
- Int, -- Liveness mask
- AbstractC) -- Simultaneous assignments to assign args to regs
-
-makePrimOpArgsRobust op arg_amodes
- = ASSERT (primOpCanTriggerGC op)
- let
- non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
- arg_kinds = map getAmodeRep non_robust_amodes
-
- (arg_regs, extra_args)
- = assignRegs [{-nothing live-}] arg_kinds
-
- -- Check that all the args fit before returning arg_regs
- final_arg_regs = case extra_args of
- [] -> arg_regs
- other -> pprPanic "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr op)
-
- arg_assts
- = mkAbstractCs (zipWithEqual "assign_to_reg" assign_to_reg final_arg_regs non_robust_amodes)
-
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-
- safe_arg regs arg
- | amodeCanSurviveGC arg = (regs, arg)
- | otherwise = (tail regs, CReg (head regs))
- safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
-
- liveness_mask = mkLiveRegsMask final_arg_regs
- in
- (safe_amodes, liveness_mask, arg_assts)
-\end{code}
-
%************************************************************************
%* *
\subsubsection[CgRetConv-regs]{Register assignment}
%* *
%************************************************************************
-How to assign registers.
+How to assign registers for
+
+ 1) Calling a fast entry point.
+ 2) Returning an unboxed tuple.
+ 3) Invoking an out-of-line PrimOp.
+
Registers are assigned in order.
-If we run out, we don't attempt to assign
-any further registers (even though we might have run out of only one kind of
-register); we just return immediately with the left-overs specified.
+If we run out, we don't attempt to assign any further registers (even
+though we might have run out of only one kind of register); we just
+return immediately with the left-overs specified.
+
+The alternative version @assignAllRegs@ uses the complete set of
+registers, including those that aren't mapped to real machine
+registers. This is used for calling special RTS functions and PrimOps
+which expect their arguments to always be in the same registers.
\begin{code}
-assignRegs :: [MagicId] -- Unavailable registers
- -> [PrimRep] -- Arg or result kinds to assign
- -> ([MagicId], -- Register assignment in same order
+assignRegs, assignAllRegs
+ :: [MagicId] -- Unavailable registers
+ -> [PrimRep] -- Arg or result kinds to assign
+ -> ([MagicId], -- Register assignment in same order
-- for *initial segment of* input list
- [PrimRep])-- leftover kinds
+ [PrimRep])-- leftover kinds
assignRegs regs_in_use kinds
= assign_reg kinds [] (mkRegTbl regs_in_use)
- where
- assign_reg :: [PrimRep] -- arg kinds being scrutinized
- -> [MagicId] -- accum. regs assigned so far (reversed)
- -> ([Int], [Int], [Int], [Int])
- -- regs still avail: Vanilla, Float, Double, Int64, Word64
- -> ([MagicId], [PrimRep])
+assignAllRegs regs_in_use kinds
+ = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
+
+assign_reg
+ :: [PrimRep] -- arg kinds being scrutinized
+ -> [MagicId] -- accum. regs assigned so far (reversed)
+ -> AvailRegs -- regs still avail: Vanilla, Float, Double, longs
+ -> ([MagicId], [PrimRep])
- assign_reg (VoidRep:ks) acc supply
- = assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody!
+assign_reg (VoidRep:ks) acc supply
+ = assign_reg ks (VoidReg:acc) supply
+ -- one VoidReg is enough for everybody!
- assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs, long_rs)
+assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs, long_rs)
= assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs, long_rs)
- assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs, long_rs)
+assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs, long_rs)
= assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs, long_rs)
- assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(u):long_rs)
+assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(u):long_rs)
= assign_reg ks (LongReg Word64Rep u:acc) (vanilla_rs, float_rs, double_rs, long_rs)
- assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(l):long_rs)
+assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(l):long_rs)
= assign_reg ks (LongReg Int64Rep l:acc) (vanilla_rs, float_rs, double_rs, long_rs)
- assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs, long_rs)
+assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs, long_rs)
| not (isFloatingRep k || is64BitRep k)
= assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs, long_rs)
- -- The catch-all. It can happen because either
- -- (a) we've assigned all the regs so leftover_ks is []
- -- (b) we couldn't find a spare register in the appropriate supply
- -- or, I suppose,
- -- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
- assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
-\end{code}
-
-Register supplies. Vanilla registers can contain pointers, Ints, Chars.
+-- The catch-all. It can happen because either
+-- (a) we've assigned all the regs so leftover_ks is []
+-- (b) we couldn't find a spare register in the appropriate supply
+-- or, I suppose,
+-- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
+assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
-\begin{code}
-vanillaRegNos :: [Int]
-vanillaRegNos = [1 .. mAX_Vanilla_REG]
\end{code}
+Register supplies. Vanilla registers can contain pointers, Ints, Chars.
Floats and doubles have separate register supplies.
+We take these register supplies from the *real* registers, i.e. those
+that are guaranteed to map to machine registers.
+
\begin{code}
-floatRegNos, doubleRegNos :: [Int]
-floatRegNos = [1 .. mAX_Float_REG]
-doubleRegNos = [1 .. mAX_Double_REG]
-longRegNos = [1 .. mAX_Long_REG]
+vanillaRegNos, floatRegNos, doubleRegNos :: [Int]
+vanillaRegNos = [1 .. mAX_Real_Vanilla_REG]
+floatRegNos = [1 .. mAX_Real_Float_REG]
+doubleRegNos = [1 .. mAX_Real_Double_REG]
+longRegNos = [1 .. mAX_Long_REG]
+
+allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
+allVanillaRegNos = [1 .. mAX_Vanilla_REG]
+allFloatRegNos = [1 .. mAX_Float_REG]
+allDoubleRegNos = [1 .. mAX_Double_REG]
+allLongRegNos = [1 .. mAX_Double_REG]
+
+type AvailRegs = ( [Int] -- available vanilla regs.
+ , [Int] -- floats
+ , [Int] -- doubles
+ , [Int] -- longs (int64 and word64)
+ )
+
+mkRegTbl :: [MagicId] -> AvailRegs
+mkRegTbl regs_in_use
+ = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
-mkRegTbl :: [MagicId] -> ([Int], [Int], [Int], [Int])
+mkRegTbl_allRegs :: [MagicId] -> AvailRegs
+mkRegTbl_allRegs regs_in_use
+ = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
-mkRegTbl regs_in_use
+mkRegTbl' regs_in_use vanillas floats doubles longs
= (ok_vanilla, ok_float, ok_double, ok_long)
where
- ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos))
- ok_float = catMaybes (map (select FloatReg) floatRegNos)
- ok_double = catMaybes (map (select DoubleReg) doubleRegNos)
- ok_long = catMaybes (map (select (LongReg Int64Rep)) longRegNos) -- rep isn't looked at, hence we can use any old rep.
-
- taker :: [Int] -> [Int]
- taker rs
- = case (opt_ReturnInRegsThreshold) of
- Nothing -> rs -- no flag set; use all of them
- Just n -> take n rs
+ ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) vanillas)
+ ok_float = catMaybes (map (select FloatReg) floats)
+ ok_double = catMaybes (map (select DoubleReg) doubles)
+ ok_long = catMaybes (map (select (LongReg Int64Rep)) longs)
+ -- rep isn't looked at, hence we can use any old rep.
select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
-- one we've unboxed the Int, we make a MagicId
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgStackery.lhs,v 1.9 1998/12/02 13:17:51 simonm Exp $
%
\section[CgStackery]{Stack management functions}
\begin{code}
module CgStackery (
- allocAStack, allocBStack, allocAStackTop, allocBStackTop,
+ allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
allocUpdateFrame,
- adjustRealSps, getFinalStackHW,
- mkVirtStkOffsets, mkStkAmodes
+ adjustRealSp, adjustStackHW, getFinalStackHW,
+ mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts,
+ freeStackSlots, addFreeSlots
) where
#include "HsVersions.h"
import CgMonad
import AbsCSyn
+import CgUsages ( getRealSp )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
-import HeapOffs ( VirtualSpAOffset, VirtualSpBOffset )
-import PrimRep ( getPrimRepSize, separateByPtrFollowness,
- PrimRep(..)
- )
-import Util ( mapAccumR, panic )
+import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
+import Util ( panic )
\end{code}
%************************************************************************
%* *
%************************************************************************
-@mkVirtStkOffsets@ is given a list of arguments. The first argument
-gets the {\em largest} virtual stack offset (remember, virtual offsets
-increase towards the top of stack).
+@mkTaggedVirtStkOffsets@ is given a list of arguments. The first
+argument gets the {\em largest} virtual stack offset (remember,
+virtual offsets increase towards the top of stack). This function
+also computes the correct tagging arrangement for standard function
+entry points. Each non-pointer on the stack is preceded by a tag word
+indicating the number of non-pointer words above it on the stack.
+
+ offset --> | | <---- last allocated stack word
+ --------- <
+ | | .
+ --------- .
+ | | total_nptrs (words)
+ --------- .
+ | | .
+ --------- <
+offset + tot_nptrs + 1 --> | tag |
+ ---------
\begin{code}
-mkVirtStkOffsets :: VirtualSpAOffset -- Offset of the last allocated thing
- -> VirtualSpBOffset -- ditto
+mkTaggedVirtStkOffsets
+ :: VirtualSpOffset -- Offset of the last allocated thing
-> (a -> PrimRep) -- to be able to grab kinds
-> [a] -- things to make offsets for
- -> (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
- VirtualSpBOffset, -- ditto
- [(a, VirtualSpAOffset)], -- boxed things with offsets
- [(a, VirtualSpBOffset)]) -- unboxed things with offsets
-
-mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
- = let (boxeds, unboxeds)
- = separateByPtrFollowness kind_fun things
- (last_SpA_offset, boxd_w_offsets)
- = mapAccumR computeOffset init_SpA_offset boxeds
- (last_SpB_offset, ubxd_w_offsets)
- = mapAccumR computeOffset init_SpB_offset unboxeds
- in
- (last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
+ -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
+ [(a, VirtualSpOffset)], -- things with offsets
+ [(VirtualSpOffset,Int)]) -- offsets for tags
+
+mkTaggedVirtStkOffsets init_Sp_offset kind_fun things
+ = loop init_Sp_offset [] [] (reverse things)
where
- computeOffset offset thing
- = (offset + (max 1 . getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
- -- The "max 1" bit is ULTRA important
- -- Why? mkVirtStkOffsets is the unique function that lays out function
- -- arguments on the stack. The "max 1" ensures that every argument takes
- -- at least one stack slot, even if it's of kind VoidKind that actually
- -- takes no space at all.
- -- This is important to make sure that argument satisfaction checks work
- -- properly. Consider
- -- f a b s# = (a,b)
- -- where s# is a VoidKind. f's argument satisfaction check will check
- -- that s# is on the B stack above SuB; but if s# takes zero space, the
- -- check will be ARGS_B_CHK(0), which always succeeds. As a result, even
- -- if a,b aren't available either, the PAP update won't trigger and
- -- we are throughly hosed. (SLPJ 96/05)
+ loop offset tags offs [] = (offset,offs,tags)
+ loop offset tags offs (t:things)
+ | isFollowableRep (kind_fun t) =
+ loop (offset+1) tags ((t,offset+1):offs) things
+ | otherwise =
+ let
+ size = getPrimRepSize (kind_fun t)
+ tag_slot = offset+size+1
+ in
+ loop tag_slot ((tag_slot,size):tags) ((t,offset+size):offs) things
+ -- offset of thing is offset+size, because we're growing the stack
+ -- *downwards* as the offsets increase.
\end{code}
-@mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
-It starts from the tail-call locations.
-It returns a single list of addressing modes for the stack locations,
-and therefore is in the monad.
+@mkTaggedStkAmodes@ is a higher-level version of
+@mkTaggedVirtStkOffsets@. It starts from the tail-call locations. It
+returns a single list of addressing modes for the stack locations, and
+therefore is in the monad.
-It also adjusts the high water mark if necessary.
+It *doesn't* adjust the high water mark.
\begin{code}
-mkStkAmodes :: VirtualSpAOffset -- Tail call positions
- -> VirtualSpBOffset
- -> [CAddrMode] -- things to make offsets for
- -> FCode (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
- VirtualSpBOffset, -- ditto
- AbstractC) -- Assignments to appropriate stk slots
-
-mkStkAmodes tail_spa tail_spb things
- info_down (MkCgState absC binds usage)
- = (result, MkCgState absC binds new_usage)
- where
- result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
-
- (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
- = mkVirtStkOffsets tail_spa tail_spb getAmodeRep things
-
- abs_cs
- = [ CAssign (CVal (SpARel realSpA offset) PtrRep) thing
- | (thing, offset) <- ptrs_w_offsets
+mkTaggedStkAmodes
+ :: VirtualSpOffset -- Tail call positions
+ -> [CAddrMode] -- things to make offsets for
+ -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
+ AbstractC, -- Assignments to appropriate stk slots
+ AbstractC) -- Assignments for tagging
+
+mkTaggedStkAmodes tail_Sp things
+ = getRealSp `thenFC` \ realSp ->
+ let
+ (last_Sp_offset, offsets, tags)
+ = mkTaggedVirtStkOffsets tail_Sp getAmodeRep things
+
+ abs_cs =
+ [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
+ | (thing, offset) <- offsets
]
- ++
- [ CAssign (CVal (SpBRel realSpB offset) (getAmodeRep thing)) thing
- | (thing, offset) <- non_ptrs_w_offsets
+
+ tag_cs =
+ [ CAssign (CVal (spRel realSp offset) WordRep)
+ (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
+ | (offset,size) <- tags
]
+ in
+ returnFC (last_Sp_offset, mkAbstractCs abs_cs, mkAbstractCs tag_cs)
- ((vspA,fspA,realSpA,hwSpA), (vspB,fspB,realSpB,hwSpB), h_usage) = usage
-
- new_usage = ((vspA,fspA,realSpA,max last_SpA_offset hwSpA),
- (vspB,fspB,realSpB,max last_SpB_offset hwSpB),
- h_usage)
- -- No need to fiddle with virtual SpA etc because this call is
- -- only done just before the end of a block
-
+mkTagAssts :: [(VirtualSpOffset,Int)] -> FCode AbstractC
+mkTagAssts tags =
+ getRealSp `thenFC` \realSp ->
+ returnFC (mkAbstractCs
+ [ CAssign (CVal (spRel realSp offset) WordRep)
+ (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
+ | (offset,size) <- tags
+ ])
\end{code}
%************************************************************************
Allocate a virtual offset for something.
+
\begin{code}
-allocAStack :: FCode VirtualSpAOffset
+allocStack :: FCode VirtualSpOffset
+allocStack = allocPrimStack 1
-allocAStack info_down (MkCgState absC binds
- ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
- = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
- where
- push_virt_a = virt_a + 1
-
- (chosen_slot, new_a_usage)
- = if null free_a then
- -- No free slots, so push a new one
- -- We need to adjust the high-water mark
- (push_virt_a, (push_virt_a, [], real_a, hw_a `max` push_virt_a))
- else
- -- Free slots available, so use one
- (free_slot, (virt_a, new_free_a, real_a, hw_a))
-
- (free_slot, _) = head ([f | f@(slot, st) <- free_a, not (isStubbed st)] ++ free_a)
- -- Try to find an un-stubbed location;
- -- if none, return the first in the free list
- -- We'll only try this if free_a is known to be non-empty
-
- -- Free list with the free_slot deleted
- new_free_a = [ f | f@(s,_) <- free_a, s /= free_slot ]
-
-allocBStack :: Int -> FCode VirtualSpBOffset
-allocBStack size info_down (MkCgState absC binds
- (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
- = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
+allocPrimStack :: Int -> FCode VirtualSpOffset
+allocPrimStack size info_down (MkCgState absC binds
+ ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
+ = (chosen_slot, MkCgState absC binds (new_stk_usage, h_usage))
where
- push_virt_b = virt_b + size
+ push_virt_sp = virt_sp + size
- (chosen_slot, new_b_usage)
- = case find_block free_b of
- Nothing -> (virt_b+1, (push_virt_b, free_b, real_b,
- hw_b `max` push_virt_b))
+ (chosen_slot, new_stk_usage)
+ = case find_block free_stk of
+ Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
+ hw_sp `max` push_virt_sp))
-- Adjust high water mark
- Just slot -> (slot, (virt_b, delete_block free_b slot, real_b, hw_b))
+ Just slot -> (slot, (virt_sp,
+ delete_block free_stk slot, real_sp, hw_sp))
-- find_block looks for a contiguous chunk of free slots
- find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset
+ find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset
find_block [] = Nothing
find_block (slot:slots)
- | take size (slot:slots) == [slot..slot+size-1]
- = Just slot
- | otherwise
- = find_block slots
-
- delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
+ | take size (slot:slots) == [slot..top_slot] = Just top_slot
+ | otherwise = find_block slots
+ -- The stack grows downwards, with increasing virtual offsets.
+ -- Therefore, the address of a multi-word object is the *highest*
+ -- virtual offset it occupies (top_slot below).
+ where top_slot = slot+size-1
+
+ delete_block free_stk slot = [s | s <- free_stk, (s<=slot-size) || (s>slot)]
-- Retain slots which are not in the range
- -- slot..slot+size-1
+ -- slot-size+1..slot
-- Allocate a chunk ON TOP OF the stack
-allocAStackTop :: Int -> FCode VirtualSpAOffset
-allocAStackTop size info_down (MkCgState absC binds
- ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
- = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
+allocStackTop :: Int -> FCode VirtualSpOffset
+allocStackTop size info_down (MkCgState absC binds
+ ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
+ = (push_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
where
- push_virt_a = virt_a + size
- chosen_slot = virt_a + 1
- new_a_usage = (push_virt_a, free_a, real_a, hw_a `max` push_virt_a)
+ push_virt_sp = virt_sp + size
+ new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
-- Adjust high water mark
+\end{code}
--- Allocate a chunk ON TOP OF the stack
-allocBStackTop :: Int -> FCode VirtualSpBOffset
-allocBStackTop size info_down (MkCgState absC binds
- (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
- = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
+Pop some words from the current top of stack. This is used for
+de-allocating the return address in a case alternative.
+
+\begin{code}
+deAllocStackTop :: Int -> FCode VirtualSpOffset
+deAllocStackTop size info_down (MkCgState absC binds
+ ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
+ = (pop_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
where
- push_virt_b = virt_b + size
- chosen_slot = virt_b+1
- new_b_usage = (push_virt_b, free_b, real_b, hw_b `max` push_virt_b)
- -- Adjust high water mark
+ pop_virt_sp = virt_sp - size
+ new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
\end{code}
-@allocUpdateFrame@ allocates enough space for an update frame
-on the B stack, records the fact in the end-of-block info (in the ``args''
+@allocUpdateFrame@ allocates enough space for an update frame on the
+stack, records the fact in the end-of-block info (in the ``args''
fields), and passes on the old ``args'' fields to the enclosed code.
This is all a bit disgusting.
\begin{code}
allocUpdateFrame :: Int -- Size of frame
- -> CAddrMode -- Return address which is to be the
- -- top word of frame
- -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
- -- Scope of update
+ -> Code -- Scope of update
-> Code
-allocUpdateFrame size update_amode code
- (MkCgInfoDown c_info statics (EndOfBlockInfo args_spa args_spb sequel))
- (MkCgState absc binds (a_usage, (vB,rr,qq,hwB),h_usage))
+allocUpdateFrame size code
+ (MkCgInfoDown c_info statics srt (EndOfBlockInfo args_Sp sequel))
+ (MkCgState absc binds ((vSp,rr,qq,hwSp),h_usage))
= case sequel of
- InRetReg -> code (args_spa, args_spb, vB)
- (MkCgInfoDown c_info statics new_eob_info)
- (MkCgState absc binds new_usage)
+ OnStack _ -> code (MkCgInfoDown c_info statics srt new_eob_info)
+ (MkCgState absc binds new_usage)
- other -> panic "allocUpdateFrame"
+ other -> panic "allocUpdateFrame"
where
- new_vB = vB + size
- new_eob_info = EndOfBlockInfo args_spa new_vB (UpdateCode update_amode)
- new_usage = (a_usage, (new_vB,rr,qq,hwB `max` new_vB), h_usage)
+ new_vSp = vSp + size
+ new_eob_info = EndOfBlockInfo new_vSp UpdateCode
+ new_usage = ((new_vSp,rr,qq,hwSp `max` new_vSp), h_usage)
\end{code}
+\begin{code}
+adjustStackHW :: VirtualSpOffset -> Code
+adjustStackHW offset info_down (MkCgState absC binds usage)
+ = MkCgState absC binds new_usage
+ where
+ ((vSp,fSp,realSp,hwSp), h_usage) = usage
+ new_usage = ((vSp, fSp, realSp, max offset hwSp), h_usage)
+ -- No need to fiddle with virtual Sp etc because this call is
+ -- only done just before the end of a block
+\end{code}
A knot-tying beast.
\begin{code}
-getFinalStackHW :: (VirtualSpAOffset -> VirtualSpBOffset -> Code) -> Code
+getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
where
- state1 = fcode hwSpA hwSpB info_down (MkCgState absC binds usages)
- (MkCgState _ _ ((_,_,_, hwSpA), (_,_,_, hwSpB), _)) = state1
+ state1 = fcode hwSp info_down (MkCgState absC binds usages)
+ (MkCgState _ _ ((_,_,_, hwSp), _)) = state1
\end{code}
That's done by functions which allocate stack space.
\begin{code}
-adjustRealSpA :: VirtualSpAOffset -- New offset for Arg stack ptr
+adjustRealSp :: VirtualSpOffset -- New offset for Arg stack ptr
-> Code
-adjustRealSpA newRealSpA info_down (MkCgState absC binds
- ((vspA,fA,realSpA,hwspA),
- b_usage, h_usage))
- = MkCgState (mkAbsCStmts absC move_instrA) binds new_usage
+adjustRealSp newRealSp info_down (MkCgState absC binds
+ ((vSp,fSp,realSp,hwSp), h_usage))
+ = MkCgState (mkAbsCStmts absC move_instr) binds new_usage
where
- move_instrA = if (newRealSpA == realSpA) then AbsCNop
+ move_instr = if (newRealSp == realSp) then AbsCNop
else (CAssign
- (CReg SpA)
- (CAddr (SpARel realSpA newRealSpA)))
- new_usage = ((vspA, fA, newRealSpA, hwspA),
- b_usage, h_usage)
+ (CReg Sp)
+ (CAddr (spRel realSp newRealSp)))
+ new_usage = ((vSp, fSp, newRealSp, hwSp), h_usage)
+\end{code}
-adjustRealSpB :: VirtualSpBOffset -- New offset for Basic/Control stack ptr
- -> Code
-adjustRealSpB newRealSpB info_down (MkCgState absC binds
- (a_usage,
- (vspB,fB,realSpB,hwspB),
- h_usage))
- = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
- where
- move_instrB = if (newRealSpB == realSpB) then AbsCNop
- else (CAssign {-PtrRep-}
- (CReg SpB)
- (CAddr (SpBRel realSpB newRealSpB)))
- new_usage = (a_usage,
- (vspB, fB, newRealSpB, hwspB),
- h_usage)
-
-adjustRealSps :: VirtualSpAOffset -- New offset for Arg stack ptr
- -> VirtualSpBOffset -- Ditto B stack
- -> Code
-adjustRealSps newRealSpA newRealSpB
- = adjustRealSpA newRealSpA `thenC` adjustRealSpB newRealSpB
+%************************************************************************
+%* *
+\subsection[CgStackery-free]{Free stack slots}
+%* *
+%************************************************************************
+
+Explicitly free some stack space.
+
+\begin{code}
+freeStackSlots :: [VirtualSpOffset] -> Code
+freeStackSlots extra_free info_down
+ state@(MkCgState abs_c binds ((vsp, free, real, hw), heap_usage))
+ = MkCgState abs_c binds new_usage
+ where
+ new_usage = ((new_vsp, new_free, real, hw), heap_usage)
+ (new_vsp, new_free) = trim vsp (addFreeSlots free extra_free)
+
+addFreeSlots :: [Int] -> [Int] -> [Int]
+addFreeSlots cs [] = cs
+addFreeSlots [] ns = ns
+addFreeSlots (c:cs) (n:ns)
+ = if c < n then
+ c : addFreeSlots cs (n:ns)
+ else if c > n then
+ n : addFreeSlots (c:cs) ns
+ else
+ panic ("addFreeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
+
+trim :: Int{-offset-} -> [Int] -> (Int{-offset-}, [Int])
+trim current_sp free_slots
+ = try current_sp (reverse free_slots)
+ where
+ try csp [] = (csp, [])
+ try csp (slot:slots)
+ = if csp < slot then
+ try csp slots -- Free slot off top of stk; ignore
+
+ else if csp == slot then
+ try (csp-1) slots -- Free slot at top of stk; trim
+
+ else
+ (csp, reverse (slot:slots)) -- Otherwise gap; give up
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgTailCall.lhs,v 1.16 1998/12/02 13:17:52 simonm Exp $
%
%********************************************************
%* *
\begin{code}
module CgTailCall (
cgTailCall,
- performReturn,
+ performReturn, performPrimReturn,
mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
+ mkUnboxedTupleReturnCode, returnUnboxedTuple,
mkPrimReturnCode,
- tailCallBusiness
+ tailCallFun,
+ tailCallPrimOp,
+ doTailCall,
+
+ pushReturnAddress
) where
#include "HsVersions.h"
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg,
+import CgRetConv ( dataReturnConvPrim,
ctrlReturnConvAlg, CtrlReturnConvention(..),
- DataReturnConvention(..)
+ assignAllRegs, assignRegs
)
-import CgStackery ( adjustRealSps, mkStkAmodes )
-import CgUsages ( getSpARelOffset )
-import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel, CLabel )
+import CgStackery ( adjustRealSp, mkTaggedStkAmodes, adjustStackHW )
+import CgUsages ( getSpRelOffset )
+import CgUpdate ( pushSeqFrame )
+import CLabel ( mkUpdEntryLabel, mkRtsPrimOpLabel )
import ClosureInfo ( nodeMustPointToIt,
getEntryConvention, EntryConvention(..),
LambdaFormInfo
)
import CmdLineOpts ( opt_DoSemiTagging )
-import HeapOffs ( zeroOff, VirtualSpAOffset )
-import Id ( idType, dataConTyCon, dataConTag,
- fIRST_TAG, Id
- )
-import Literal ( mkMachInt )
+import Id ( Id, idType, idName )
+import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
+import Const ( mkMachInt )
import Maybes ( assocMaybe )
import PrimRep ( PrimRep(..) )
-import StgSyn ( StgArg, GenStgArg(..), StgLiveVars )
-import Type ( isUnpointedType )
+import StgSyn ( StgArg, GenStgArg(..) )
+import Type ( isUnLiftedType )
import TyCon ( TyCon )
+import PrimOp ( PrimOp )
import Util ( zipWithEqual, panic, assertPanic )
\end{code}
%************************************************************************
\begin{code}
-cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
+cgTailCall :: Id -> [StgArg] -> Code
\end{code}
Here's the code we generate for a tail call. (NB there may be no
\item Adjust the stack high water mark appropriately.
\end{itemize}
-\begin{code}
-cgTailCall (StgConArg con) args live_vars
- = panic "cgTailCall StgConArg" -- Only occur in argument positions
-\end{code}
-
-Literals are similar to constructors; they return by putting
-themselves in an appropriate register and returning to the address on
-top of the B stack.
-
-\begin{code}
-cgTailCall (StgLitArg lit) [] live_vars
- = performPrimReturn (CLit lit) live_vars
-\end{code}
-
Treat unboxed locals exactly like literals (above) except use the addr
mode for the local instead of (CLit lit) in the assignment.
Case for unboxed @Ids@ first:
\begin{code}
-cgTailCall atom@(StgVarArg fun) [] live_vars
- | isUnpointedType (idType fun)
- = getCAddrMode fun `thenFC` \ amode ->
- performPrimReturn amode live_vars
+cgTailCall fun []
+ | isUnLiftedType (idType fun)
+ = getCAddrMode fun `thenFC` \ amode ->
+ performPrimReturn amode
\end{code}
The general case (@fun@ is boxed):
\begin{code}
-cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
+cgTailCall fun args = performTailCall fun args
\end{code}
%************************************************************************
%* *
%************************************************************************
-ADR-HACK
-
- A quick bit of hacking to try to solve my void#-leaking blues...
-
- I think I'm getting bitten by this stuff because code like
-
- \begin{pseudocode}
- case ds.s12 :: IoWorld of {
- -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
- IoWorld ds.s13# -> ds.s13#;
- } :: Universe#
- \end{pseudocode}
-
- causes me to try to allocate a register to return the result in. The
- hope is that the following will avoid such problems (and that Will
- will do this in a cleaner way when he hits the same problem).
-
-KCAH-RDA
-
\begin{code}
performPrimReturn :: CAddrMode -- The thing to return
- -> StgLiveVars
-> Code
-performPrimReturn amode live_vars
+performPrimReturn amode
= let
kind = getAmodeRep amode
ret_reg = dataReturnConvPrim kind
VoidRep -> AbsCNop
kind -> (CAssign (CReg ret_reg) amode)
in
- performReturn assign_possibly mkPrimReturnCode live_vars
+ performReturn assign_possibly mkPrimReturnCode
mkPrimReturnCode :: Sequel -> Code
-mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
+mkPrimReturnCode UpdateCode = panic "mkPrimReturnCode: Upd"
mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
absC (CReturn dest_amode DirectReturn)
-- Direct, no vectoring
--- All constructor arguments in registers; Node and InfoPtr are set.
+-- Constructor is built on the heap; Node is set.
-- All that remains is
-- (a) to set TagReg, if necessary
--- (b) to set InfoPtr to the info ptr, if necessary
-- (c) to do the right sort of jump.
-mkStaticAlgReturnCode :: Id -- The constructor
- -> Maybe CLabel -- The info ptr, if it isn't already set
+mkStaticAlgReturnCode :: DataCon -- The constructor
-> Sequel -- where to return to
-> Code
-mkStaticAlgReturnCode con maybe_info_lbl sequel
+mkStaticAlgReturnCode con sequel
= -- Generate profiling code if necessary
(case return_convention of
- VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
+ VectoredReturn sz -> profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz]
other -> nopC
) `thenC`
-- Generate the right jump or return
(case sequel of
- UpdateCode _ -> -- Ha! We know the constructor,
- -- so we can go direct to the correct
- -- update code for that constructor
-
- -- Set the info pointer, and jump
- set_info_ptr `thenC`
- absC (CJump (CLbl update_label CodePtrRep))
+ UpdateCode -> -- Ha! We can go direct to the update code,
+ -- (making sure to jump to the *correct* update
+ -- code.)
+ absC (CReturn (CLbl mkUpdEntryLabel CodePtrRep)
+ return_info)
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
- -- No need to set info ptr when returning to a
- -- known join point. After all, the code at
- -- the destination knows what constructor it
- -- is going to handle.
+ case assocMaybe alts tag of
+ Just (alt_absC, join_lbl) ->
+ absC (CJump (CLbl join_lbl CodePtrRep))
+ Nothing -> panic "mkStaticAlgReturnCode: default"
+ -- The Nothing case should never happen;
+ -- it's the subject of a wad of special-case
+ -- code in cgReturnCon
- case assocMaybe alts tag of
- Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
- Nothing -> panic "mkStaticAlgReturnCode: default"
- -- The Nothing case should never happen; it's the subject
- -- of a wad of special-case code in cgReturnCon
+ -- can't be a SeqFrame, because we're returning a constructor
- other -> -- OnStack, or (CaseAlts) ret_amode Nothing)
- -- Set the info pointer, and jump
- set_info_ptr `thenC`
+ other -> -- OnStack, or (CaseAlts ret_amode Nothing)
sequelToAmode sequel `thenFC` \ ret_amode ->
absC (CReturn ret_amode return_info)
)
zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
-- cf AbsCUtils.mkAlgAltsCSwitch
- update_label
- = case (dataReturnConvAlg con) of
- ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
+ return_info =
+ case return_convention of
+ UnvectoredReturn _ -> DirectReturn
+ VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
+
+mkUnboxedTupleReturnCode :: Sequel -> Code
+mkUnboxedTupleReturnCode sequel
+ = case sequel of
+ -- can't update with an unboxed tuple!
+ UpdateCode -> panic "mkUnboxedTupleReturnCode"
- return_info = case return_convention of
- UnvectoredReturn _ -> DirectReturn
- VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
+ CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) ->
+ absC (CJump (CLbl join_lbl CodePtrRep))
- set_info_ptr = case maybe_info_lbl of
- Nothing -> nopC
- Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
+ -- can't be a SeqFrame
+
+ other -> -- OnStack, or (CaseAlts ret_amode something)
+ sequelToAmode sequel `thenFC` \ ret_amode ->
+ absC (CReturn ret_amode DirectReturn)
+-- This function is used by PrimOps that return enumerated types (i.e.
+-- all the comparison operators).
mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
= case ctrlReturnConvAlg tycon of
VectoredReturn sz ->
- profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
+ profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
sequelToAmode sequel `thenFC` \ ret_addr ->
absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
-> (Sequel -> Code) -- The code to execute to actually do
-- the return, given an addressing mode
-- for the return address
- -> StgLiveVars
-> Code
-performReturn sim_assts finish_code live_vars
- = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+-- this is just a special case of doTailCall, later.
+performReturn sim_assts finish_code
+ = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-- Do the simultaneous assignments,
- doSimAssts args_spa live_vars sim_assts `thenC`
+ doSimAssts sim_assts `thenC`
- -- Adjust stack pointers
- adjustRealSps args_spa args_spb `thenC`
+ -- push a return address if necessary
+ -- (after the assignments above, in case we clobber a live
+ -- stack location)
+ pushReturnAddress eob `thenC`
+
+ -- Adjust stack pointer
+ adjustRealSp args_sp `thenC`
-- Do the return
finish_code sequel -- "sequel" is `robust' in that it doesn't
-- depend on stk-ptr values
\end{code}
+Returning unboxed tuples. This is mainly to support _ccall_GC_, where
+we want to do things in a slightly different order to normal:
+
+ - push return address
+ - adjust stack pointer
+ - r = call(args...)
+ - assign regs for unboxed tuple (usually just R1 = r)
+ - return to continuation
+
+The return address (i.e. stack frame) must be on the stack before
+doing the call in case the call ends up in the garbage collector.
+
+Sadly, the information about the continuation is lost after we push it
+(in order to avoid pushing it again), so we end up doing a needless
+indirect jump (ToDo).
+
\begin{code}
-performTailCall :: Id -- Function
+returnUnboxedTuple :: [CAddrMode] -> Code -> Code
+returnUnboxedTuple amodes before_jump
+ = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
+
+ -- push a return address if necessary
+ pushReturnAddress eob `thenC`
+ setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
+
+ -- Adjust stack pointer
+ adjustRealSp args_sp `thenC`
+
+ before_jump `thenC`
+
+ let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes)
+ in
+
+ doTailCall amodes ret_regs
+ mkUnboxedTupleReturnCode
+ (length leftovers) {- fast args arity -}
+ AbsCNop {-no pending assigments-}
+ Nothing {-not a let-no-escape-}
+ False {-node doesn't point-}
+ )
+\end{code}
+
+\begin{code}
+performTailCall :: Id -- Function
-> [StgArg] -- Args
- -> StgLiveVars
-> Code
-performTailCall fun args live_vars
+performTailCall fun args
= -- Get all the info we have about the function and args and go on to
-- the business end
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
- tailCallBusiness
+ tailCallFun
fun fun_amode lf_info arg_amodes
- live_vars AbsCNop {- No pending assignments -}
+ AbsCNop {- No pending assignments -}
+
+-- generating code for a tail call to a function (or closure)
-tailCallBusiness :: Id -> CAddrMode -- Function and its amode
+tailCallFun :: Id -> CAddrMode -- Function and its amode
-> LambdaFormInfo -- Info about the function
-> [CAddrMode] -- Arguments
- -> StgLiveVars -- Live in continuation
-> AbstractC -- Pending simultaneous assignments
- -- *** GUARANTEED to contain only stack assignments.
- -- In ptic, we don't need to look in here to
- -- discover all live regs
+ -- *** GUARANTEED to contain only stack
+ -- assignments.
+
+ -- In ptic, we don't need to look in
+ -- here to discover all live regs
-> Code
-tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
+tailCallFun fun fun_amode lf_info arg_amodes pending_assts
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- getEntryConvention fun lf_info
+ getEntryConvention (idName fun) lf_info
(map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
-
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
-
let
node_asst
= if node_points then
else
AbsCNop
- (arg_regs, finish_code)
+ (arg_regs, finish_code, arity)
= case entry_conv of
- ViaNode ->
+ ViaNode ->
([],
- mkAbstractCs [
- CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
- CJump (CMacroExpr CodePtrRep ENTRY_CODE [(CMacroExpr DataPtrRep INFO_PTR [CReg node])])
- ])
- StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
- StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
- `mkAbsCStmts`
- CJump (CLbl lbl CodePtrRep))
+ profCtrC SLIT("TICK_ENT_VIA_NODE") [] `thenC`
+ absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
+ [CVal (nodeRel 0) DataPtrRep]))
+ , 0)
+ StdEntry lbl -> ([], absC (CJump (CLbl lbl CodePtrRep)), 0)
DirectEntry lbl arity regs ->
- (regs, CJump (CLbl lbl CodePtrRep))
+ (regs, absC (CJump (CLbl lbl CodePtrRep)),
+ arity - length regs)
+
+ -- set up for a let-no-escape if necessary
+ join_sp = case fun_amode of
+ CJoinPoint sp -> Just sp
+ other -> Nothing
+ in
+ doTailCall arg_amodes arg_regs (const finish_code) arity
+ (mkAbstractCs [node_asst,pending_assts]) join_sp node_points
+
+
+-- this generic tail call code is used for both function calls and returns.
+
+doTailCall
+ :: [CAddrMode] -- args to pass to function
+ -> [MagicId] -- registers to use
+ -> (Sequel->Code) -- code to perform jump
+ -> Int -- number of "fast" stack arguments
+ -> AbstractC -- pending assignments
+ -> Maybe VirtualSpOffset -- sp offset to trim stack to
+ -> Bool -- node points to the closure to enter
+ -> Code
+
+doTailCall arg_amodes arg_regs finish_code arity pending_assts
+ maybe_join_sp node_points
+ = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
+ let
no_of_args = length arg_amodes
(reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
- -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
+ -- We get some stk_arg_amodes if (a) no regs, or
+ -- (b) args beyond arity
reg_arg_assts
- = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
+ = mkAbstractCs (zipWithEqual "assign_to_reg2"
+ assign_to_reg arg_regs reg_arg_amodes)
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
- in
- case fun_amode of
- CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
- ASSERT(not (args_spa > join_spa) || (args_spb > join_spb))
+ join_sp = case maybe_join_sp of
+ Just sp -> ASSERT(not (args_sp > sp)) sp
-- If ASSERTion fails: Oops: the join point has *lower*
-- stack ptrs than the continuation Note that we take
- -- the SpB point without the return address here. The
+ -- the Sp point without the return address here. The
-- return address is put on by the let-no-escapey thing
-- when it finishes.
+ Nothing -> args_sp
- mkStkAmodes join_spa join_spb stk_arg_amodes
- `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
-
- -- Do the simultaneous assignments,
- doSimAssts join_spa live_vars
- (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
- `thenC`
-
- -- Adjust stack ptrs
- adjustRealSps final_spa final_spb `thenC`
-
- -- Jump to join point
- absC finish_code
-
- _ -> -- else: not a let-no-escape (the common case)
+ (fast_stk_amodes, tagged_stk_amodes) =
+ splitAt arity stk_arg_amodes
+ in
+ -- We can omit tags on the arguments passed to the fast entry point,
+ -- but we have to be careful to fill in the tags on any *extra*
+ -- arguments we're about to push on the stack.
- -- Make instruction to save return address
- loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
+ mkTaggedStkAmodes join_sp tagged_stk_amodes `thenFC`
+ \ (fast_sp, tagged_arg_assts, tag_assts) ->
- mkStkAmodes args_spa args_spb stk_arg_amodes
- `thenFC`
- \ (final_spa, final_spb, stk_arg_assts) ->
+ mkTaggedStkAmodes fast_sp fast_stk_amodes `thenFC`
+ \ (final_sp, fast_arg_assts, _) ->
- -- The B-stack space for the pushed return addess, with any args pushed
- -- on top, is recorded in final_spb.
+ -- adjust the high-water mark if necessary
+ adjustStackHW final_sp `thenC`
+ -- The stack space for the pushed return addess,
+ -- with any args pushed on top, is recorded in final_sp.
+
-- Do the simultaneous assignments,
- doSimAssts args_spa live_vars
- (mkAbstractCs [pending_assts, node_asst, ret_asst,
- reg_arg_assts, stk_arg_assts])
- `thenC`
-
- -- Final adjustment of stack pointers
- adjustRealSps final_spa final_spb `thenC`
-
+ doSimAssts (mkAbstractCs [pending_assts,
+ reg_arg_assts,
+ fast_arg_assts,
+ tagged_arg_assts,
+ tag_assts]) `thenC`
+
+ -- push a return address if necessary
+ -- (after the assignments above, in case we clobber a live
+ -- stack location)
+ pushReturnAddress eob `thenC`
+
+ -- Final adjustment of stack pointer
+ adjustRealSp final_sp `thenC`
+
-- Now decide about semi-tagging
- let
+ let
semi_tagging_on = opt_DoSemiTagging
- in
- case (semi_tagging_on, arg_amodes, node_points, sequel) of
+ in
+ case (semi_tagging_on, arg_amodes, node_points, sequel) of
--
-- *************** The semi-tagging case ***************
--
+ {- XXX leave this out for now.
( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
-- Whoppee! Semi-tagging rules OK!
(semi_tagged_alts)
(join_details_to_code details))
])
+ -}
--
-- *************** The non-semi-tagging case ***************
--
- other -> absC finish_code
+ other -> finish_code sequel
\end{code}
-\begin{code}
-loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
-
-loadRetAddrIntoRetReg InRetReg
- = returnFC AbsCNop -- Return address already there
-
-loadRetAddrIntoRetReg sequel
- = sequelToAmode sequel `thenFC` \ amode ->
- returnFC (CAssign (CReg RetReg) amode)
+%************************************************************************
+%* *
+\subsection[tailCallPrimOp]{@tailCallPrimOp@}
+%* *
+%************************************************************************
+\begin{code}
+tailCallPrimOp :: PrimOp -> [StgArg] -> Code
+tailCallPrimOp op args =
+ -- we're going to perform a normal-looking tail call,
+ -- except that *all* the arguments will be in registers.
+ getArgAmodes args `thenFC` \ arg_amodes ->
+ let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes)
+ in
+ ASSERT(null leftovers) -- no stack-resident args
+ doTailCall arg_amodes arg_regs
+ (const (absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))))
+ 0 {- arity shouldn't matter, all args in regs -}
+ AbsCNop {- no pending assignments -}
+ Nothing {- not a let-no-escape -}
+ False {- node doesn't point -}
\end{code}
%************************************************************************
They are separate because we sometimes do some jiggery-pokery in between.
\begin{code}
-doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
- -> StgLiveVars -- Live in continuation
- -> AbstractC
- -> Code
-
-doSimAssts tail_spa live_vars sim_assts
- = -- Do the simultaneous assignments
- absC (CSimultaneous sim_assts) `thenC`
-
- -- Stub any unstubbed slots; the only live variables are indicated in
- -- the end-of-block info in the monad
- nukeDeadBindings live_vars `thenC`
- getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
- -- Passing in tail_spa here should actually be redundant, because
- -- the stack should be trimmed (by nukeDeadBindings) to
- -- exactly the tail_spa position anyhow.
-
- -- Emit code to stub dead regs; this only generates actual
- -- machine instructions in in the DEBUG version
- -- *** NOT DONE YET ***
-
- (if (null a_slots)
- then nopC
- else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
- mapCs stub_A_slot a_slots
- )
- where
- stub_A_slot :: VirtualSpAOffset -> Code
- stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
- absC (CAssign (CVal spa_rel PtrRep)
- (CReg StkStubReg))
+doSimAssts :: AbstractC -> Code
+
+doSimAssts sim_assts
+ = absC (CSimultaneous sim_assts)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[retAddr]{@Return Addresses@}
+%* *
+%************************************************************************
+
+We always push the return address just before performing a tail call
+or return. The reason we leave it until then is because the stack
+slot that the return address is to go into might contain something
+useful.
+
+If the end of block info is CaseAlts, then we're in the scrutinee of a
+case expression and the return address is still to be pushed.
+
+There are cases where it doesn't look necessary to push the return
+address: for example, just before doing a return to a known
+continuation. However, the continuation will expect to find the
+return address on the stack in case it needs to do a heap check.
+
+\begin{code}
+pushReturnAddress :: EndOfBlockInfo -> Code
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _)) =
+ getSpRelOffset args_sp `thenFC` \ sp_rel ->
+ absC (CAssign (CVal sp_rel RetRep) amode)
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(SeqFrame amode _)) =
+ pushSeqFrame args_sp `thenFC` \ ret_sp ->
+ getSpRelOffset ret_sp `thenFC` \ sp_rel ->
+ absC (CAssign (CVal sp_rel RetRep) amode)
+pushReturnAddress _ = nopC
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CgUpdate]{Manipulating update frames}
\begin{code}
-module CgUpdate ( pushUpdateFrame ) where
+module CgUpdate ( pushUpdateFrame, reserveSeqFrame, pushSeqFrame ) where
#include "HsVersions.h"
import CgMonad
import AbsCSyn
-import Constants ( sTD_UF_SIZE, sCC_STD_UF_SIZE )
+import Constants ( uF_SIZE, sCC_UF_SIZE, sEQ_FRAME_SIZE )
+import PrimRep ( PrimRep(..) )
import CgStackery ( allocUpdateFrame )
+import CgUsages ( getSpRelOffset )
import CmdLineOpts ( opt_SccProfilingOn )
import Util ( assertPanic )
\end{code}
to reflect the frame pushed.
\begin{code}
-pushUpdateFrame :: CAddrMode -> CAddrMode -> Code -> Code
+pushUpdateFrame :: CAddrMode -> Code -> Code
-pushUpdateFrame updatee vector code
+pushUpdateFrame updatee code
= let
- profiling_on = opt_SccProfilingOn
-
-- frame_size *includes* the return address
- frame_size = if profiling_on
- then sCC_STD_UF_SIZE
- else sTD_UF_SIZE
+ frame_size = if opt_SccProfilingOn
+ then sCC_UF_SIZE
+ else uF_SIZE
in
getEndOfBlockInfo `thenFC` \ eob_info ->
- ASSERT(case eob_info of { EndOfBlockInfo _ _ InRetReg -> True; _ -> False})
- allocUpdateFrame frame_size vector (\ _ ->
+ ASSERT(case eob_info of { EndOfBlockInfo _ (OnStack _) -> True;
+ _ -> False})
+ allocUpdateFrame frame_size (
-- Emit the push macro
- absC (CMacroStmt PUSH_STD_UPD_FRAME [
+ absC (CMacroStmt PUSH_UPD_FRAME [
updatee,
- int_CLit0, -- Known to be zero because we have just
- int_CLit0 -- entered a thunk
+ int_CLit0 -- Known to be zero because we have just
])
`thenC` code
)
int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh)
-{- ---------------------
- What actually happens is something like this; but it got macro-ised
-
- = pushOnBStack (CReg CurCostCentre) `thenFC` \ _ ->
- pushOnBStack (CReg SuA) `thenFC` \ _ ->
- pushOnBStack (CReg SuB) `thenFC` \ _ ->
- pushOnBStack updatee `thenFC` \ _ ->
- pushOnBStack (CLabel sTD_UPD_RET_VEC_LABEL CodePtrRep) `thenFC` \ _ ->
-
- -- MAKE SuA, SuB POINT TO TOP OF A,B STACKS
- -- Remember, SpB hasn't yet been incremented to account for the
- -- 4-word update frame which has been pushed.
- -- This code seems crude, but effective...
- absC (AbsCStmts (CAssign (CReg SuA) (CReg SpA))
- (CAssign (CReg SuB) (CAddr (SpBRel 0 4))))
--------------------------- -}
+\end{code}
+
+We push a SEQ frame just before evaluating the scrutinee of a case, if
+the scrutinee has a polymorphic or function type. The SEQ frame acts
+as a barrier in case the scrutinee evaluates to a partial application.
+
+reserveSeqFrame takes the EndOfBlockInfo for the case expression and
+updates the sequel to a SeqFrame, reserving room for the frame at
+args_sp. When the scrutinee comes around to pushing a return address,
+it will also push the SEQ frame, using pushSeqFrame.
+
+\begin{code}
+reserveSeqFrame :: EndOfBlockInfo -> EndOfBlockInfo
+reserveSeqFrame (EndOfBlockInfo args_sp (CaseAlts amode stuff))
+ = EndOfBlockInfo (args_sp + sEQ_FRAME_SIZE) (SeqFrame amode stuff)
+
+pushSeqFrame :: VirtualSpOffset -> FCode VirtualSpOffset
+pushSeqFrame args_sp
+ = getSpRelOffset args_sp `thenFC` \ sp_rel ->
+ absC (CMacroStmt PUSH_SEQ_FRAME [CAddr sp_rel]) `thenC`
+ returnFC (args_sp - sEQ_FRAME_SIZE)
\end{code}
_interface_ CgUsages 1
_exports_
-CgUsages getSpBRelOffset;
+CgUsages getSpRelOffset;
_declarations_
-1 getSpBRelOffset _:_ HeapOffs.VirtualSpBOffset -> CgMonad.FCode AbsCSyn.RegRelative ;;
+1 getSpRelOffset _:_ AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.RegRelative ;;
--- /dev/null
+__interface CgUsages 1 0 where
+__export CgUsages getSpRelOffset;
+1 getSpRelOffset :: AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.RegRelative ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CgUsages]{Accessing and modifying stacks and heap usage info}
\begin{code}
module CgUsages (
initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
- setRealAndVirtualSps,
+ setRealAndVirtualSp,
- getVirtSps,
+ getVirtSp, getRealSp,
- getHpRelOffset, getSpARelOffset, getSpBRelOffset,
-
- freeBStkSlot
+ getHpRelOffset, getSpRelOffset
) where
#include "HsVersions.h"
-import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode )
+import AbsCSyn ( RegRelative(..), VirtualHeapOffset, VirtualSpOffset,
+ hpRel, spRel )
import CgMonad
-import HeapOffs ( zeroOff,
- VirtualHeapOffset,
- VirtualSpAOffset,
- VirtualSpBOffset
- )
-import Id ( IdEnv )
\end{code}
%************************************************************************
\begin{code}
initHeapUsage :: (VirtualHeapOffset -> Code) -> Code
-initHeapUsage fcode info_down (MkCgState absC binds (a_usage, b_usage, heap_usage))
+initHeapUsage fcode info_down (MkCgState absC binds (stk_usage, heap_usage))
= state3
where
- state1 = MkCgState absC binds (a_usage, b_usage, (zeroOff, zeroOff))
+ state1 = MkCgState absC binds (stk_usage, (0, 0))
state2 = fcode (heapHWM heap_usage2) info_down state1
- (MkCgState absC2 binds2 (a_usage2, b_usage2, heap_usage2)) = state2
+ (MkCgState absC2 binds2 (stk_usage2, heap_usage2)) = state2
state3 = MkCgState absC2
binds2
- (a_usage2, b_usage2, heap_usage {- unchanged -})
+ (stk_usage2, heap_usage {- unchanged -})
\end{code}
\begin{code}
setVirtHp :: VirtualHeapOffset -> Code
setVirtHp new_virtHp info_down
- state@(MkCgState absC binds (a_stk, b_stk, (virtHp, realHp)))
- = MkCgState absC binds (a_stk, b_stk, (new_virtHp, realHp))
+ state@(MkCgState absC binds (stk, (virtHp, realHp)))
+ = MkCgState absC binds (stk, (new_virtHp, realHp))
\end{code}
\begin{code}
getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset)
-getVirtAndRealHp info_down state@(MkCgState _ _ (au, bu, (virtHp, realHp)))
+getVirtAndRealHp info_down state@(MkCgState _ _ (_, (virtHp, realHp)))
= ((virtHp, realHp), state)
\end{code}
\begin{code}
setRealHp :: VirtualHeapOffset -> Code
-setRealHp realHp info_down (MkCgState absC binds (au, bu, (vHp, _)))
- = MkCgState absC binds (au, bu, (vHp, realHp))
+setRealHp realHp info_down (MkCgState absC binds (stk_usage, (vHp, _)))
+ = MkCgState absC binds (stk_usage, (vHp, realHp))
\end{code}
\begin{code}
getHpRelOffset :: VirtualHeapOffset -> FCode RegRelative
-getHpRelOffset virtual_offset info_down state@(MkCgState _ _ (_,_,(_,realHp)))
- = (HpRel realHp virtual_offset, state)
+getHpRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,realHp)))
+ = (hpRel realHp virtual_offset, state)
\end{code}
The heap high water mark is the larger of virtHp and hwHp. The latter is
%* *
%************************************************************************
-@setRealAndVirtualSps@ sets into the environment the offsets of the
+@setRealAndVirtualSp@ sets into the environment the offsets of the
current position of the real and virtual stack pointers in the current
stack frame. The high-water mark is set too. It generates no code.
It is used to initialise things at the beginning of a closure body.
\begin{code}
-setRealAndVirtualSps :: VirtualSpAOffset -- New real SpA
- -> VirtualSpBOffset -- Ditto B stack
+setRealAndVirtualSp :: VirtualSpOffset -- New real Sp
-> Code
-setRealAndVirtualSps spA spB info_down (MkCgState absC binds
- ((vspA,fA,realSpA,hwspA),
- (vspB,fB,realSpB,hwspB),
- h_usage))
+setRealAndVirtualSp sp info_down (MkCgState absC binds
+ ((vsp,f,realSp,hwsp), h_usage))
= MkCgState absC binds new_usage
where
- new_usage = ((spA, fA, spA, spA),
- (spB, fB, spB, spB),
- h_usage)
+ new_usage = ((sp, f, sp, sp), h_usage)
\end{code}
\begin{code}
-getVirtSps :: FCode (VirtualSpAOffset,VirtualSpBOffset)
-getVirtSps info_down state@(MkCgState absC binds ((virtSpA,_,_,_), (virtSpB,_,_,_), _))
- = ((virtSpA,virtSpB), state)
-\end{code}
+getVirtSp :: FCode VirtualSpOffset
+getVirtSp info_down state@(MkCgState absC binds ((virtSp,_,_,_), _))
+ = (virtSp, state)
-\begin{code}
-getSpARelOffset :: VirtualSpAOffset -> FCode RegRelative
-getSpARelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSpA,_),_,_))
- = (SpARel realSpA virtual_offset, state)
-
-getSpBRelOffset :: VirtualSpBOffset -> FCode RegRelative
-getSpBRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,_,realSpB,_),_))
- = (SpBRel realSpB virtual_offset, state)
+getRealSp :: FCode VirtualSpOffset
+getRealSp info_down state@(MkCgState absC binds ((_,_,realSp,_),_))
+ = (realSp,state)
\end{code}
\begin{code}
-freeBStkSlot :: VirtualSpBOffset -> Code
-freeBStkSlot b_slot info_down
- state@(MkCgState absC binds (spa_usage, (virtSpB,free_b,realSpB,hwSpB), heap_usage))
- = MkCgState absC binds (spa_usage, (virtSpB,new_free_b,realSpB,hwSpB), heap_usage)
- where
- new_free_b = addFreeBSlots free_b [b_slot]
+getSpRelOffset :: VirtualSpOffset -> FCode RegRelative
+getSpRelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSp,_),_))
+ = (spRel realSp virtual_offset, state)
\end{code}
_interface_ ClosureInfo 1
_exports_
-ClosureInfo ClosureInfo LambdaFormInfo
- ;
+ClosureInfo ClosureInfo LambdaFormInfo;
_declarations_
--- 1 infoTableLabelFromCI _:_ ClosureInfo -> CLabel ;;
--- 1 closureSMRep _:_ ClosureInfo -> SMRep.SMRep ;;
--- 1 closureSizeWithoutFixedHdr _:_ ClosureInfo -> HeapOffs.HeapOffset ;;
--- 1 closureTypeDescr _:_ ClosureInfo -> PrelBase.String ;;
--- 1 closureLabelFromCI _:_ ClosureInfo -> CLabel ;;
-
1 data LambdaFormInfo;
1 data ClosureInfo;
--- /dev/null
+__interface ClosureInfo 1 0 where
+__export ClosureInfo ClosureInfo LambdaFormInfo;
+1 data LambdaFormInfo;
+1 data ClosureInfo;
-
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: ClosureInfo.lhs,v 1.31 1998/12/02 13:17:55 simonm Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
EntryConvention(..),
- mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo,
- mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
+ mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
UpdateFlag,
- closureSize, closureHdrSize,
- closureNonHdrSize, closureSizeWithoutFixedHdr,
+ closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
- slopSize, fitsMinUpdSize,
+ slopSize,
layOutDynClosure, layOutDynCon, layOutStaticClosure,
- layOutStaticNoFVClosure, layOutPhantomClosure,
+ layOutStaticNoFVClosure,
mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
staticClosureRequired,
slowFunEntryCodeRequired, funInfoTableRequired,
- stdVapRequired, noUpdVapRequired,
- StgBinderInfo,
- closureId, infoTableLabelFromCI, fastLabelFromCI,
+ closureName, infoTableLabelFromCI, fastLabelFromCI,
closureLabelFromCI,
entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
- closureSingleEntry, closureSemiTag, closureType,
- closureReturnsUnpointedType, getStandardFormThunkInfo,
+ closureSingleEntry, closureSemiTag,
+ isStandardFormThunk,
GenStgArg,
isToplevClosure,
- closureKind, closureTypeDescr, -- profiling
+ closureTypeDescr, -- profiling
- isStaticClosure, allocProfilingMsg,
+ isStaticClosure,
+ allocProfilingMsg,
blackHoleClosureInfo,
maybeSelectorInfo,
-
- dataConLiveness -- concurrency
+ needsSRT
) where
#include "HsVersions.h"
-import AbsCSyn ( MagicId, node, mkLiveRegsMask,
- {- GHC 0.29 only -} AbstractC, CAddrMode
- )
+import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset )
import StgSyn
import CgMonad
-import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
- mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
- mAX_SPEC_ALL_NONPTRS,
- oTHER_TAG
- )
-import CgRetConv ( assignRegs, dataReturnConvAlg,
- DataReturnConvention(..)
- )
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
+import CgRetConv ( assignRegs )
import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
- mkPhantomInfoTableLabel, mkInfoTableLabel,
+ mkInfoTableLabel,
mkConInfoTableLabel, mkStaticClosureLabel,
- mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
+ mkBlackHoleInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
- mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
+ mkConEntryLabel, mkClosureLabel,
+ mkSelectorInfoLabel, mkSelectorEntryLabel,
+ mkApInfoTableLabel, mkApEntryLabel,
+ mkReturnPtLabel
)
-import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
-import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
- VirtualHeapOffset, HeapOffset
- )
-import Id ( idType, getIdArity,
- externallyVisibleId,
- dataConTag, fIRST_TAG,
- isDataCon, isNullaryDataCon, dataConTyCon,
- isTupleCon, DataCon,
- GenId{-instance Eq-}, Id
+import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
+ opt_Parallel )
+import Id ( Id, idType, getIdArity )
+import DataCon ( DataCon, dataConTag, fIRST_TAG,
+ isNullaryDataCon, isTupleCon, dataConName
)
import IdInfo ( ArityInfo(..) )
-import Maybes ( maybeToBool )
-import Name ( getOccString )
+import Name ( Name, isExternallyVisibleName, nameUnique )
import PprType ( getTyDescription )
-import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
import SMRep -- all of it
-import TyCon ( TyCon, isNewTyCon )
-import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys,
- splitAlgTyConApp_maybe, applyTys,
- Type
- )
-import Util ( isIn, mapAccumL )
+import Type ( isUnLiftedType, Type )
+import BasicTypes ( TopLevelFlag(..) )
+import Util ( mapAccumL )
import Outputable
\end{code}
\begin{code}
data ClosureInfo
= MkClosureInfo
- Id -- The thing bound to this closure
+ Name -- The thing bound to this closure
LambdaFormInfo -- info derivable from the *source*
SMRep -- representation used by storage manager
\end{code}
%************************************************************************
%* *
-\subsection[ClosureInfo-OLD-DOC]{OLD DOCUMENTATION PROBABLY SUPERCEDED BY stg-details}
-%* *
-%************************************************************************
-
-We can optimise the function-entry code as follows.
-\begin{itemize}
-
-\item If the ``function'' is not updatable, we can jump directly to its
- entry code, rather than indirecting via the info pointer in the
- closure. (For updatable thunks we must go via the closure, in
- case it has been updated.)
-
-\item If the former bullet applies, and the application we are
- compiling gives the function as many arguments as it needs, we
- can jump to its fast-entry code. (This only applies if the
- function has one or more args, because zero-arg closures have
- no fast-entry code.)
-
-\item If the function is a top-level non-constructor or imported, there
- is no need to make Node point to its closure. In order for
- this to be right, we need to ensure that:
- \begin{itemize}
- \item If such closures are updatable then they push their
- static address in the update frame, not Node. Actually
- we create a black hole and push its address.
-
- \item The arg satisfaction check should load Node before jumping to
- UpdatePAP.
-
- \item Top-level constructor closures need careful handling. If we are to
- jump direct to the constructor code, we must load Node first, even
- though they are top-level. But if we go to their ``own''
- standard-entry code (which loads Node and then jumps to the
- constructor code) we don't need to load Node.
- \end{itemize}
-\end{itemize}
-
-
-{\em Top level constructors (@mkStaticConEntryInfo@)}
-
-\begin{verbatim}
- x = {y,ys} \ {} Cons {y,ys} -- Std form constructor
-\end{verbatim}
-
-x-closure: Cons-info-table, y-closure, ys-closure
-
-x-entry: Node = x-closure; jump( Cons-entry )
-
-x's EntryInfo in its own module:
-\begin{verbatim}
- Base-label = Cons -- Not x!!
- NodeMustPoint = True
- ClosureClass = Constructor
-\end{verbatim}
-
- So if x is entered, Node will be set up and
- we'll jump direct to the Cons code.
-
-x's EntryInfo in another module: (which may not know that x is a constructor)
-\begin{verbatim}
- Base-label = x -- Is x!!
- NodeMustPoint = False -- All imported things have False
- ClosureClass = non-committal
-\end{verbatim}
-
- If x is entered, we'll jump to x-entry, which will set up Node
- before jumping to the standard Cons code
-
-{\em Top level non-constructors (@mkStaticEntryInfo@)}
-\begin{verbatim}
- x = ...
-\end{verbatim}
-
-For updatable thunks, x-entry must push an allocated BH in update frame, not Node.
-
-For non-zero arity, arg satis check must load Node before jumping to
- UpdatePAP.
-
-x's EntryInfo in its own module:
-\begin{verbatim}
- Base-label = x
- NodeMustPoint = False
- ClosureClass = whatever
-\end{verbatim}
-
-{\em Inner constructors (@mkConEntryInfo@)}
-
-\begin{verbatim}
- Base-label = Cons -- Not x!!
- NodeMustPoint = True -- If its arity were zero, it would
- -- have been lifted to top level
- ClosureClass = Constructor
-\end{verbatim}
-
-{\em Inner non-constructors (@mkEntryInfo@)}
-
-\begin{verbatim}
- Base-label = x
- NodeMustPoint = True -- If no free vars, would have been
- -- lifted to top level
- ClosureClass = whatever
-\end{verbatim}
-
-{\em Imported}
-
-\begin{verbatim}
- Nothing,
- or
- Base-label = x
- NodeMustPoint = False
- ClosureClass = whatever
-\end{verbatim}
-
-==============
-THINK: we could omit making Node point to top-level constructors
-of arity zero; but that might interact nastily with updates.
-==============
-
-
-==========
-The info we need to import for imported things is:
-
-\begin{verbatim}
- data ImportInfo = UnknownImportInfo
- | HnfImport Int -- Not updatable, arity given
- -- Arity can be zero, for (eg) constrs
- | UpdatableImport -- Must enter via the closure
-\end{verbatim}
-
-ToDo: move this stuff???
-
-\begin{pseudocode}
-mkStaticEntryInfo lbl cl_class
- = MkEntryInfo lbl False cl_class
-
-mkStaticConEntryInfo lbl
- = MkEntryInfo lbl True ConstructorClosure
-
-mkEntryInfo lbl cl_class
- = MkEntryInfo lbl True cl_class
-
-mkConEntryInfo lbl
- = MkEntryInfo lbl True ConstructorClosure
-\end{pseudocode}
-
-%************************************************************************
-%* *
\subsection[ClosureInfo-datatypes]{Data types for closure information}
%* *
%************************************************************************
\begin{code}
data LambdaFormInfo
= LFReEntrant -- Reentrant closure; used for PAPs too
- Bool -- True if top level
- Int -- Arity
- Bool -- True <=> no fvs
+ Type -- Type of closure (ToDo: remove)
+ TopLevelFlag -- True if top level
+ !Int -- Arity
+ !Bool -- True <=> no fvs
| LFCon -- Constructor
- DataCon -- The constructor (may be specialised)
+ DataCon -- The constructor
Bool -- True <=> zero arity
| LFTuple -- Tuples
- DataCon -- The tuple constructor (may be specialised)
+ DataCon -- The tuple constructor
Bool -- True <=> zero arity
| LFThunk -- Thunk (zero arity)
- Bool -- True <=> top level
- Bool -- True <=> no free vars
+ Type -- Type of the thunk (ToDo: remove)
+ TopLevelFlag
+ !Bool -- True <=> no free vars
Bool -- True <=> updatable (i.e., *not* single-entry)
StandardFormInfo
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
Int -- arity;
- StgLiveVars-- list of variables live in the RHS of the let.
- -- (ToDo: maybe not used)
| LFBlackHole -- Used for the closures allocated to hold the result
+
-- of a CAF. We want the target of the update frame to
-- be in the heap, so we make a black hole to hold it.
- -- This last one is really only for completeness;
- -- it isn't actually used for anything interesting
- {- | LFIndirection -}
data StandardFormInfo -- Tells whether this thunk has one of a small number
-- of standard forms
= NonStandardThunk -- No, it isn't
- | SelectorThunk
- Id -- Scrutinee
- DataCon -- Constructor
- Int -- 0-origin offset of ak within the "goods" of constructor
- -- (Recall that the a1,...,an may be laid out in the heap
- -- in a non-obvious order.)
+ | SelectorThunk
+ Int -- 0-origin offset of ak within the "goods" of
+ -- constructor (Recall that the a1,...,an may be laid
+ -- out in the heap in a non-obvious order.)
{- A SelectorThunk is of form
con a1,..,an -> ak
and the constructor is from a single-constr type.
- If we can't convert the heap-offset of the selectee into an Int, e.g.,
- it's "GEN_VHS+i", we just give up.
-}
- | VapThunk
- Id -- Function
- [StgArg] -- Args
- Bool -- True <=> the function is not top-level, so
- -- must be stored in the thunk too
+ | ApThunk
+ Int -- arity
-{- A VapThunk is of form
+{- An ApThunk is of form
- f a1 ... an
+ x1 ... xn
- where f is a known function, with arity n
- So for this thunk we can use the label for f's heap-entry
- info table (generated when f's defn was dealt with),
- rather than generating a one-off info table and entry code
- for this one thunk.
+ The code for the thunk just pushes x2..xn on the stack and enters x1.
+ There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+ in the RTS to save space.
-}
-
-mkLFArgument = LFArgument
-mkLFBlackHole = LFBlackHole
-mkLFLetNoEscape = LFLetNoEscape
-
-mkLFImported :: Id -> LambdaFormInfo
-mkLFImported id
- = case getIdArity id of
- ArityExactly 0 -> LFThunk True{-top-lev-} True{-no fvs-}
- True{-updatable-} NonStandardThunk
- ArityExactly n -> LFReEntrant True n True -- n > 0
- other -> LFImported -- Not sure of exact arity
\end{code}
%************************************************************************
@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure.
\begin{code}
-mkClosureLFInfo :: Bool -- True of top level
+mkClosureLFInfo :: Id -- The binder
+ -> TopLevelFlag -- True of top level
-> [Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
-> LambdaFormInfo
-mkClosureLFInfo top fvs upd_flag args@(_:_) -- Non-empty args
- = LFReEntrant top (length args) (null fvs)
+mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
+ = LFReEntrant (idType bndr) top (length args) (null fvs)
-mkClosureLFInfo top fvs ReEntrant []
- = LFReEntrant top 0 (null fvs)
+mkClosureLFInfo bndr top fvs ReEntrant []
+ = LFReEntrant (idType bndr) top 0 (null fvs)
-mkClosureLFInfo top fvs upd_flag []
- = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
-
-isUpdatable ReEntrant = False
-isUpdatable SingleEntry = False
-isUpdatable Updatable = True
+mkClosureLFInfo bndr top fvs upd_flag []
+#ifdef DEBUG
+ | isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty)
+#endif
+ | otherwise
+ = LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk
+ where
+ ty = idType bndr
\end{code}
@mkConLFInfo@ is similar, for constructors.
= -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
(if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
-mkSelectorLFInfo scrutinee con offset
- = LFThunk False False True (SelectorThunk scrutinee con offset)
+mkSelectorLFInfo rhs_ty offset updatable
+ = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset)
-mkVapLFInfo fvs upd_flag fun_id args fun_in_vap
- = LFThunk False (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args fun_in_vap)
+mkApLFInfo rhs_ty upd_flag arity
+ = LFThunk rhs_ty NotTopLevel (arity == 0) (isUpdatable upd_flag)
+ (ApThunk arity)
\end{code}
+Miscellaneous LF-infos.
+
+\begin{code}
+mkLFArgument = LFArgument
+mkLFBlackHole = LFBlackHole
+mkLFLetNoEscape = LFLetNoEscape
+
+mkLFImported :: Id -> LambdaFormInfo
+mkLFImported id
+ = case getIdArity id of
+ ArityExactly 0 -> LFThunk (idType id)
+ TopLevel True{-no fvs-}
+ True{-updatable-} NonStandardThunk
+ ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0
+ other -> LFImported -- Not sure of exact arity
+\end{code}
%************************************************************************
%* *
\begin{code}
closureSize :: ClosureInfo -> HeapOffset
closureSize cl_info@(MkClosureInfo _ _ sm_rep)
- = totHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
-
-closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
-closureSizeWithoutFixedHdr cl_info@(MkClosureInfo _ _ sm_rep)
- = varHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
-
-closureHdrSize :: ClosureInfo -> HeapOffset
-closureHdrSize (MkClosureInfo _ _ sm_rep)
- = totHdrSize sm_rep
+ = fixedHdrSize + closureNonHdrSize cl_info
closureNonHdrSize :: ClosureInfo -> Int
closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) --ToDo: pass lf_info?
+ = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info)
+ --ToDo: pass lf_info?
where
tot_wds = closureGoodStuffSize cl_info
in ptrs
-- not exported:
-sizes_from_SMRep (SpecialisedRep k ptrs nonptrs _) = (ptrs, nonptrs)
+sizes_from_SMRep :: SMRep -> (Int,Int)
sizes_from_SMRep (GenericRep ptrs nonptrs _) = (ptrs, nonptrs)
-sizes_from_SMRep (BigTupleRep ptrs) = (ptrs, 0)
-sizes_from_SMRep (MuTupleRep ptrs) = (ptrs, 0)
-sizes_from_SMRep (DataRep nonptrs) = (0, nonptrs)
+sizes_from_SMRep (StaticRep ptrs nonptrs _) = (ptrs, nonptrs)
+sizes_from_SMRep ConstantRep = (0, 0)
sizes_from_SMRep BlackHoleRep = (0, 0)
-sizes_from_SMRep (StaticRep ptrs nonptrs) = (ptrs, nonptrs)
-#ifdef DEBUG
-sizes_from_SMRep PhantomRep = panic "sizes_from_SMRep: PhantomRep"
-sizes_from_SMRep DynamicRep = panic "sizes_from_SMRep: DynamicRep"
-#endif
-\end{code}
-
-\begin{code}
-fitsMinUpdSize :: ClosureInfo -> Bool
-fitsMinUpdSize (MkClosureInfo _ _ BlackHoleRep) = True
-fitsMinUpdSize cl_info = isSpecRep (closureSMRep cl_info) && closureNonHdrSize cl_info <= mIN_UPD_SIZE
\end{code}
Computing slop size. WARNING: this looks dodgy --- it has deep
Updateable closures must be @mIN_UPD_SIZE@.
\begin{itemize}
\item
- Cons cell requires 2 words
- \item
Indirections require 1 word
\item
Appels collector indirections 2 words
Copying collector forward pointer requires 1 word
THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@
-
-\item
-@SpecialisedRep@ closures closures may require slop:
- \begin{itemize}
- \item
- @ConstantRep@ and @CharLikeRep@ closures always use the address of
- a static closure. They are never allocated or
- collected (eg hold forwarding pointer) hence never any slop.
-
- \item
- @IntLikeRep@ are never updatable.
- May need slop to be collected (as they will be size 1 or more
- this probably has no affect)
-
- \item
- @SpecRep@ may be updateable and will be collectable
-
- \item
- @StaticRep@ may require slop if updatable. Non-updatable ones are OK.
-
- \item
- @GenericRep@ closures will always be larger so never require slop.
- \end{itemize}
-
- ***** ToDo: keep an eye on this!
\end{itemize}
+Static closures have an extra ``static link field'' at the end, but we
+don't bother taking that into account here.
+
\begin{code}
slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = computeSlopSize (closureGoodStuffSize cl_info) sm_rep (closureUpdReqd cl_info)
+ = computeSlopSize (closureGoodStuffSize cl_info) sm_rep
+ (closureUpdReqd cl_info)
computeSlopSize :: Int -> SMRep -> Bool -> Int
-computeSlopSize tot_wds (SpecialisedRep ConstantRep _ _ _) _
- = 0
-computeSlopSize tot_wds (SpecialisedRep CharLikeRep _ _ _) _
- = 0
-
-computeSlopSize tot_wds (SpecialisedRep _ _ _ _) True -- Updatable
+computeSlopSize tot_wds (StaticRep _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds (StaticRep _ _) True -- Updatable
+computeSlopSize tot_wds (StaticRep _ _ _) False
+ = 0 -- non updatable, non-heap object
+computeSlopSize tot_wds (GenericRep _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds BlackHoleRep _ -- Updatable
- = max 0 (mIN_UPD_SIZE - tot_wds)
-
-computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False -- Not updatable
+computeSlopSize tot_wds (GenericRep _ _ _) False
= max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)
-
-computeSlopSize tot_wds other_rep _ -- Any other rep
+computeSlopSize tot_wds ConstantRep _
= 0
+computeSlopSize tot_wds BlackHoleRep _ -- Updatable
+ = max 0 (mIN_UPD_SIZE - tot_wds)
\end{code}
%************************************************************************
\begin{code}
layOutDynClosure, layOutStaticClosure
- :: Id -- STG identifier w/ which this closure assoc'd
- -> (a -> PrimRep) -- function w/ which to be able to get a PrimRep
+ :: Name -- STG identifier of this closure
+ -> (a -> PrimRep) -- how to get a PrimRep for the fields
-> [a] -- the "things" being layed out
-> LambdaFormInfo -- what sort of closure it is
-> (ClosureInfo, -- info about the closure
ptr_wds, -- #ptr_wds
things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things
sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
-
-layOutStaticClosure name kind_fn things lf_info
- = (MkClosureInfo name lf_info (StaticRep ptr_wds (tot_wds - ptr_wds)),
- things_w_offsets)
- where
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot) kind_fn things
- bot = panic "layoutStaticClosure"
-
-layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
-layOutStaticNoFVClosure name lf_info
- = MkClosureInfo name lf_info (StaticRep ptr_wds nonptr_wds)
- where
- -- I am very uncertain that this is right - it will show up when testing
- -- my dynamic loading code. ADR
- -- (If it's not right, we'll have to grab the kinds of the arguments from
- -- somewhere.)
- ptr_wds = 0
- nonptr_wds = 0
-
-layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
-layOutPhantomClosure name lf_info = MkClosureInfo name lf_info PhantomRep
\end{code}
A wrapper for when used with data constructors:
+
\begin{code}
layOutDynCon :: DataCon
-> (a -> PrimRep)
-> (ClosureInfo, [(a,VirtualHeapOffset)])
layOutDynCon con kind_fn args
- = ASSERT(isDataCon con)
- layOutDynClosure con kind_fn args (mkConLFInfo con)
+ = layOutDynClosure (dataConName con) kind_fn args (mkConLFInfo con)
\end{code}
+%************************************************************************
+%* *
+\subsection[layOutStaticClosure]{Lay out a static closure}
+%* *
+%************************************************************************
+
+layOutStaticClosure is only used for laying out static constructors at
+the moment.
+
+Static closures for functions are laid out using
+layOutStaticNoFVClosure.
+
+\begin{code}
+layOutStaticClosure name kind_fn things lf_info
+ = (MkClosureInfo name lf_info
+ (StaticRep ptr_wds (tot_wds - ptr_wds) closure_type),
+ things_w_offsets)
+ where
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
+ things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot bot) kind_fn things
+ -- constructors with no pointer fields will definitely be NOCAF things.
+ -- this is a compromise until we can generate both kinds of constructor
+ -- (a normal static kind and the NOCAF_STATIC kind).
+ closure_type = case lf_info of
+ LFCon _ _ | ptr_wds == 0 -> CONSTR_NOCAF
+ _ -> getClosureType lf_info
+
+ bot = panic "layoutStaticClosure"
+
+layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo
+layOutStaticNoFVClosure name lf_info
+ = MkClosureInfo name lf_info (StaticRep 0 0 (getClosureType lf_info))
+\end{code}
%************************************************************************
%* *
chooseDynSMRep lf_info tot_wds ptr_wds
= let
nonptr_wds = tot_wds - ptr_wds
-
- updatekind = case lf_info of
- LFThunk _ _ upd _ -> if upd then SMUpdatable else SMSingleEntry
- LFBlackHole -> SMUpdatable
- _ -> SMNormalForm
+ closure_type = getClosureType lf_info
in
- if (nonptr_wds == 0 && ptr_wds <= mAX_SPEC_ALL_PTRS)
- || (tot_wds <= mAX_SPEC_MIXED_FIELDS)
- || (ptr_wds == 0 && nonptr_wds <= mAX_SPEC_ALL_NONPTRS) then
- let
- spec_kind = case lf_info of
-
- (LFTuple _ True) -> ConstantRep
-
- (LFTuple _ _) -> SpecRep
-
- (LFCon _ True) -> ConstantRep
-
- (LFCon con _ ) -> if maybeCharLikeCon con then CharLikeRep
- else if maybeIntLikeCon con then IntLikeRep
- else SpecRep
+ case lf_info of
+ LFTuple _ True -> ConstantRep
+ LFCon _ True -> ConstantRep
+ _ -> GenericRep ptr_wds nonptr_wds closure_type
- _ -> SpecRep
- in
- SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind
- else
- GenericRep ptr_wds nonptr_wds updatekind
+getClosureType :: LambdaFormInfo -> ClosureType
+getClosureType lf_info =
+ case lf_info of
+ LFCon con True -> CONSTR_NOCAF
+ LFCon con False -> CONSTR
+ LFReEntrant _ _ _ _ -> FUN
+ LFTuple _ _ -> CONSTR
+ LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
+ LFThunk _ _ _ _ _ -> THUNK
+ _ -> panic "getClosureType"
+ -- ToDo: could be anything else here?
\end{code}
-
%************************************************************************
%* *
\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
-> (Int, -- *Total* number of words allocated
Int, -- Number of words allocated for *pointers*
[(a, VirtualHeapOffset)])
- -- Things with their offsets from start of object
- -- in order of increasing offset
+ -- Things with their offsets from start of
+ -- object in order of increasing offset
-- First in list gets lowest offset, which is initial offset + 1.
in
(tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
where
- offset_of_first_word = totHdrSize sm_rep
computeOffset wds_so_far thing
= (wds_so_far + (getPrimRepSize . kind_fun) thing,
- (thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
+ (thing, fixedHdrSize + wds_so_far)
)
\end{code}
\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
- = let
- do_profiling = opt_SccProfilingOn
- in
- case lf_info of
- LFReEntrant top arity no_fvs -> returnFC (
- not no_fvs || -- Certainly if it has fvs we need to point to it
- not top -- If it is not top level we will point to it
+ = case lf_info of
+ LFReEntrant ty top arity no_fvs -> returnFC (
+ not no_fvs || -- Certainly if it has fvs we need to point to it
+ case top of { TopLevel -> False; _ -> True }
+ -- If it is not top level we will point to it
-- We can have a \r closure with no_fvs which
-- is not top level as special case cgRhsClosure
-- has been dissabled in favour of let floating
-- having Node point to the result of an update. SLPJ
-- 27/11/92.
- LFThunk _ no_fvs updatable NonStandardThunk
- -> returnFC (updatable || not no_fvs || do_profiling)
+ LFThunk _ _ no_fvs updatable NonStandardThunk
+ -> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
-- For the non-updatable (single-entry case):
--
-- or profiling (in which case we need to recover the cost centre
-- from inside it)
- LFThunk _ no_fvs updatable some_standard_form_thunk
+ LFThunk _ _ no_fvs updatable some_standard_form_thunk
-> returnFC True
-- Node must point to any standard-form thunk.
- -- For example,
- -- x = f y
- -- generates a Vap thunk for (f y), and even if y is a global
- -- variable we must still make Node point to the thunk before entering it
- -- because that's what the standard-form code expects.
LFArgument -> returnFC True
LFImported -> returnFC True
LFBlackHole -> returnFC True
-- BH entry may require Node to point
- LFLetNoEscape _ _ -> returnFC False
+ LFLetNoEscape _ -> returnFC False
\end{code}
The entry conventions depend on the type of closure being entered,
= ViaNode -- The "normal" convention
| StdEntry CLabel -- Jump to this code, with args on stack
- (Maybe CLabel) -- possibly setting infoptr to this
- | DirectEntry -- Jump directly to code, with args in regs
+ | DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
Int -- Its arity
- [MagicId] -- Its register assignments (possibly empty)
+ [MagicId] -- Its register assignments
+ -- (possibly empty)
-getEntryConvention :: Id -- Function being applied
+getEntryConvention :: Name -- Function being applied
-> LambdaFormInfo -- Its info
-> [PrimRep] -- Available arguments
-> FCode EntryConvention
-getEntryConvention id lf_info arg_kinds
+getEntryConvention name lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- let
- is_concurrent = opt_ForConcurrent
- in
returnFC (
- if (node_points && is_concurrent) then ViaNode else
+ -- if we're parallel, then we must always enter via node. The reason
+ -- is that the closure may have been fetched since we allocated it.
+
+ if (node_points && opt_Parallel) then ViaNode else
+
+ -- Commented out by SDM after futher thoughts:
+ -- - the only closure type that can be blackholed is a thunk
+ -- - we already enter thunks via node (unless the closure is
+ -- non-updatable, in which case why is it being re-entered...)
case lf_info of
- LFReEntrant _ arity _ ->
+ LFReEntrant _ _ arity _ ->
if arity == 0 || (length arg_kinds) < arity then
- StdEntry (mkStdEntryLabel id) Nothing
+ StdEntry (mkStdEntryLabel name)
else
- DirectEntry (mkFastEntryLabel id arity) arity arg_regs
+ DirectEntry (mkFastEntryLabel name arity) arity arg_regs
where
(arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
live_regs = if node_points then [node] else []
- LFCon con zero_arity
- -> let itbl = if zero_arity then
- mkPhantomInfoTableLabel con
- else
- mkConInfoTableLabel con
- in
- --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
- StdEntry (mkConEntryLabel con) (Just itbl)
+ LFCon con True{-zero_arity-}
+ -- a real constructor. Don't bother entering it, just jump
+ -- to the constructor entry code directly.
+ -> --false:ASSERT (null arg_kinds)
+ -- Should have no args (meaning what?)
+ StdEntry (mkStaticConEntryLabel (dataConName con))
+
+ LFCon con False{-non-zero_arity-}
+ -> --false:ASSERT (null arg_kinds)
+ -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel (dataConName con))
LFTuple tup zero_arity
- -> --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
- StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup))
+ -> --false:ASSERT (null arg_kinds)
+ -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel (dataConName tup))
- LFThunk _ _ updatable std_form_info
+ LFThunk _ _ _ updatable std_form_info
-> if updatable
then ViaNode
- else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
+ else StdEntry (thunkEntryLabel name std_form_info updatable)
LFArgument -> ViaNode
LFImported -> ViaNode
-- been updated, but we don't know with
-- what, so we enter via Node
- LFLetNoEscape arity _
+ LFLetNoEscape 0
+ -> StdEntry (mkReturnPtLabel (nameUnique name))
+
+ LFLetNoEscape arity
-> ASSERT(arity == length arg_kinds)
- DirectEntry (mkStdEntryLabel id) arity arg_regs
+ DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
where
- (arg_regs, _) = assignRegs live_regs arg_kinds
- live_regs = if node_points then [node] else []
+ (arg_regs, _) = assignRegs [] arg_kinds
+ -- node never points to a LetNoEscape, see above --SDM
+ --live_regs = if node_points then [node] else []
)
-blackHoleOnEntry :: Bool -- No-black-holing flag
- -> ClosureInfo
- -> Bool
+blackHoleOnEntry :: ClosureInfo -> Bool
-- Static closures are never themselves black-holed.
--- Updatable ones will be overwritten with a CAFList cell, which points to a black hole;
--- Single-entry ones have no fvs to plug, and we trust they don't form part of a loop.
+-- Updatable ones will be overwritten with a CAFList cell, which points to a
+-- black hole;
+-- Single-entry ones have no fvs to plug, and we trust they don't form part
+-- of a loop.
-blackHoleOnEntry no_black_holing (MkClosureInfo _ _ (StaticRep _ _)) = False
+blackHoleOnEntry (MkClosureInfo _ _ (StaticRep _ _ _)) = False
-blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _)
+blackHoleOnEntry (MkClosureInfo _ lf_info _)
= case lf_info of
- LFReEntrant _ _ _ -> False
- LFThunk _ no_fvs updatable _
+ LFReEntrant _ _ _ _ -> False
+ LFLetNoEscape _ -> False
+ LFThunk _ _ no_fvs updatable _
-> if updatable
- then not no_black_holing
+ then not opt_OmitBlackHoling
else not no_fvs
other -> panic "blackHoleOnEntry" -- Should never happen
-getStandardFormThunkInfo
- :: LambdaFormInfo
- -> Maybe [StgArg] -- Nothing => not a standard-form thunk
- -- Just atoms => a standard-form thunk with payload atoms
+isStandardFormThunk :: LambdaFormInfo -> Bool
-getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
- = --trace "Selector thunk: missed opportunity to save info table + code"
- Nothing
- -- Just [StgVarArg scrutinee]
- -- We can't save the info tbl + code until we have a way to generate
- -- a fixed family thereof.
+isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True
+isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True
+isStandardFormThunk other_lf_info = False
-getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
- | fun_in_payload = Just (StgVarArg fun_id : args)
- | otherwise = Just args
+maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ _
+ (SelectorThunk offset)) _) = Just offset
+maybeSelectorInfo _ = Nothing
-getStandardFormThunkInfo other_lf_info = Nothing
+-- Does this thunk's info table have an SRT?
-maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ (SelectorThunk _ con offset)) _) = Just (con,offset)
-maybeSelectorInfo _ = Nothing
+needsSRT :: ClosureInfo -> Bool
+needsSRT (MkClosureInfo _ info _) =
+ case info of
+ LFThunk _ _ _ _ (SelectorThunk _) -> False -- not for selectors
+ LFThunk _ _ _ _ _ -> True
+ LFReEntrant _ _ _ _ -> True
+ _ -> False
\end{code}
Avoiding generating entries and info tables
to use an error label in the info table to substitute for the absent
slow entry code.
-* Standard vap-entry code
- Standard vap-entry info table
- Needed iff we have any updatable thunks of the standard vap-entry shape.
-
-* Single-update vap-entry code
- Single-update vap-entry info table
- Needed iff we have any non-updatable thunks of the
- standard vap-entry shape.
-
-
\begin{code}
staticClosureRequired
- :: Id
+ :: Name
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant top_level _ _) -- It's a function
- = ASSERT( top_level ) -- Assumption: it's a top-level, no-free-var binding
+ (LFReEntrant _ top_level _ _) -- It's a function
+ = ASSERT( case top_level of { TopLevel -> True; other -> False } )
+ -- Assumption: it's a top-level, no-free-var binding
arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
+ || isExternallyVisibleName binder
staticClosureRequired binder other_binder_info other_lf_info = True
slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk.
- :: Id
+ :: Name
-> StgBinderInfo
-> EntryConvention
-> Bool
slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv
= arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
+ || isExternallyVisibleName binder
|| (case entry_conv of { DirectEntry _ _ _ -> False; other -> True })
{- The last case deals with the parallel world; a function usually
as a DirectEntry convention, but if it doesn't we must generate slow-entry code -}
slowFunEntryCodeRequired binder NoStgBinderInfo _ = True
funInfoTableRequired
- :: Id
+ :: Name
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant top_level _ _)
- = not top_level
+ (LFReEntrant _ top_level _ _)
+ = (case top_level of { NotTopLevel -> True; TopLevel -> False })
|| arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
+ || isExternallyVisibleName binder
funInfoTableRequired other_binder_info binder other_lf_info = True
-
--- We need the vector-apply entry points for a function if
--- there's a vector-apply occurrence in this module
-
-stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool
-
-stdVapRequired binder_info
- = case binder_info of
- StgBinderInfo _ _ std_vap_occ _ _ -> std_vap_occ
- _ -> False
-
-noUpdVapRequired binder_info
- = case binder_info of
- StgBinderInfo _ _ _ no_upd_vap_occ _ -> no_upd_vap_occ
- _ -> False
-\end{code}
-
-@lfArity@ extracts the arity of a function from its LFInfo
-
-\begin{code}
-{- Not needed any more
-
-lfArity_maybe (LFReEntrant _ arity _) = Just arity
-
--- Removed SLPJ March 97. I don't believe these two;
--- LFCon is used for construcor *applications*, not constructors!
---
--- lfArity_maybe (LFCon con _) = Just (dataConArity con)
--- lfArity_maybe (LFTuple con _) = Just (dataConArity con)
-
-lfArity_maybe other = Nothing
--}
\end{code}
%************************************************************************
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
-closureId :: ClosureInfo -> Id
-closureId (MkClosureInfo id _ _) = id
+closureName :: ClosureInfo -> Name
+closureName (MkClosureInfo name _ _) = name
closureSMRep :: ClosureInfo -> SMRep
closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd
+closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = upd
closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True
-- Black-hole closures are allocated to receive the results of an
-- alg case with a named default... so they need to be updated.
closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (MkClosureInfo _ (LFThunk _ _ upd _) _) = not upd
+closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = not upd
closureSingleEntry other_closure = False
\end{code}
-Note: @closureType@ returns appropriately specialised tycon and
-datacons.
-\begin{code}
-closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
-
--- First, a turgid special case. When we are generating the
--- standard code and info-table for Vaps (which is done when the function
--- defn is encountered), we don't have a convenient Id to hand whose
--- type is that of (f x y z). So we need to figure out the type
--- rather than take it from the Id. The Id is probably just "f"!
-
-closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
- = splitAlgTyConApp_maybe (fun_result_ty (length args) (idType fun_id))
-
-closureType (MkClosureInfo id lf _) = splitAlgTyConApp_maybe (idType id)
-\end{code}
-
-@closureReturnsUnpointedType@ is used to check whether a closure, {\em
-once it has eaten its arguments}, returns an unboxed type. For
-example, the closure for a function:
-\begin{verbatim}
- f :: Int -> Int#
-\end{verbatim}
-returns an unboxed type. This is important when dealing with stack
-overflow checks.
-\begin{code}
-closureReturnsUnpointedType :: ClosureInfo -> Bool
-
-closureReturnsUnpointedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
- = isUnpointedType (fun_result_ty arity (idType fun_id))
-
-closureReturnsUnpointedType other_closure = False
- -- All non-function closures aren't functions,
- -- and hence are boxed, since they are heap alloc'd
-
--- fun_result_ty is a disgusting little bit of code that finds the result
--- type of a function application. It looks "through" new types.
--- We don't have type args available any more, so we are pretty cavilier,
--- and quite possibly plain wrong. Let's hope it doesn't matter if we are!
-
-fun_result_ty arity ty
- | arity <= n_arg_tys
- = mkFunTys (drop arity arg_tys) res_ty
-
- | otherwise
- = case splitAlgTyConApp_maybe res_ty of
- Nothing -> pprPanic "fun_result_ty:" (hsep [int arity,
- ppr ty])
-
- Just (tycon, tycon_arg_tys, [con]) | isNewTyCon tycon
- -> fun_result_ty (arity - n_arg_tys) rep_ty
- where
- ([rep_ty], _) = splitFunTys (applyTys (idType con) tycon_arg_tys)
- Just _ ->
- pprPanic "fun_result_ty:" (hsep [int arity,
- ppr ty,
- ppr res_ty])
- where
- (_, rho_ty) = splitForAllTys ty
- (arg_tys, res_ty) = splitFunTys rho_ty
- n_arg_tys = length arg_tys
-\end{code}
-
\begin{code}
-closureSemiTag :: ClosureInfo -> Int
+closureSemiTag :: ClosureInfo -> Maybe Int
closureSemiTag (MkClosureInfo _ lf_info _)
= case lf_info of
- LFCon data_con _ -> dataConTag data_con - fIRST_TAG
- LFTuple _ _ -> 0
- _ -> fromInteger oTHER_TAG
+ LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)
+ LFTuple _ _ -> Just 0
+ _ -> Nothing
\end{code}
\begin{code}
isToplevClosure (MkClosureInfo _ lf_info _)
= case lf_info of
- LFReEntrant top _ _ -> top
- LFThunk top _ _ _ -> top
- _ -> panic "ClosureInfo:isToplevClosure"
+ LFReEntrant _ TopLevel _ _ -> True
+ LFThunk _ TopLevel _ _ _ -> True
+ other -> False
+\end{code}
+
+\begin{code}
+isLetNoEscape :: ClosureInfo -> Bool
+
+isLetNoEscape (MkClosureInfo _ (LFLetNoEscape _) _) = True
+isLetNoEscape _ = False
\end{code}
Label generation.
\begin{code}
fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo id lf_info _)
-{- [SLPJ Changed March 97]
- (was ok, but is the only call to lfArity,
- and the id should guarantee to have the correct arity in it.
+fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _) _)
+ = mkFastEntryLabel name arity
- = case lfArity_maybe lf_info of
- Just arity ->
--}
- = case getIdArity id of
- ArityExactly arity -> mkFastEntryLabel id arity
- other -> pprPanic "fastLabelFromCI" (ppr id)
+fastLabelFromCI (MkClosureInfo name _ _)
+ = pprPanic "fastLabelFromCI" (ppr name)
infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI (MkClosureInfo id lf_info rep)
LFBlackHole -> mkBlackHoleInfoTableLabel
- LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
- -- Use the standard vap info table
- -- for the function, rather than a one-off one
- -- for this particular closure
-
-{- For now, we generate individual info table and entry code for selector thunks,
- so their info table should be labelled in the standard way.
- The only special thing about them is that the info table has a field which
- tells the GC that it really is a selector.
-
- Later, perhaps, we'll have some standard RTS code for selector-thunk info tables,
- in which case this line will spring back to life.
+ LFThunk _ _ _ upd_flag (SelectorThunk offset) ->
+ mkSelectorInfoLabel upd_flag offset
- LFThunk _ _ upd_flag (SelectorThunk _ _ offset) -> mkSelectorInfoTableLabel upd_flag offset
- -- Ditto for selectors
--}
+ LFThunk _ _ _ upd_flag (ApThunk arity) ->
+ mkApInfoTableLabel upd_flag arity
other -> {-NO: if isStaticRep rep
then mkStaticInfoTableLabel id
else -} mkInfoTableLabel id
-mkConInfoPtr :: Id -> SMRep -> CLabel
+mkConInfoPtr :: DataCon -> SMRep -> CLabel
mkConInfoPtr con rep
- = ASSERT(isDataCon con)
- case rep of
- PhantomRep -> mkPhantomInfoTableLabel con
- StaticRep _ _ -> mkStaticInfoTableLabel con
- _ -> mkConInfoTableLabel con
+ = case rep of
+ StaticRep _ _ _ -> mkStaticInfoTableLabel name
+ _ -> mkConInfoTableLabel name
+ where
+ name = dataConName con
-mkConEntryPtr :: Id -> SMRep -> CLabel
+mkConEntryPtr :: DataCon -> SMRep -> CLabel
mkConEntryPtr con rep
- = ASSERT(isDataCon con)
- case rep of
- StaticRep _ _ -> mkStaticConEntryLabel con
- _ -> mkConEntryLabel con
-
+ = case rep of
+ StaticRep _ _ _ -> mkStaticConEntryLabel (dataConName con)
+ _ -> mkConEntryLabel (dataConName con)
+ where
+ name = dataConName con
-closureLabelFromCI (MkClosureInfo id _ rep)
+closureLabelFromCI (MkClosureInfo name _ rep)
| isConstantRep rep
- = mkStaticClosureLabel id
+ = mkStaticClosureLabel name
-- This case catches those pesky static closures for nullary constructors
closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info rep)
= case lf_info of
- LFThunk _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
- LFCon con _ -> mkConEntryPtr con rep
- LFTuple tup _ -> mkConEntryPtr tup rep
- other -> mkStdEntryLabel id
+ LFThunk _ _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
+ LFCon con _ -> mkConEntryPtr con rep
+ LFTuple tup _ -> mkConEntryPtr tup rep
+ other -> mkStdEntryLabel id
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getEntryConvention.
--- I don't think it needs to deal with the SelectorThunk case
--- Well, it's falling over now, so I've made it deal with it. (JSM)
-thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
- = mkVapEntryLabel fun_id is_updatable
+thunkEntryLabel thunk_id (ApThunk arity) is_updatable
+ = mkApEntryLabel is_updatable arity
+thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
+ = mkSelectorEntryLabel upd_flag offset
thunkEntryLabel thunk_id _ is_updatable
= mkStdEntryLabel thunk_id
\end{code}
allocProfilingMsg (MkClosureInfo _ lf_info _)
= case lf_info of
- LFReEntrant _ _ _ -> SLIT("ALLOC_FUN")
- LFCon _ _ -> SLIT("ALLOC_CON")
- LFTuple _ _ -> SLIT("ALLOC_CON")
- LFThunk _ _ _ _ -> SLIT("ALLOC_THK")
- LFBlackHole -> SLIT("ALLOC_BH")
- LFImported -> panic "ALLOC_IMP"
+ LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
+ LFCon _ _ -> SLIT("TICK_ALLOC_CON")
+ LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
+ LFThunk _ _ _ _ _ -> SLIT("TICK_ALLOC_THK")
+ LFBlackHole -> SLIT("TICK_ALLOC_BH")
+ LFImported -> panic "TICK_ALLOC_IMP"
\end{code}
We need a black-hole closure info to pass to @allocDynClosure@ when we
want to allocate the black hole on entry to a CAF.
\begin{code}
-blackHoleClosureInfo (MkClosureInfo id _ _)
- = MkClosureInfo id LFBlackHole BlackHoleRep
-\end{code}
-
-The register liveness when returning from a constructor. For
-simplicity, we claim just [node] is live for all but PhantomRep's. In
-truth, this means that non-constructor info tables also claim node,
-but since their liveness information is never used, we don't care.
-
-\begin{code}
-dataConLiveness (MkClosureInfo con _ PhantomRep)
- = case (dataReturnConvAlg con) of
- ReturnInRegs regs -> mkLiveRegsMask regs
- ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
-
-dataConLiveness _ = mkLiveRegsMask [node]
+blackHoleClosureInfo (MkClosureInfo name _ _)
+ = MkClosureInfo name LFBlackHole BlackHoleRep
\end{code}
%************************************************************************
%* *
%************************************************************************
-Profiling requires three pices of information to be determined for
-each closure's info table --- kind, description and type.
+Profiling requires two pieces of information to be determined for
+each closure's info table --- description and type.
The description is stored directly in the @CClosureInfoTable@ when the
info table is built.
-The kind is determined from the @LambdaForm@ stored in the closure
-info using @closureKind@.
-
The type is determined from the type information stored with the @Id@
in the closure info using @closureTypeDescr@.
\begin{code}
-closureKind :: ClosureInfo -> String
-
-closureKind (MkClosureInfo _ lf _)
- = case lf of
- LFReEntrant _ n _ -> if n > 0 then "FN_K" else "THK_K"
- LFCon _ _ -> "CON_K"
- LFTuple _ _ -> "CON_K"
- LFThunk _ _ _ _ -> "THK_K"
- LFBlackHole -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
- LFImported -> panic "IMP_KIND"
-
closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr (MkClosureInfo id lf _)
- = if (isDataCon id) then -- DataCon has function types
- getOccString (dataConTyCon id) -- We want the TyCon not the ->
- else
- getTyDescription (idType id)
+closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _) _)
+ = getTyDescription ty
+closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _) _)
+ = getTyDescription ty
+closureTypeDescr (MkClosureInfo name lf _)
+ = showSDoc (ppr name)
\end{code}
+
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CodeGen]{@CodeGen@: main module of the code generator}
import StgSyn
import CgMonad
import AbsCSyn
+import CLabel ( CLabel, mkSRTLabel, mkClosureLabel )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
-import Bag ( foldBag )
import CgBindery ( CgIdInfo )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC,
opt_SccGroup
)
-import CostCentre ( CostCentre )
+import CostCentre ( CostCentre, CostCentreStack )
import CStrings ( modnameToC )
import FiniteMap ( FiniteMap )
-import Id ( Id )
-import Maybes ( maybeToBool )
+import Id ( Id, idName )
import Name ( Module )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Type ( Type )
import TyCon ( TyCon )
-import Util ( panic, assertPanic )
+import BasicTypes ( TopLevelFlag(..) )
+import Util
\end{code}
\begin{code}
codeGen :: FAST_STRING -- module name
-> ([CostCentre], -- local cost-centres needing declaring/registering
- [CostCentre]) -- "extern" cost-centres needing declaring
+ [CostCentre], -- "extern" cost-centres needing declaring
+ [CostCentreStack]) -- pre-defined "singleton" cost centre stacks
-> [Module] -- import names
-> [TyCon] -- tycons with data constructors to convert
-> FiniteMap TyCon [(Bool, [Maybe Type])]
-- tycon specialisation info
- -> [StgBinding] -- bindings to convert
+ -> [(StgBinding,[Id])] -- bindings to convert, with SRTs
-> AbstractC -- output
-codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm
+codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs)
+ import_names gen_tycons tycon_specs stg_pgm
= let
- doing_profiling = opt_SccProfilingOn
- maybe_split = if opt_EnsureSplittableC then CSplitMarker else AbsCNop
+ maybe_split = if opt_EnsureSplittableC
+ then CSplitMarker
+ else AbsCNop
cinfo = MkCompInfo mod_name
in
- if not doing_profiling then
- mkAbstractCs [
+ let
+ module_code = mkAbstractCs [
genStaticConBits cinfo gen_tycons tycon_specs,
initC cinfo (cgTopBindings maybe_split stg_pgm) ]
- else -- yes, cost-centre profiling:
+ -- Cost-centre profiling:
-- Besides the usual stuff, we must produce:
--
-- * Declarations for the cost-centres defined in this module;
-- into the code-generator, as are the imported-modules' names.)
--
--
- mkAbstractCs [
- mkAbstractCs [mkAbstractCs (map (CCostCentreDecl True) local_CCs),
- mkAbstractCs (map (CCostCentreDecl False) extern_CCs),
- mkCcRegister local_CCs import_names],
- genStaticConBits cinfo gen_tycons tycon_specs,
- initC cinfo (cgTopBindings maybe_split stg_pgm) ]
+ cost_centre_stuff
+ | not opt_SccProfilingOn = AbsCNop
+ | otherwise = mkAbstractCs (
+ map (CCostCentreDecl True) local_CCs ++
+ map (CCostCentreDecl False) extern_CCs ++
+ map CCostCentreStackDecl singleton_CCSs ++
+ mkCcRegister local_CCs singleton_CCSs import_names
+ )
+ in
+ mkAbstractCs [ cost_centre_stuff, module_code ]
+
where
-----------------
grp_name = case opt_SccGroup of
Nothing -> mod_name -- default: module name
-----------------
- mkCcRegister ccs import_names
+ mkCcRegister ccs cc_stacks import_names
= let
register_ccs = mkAbstractCs (map mk_register ccs)
register_imports
= foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names
+ register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
in
- mkAbstractCs [
- CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
+ [
+ CCallProfCCMacro SLIT("START_REGISTER_CCS")
+ [ CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
register_ccs,
+ register_cc_stacks,
register_imports,
CCallProfCCMacro SLIT("END_REGISTER_CCS") []
]
mk_register cc
= CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
+ mk_register_ccs ccs
+ = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
+
mk_import_register import_name
- = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep]
+ = CCallProfCCMacro SLIT("REGISTER_IMPORT")
+ [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep]
\end{code}
%************************************************************************
variable.
\begin{code}
-cgTopBindings :: AbstractC -> [StgBinding] -> Code
+cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code
cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
-cgTopBinding :: AbstractC -> StgBinding -> Code
+cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code
-cgTopBinding split (StgNonRec name rhs)
- = absC split `thenC`
- cgTopRhs name rhs `thenFC` \ (name, info) ->
+cgTopBinding split ((StgNonRec name rhs), srt)
+ = absC split `thenC`
+ absC (mkSRT srt_label srt) `thenC`
+ setSRTLabel srt_label (
+ cgTopRhs name rhs `thenFC` \ (name, info) ->
addBindC name info
+ )
+ where
+ srt_label = mkSRTLabel (idName name)
-cgTopBinding split (StgRec pairs)
- = absC split `thenC`
+cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
+ = absC split `thenC`
+ absC (mkSRT srt_label srt) `thenC`
+ setSRTLabel srt_label (
fixC (\ new_binds -> addBindsC new_binds `thenC`
mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
- ) `thenFC` \ new_binds ->
+ ) `thenFC` \ new_binds ->
addBindsC new_binds
+ )
+ where
+ srt_label = mkSRTLabel (idName name)
+
+mkSRT :: CLabel -> [Id] -> AbstractC
+mkSRT lbl [] = AbsCNop
+mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids)
-- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
-- to enclose the listFCs in cgTopBinding, but that tickled the
cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along for setting up a binding...
-cgTopRhs name (StgRhsCon cc con args)
- = forkStatics (cgTopRhsCon name con args (all zero_size args))
+cgTopRhs bndr (StgRhsCon cc con args)
+ = forkStatics (cgTopRhsCon bndr con args (all zero_size args))
where
zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
-cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body)
+cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
= ASSERT(null fvs) -- There should be no free variables
- forkStatics (cgTopRhsClosure name cc bi args body lf_info)
+ forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
where
- lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args
+ lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SMRep]{Storage manager representations of closure}
\begin{code}
module SMRep (
- SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
- getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr,
- isConstantRep, isSpecRep, isStaticRep, isPhantomRep,
- isIntLikeRep
+ SMRep(..), ClosureType(..),
+ isConstantRep, isStaticRep,
+ fixedHdrSize, arrHdrSize, fixedItblSize, getSMRepStr, getClosureTypeStr
+
+#ifndef OMIT_NATIVE_CODEGEN
+ , getSMRepClosureTypeInt
+ , cONSTR
+ , cONSTR_STATIC
+ , cONSTR_NOCAF_STATIC
+ , fUN
+ , fUN_STATIC
+ , tHUNK
+ , tHUNK_STATIC
+ , tHUNK_SELECTOR
+ , rET_SMALL
+ , rET_VEC_SMALL
+ , rET_BIG
+ , rET_VEC_BIG
+ , bLACKHOLE
+#endif
) where
#include "HsVersions.h"
+import CmdLineOpts
+import AbsCSyn ( Liveness(..) )
+import Constants ( sTD_HDR_SIZE, pROF_HDR_SIZE,
+ gRAN_HDR_SIZE, tICKY_HDR_SIZE, aRR_HDR_SIZE,
+ sTD_ITBL_SIZE, pROF_ITBL_SIZE,
+ gRAN_ITBL_SIZE, tICKY_ITBL_SIZE )
import Outputable
import Util ( panic )
import GlaExts ( Int(..), Int#, (<#), (==#), (<#), (>#) )
%* *
%************************************************************************
-Ways in which a closure may be represented by the storage manager;
-this list slavishly follows the storage-manager interface document.
-
\begin{code}
-data SMSpecRepKind
- = SpecRep -- Normal Spec representation
-
- | ConstantRep -- Common me up with single global copy
- -- Used for nullary constructors
-
- | CharLikeRep -- Common me up with entry from global table
-
- | IntLikeRep -- Common me up with entry from global table,
- -- if the intlike field is in range.
-
-data SMUpdateKind
- = SMNormalForm -- Normal form, no update
- | SMSingleEntry -- Single entry thunk, non-updatable
- | SMUpdatable -- Shared thunk, updatable
-
data SMRep
- = StaticRep -- Don't move me, Oh garbage collector!
- -- Used for all statically-allocated closures.
+ -- static closure have an extra static link field at the end.
+ = StaticRep
Int -- # ptr words (useful for interpreter, debugger, etc)
Int -- # non-ptr words
-
- | SpecialisedRep -- GC routines know size etc
- -- All have same _HS = SPEC_HS and no _VHS
- SMSpecRepKind -- Which kind of specialised representation
- Int -- # ptr words
- Int -- # non-ptr words
- SMUpdateKind -- Updatable?
+ ClosureType -- closure type
| GenericRep -- GC routines consult sizes in info tbl
Int -- # ptr words
Int -- # non-ptr words
- SMUpdateKind -- Updatable?
+ ClosureType -- closure type
- | BigTupleRep -- All ptrs, size in var-hdr field
- -- Used for big tuples
- Int -- # ptr words
+ | ConstantRep -- CONSTR with zero-arity
- | DataRep -- All non-ptrs, size in var-hdr field
- -- Used for arbitrary-precision integers, strings
- Int -- # non-ptr words
+ | BlackHoleRep
+
+data ClosureType
+ = CONSTR
+ | CONSTR_NOCAF
+ | FUN
+ | THUNK
+ | THUNK_SELECTOR
+ deriving (Eq,Ord)
- | DynamicRep -- Size and # ptrs in var-hdr field
- -- Used by RTS for partial applications
+\end{code}
+
+Size of a closure header.
- | BlackHoleRep -- for black hole closures
+\begin{code}
+fixedHdrSize :: Int{-words-}
+fixedHdrSize = sTD_HDR_SIZE + profHdrSize + granHdrSize + tickyHdrSize
- | PhantomRep -- for "phantom" closures that only exist in registers
+profHdrSize :: Int{-words-}
+profHdrSize | opt_SccProfilingOn = pROF_HDR_SIZE
+ | otherwise = 0
- | MuTupleRep -- All ptrs, size in var-hdr field
- -- Used for mutable tuples
- Int -- # ptr words
+granHdrSize :: Int{-words-}
+granHdrSize | opt_GranMacros = gRAN_HDR_SIZE
+ | otherwise = 0
-{- Mattson review:
-
-To: simonpj@dcs.gla.ac.uk, partain@dcs.gla.ac.uk
-Cc: kh@dcs.gla.ac.uk, trinder@dcs.gla.ac.uk, areid@dcs.gla.ac.uk
-Subject: Correct me if I'm wrong...
-Date: Fri, 17 Feb 1995 18:09:00 +0000
-From: Jim Mattson <mattson@dcs.gla.ac.uk>
-
-BigTupleRep == TUPLE
-
- Never generated by the compiler, and only used in the RTS when
- mutuples don't require special attention at GC time (e.g. 2s)
- When it is used, it is a primitive object (never entered).
- May be mutable...probably should never be used in the parallel
- system, since we need to distinguish mutables from immutables when
- deciding whether to copy or move closures across processors.
-
-DataRep == DATA (aka MutableByteArray & ByteArray)
- Never generated by the compiler, and only used in the RTS for
- ArrayOfData. Always a primitive object (never entered). May
- be mutable...though we don't distinguish between mutable and
- immutable data arrays in the sequential world, it would probably
- be useful in the parallel world to know when it is safe to just
- copy one of these. I believe the hooks are in place for changing
- the InfoPtr on a MutableByteArray when it's frozen to a ByteArray
- if we want to do so.
-
-DynamicRep == DYN
- Never generated by the compiler, and only used in the RTS for
- PAPs and the Stable Pointer table. PAPs are non-primitive,
- non-updatable, normal-form objects, but the SPT is a primitive,
- mutable object. At the moment, there is no SPT in the parallel
- world. Presumably, it would be possible to have an SPT on each
- processor, and we could identify a stable pointer as a (processor,
- SPT-entry) pair, but would it be worth it?
-
-MuTupleRep == MUTUPLE
- Never generated by the compiler, and only used in the RTS when
- mutuples *do* require special attention at GC time.
- When it is used, it is a primitive object (never entered).
- Always mutable...there is an IMMUTUPLE in the RTS, but no
- corresponding type in the compiler.
-
---jim
--}
+tickyHdrSize :: Int{-words-}
+tickyHdrSize | opt_DoTickyProfiling = tICKY_HDR_SIZE
+ | otherwise = 0
+
+arrHdrSize :: Int{-words-}
+arrHdrSize = fixedHdrSize + aRR_HDR_SIZE
\end{code}
-\begin{code}
-isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool
-isConstantRep (SpecialisedRep ConstantRep _ _ _) = True
-isConstantRep other = False
+Size of an info table.
-isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures
-isSpecRep other = False -- True indicates that the _VHS is 0 !
+\begin{code}
+fixedItblSize :: Int{-words-}
+fixedItblSize = sTD_ITBL_SIZE + profItblSize + granItblSize + tickyItblSize
-isStaticRep (StaticRep _ _) = True
-isStaticRep _ = False
+profItblSize :: Int{-words-}
+profItblSize | opt_SccProfilingOn = pROF_ITBL_SIZE
+ | otherwise = 0
-isPhantomRep PhantomRep = True
-isPhantomRep _ = False
+granItblSize :: Int{-words-}
+granItblSize | opt_GranMacros = gRAN_ITBL_SIZE
+ | otherwise = 0
-isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True
-isIntLikeRep other = False
+tickyItblSize :: Int{-words-}
+tickyItblSize | opt_DoTickyProfiling = tICKY_ITBL_SIZE
+ | otherwise = 0
\end{code}
\begin{code}
-instance Eq SMRep where
- (SpecialisedRep k1 a1 b1 _) == (SpecialisedRep k2 a2 b2 _) = (tagOf_SMSpecRepKind k1) _EQ_ (tagOf_SMSpecRepKind k2)
- && a1 == a2 && b1 == b2
- (GenericRep a1 b1 _) == (GenericRep a2 b2 _) = a1 == a2 && b1 == b2
- (BigTupleRep a1) == (BigTupleRep a2) = a1 == a2
- (MuTupleRep a1) == (MuTupleRep a2) = a1 == a2
- (DataRep a1) == (DataRep a2) = a1 == a2
- a == b = (tagOf_SMRep a) _EQ_ (tagOf_SMRep b)
-
-ltSMRepHdr :: SMRep -> SMRep -> Bool
-a `ltSMRepHdr` b = (tagOf_SMRep a) _LT_ (tagOf_SMRep b)
-
-instance Ord SMRep where
- -- ToDo: cmp-ify? This instance seems a bit weird (WDP 94/10)
- rep1 <= rep2 = rep1 < rep2 || rep1 == rep2
- rep1 < rep2
- = let tag1 = tagOf_SMRep rep1
- tag2 = tagOf_SMRep rep2
- in
- if tag1 _LT_ tag2 then True
- else if tag1 _GT_ tag2 then False
- else {- tags equal -} rep1 `lt` rep2
- where
- (SpecialisedRep k1 a1 b1 _) `lt` (SpecialisedRep k2 a2 b2 _) =
- t1 _LT_ t2 || (t1 _EQ_ t2 && (a1 < a2 || (a1 == a2 && b1 < b2)))
- where t1 = tagOf_SMSpecRepKind k1
- t2 = tagOf_SMSpecRepKind k2
- (GenericRep a1 b1 _) `lt` (GenericRep a2 b2 _) = a1 < a2 || (a1 == a2 && b1 < b2)
- (BigTupleRep a1) `lt` (BigTupleRep a2) = a1 < a2
- (MuTupleRep a1) `lt` (MuTupleRep a2) = a1 < a2
- (DataRep a1) `lt` (DataRep a2) = a1 < a2
- a `lt` b = True
-
-tagOf_SMSpecRepKind SpecRep = (ILIT(1) :: FAST_INT)
-tagOf_SMSpecRepKind ConstantRep = ILIT(2)
-tagOf_SMSpecRepKind CharLikeRep = ILIT(3)
-tagOf_SMSpecRepKind IntLikeRep = ILIT(4)
-
-tagOf_SMRep (StaticRep _ _) = (ILIT(1) :: FAST_INT)
-tagOf_SMRep (SpecialisedRep k _ _ _) = ILIT(2)
-tagOf_SMRep (GenericRep _ _ _) = ILIT(3)
-tagOf_SMRep (BigTupleRep _) = ILIT(4)
-tagOf_SMRep (DataRep _) = ILIT(5)
-tagOf_SMRep DynamicRep = ILIT(6)
-tagOf_SMRep BlackHoleRep = ILIT(7)
-tagOf_SMRep PhantomRep = ILIT(8)
-tagOf_SMRep (MuTupleRep _) = ILIT(9)
+isConstantRep, isStaticRep :: SMRep -> Bool
+isConstantRep ConstantRep = True
+isConstantRep other = False
+isStaticRep (StaticRep _ _ _) = True
+isStaticRep _ = False
+\end{code}
+
+\begin{code}
+{- ToDo: needed? -}
instance Text SMRep where
showsPrec d rep
= showString (case rep of
- StaticRep _ _ -> "STATIC"
- SpecialisedRep kind _ _ SMNormalForm -> "SPEC_N"
- SpecialisedRep kind _ _ SMSingleEntry -> "SPEC_S"
- SpecialisedRep kind _ _ SMUpdatable -> "SPEC_U"
- GenericRep _ _ SMNormalForm -> "GEN_N"
- GenericRep _ _ SMSingleEntry -> "GEN_S"
- GenericRep _ _ SMUpdatable -> "GEN_U"
- BigTupleRep _ -> "TUPLE"
- DataRep _ -> "DATA"
- DynamicRep -> "DYN"
- BlackHoleRep -> "BH"
- PhantomRep -> "INREGS"
- MuTupleRep _ -> "MUTUPLE")
+ StaticRep _ _ _ -> "STATIC"
+ GenericRep _ _ _ -> ""
+ ConstantRep -> "")
instance Outputable SMRep where
ppr rep = text (show rep)
-getSMInfoStr :: SMRep -> String
-getSMInfoStr (StaticRep _ _) = "STATIC"
-getSMInfoStr (SpecialisedRep ConstantRep _ _ _) = "CONST"
-getSMInfoStr (SpecialisedRep CharLikeRep _ _ _) = "CHARLIKE"
-getSMInfoStr (SpecialisedRep IntLikeRep _ _ _) = "INTLIKE"
-getSMInfoStr (SpecialisedRep SpecRep _ _ SMNormalForm) = "SPEC_N"
-getSMInfoStr (SpecialisedRep SpecRep _ _ SMSingleEntry) = "SPEC_S"
-getSMInfoStr (SpecialisedRep SpecRep _ _ SMUpdatable) = "SPEC_U"
-getSMInfoStr (GenericRep _ _ SMNormalForm) = "GEN_N"
-getSMInfoStr (GenericRep _ _ SMSingleEntry) = "GEN_S"
-getSMInfoStr (GenericRep _ _ SMUpdatable) = "GEN_U"
-getSMInfoStr (BigTupleRep _) = "TUPLE"
-getSMInfoStr (DataRep _ ) = "DATA"
-getSMInfoStr DynamicRep = "DYN"
-getSMInfoStr BlackHoleRep = panic "getSMInfoStr.BlackHole"
-getSMInfoStr PhantomRep = "INREGS"
-getSMInfoStr (MuTupleRep _) = "MUTUPLE"
-
-getSMInitHdrStr :: SMRep -> String
-getSMInitHdrStr (SpecialisedRep IntLikeRep _ _ _) = "SET_INTLIKE"
-getSMInitHdrStr (SpecialisedRep SpecRep _ _ _) = "SET_SPEC"
-getSMInitHdrStr (GenericRep _ _ _) = "SET_GEN"
-getSMInitHdrStr (BigTupleRep _) = "SET_TUPLE"
-getSMInitHdrStr (DataRep _ ) = "SET_DATA"
-getSMInitHdrStr DynamicRep = "SET_DYN"
-getSMInitHdrStr BlackHoleRep = "SET_BH"
-#ifdef DEBUG
-getSMInitHdrStr (StaticRep _ _) = panic "getSMInitHdrStr.Static"
-getSMInitHdrStr PhantomRep = panic "getSMInitHdrStr.Phantom"
-getSMInitHdrStr (MuTupleRep _) = panic "getSMInitHdrStr.Mutuple"
-getSMInitHdrStr (SpecialisedRep ConstantRep _ _ _) = panic "getSMInitHdrStr.Constant"
-getSMInitHdrStr (SpecialisedRep CharLikeRep _ _ _) = panic "getSMInitHdrStr.CharLike"
-#endif
-
-getSMUpdInplaceHdrStr :: SMRep -> String
-getSMUpdInplaceHdrStr (SpecialisedRep ConstantRep _ _ _) = "INPLACE_UPD"
-getSMUpdInplaceHdrStr (SpecialisedRep CharLikeRep _ _ _) = "INPLACE_UPD"
-getSMUpdInplaceHdrStr (SpecialisedRep IntLikeRep _ _ _) = "INPLACE_UPD"
-getSMUpdInplaceHdrStr (SpecialisedRep SpecRep _ _ _) = "INPLACE_UPD"
-#ifdef DEBUG
-getSMUpdInplaceHdrStr (StaticRep _ _) = panic "getSMUpdInplaceHdrStr.Static"
-getSMUpdInplaceHdrStr (GenericRep _ _ _) = panic "getSMUpdInplaceHdrStr.Generic"
-getSMUpdInplaceHdrStr (BigTupleRep _ ) = panic "getSMUpdInplaceHdrStr.BigTuple"
-getSMUpdInplaceHdrStr (DataRep _ ) = panic "getSMUpdInplaceHdrStr.Data"
-getSMUpdInplaceHdrStr DynamicRep = panic "getSMUpdInplaceHdrStr.Dynamic"
-getSMUpdInplaceHdrStr BlackHoleRep = panic "getSMUpdInplaceHdrStr.BlackHole"
-getSMUpdInplaceHdrStr PhantomRep = panic "getSMUpdInplaceHdrStr.Phantom"
-getSMUpdInplaceHdrStr (MuTupleRep _ ) = panic "getSMUpdInplaceHdrStr.MuTuple"
-#endif
+getSMRepStr (GenericRep _ _ t) = getClosureTypeStr t
+getSMRepStr (StaticRep _ _ t) = getClosureTypeStr t ++ "_STATIC"
+getSMRepStr ConstantRep = "CONSTR_NOCAF_STATIC"
+getSMRepStr BlackHoleRep = "BLACKHOLE"
+
+getClosureTypeStr CONSTR = "CONSTR"
+getClosureTypeStr CONSTR_NOCAF = "CONSTR_NOCAF"
+getClosureTypeStr FUN = "FUN"
+getClosureTypeStr THUNK = "THUNK"
+getClosureTypeStr THUNK_SELECTOR = "THUNK_SELECTOR"
+
+#ifndef OMIT_NATIVE_CODEGEN
+getSMRepClosureTypeInt :: SMRep -> Int
+getSMRepClosureTypeInt (GenericRep _ _ t) =
+ case t of
+ CONSTR -> cONSTR
+ CONSTR_NOCAF -> panic "getClosureTypeInt: CONSTR_NOCAF"
+ FUN -> fUN
+ THUNK -> tHUNK
+ THUNK_SELECTOR -> tHUNK_SELECTOR
+getSMRepClosureTypeInt (StaticRep _ _ t) =
+ case t of
+ CONSTR -> cONSTR_STATIC
+ CONSTR_NOCAF -> cONSTR_NOCAF_STATIC
+ FUN -> fUN_STATIC
+ THUNK -> tHUNK_STATIC
+ THUNK_SELECTOR -> panic "getClosureTypeInt: THUNK_SELECTOR_STATIC"
+
+getSMRepClosureTypeInt ConstantRep = cONSTR_NOCAF_STATIC
+
+getSMRepClosureTypeInt BlackHoleRep = bLACKHOLE
+
+-- Just the ones we need:
+
+#include "../includes/ClosureTypes.h"
+
+cONSTR = (CONSTR :: Int)
+cONSTR_STATIC = (CONSTR_STATIC :: Int)
+cONSTR_NOCAF_STATIC = (CONSTR_NOCAF_STATIC :: Int)
+fUN = (FUN :: Int)
+fUN_STATIC = (FUN_STATIC :: Int)
+tHUNK = (THUNK :: Int)
+tHUNK_STATIC = (THUNK_STATIC :: Int)
+tHUNK_SELECTOR = (THUNK_SELECTOR :: Int)
+rET_SMALL = (RET_SMALL :: Int)
+rET_VEC_SMALL = (RET_VEC_SMALL :: Int)
+rET_BIG = (RET_BIG :: Int)
+rET_VEC_BIG = (RET_VEC_BIG :: Int)
+bLACKHOLE = (BLACKHOLE :: Int)
+
+#endif OMIT_NATIVE_CODEGEN
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[AnnCoreSyntax]{Annotated core syntax}
-
-For when you want @CoreSyntax@ trees annotated at every node. Other
-than that, just like @CoreSyntax@. (Important to be sure that it {\em
-really is} just like @CoreSyntax@.)
-
-\begin{code}
-module AnnCoreSyn (
- AnnCoreBinding(..), AnnCoreExpr,
- AnnCoreExpr'(..), -- v sad that this must be exported
- AnnCoreCaseAlts(..), AnnCoreCaseDefault(..),
-
- deAnnotate -- we may eventually export some of the other deAnners
- ) where
-
-#include "HsVersions.h"
-
-import CoreSyn
-
-import Id ( Id )
-import Literal ( Literal )
-import PrimOp ( PrimOp )
-import CostCentre ( CostCentre )
-import Type ( GenType )
-
-\end{code}
-
-\begin{code}
-data AnnCoreBinding val_bdr val_occ flexi annot
- = AnnNonRec val_bdr (AnnCoreExpr val_bdr val_occ flexi annot)
- | AnnRec [(val_bdr, AnnCoreExpr val_bdr val_occ flexi annot)]
-\end{code}
-
-\begin{code}
-type AnnCoreExpr val_bdr val_occ flexi annot
- = (annot, AnnCoreExpr' val_bdr val_occ flexi annot)
-
-data AnnCoreExpr' val_bdr val_occ flexi annot
- = AnnVar val_occ
- | AnnLit Literal
-
- | AnnCon Id [GenCoreArg val_occ flexi]
- | AnnPrim PrimOp [GenCoreArg val_occ flexi]
-
- | AnnLam (GenCoreBinder val_bdr flexi)
- (AnnCoreExpr val_bdr val_occ flexi annot)
-
- | AnnApp (AnnCoreExpr val_bdr val_occ flexi annot)
- (GenCoreArg val_occ flexi)
-
- | AnnCase (AnnCoreExpr val_bdr val_occ flexi annot)
- (AnnCoreCaseAlts val_bdr val_occ flexi annot)
-
- | AnnLet (AnnCoreBinding val_bdr val_occ flexi annot)
- (AnnCoreExpr val_bdr val_occ flexi annot)
-
- | AnnNote (CoreNote flexi)
- (AnnCoreExpr val_bdr val_occ flexi annot)
-\end{code}
-
-\begin{code}
-data AnnCoreCaseAlts val_bdr val_occ flexi annot
- = AnnAlgAlts [(Id,
- [val_bdr],
- AnnCoreExpr val_bdr val_occ flexi annot)]
- (AnnCoreCaseDefault val_bdr val_occ flexi annot)
- | AnnPrimAlts [(Literal,
- AnnCoreExpr val_bdr val_occ flexi annot)]
- (AnnCoreCaseDefault val_bdr val_occ flexi annot)
-
-data AnnCoreCaseDefault val_bdr val_occ flexi annot
- = AnnNoDefault
- | AnnBindDefault val_bdr
- (AnnCoreExpr val_bdr val_occ flexi annot)
-\end{code}
-
-\begin{code}
-deAnnotate :: AnnCoreExpr val_bdr val_occ flexi ann
- -> GenCoreExpr val_bdr val_occ flexi
-
-deAnnotate (_, AnnVar v) = Var v
-deAnnotate (_, AnnLit lit) = Lit lit
-deAnnotate (_, AnnCon con args) = Con con args
-deAnnotate (_, AnnPrim op args) = Prim op args
-deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body)
-deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) arg
-deAnnotate (_, AnnNote note body) = Note note (deAnnotate body)
-
-deAnnotate (_, AnnLet bind body)
- = Let (deAnnBind bind) (deAnnotate body)
- where
- deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
- deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
-
-deAnnotate (_, AnnCase scrut alts)
- = Case (deAnnotate scrut) (deAnnAlts alts)
- where
- deAnnAlts (AnnAlgAlts alts deflt)
- = AlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts]
- (deAnnDeflt deflt)
-
- deAnnAlts (AnnPrimAlts alts deflt)
- = PrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts]
- (deAnnDeflt deflt)
-
- deAnnDeflt AnnNoDefault = NoDefault
- deAnnDeflt (AnnBindDefault var rhs) = BindDefault var (deAnnotate rhs)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
-%
-\section[CoreLift]{Lifts unboxed bindings and any references to them}
-
-\begin{code}
-module CoreLift (
- liftCoreBindings,
-
- mkLiftedId,
- liftExpr,
- bindUnlift,
- applyBindUnlifts
-
- ) where
-
-#include "HsVersions.h"
-
-import CoreSyn
-import CoreUtils ( coreExprType )
-import MkId ( mkSysLocal )
-import Id ( idType, mkIdWithNewType,
- nullIdEnv, growIdEnvList, lookupIdEnv,
- IdEnv, Id
- )
-import Name ( isLocallyDefined, getSrcLoc, getOccString )
-import TyCon ( isBoxedTyCon, TyCon{-instance-} )
-import Type ( splitAlgTyConApp_maybe )
-import TysPrim ( statePrimTyCon )
-import TysWiredIn ( liftDataCon, mkLiftTy )
-import Unique ( Unique )
-import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
-import Util ( zipEqual, zipWithEqual, assertPanic, panic )
-
-infixr 9 `thenL`
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{``lift'' for various constructs}
-%* *
-%************************************************************************
-
-@liftCoreBindings@ is the top-level interface function.
-
-\begin{code}
-liftCoreBindings :: UniqSupply -- unique supply
- -> [CoreBinding] -- unlifted bindings
- -> [CoreBinding] -- lifted bindings
-
-liftCoreBindings us binds
- = initL (lift_top_binds binds) us
- where
- lift_top_binds [] = returnL []
-
- lift_top_binds (b:bs)
- = liftBindAndScope True b (
- lift_top_binds bs `thenL` \ bs ->
- returnL (ItsABinds bs)
- ) `thenL` \ (b, ItsABinds bs) ->
- returnL (b:bs)
-
-
------------------------
-liftBindAndScope :: Bool -- top level ?
- -> CoreBinding -- As yet unprocessed
- -> LiftM BindsOrExpr -- Do the scope of the bindings
- -> LiftM (CoreBinding, -- Processed
- BindsOrExpr)
-
-liftBindAndScope top_lev bind scopeM
- = liftBinders top_lev bind (
- liftCoreBind bind `thenL` \ bind ->
- scopeM `thenL` \ bindsorexpr ->
- returnL (bind, bindsorexpr)
- )
-
------------------------
-liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
-
-liftCoreArg arg@(TyArg _) = returnL (arg, id)
-liftCoreArg arg@(LitArg _) = returnL (arg, id)
-liftCoreArg arg@(VarArg v)
- = isLiftedId v `thenL` \ lifted ->
- case lifted of
- Nothing -> returnL (arg, id)
-
- Just (lifted, unlifted) ->
- returnL (VarArg unlifted, bindUnlift lifted unlifted)
-
-
------------------------
-liftCoreBind :: CoreBinding -> LiftM CoreBinding
-
-liftCoreBind (NonRec b rhs)
- = liftOneBind (b,rhs) `thenL` \ (b,rhs) ->
- returnL (NonRec b rhs)
-
-liftCoreBind (Rec pairs)
- = mapL liftOneBind pairs `thenL` \ pairs ->
- returnL (Rec pairs)
-
------------------------
-liftOneBind (binder,rhs)
- = liftCoreExpr rhs `thenL` \ rhs ->
- isLiftedId binder `thenL` \ lifted ->
- case lifted of
- Just (lifted, unlifted) ->
- returnL (lifted, liftExpr unlifted rhs)
- Nothing ->
- returnL (binder, rhs)
-
------------------------
-liftCoreExpr :: CoreExpr -> LiftM CoreExpr
-
-liftCoreExpr expr@(Var var)
- = isLiftedId var `thenL` \ lifted ->
- case lifted of
- Nothing -> returnL expr
- Just (lifted, unlifted) ->
- returnL (bindUnlift lifted unlifted (Var unlifted))
-
-liftCoreExpr expr@(Lit lit) = returnL expr
-
-liftCoreExpr (Note note expr)
- = liftCoreExpr expr `thenL` \ expr ->
- returnL (Note note expr)
-
-liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
- = liftCoreExpr rhs `thenL` \ rhs ->
- liftCoreExpr body `thenL` \ body ->
- returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
-
-liftCoreExpr (Let bind body) -- general case
- = liftBindAndScope False bind (
- liftCoreExpr body `thenL` \ body ->
- returnL (ItsAnExpr body)
- ) `thenL` \ (bind, ItsAnExpr body) ->
- returnL (Let bind body)
-
-liftCoreExpr (Con con args)
- = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
- returnL (applyBindUnlifts unlifts (Con con args))
-
-liftCoreExpr (Prim op args)
- = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
- returnL (applyBindUnlifts unlifts (Prim op args))
-
-liftCoreExpr (App fun arg)
- = lift_app fun [arg]
- where
- lift_app (App fun arg) args
- = lift_app fun (arg:args)
- lift_app other_fun args
- = liftCoreExpr other_fun `thenL` \ other_fun ->
- mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
- returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
-
-liftCoreExpr (Lam binder expr)
- = liftCoreExpr expr `thenL` \ expr ->
- returnL (Lam binder expr)
-
-liftCoreExpr (Case scrut alts)
- = liftCoreExpr scrut `thenL` \ scrut ->
- liftCoreAlts alts `thenL` \ alts ->
- returnL (Case scrut alts)
-
-------------
-liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
-
-liftCoreAlts (AlgAlts alg_alts deflt)
- = mapL liftAlgAlt alg_alts `thenL` \ alg_alts ->
- liftDeflt deflt `thenL` \ deflt ->
- returnL (AlgAlts alg_alts deflt)
-
-liftCoreAlts (PrimAlts prim_alts deflt)
- = mapL liftPrimAlt prim_alts `thenL` \ prim_alts ->
- liftDeflt deflt `thenL` \ deflt ->
- returnL (PrimAlts prim_alts deflt)
-
-------------
-liftAlgAlt (con,args,rhs)
- = liftCoreExpr rhs `thenL` \ rhs ->
- returnL (con,args,rhs)
-
-------------
-liftPrimAlt (lit,rhs)
- = liftCoreExpr rhs `thenL` \ rhs ->
- returnL (lit,rhs)
-
-------------
-liftDeflt NoDefault
- = returnL NoDefault
-liftDeflt (BindDefault binder rhs)
- = liftCoreExpr rhs `thenL` \ rhs ->
- returnL (BindDefault binder rhs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Misc functions}
-%* *
-%************************************************************************
-
-\begin{code}
-type LiftM a
- = IdEnv (Id, Id) -- lifted Ids are mapped to:
- -- * lifted Id with the same Unique
- -- (top-level bindings must keep their unique
- -- * unlifted version with a new Unique
- -> UniqSupply -- unique supply
- -> a -- result
-
-data BindsOrExpr
- = ItsABinds [CoreBinding]
- | ItsAnExpr CoreExpr
-
-initL m us = m nullIdEnv us
-
-returnL :: a -> LiftM a
-returnL r idenv us = r
-
-thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
-thenL m k idenv s0
- = case (splitUniqSupply s0) of { (s1, s2) ->
- case (m idenv s1) of { r ->
- k r idenv s2 }}
-
-
-mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
-mapL f [] = returnL []
-mapL f (x:xs)
- = f x `thenL` \ r ->
- mapL f xs `thenL` \ rs ->
- returnL (r:rs)
-
-mapAndUnzipL :: (a -> LiftM (b1, b2)) -> [a] -> LiftM ([b1],[b2])
-mapAndUnzipL f [] = returnL ([],[])
-mapAndUnzipL f (x:xs)
- = f x `thenL` \ (r1, r2) ->
- mapAndUnzipL f xs `thenL` \ (rs1,rs2) ->
- returnL ((r1:rs1),(r2:rs2))
-
--- liftBinders is only called for top-level or recusive case
-liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
-
-liftBinders False (NonRec _ _) liftM idenv s0
- = panic "CoreLift:liftBinders" -- should be caught by special case above
-
-liftBinders top_lev bind liftM idenv s0
- = liftM (growIdEnvList idenv lift_map) s2
- where
- (s1, s2) = splitUniqSupply s0
- lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
- lift_uniqs = getUniques (length lift_ids) s1
- lift_map = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
-
- -- ToDo: Give warning for recursive bindings involving unboxed values ???
-
-isLiftedId :: Id -> LiftM (Maybe (Id, Id))
-isLiftedId id idenv us
- | isLocallyDefined id
- = lookupIdEnv idenv id
- | otherwise -- ensure all imported ids are lifted
- = if isUnboxedButNotState (idType id)
- then Just (mkLiftedId id (getUnique us))
- else Nothing
-
-mkLiftedId :: Id -> Unique -> (Id,Id)
-mkLiftedId id u
- = ASSERT (isUnboxedButNotState unlifted_ty)
- (lifted_id, unlifted_id)
- where
- id_name = _PK_ (getOccString id) -- yuk!
- lifted_id = mkIdWithNewType id lifted_ty
- unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
-
- unlifted_ty = idType id
- lifted_ty = mkLiftTy unlifted_ty
-
-bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
-bindUnlift vlift vunlift expr
- = ASSERT (isUnboxedButNotState unlift_ty)
- ASSERT (lift_ty == mkLiftTy unlift_ty)
- Case (Var vlift)
- (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
- where
- lift_ty = idType vlift
- unlift_ty = idType vunlift
-
-liftExpr :: Id -> CoreExpr -> CoreExpr
-liftExpr vunlift rhs
- = ASSERT (isUnboxedButNotState unlift_ty)
- ASSERT (rhs_ty == unlift_ty)
- Case rhs (PrimAlts []
- (BindDefault vunlift (mkCon liftDataCon [unlift_ty] [VarArg vunlift])))
- where
- rhs_ty = coreExprType rhs
- unlift_ty = idType vunlift
-
-
-applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
-applyBindUnlifts [] expr = expr
-applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
-
-isUnboxedButNotState ty =
- case (splitAlgTyConApp_maybe ty) of
- Nothing -> False
- Just (tycon, _, _) ->
- not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[CoreLint]{A ``lint'' pass to check for Core correctness}
\begin{code}
module CoreLint (
lintCoreBindings,
- lintUnfolding
+ lintUnfolding,
+ beginPass, endPass
) where
#include "HsVersions.h"
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting )
import CoreSyn
-import CoreUtils ( idSpecVars )
+import CoreUtils ( idFreeVars )
import Bag
-import Kind ( hasMoreBoxityInfo, Kind{-instance-} )
-import Literal ( literalType, Literal{-instance-} )
-import Id ( idType, isBottomingId, dataConRepType, isDataCon, isAlgCon,
- dataConArgTys, GenId{-instances-},
- emptyIdSet, mkIdSet,
- unionIdSets, elementOfIdSet, IdSet,
- Id
- )
-import Maybes ( catMaybes )
-import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
- NamedThing(..)
- )
+import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
+import Id ( isConstantId, idMustBeINLINEd )
+import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar )
+import VarSet
+import VarEnv ( mkVarEnv )
+import Name ( isLocallyDefined, getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, ghcExit )
-import PrimOp ( primOpType )
+import ErrUtils ( doIfSet, dumpIfSet, ghcExit )
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc )
-import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy,
- splitForAllTy_maybe, tyVarsOfType,
- isUnpointedType, typeKind, instantiateTy,
- splitAlgTyConApp_maybe, Type
- )
-import TyCon ( TyCon, isPrimTyCon, isDataTyCon )
-import TyVar ( TyVar, tyVarKind, mkTyVarEnv,
- TyVarSet,
- emptyTyVarSet, mkTyVarSet, isEmptyTyVarSet,
- minusTyVarSet, elementOfTyVarSet, tyVarSetToList,
- unionTyVarSets, intersectTyVarSets
+import Type ( Type, Kind, tyVarsOfType,
+ splitFunTy_maybe, mkPiType, mkTyVarTy,
+ splitForAllTy_maybe, splitTyConApp_maybe,
+ isUnLiftedType, typeKind, substTy,
+ splitAlgTyConApp_maybe,
+ isUnboxedTupleType,
+ hasMoreBoxityInfo
)
+import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
import ErrUtils ( ErrMsg )
-import Unique ( Unique )
-import Util ( zipEqual )
import Outputable
infixr 9 `thenL`, `seqL`, `thenMaybeL`
%************************************************************************
%* *
+\subsection{Start and end pass}
+%* *
+%************************************************************************
+
+@beginPass@ and @endPass@ don't really belong here, but it makes a convenient
+place for them. They print out stuff before and after core passes,
+and do Core Lint when necessary.
+
+\begin{code}
+beginPass :: String -> IO ()
+beginPass pass_name
+ | opt_D_show_passes
+ = hPutStr stderr ("*** " ++ pass_name ++ "\n")
+ | otherwise
+ = return ()
+
+
+endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
+endPass pass_name dump_flag binds
+ = do
+ -- Report verbosely, if required
+ dumpIfSet dump_flag pass_name
+ (pprCoreBindings binds)
+
+ -- Type check
+ lintCoreBindings pass_name binds
+
+ return binds
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
%* *
%************************************************************************
--
-- * Oversaturated type app after specialisation (eta reduction
-- may well be happening...);
- --
- -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
- --
\begin{code}
-lintCoreBindings :: String -> Bool -> [CoreBinding] -> IO ()
+lintCoreBindings :: String -> [CoreBind] -> IO ()
-lintCoreBindings whoDunnit spec_done binds
+lintCoreBindings whoDunnit binds
| not opt_DoCoreLinting
= return ()
-lintCoreBindings whoDunnit spec_done binds
- = case (initL (lint_binds binds) spec_done) of
+lintCoreBindings whoDunnit binds
+ = case (initL (lint_binds binds)) of
Nothing -> doIfSet opt_D_show_passes
(hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
lintUnfolding locn expr
= case
- (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
- True{-pretend spec done-})
+ initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
of
Nothing -> Just expr
Just msg ->
Check a core binding, returning the list of variables bound.
\begin{code}
-lintCoreBinding :: CoreBinding -> LintM [Id]
+lintCoreBinding :: CoreBind -> LintM [Id]
lintCoreBinding (NonRec binder rhs)
= lintSingleBinding (binder,rhs) `seqL` returnL [binder]
mapL lintSingleBinding pairs `seqL` returnL binders
)
where
- binders = [b | (b,_) <- pairs]
+ binders = map fst pairs
lintSingleBinding (binder,rhs)
- = addLoc (RhsOf binder) (
+ = addLoc (RhsOf binder) $
+
-- Check the rhs
- lintCoreExpr rhs
+ lintCoreExpr rhs `thenL` \ ty ->
- `thenL` \maybe_ty ->
-- Check match to RHS type
- (case maybe_ty of
- Nothing -> returnL ()
- Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
+ lintBinder binder `seqL`
+ checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
- `seqL`
- -- Check (not isUnpointedType)
- checkIfSpecDoneL (not (isUnpointedType (idType binder)))
- (mkRhsPrimMsg binder rhs) `seqL`
+ -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
+ checkL (not (isUnLiftedType binder_ty))
+ (mkRhsPrimMsg binder rhs) `seqL`
-- Check whether binder's specialisations contain any out-of-scope variables
- ifSpecDoneL (mapL (checkSpecIdInScope binder) spec_vars `seqL` returnL ())
+ mapL (checkBndrIdInScope binder) bndr_vars `seqL`
+ returnL ()
-- We should check the unfolding, if any, but this is tricky because
-- the unfolding is a SimplifiableCoreExpr. Give up for now.
- )
- where
- spec_vars = idSpecVars binder
-
+ where
+ binder_ty = idType binder
+ bndr_vars = varSetElems (idFreeVars binder)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
+lintCoreExpr :: CoreExpr -> LintM Type
lintCoreExpr (Var var)
- | isAlgCon var = returnL (Just (idType var))
+ | isConstantId var = returnL (idType var)
-- Micro-hack here... Class decls generate applications of their
-- dictionary constructor, but don't generate a binding for the
-- constructor (since it would never be used). After a single round
-- variables as the function in an application.
-- The hack here simply doesn't check for out-of-scope-ness for
-- data constructors (at least, in a function position).
+ -- Ditto primitive Ids
- | otherwise = checkIdInScope var `seqL` returnL (Just (idType var))
-
-lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
+ | otherwise = checkIdInScope var `seqL` returnL (idType var)
lintCoreExpr (Note (Coerce to_ty from_ty) expr)
- = lintCoreExpr expr `thenMaybeL` \ expr_ty ->
+ = lintCoreExpr expr `thenL` \ expr_ty ->
lintTy to_ty `seqL`
lintTy from_ty `seqL`
checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
- returnL (Just to_ty)
+ returnL to_ty
lintCoreExpr (Note other_note expr)
= lintCoreExpr expr
(addInScopeVars binders (lintCoreExpr body))
lintCoreExpr e@(Con con args)
- = checkL (isDataCon con) (mkConErrMsg e) `seqL`
- lintCoreArgs {-False-} e (dataConRepType con) args
- -- Note: we don't check for primitive types in these arguments
-
-lintCoreExpr e@(Prim op args)
- = lintCoreArgs {-True-} e (primOpType op) args
- -- Note: we do check for primitive types in these arguments
-
-lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
- = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
- -- Note: we don't check for primitive types in argument to 'error'
+ = addLoc (AnExpr e) $
+ checkL (conOkForApp con) (mkConAppMsg e) `seqL`
+ lintCoreArgs (conType con) args
lintCoreExpr e@(App fun arg)
- = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
- -- Note: we do check for primitive types in this argument
-
-lintCoreExpr (Lam vb@(ValBinder var) expr)
- = addLoc (LambdaBodyOf vb)
- (addInScopeVars [var]
- (lintCoreExpr expr `thenMaybeL` \ty ->
- returnL (Just (mkFunTy (idType var) ty))))
-
-lintCoreExpr (Lam tb@(TyBinder tyvar) expr)
- = addLoc (LambdaBodyOf tb) $
- addInScopeTyVars [tyvar] $
- lintCoreExpr expr `thenMaybeL` \ ty ->
- returnL (Just(mkForAllTy tyvar ty))
-
-lintCoreExpr e@(Case scrut alts)
- = lintCoreExpr scrut `thenMaybeL` \ty ->
- lintCoreAlts alts ty
+ = lintCoreExpr fun `thenL` \ ty ->
+ addLoc (AnExpr e) $
+ lintCoreArg ty arg
+
+lintCoreExpr (Lam var expr)
+ = addLoc (LambdaBodyOf var) $
+ checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
+ `seqL`
+ (addInScopeVars [var] $
+ lintCoreExpr expr `thenL` \ ty ->
+ returnL (mkPiType var ty))
+
+lintCoreExpr e@(Case scrut var alts)
+ = -- Check the scrutinee
+ lintCoreExpr scrut `thenL` \ scrut_ty ->
+
+ -- Check the binder
+ lintBinder var `seqL`
+
+ -- If this is an unboxed tuple case, then the binder must be dead
+ {-
+ checkL (if isUnboxedTupleType (idType var)
+ then isDeadBinder var
+ else True) (mkUnboxedTupleMsg var) `seqL`
+ -}
+
+ checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
+
+ addInScopeVars [var] (
+
+ -- Check the alternatives
+ checkAllCasesCovered e scrut_ty alts `seqL`
+ mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
+ mapL (check alt_ty) alt_tys `seqL`
+ returnL alt_ty)
+ where
+ check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
\end{code}
%************************************************************************
applications to primitive types as being errors.
\begin{code}
-lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
+lintCoreArgs :: Type -> [CoreArg] -> LintM Type
-lintCoreArgs _ ty [] = returnL (Just ty)
-lintCoreArgs e ty (a : args)
- = lintCoreArg e ty a `thenMaybeL` \ res ->
- lintCoreArgs e res args
+lintCoreArgs ty [] = returnL ty
+lintCoreArgs ty (a : args)
+ = lintCoreArg ty a `thenL` \ res ->
+ lintCoreArgs res args
\end{code}
-%************************************************************************
-%* *
-\subsection[lintCoreArg]{lintCoreArg}
-%* *
-%************************************************************************
-
\begin{code}
-lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
+lintCoreArg :: Type -> CoreArg -> LintM Type
-lintCoreArg e ty (LitArg lit)
+lintCoreArg ty a@(Type arg_ty)
+ = lintTy arg_ty `seqL`
+ lintTyApp ty arg_ty
+
+lintCoreArg fun_ty arg
= -- Make sure function type matches argument
- case (splitFunTy_maybe ty) of
- Just (arg,res) | (lit_ty == arg) -> returnL(Just res)
- _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
- where
- lit_ty = literalType lit
-
-lintCoreArg e ty (VarArg v)
- = -- Make sure variable is bound
- checkIdInScope v `seqL`
- -- Make sure function type matches argument
- case (splitFunTy_maybe ty) of
- Just (arg,res) | (var_ty == arg) -> returnL(Just res)
- _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
- where
- var_ty = idType v
+ lintCoreExpr arg `thenL` \ arg_ty ->
+ case (splitFunTy_maybe fun_ty) of
+ Just (arg,res) | (arg_ty == arg) -> returnL res
+ _ -> addErrL (mkAppMsg fun_ty arg_ty)
+\end{code}
-lintCoreArg e ty a@(TyArg arg_ty)
- = lintTy arg_ty `seqL`
- checkTyVarsInScope (tyVarsOfType arg_ty) `seqL`
- case (splitForAllTy_maybe ty) of
- Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
+\begin{code}
+lintTyApp ty arg_ty
+ = case splitForAllTy_maybe ty of
+ Nothing -> addErrL (mkTyAppMsg ty arg_ty)
Just (tyvar,body) ->
let
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
- returnL(Just(instantiateTy (mkTyVarEnv [(tyvar,arg_ty)]) body))
+ returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body)
else
- pprTrace "lintCoreArg:kinds:" (hsep [ppr tyvar_kind, ppr argty_kind]) $
- addErrL (mkKindErrMsg tyvar arg_ty e) `seqL` returnL Nothing
+ addErrL (mkKindErrMsg tyvar arg_ty)
+
+lintTyApps fun_ty []
+ = returnL fun_ty
+
+lintTyApps fun_ty (arg_ty : arg_tys)
+ = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
+ lintTyApps fun_ty' arg_tys
\end{code}
+
+
%************************************************************************
%* *
\subsection[lintCoreAlts]{lintCoreAlts}
%************************************************************************
\begin{code}
-lintCoreAlts :: CoreCaseAlts
- -> Type -- Type of scrutinee
--- -> TyCon -- TyCon pinned on the case
- -> LintM (Maybe Type) -- Type of alternatives
-
-lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
- = -- Check tycon is not a primitive tycon
--- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
--- `seqL`
- -- Check we are scrutinising a proper datatype
- -- (ToDo: robustify)
--- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
--- `seqL`
- lintDeflt deflt ty
- `thenL` \maybe_deflt_ty ->
- mapL (lintAlgAlt ty {-tycon-}) alts
- `thenL` \maybe_alt_tys ->
- -- Check the result types
- case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
- [] -> returnL Nothing
-
- (first_ty:tys) -> mapL check tys `seqL`
- returnL (Just first_ty)
- where
- check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-
-lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
- = -- Check tycon is a primitive tycon
--- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
--- `seqL`
- mapL (lintPrimAlt ty) alts
- `thenL` \maybe_alt_tys ->
- lintDeflt deflt ty
- `thenL` \maybe_deflt_ty ->
- -- Check the result types
- case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
- [] -> returnL Nothing
-
- (first_ty:tys) -> mapL check tys `seqL`
- returnL (Just first_ty)
- where
- check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-
-lintAlgAlt scrut_ty (con,args,rhs)
- = (case splitAlgTyConApp_maybe scrut_ty of
- Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
- let
- arg_tys = dataConArgTys con tys_applied
- in
- checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
- checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
- `seqL`
- mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
- returnL ()
-
- other -> addErrL (mkAlgAltMsg1 scrut_ty)
- ) `seqL`
- addInScopeVars args (
- lintCoreExpr rhs
- )
+checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
+
+checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
+
+checkAllCasesCovered e scrut_ty alts
+ = case splitTyConApp_maybe scrut_ty of {
+ Nothing -> addErrL (badAltsMsg e);
+ Just (tycon, tycon_arg_tys) ->
+
+ if isPrimTyCon tycon then
+ checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
+ else
+#ifdef DEBUG
+ -- Algebraic cases are not necessarily exhaustive, because
+ -- the simplifer correctly eliminates case that can't
+ -- possibly match.
+ -- This code just emits a message to say so
+ let
+ missing_cons = filter not_in_alts (tyConDataCons tycon)
+ not_in_alts con = all (not_in_alt con) alts
+ not_in_alt con (DataCon con', _, _) = con /= con'
+ not_in_alt con other = True
+
+ case_bndr = case e of { Case _ bndr alts -> bndr }
+ in
+ if not (hasDefault alts || null missing_cons) then
+ pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
+ (ppr case_bndr <+> ppr missing_cons)
+ nopL
+ else
+#endif
+ nopL }
+
+hasDefault [] = False
+hasDefault ((DEFAULT,_,_) : alts) = True
+hasDefault (alt : alts) = hasDefault alts
+\end{code}
+
+\begin{code}
+lintCoreAlt :: Type -- Type of scrutinee
+ -> CoreAlt
+ -> LintM Type -- Type of alternatives
+
+lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
+ = checkL (null args) (mkDefaultArgsMsg args) `seqL`
+ lintCoreExpr rhs
+
+lintCoreAlt scrut_ty alt@(con, args, rhs)
+ = addLoc (CaseAlt alt) (
+
+ checkL (conOkForAlt con) (mkConAltMsg con) `seqL`
+
+ mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
+ (mkUnboxedTupleMsg arg)) args `seqL`
+
+ addInScopeVars args (
+
+ -- Check the pattern
+ -- Scrutinee type must be a tycon applicn; checked by caller
+ -- This code is remarkably compact considering what it does!
+ -- NB: args must be in scope here so that the lintCoreArgs line works.
+ case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
+ lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type ->
+ lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
+ checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
+ } `seqL`
+
+ -- Check the RHS
+ lintCoreExpr rhs
+ ))
where
- check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
-
- -- elem: yes, the elem-list here can sometimes be long-ish,
- -- but as it's use-once, probably not worth doing anything different
- -- We give it its own copy, so it isn't overloaded.
- elem _ [] = False
- elem x (y:ys) = x==y || elem x ys
-
-lintPrimAlt ty alt@(lit,rhs)
- = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
- lintCoreExpr rhs
-
-lintDeflt NoDefault _ = returnL Nothing
-lintDeflt deflt@(BindDefault binder rhs) ty
- = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
- addInScopeVars [binder] (lintCoreExpr rhs)
+ mk_arg b | isTyVar b = Type (mkTyVarTy b)
+ | otherwise = Var b
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+lintBinder :: IdOrTyVar -> LintM ()
+lintBinder v = nopL
+-- ToDo: lint its type
+
lintTy :: Type -> LintM ()
-lintTy ty = returnL ()
--- ToDo: Check that ty is well-kinded and has no unbound tyvars
+lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
+ returnL ()
+ -- ToDo: check the kind structure of the type
\end{code}
%************************************************************************
\begin{code}
-type LintM a = Bool -- True <=> specialisation has been done
- -> [LintLocInfo] -- Locations
+type LintM a = [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
- -> TyVarSet -- Local tyvars in scope
-> Bag ErrMsg -- Error messages so far
- -> (a, Bag ErrMsg) -- Result and error messages (if any)
+ -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any)
data LintLocInfo
- = RhsOf Id -- The variable bound
- | LambdaBodyOf CoreBinder -- The lambda-binder
- | BodyOfLetRec [Id] -- One of the binders
- | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
-
-instance Outputable LintLocInfo where
- ppr (RhsOf v)
- = ppr (getSrcLoc v) <> colon <+>
- brackets (ptext SLIT("RHS of") <+> pp_binders [v])
-
- ppr (LambdaBodyOf (ValBinder b))
- = ppr (getSrcLoc b) <> colon <+>
- brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
-
- ppr (LambdaBodyOf (TyBinder b))
- = ppr (getSrcLoc b) <> colon <+>
- brackets (ptext SLIT("in body of lambda with type binder") <+> ppr b)
-
- ppr (BodyOfLetRec bs)
- = ppr (getSrcLoc (head bs)) <> colon <+>
- brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
-
- ppr (ImportedUnfolding locn)
- = ppr locn <> colon <+>
- brackets (ptext SLIT("in an imported unfolding"))
-
-pp_binders :: [Id] -> SDoc
-pp_binders bs = sep (punctuate comma (map pp_binder bs))
-
-pp_binder :: Id -> SDoc
-pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
+ = RhsOf Id -- The variable bound
+ | LambdaBodyOf Id -- The lambda-binder
+ | BodyOfLetRec [Id] -- One of the binders
+ | CaseAlt CoreAlt -- Pattern of a case alternative
+ | AnExpr CoreExpr -- Some expression
+ | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
\end{code}
\begin{code}
-initL :: LintM a -> Bool -> Maybe ErrMsg
-initL m spec_done
- = case (m spec_done [] emptyIdSet emptyTyVarSet emptyBag) of { (_, errs) ->
+initL :: LintM a -> Maybe ErrMsg
+initL m
+ = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
}
returnL :: a -> LintM a
-returnL r spec loc scope tyscope errs = (r, errs)
+returnL r loc scope errs = (Just r, errs)
+
+nopL :: LintM a
+nopL loc scope errs = (Nothing, errs)
thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k spec loc scope tyscope errs
- = case m spec loc scope tyscope errs of
- (r, errs') -> k r spec loc scope tyscope errs'
+thenL m k loc scope errs
+ = case m loc scope errs of
+ (Just r, errs') -> k r loc scope errs'
+ (Nothing, errs') -> (Nothing, errs')
seqL :: LintM a -> LintM b -> LintM b
-seqL m k spec loc scope tyscope errs
- = case m spec loc scope tyscope errs of
- (_, errs') -> k spec loc scope tyscope errs'
-
-thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
-thenMaybeL m k spec loc scope tyscope errs
- = case m spec loc scope tyscope errs of
- (Nothing, errs2) -> (Nothing, errs2)
- (Just r, errs2) -> k r spec loc scope tyscope errs2
+seqL m k loc scope errs
+ = case m loc scope errs of
+ (_, errs') -> k loc scope errs'
mapL :: (a -> LintM b) -> [a] -> LintM [b]
mapL f [] = returnL []
= f x `thenL` \ r ->
mapL f xs `thenL` \ rs ->
returnL (r:rs)
-
-mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
- -- Returns Nothing if anything fails
-mapMaybeL f [] = returnL (Just [])
-mapMaybeL f (x:xs)
- = f x `thenMaybeL` \ r ->
- mapMaybeL f xs `thenMaybeL` \ rs ->
- returnL (Just (r:rs))
\end{code}
\begin{code}
checkL :: Bool -> ErrMsg -> LintM ()
-checkL True msg spec loc scope tyscope errs = ((), errs)
-checkL False msg spec loc scope tyscope errs = ((), addErr errs msg loc)
-
-checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
-checkIfSpecDoneL True msg spec loc scope tyscope errs = ((), errs)
-checkIfSpecDoneL False msg True loc scope tyscope errs = ((), addErr errs msg loc)
-checkIfSpecDoneL False msg False loc scope tyscope errs = ((), errs)
-
-ifSpecDoneL :: LintM () -> LintM ()
-ifSpecDoneL m False loc scope tyscope errs = ((), errs)
-ifSpecDoneL m True loc scope tyscope errs = m True loc scope tyscope errs
+checkL True msg loc scope errs = (Nothing, errs)
+checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
-addErrL :: ErrMsg -> LintM ()
-addErrL msg spec loc scope tyscope errs = ((), addErr errs msg loc)
+addErrL :: ErrMsg -> LintM a
+addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
addErr errs_so_far msg locs
= ASSERT (not (null locs))
- errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg)
+ errs_so_far `snocBag` (hang (pprLoc (head locs)) 4 msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m spec loc scope tyscope errs
- = m spec (extra_loc:loc) scope tyscope errs
-
-addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m spec loc scope tyscope errs
- = -- We check if these "new" ids are already
- -- in scope, i.e., we have *shadowing* going on.
- -- For now, it's just a "trace"; we may make
- -- a real error out of it...
- let
- new_set = mkIdSet ids
+addLoc extra_loc m loc scope errs
+ = m (extra_loc:loc) scope errs
--- shadowed = scope `intersectIdSets` new_set
- in
--- After adding -fliberate-case, Simon decided he likes shadowed
--- names after all. WDP 94/07
--- (if isEmptyUniqSet shadowed
--- then id
--- else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) (
- m spec loc (scope `unionIdSets` new_set) tyscope errs
--- )
-
-addInScopeTyVars :: [TyVar] -> LintM a -> LintM a
-addInScopeTyVars tyvars m spec loc scope tyscope errs
- = m spec loc scope (tyscope `unionTyVarSets` new_set) errs
- where
- new_set = mkTyVarSet tyvars
-
+addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a
+addInScopeVars ids m loc scope errs
+ = m loc (scope `unionVarSet` mkVarSet ids) errs
\end{code}
\begin{code}
-checkIdInScope :: Id -> LintM ()
+checkIdInScope :: IdOrTyVar -> LintM ()
checkIdInScope id
= checkInScope (ptext SLIT("is out of scope")) id
-checkSpecIdInScope :: Id -> Id -> LintM ()
-checkSpecIdInScope binder id
+checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
+checkBndrIdInScope binder id
= checkInScope msg id
where
- msg = ptext SLIT("is out of scope inside specialisation info for") <+>
+ msg = ptext SLIT("is out of scope inside info for") <+>
ppr binder
-checkInScope :: SDoc -> Id -> LintM ()
-checkInScope loc_msg id spec loc scope tyscope errs
- = let
- id_name = getName id
- in
- if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
- ((), addErr errs (hsep [ppr id, loc_msg]) loc)
- else
- ((),errs)
-
-checkTyVarsInScope :: TyVarSet -> LintM ()
-checkTyVarsInScope tyvars spec loc scope tyscope errs
--- | not (isEmptyTyVarSet out_of_scope) = ((), errs')
- | otherwise = ((), errs)
- where
- out_of_scope = tyvars `minusTyVarSet` tyscope
- errs' =
- foldr (\ tv errs -> addErr errs (hsep [ppr tv, ptext SLIT("is out of scope")]) loc)
- errs
- (tyVarSetToList out_of_scope)
+checkInScope :: SDoc -> IdOrTyVar -> LintM ()
+checkInScope loc_msg id loc scope errs
+ | isLocallyDefined id
+ && not (id `elemVarSet` scope)
+ && not (idMustBeINLINEd id) -- Constructors and dict selectors
+ -- don't have bindings,
+ -- just MustInline prags
+ = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
+ | otherwise
+ = (Nothing,errs)
checkTys :: Type -> Type -> ErrMsg -> LintM ()
-checkTys ty1 ty2 msg spec loc scope tyscope errs
- = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc)
+checkTys ty1 ty2 msg loc scope errs
+ | ty1 == ty2 = (Nothing, errs)
+ | otherwise = (Nothing, addErr errs msg loc)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
\begin{code}
-mkConErrMsg e
- = ($$) (ptext SLIT("Application of newtype constructor:"))
- (ppr e)
+pprLoc (RhsOf v)
+ = ppr (getSrcLoc v) <> colon <+>
+ brackets (ptext SLIT("RHS of") <+> pp_binders [v])
+
+pprLoc (LambdaBodyOf b)
+ = ppr (getSrcLoc b) <> colon <+>
+ brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
+pprLoc (BodyOfLetRec bs)
+ = ppr (getSrcLoc (head bs)) <> colon <+>
+ brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
+
+pprLoc (AnExpr e)
+ = text "In the expression:" <+> ppr e
-mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
-mkCaseAltMsg alts
- = ($$) (ptext SLIT("Type of case alternatives not the same:"))
- (ppr alts)
+pprLoc (CaseAlt (con, args, rhs))
+ = text "In a case pattern:" <+> parens (ppr con <+> ppr args)
+
+pprLoc (ImportedUnfolding locn)
+ = ppr locn <> colon <+>
+ brackets (ptext SLIT("in an imported unfolding"))
+
+pp_binders :: [Id] -> SDoc
+pp_binders bs = sep (punctuate comma (map pp_binder bs))
+
+pp_binder :: Id -> SDoc
+pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
+\end{code}
-mkCaseAbstractMsg :: TyCon -> ErrMsg
-mkCaseAbstractMsg tycon
- = ($$) (ptext SLIT("An algebraic case on some weird type:"))
- (ppr tycon)
+\begin{code}
+------------------------------------------------------
+-- Messages for case expressions
+
+mkConAppMsg :: CoreExpr -> ErrMsg
+mkConAppMsg e
+ = hang (text "Application of newtype constructor:")
+ 4 (ppr e)
+
+mkConAltMsg :: Con -> ErrMsg
+mkConAltMsg con
+ = text "PrimOp in case pattern:" <+> ppr con
+
+mkNullAltsMsg :: CoreExpr -> ErrMsg
+mkNullAltsMsg e
+ = hang (text "Case expression with no alternatives:")
+ 4 (ppr e)
+
+mkDefaultArgsMsg :: [IdOrTyVar] -> ErrMsg
+mkDefaultArgsMsg args
+ = hang (text "DEFAULT case with binders")
+ 4 (ppr args)
+
+mkCaseAltMsg :: CoreExpr -> ErrMsg
+mkCaseAltMsg e
+ = hang (text "Type of case alternatives not the same:")
+ 4 (ppr e)
+
+mkScrutMsg :: Id -> Type -> ErrMsg
+mkScrutMsg var scrut_ty
+ = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
+ text "Result binder type:" <+> ppr (idType var),
+ text "Scrutinee type:" <+> ppr scrut_ty]
+
+badAltsMsg :: CoreExpr -> ErrMsg
+badAltsMsg e
+ = hang (text "Case statement scrutinee is not a data type:")
+ 4 (ppr e)
+
+nonExhaustiveAltsMsg :: CoreExpr -> ErrMsg
+nonExhaustiveAltsMsg e
+ = hang (text "Case expression with non-exhaustive alternatives")
+ 4 (ppr e)
+
+mkBadPatMsg :: Type -> Type -> ErrMsg
+mkBadPatMsg con_result_ty scrut_ty
+ = vcat [
+ text "In a case alternative, pattern result type doesn't match scrutinee type:",
+ text "Pattern result type:" <+> ppr con_result_ty,
+ text "Scrutinee type:" <+> ppr scrut_ty
+ ]
-mkDefltMsg :: CoreCaseDefault -> ErrMsg
-mkDefltMsg deflt
- = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
- (ppr deflt)
+------------------------------------------------------
+-- Other error messages
-mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
-mkAppMsg fun arg expr
+mkAppMsg :: Type -> Type -> ErrMsg
+mkAppMsg fun arg
= vcat [ptext SLIT("Argument value doesn't match argument type:"),
hang (ptext SLIT("Fun type:")) 4 (ppr fun),
- hang (ptext SLIT("Arg type:")) 4 (ppr arg),
- hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
+ hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
-mkKindErrMsg :: TyVar -> Type -> CoreExpr -> ErrMsg
-mkKindErrMsg tyvar arg_ty expr
+mkKindErrMsg :: TyVar -> Type -> ErrMsg
+mkKindErrMsg tyvar arg_ty
= vcat [ptext SLIT("Kinds don't match in type application:"),
hang (ptext SLIT("Type variable:"))
4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty)),
- hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
+ 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
-mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
-mkTyAppMsg msg ty arg expr
- = vcat [hsep [ptext msg, ptext SLIT("type application:")],
+mkTyAppMsg :: Type -> Type -> ErrMsg
+mkTyAppMsg ty arg_ty
+ = vcat [text "Illegal type application:",
hang (ptext SLIT("Exp type:"))
4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg <+> ptext SLIT("::") <+> ppr (typeKind arg)),
- hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
-
-mkAlgAltMsg1 :: Type -> ErrMsg
-mkAlgAltMsg1 ty
- = ($$) (text "In some case statement, type of scrutinee is not a data type:")
- (ppr ty)
-
-mkAlgAltMsg2 :: Type -> Id -> ErrMsg
-mkAlgAltMsg2 ty con
- = vcat [
- text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
- ppr ty,
- ppr con
- ]
-
-mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
-mkAlgAltMsg3 con alts
- = vcat [
- text "In some algebraic case alternative, number of arguments doesn't match constructor:",
- ppr con,
- ppr alts
- ]
-
-mkAlgAltMsg4 :: Type -> Id -> ErrMsg
-mkAlgAltMsg4 ty arg
- = vcat [
- text "In some algebraic case alternative, type of argument doesn't match data constructor:",
- ppr ty,
- ppr arg
- ]
-
-mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
-mkPrimAltMsg alt
- = ($$)
- (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
- (ppr alt)
+ 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
mkRhsMsg :: Id -> Type -> ErrMsg
mkRhsMsg binder ty
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
]
+mkUnboxedTupleMsg :: Id -> ErrMsg
+mkUnboxedTupleMsg binder
+ = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
+ hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
+
mkCoerceErr from_ty expr_ty
= vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
ptext SLIT("From-type:") <+> ppr from_ty,
_declarations_
-- Needed by IdInfo
-1 type CoreExpr = GenCoreExpr Id!Id Id!Id BasicTypes.Unused ;
-1 data GenCoreExpr a b c ;
+1 type CoreExpr = Expr Var.IdOrTyVar BasicTypes.Unused;
+1 data Expr b f ;
--- /dev/null
+__interface CoreSyn 1 0 where
+__export CoreSyn CoreExpr ;
+-- Needed by IdInfo
+1 type CoreExpr = Expr Var.IdOrTyVar BasicTypes.Unused;
+1 data Expr b f ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CoreSyn]{A data type for the Haskell compiler midsection}
\begin{code}
module CoreSyn (
- GenCoreBinding(..), GenCoreExpr(..),
- GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
- GenCoreCaseDefault(..), CoreNote(..),
-
- bindersOf, pairsFromCoreBinds, rhssOfBind,
-
- mkGenApp, mkValApp, mkTyApp,
- mkApp, mkCon, mkPrim,
- mkValLam, mkTyLam,
- mkLam,
- collectBinders, collectValBinders, collectTyBinders,
- isValBinder, notValBinder,
-
- collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
-
- mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
- mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
- mkCoLetrecAny, mkCoLetrecNoUnboxed,
-
- rhssOfAlts,
-
- -- Common type instantiation...
- CoreBinding,
- CoreExpr,
- CoreBinder,
- CoreArg,
- CoreCaseAlts,
- CoreCaseDefault,
-
- -- And not-so-common type instantiations...
- TaggedCoreBinding,
- TaggedCoreExpr,
- TaggedCoreBinder,
- TaggedCoreArg,
- TaggedCoreCaseAlts,
- TaggedCoreCaseDefault,
-
- SimplifiableCoreBinding,
- SimplifiableCoreExpr,
- SimplifiableCoreBinder,
- SimplifiableCoreArg,
- SimplifiableCoreCaseAlts,
- SimplifiableCoreCaseDefault
+ Expr(..), Alt, Bind(..), Arg(..), Note(..),
+ CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
+ TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
+
+ mkLets, mkLams,
+ mkApps, mkTyApps, mkValApps,
+ mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, mkNilExpr,
+ bindNonRec, mkIfThenElse, varToCoreExpr,
+
+ bindersOf, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
+ collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
+ collectArgs,
+ coreExprCc,
+
+ isValArg, isTypeArg, valArgCount,
+
+ -- Annotated expressions
+ AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate
) where
#include "HsVersions.h"
-import CostCentre ( CostCentre )
-import Id ( idType, Id )
-import Type ( isUnboxedType,GenType, Type )
-import TyVar ( GenTyVar, TyVar )
-import Util ( panic, assertPanic )
-import BinderInfo ( BinderInfo )
+import TysWiredIn ( boolTy, stringTy, nilDataCon )
+import CostCentre ( CostCentre, isDupdCC, noCostCentre )
+import Var ( Var, GenId, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
+import Id ( mkWildId, getInlinePragma )
+import Type ( GenType, Type, mkTyVarTy, isUnLiftedType )
+import IdInfo ( InlinePragInfo(..) )
import BasicTypes ( Unused )
-import Literal ( Literal )
-import PrimOp ( PrimOp )
+import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
+import TysWiredIn ( trueDataCon, falseDataCon )
+import Outputable
\end{code}
%************************************************************************
%* *
-\subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
+\subsection{The main data types}
%* *
%************************************************************************
-Core programs, bindings, expressions, etc., are parameterised with
-respect to the information kept about binding and bound occurrences of
-variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively. [I
-don't really like the pair of names; I prefer {\em binder} and {\em
-bounder}. Or {\em binder} and {\em var}.]
-
-A @GenCoreBinding@ is either a single non-recursive binding of a
-``binder'' to an expression, or a mutually-recursive blob of same.
-\begin{code}
-data GenCoreBinding val_bdr val_occ flexi
- = NonRec val_bdr (GenCoreExpr val_bdr val_occ flexi)
- | Rec [(val_bdr, GenCoreExpr val_bdr val_occ flexi)]
-\end{code}
+These data types are the heart of the compiler
\begin{code}
-bindersOf :: GenCoreBinding val_bdr val_occ flexi -> [val_bdr]
+data Expr b f -- "b" for the type of binders,
+ -- "f" for the flexi slot in types
+ = Var (GenId f)
+ | Con Con [Arg b f] -- Guaranteed saturated
+ | App (Expr b f) (Arg b f)
+ | Lam b (Expr b f)
+ | Let (Bind b f) (Expr b f)
+ | Case (Expr b f) b [Alt b f] -- Binder gets bound to value of scrutinee
+ -- DEFAULT case must be last, if it occurs at all
+ | Note (Note f) (Expr b f)
+ | Type (GenType f) -- This should only show up at the top
+ -- level of an Arg
+
+type Arg b f = Expr b f -- Can be a Type
+
+type Alt b f = (Con, [b], Expr b f)
+ -- (DEFAULT, [], rhs) is the default alternative
+ -- Remember, a Con can be a literal or a data constructor
+
+data Bind b f = NonRec b (Expr b f)
+ | Rec [(b, (Expr b f))]
+
+data Note f
+ = SCC CostCentre
-pairsFromCoreBinds ::
- [GenCoreBinding val_bdr val_occ flexi] ->
- [(val_bdr, GenCoreExpr val_bdr val_occ flexi)]
-
-rhssOfBind :: GenCoreBinding val_bdr val_occ flexi -> [GenCoreExpr val_bdr val_occ flexi]
-
-bindersOf (NonRec binder _) = [binder]
-bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
-
-pairsFromCoreBinds [] = []
-pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs
-pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs
+ | Coerce
+ (GenType f) -- The to-type: type of whole coerce expression
+ (GenType f) -- The from-type: type of enclosed expression
-rhssOfBind (NonRec _ rhs) = [rhs]
-rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
+ | InlineCall -- Instructs simplifier to inline
+ -- the enclosed call
\end{code}
+
%************************************************************************
%* *
-\subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
+\subsection{Useful synonyms}
%* *
%************************************************************************
-@GenCoreExpr@ is the heart of the ``core'' data types; it is
-(more-or-less) boiled-down second-order polymorphic lambda calculus.
-For types in the core world, we just keep using @Types@.
-\begin{code}
-data GenCoreExpr val_bdr val_occ flexi
- = Var val_occ
- | Lit Literal -- literal constants
-\end{code}
-
-@Cons@ and @Prims@ are saturated constructor and primitive-op
-applications (see the comment). Note: @Con@s are only set up by the
-simplifier (and by the desugarer when it knows what it's doing). The
-desugarer sets up constructors as applications of global @Vars@s.
+The common case
\begin{code}
- | Con Id [GenCoreArg val_occ flexi]
- -- Saturated constructor application:
- -- The constructor is a function of the form:
- -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
- -- <expr> where "/\" is a type lambda and "\" the
- -- regular kind; there will be "m" Types and
- -- "n" bindees in the Con args.
-
- | Prim PrimOp [GenCoreArg val_occ flexi]
- -- saturated primitive operation;
-
- -- comment on Cons applies here, too.
+type CoreBndr = IdOrTyVar
+type CoreExpr = Expr CoreBndr Unused
+type CoreArg = Arg CoreBndr Unused
+type CoreBind = Bind CoreBndr Unused
+type CoreAlt = Alt CoreBndr Unused
+type CoreNote = Note Unused
\end{code}
-Ye olde abstraction and application operators.
-\begin{code}
- | Lam (GenCoreBinder val_bdr flexi)
- (GenCoreExpr val_bdr val_occ flexi)
-
- | App (GenCoreExpr val_bdr val_occ flexi)
- (GenCoreArg val_occ flexi)
-\end{code}
-
-Case expressions (\tr{case <expr> of <List of alternatives>}): there
-are really two flavours masquerading here---those for scrutinising
-{\em algebraic} types and those for {\em primitive} types. Please see
-under @GenCoreCaseAlts@.
-\begin{code}
- | Case (GenCoreExpr val_bdr val_occ flexi)
- (GenCoreCaseAlts val_bdr val_occ flexi)
-\end{code}
-
-A Core case expression \tr{case e of v -> ...} implies evaluation of
-\tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
-\tr{case}).
+Binders are ``tagged'' with a \tr{t}:
-Non-recursive @Lets@ only have one binding; having more than one
-doesn't buy you much, and it is an easy way to mess up variable
-scoping.
\begin{code}
- | Let (GenCoreBinding val_bdr val_occ flexi)
- (GenCoreExpr val_bdr val_occ flexi)
- -- both recursive and non-.
- -- The "GenCoreBinding" records that information
-\end{code}
+type Tagged t = (CoreBndr, t)
-A @Note@ annotates a @CoreExpr@ with useful information
-of some kind.
-\begin{code}
- | Note (CoreNote flexi)
- (GenCoreExpr val_bdr val_occ flexi)
+type TaggedBind t = Bind (Tagged t) Unused
+type TaggedExpr t = Expr (Tagged t) Unused
+type TaggedArg t = Arg (Tagged t) Unused
+type TaggedAlt t = Alt (Tagged t) Unused
\end{code}
%************************************************************************
%* *
-\subsection{Core-notes}
+\subsection{Core-constructing functions with checking}
%* *
%************************************************************************
\begin{code}
-data CoreNote flexi
- = SCC
- CostCentre
-
- | Coerce
- (GenType flexi) -- The to-type: type of whole coerce expression
- (GenType flexi) -- The from-type: type of enclosed expression
-
- | InlineCall -- Instructs simplifier to inline
- -- the enclosed call
+mkApps :: Expr b f -> [Arg b f] -> Expr b f
+mkTyApps :: Expr b f -> [GenType f] -> Expr b f
+mkValApps :: Expr b f -> [Expr b f] -> Expr b f
+
+mkApps f args = foldl App f args
+mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
+mkValApps f args = foldl (\ e a -> App e a) f args
+
+mkLit :: Literal -> Expr b f
+mkStringLit :: String -> Expr b f
+mkConApp :: DataCon -> [Arg b f] -> Expr b f
+mkPrimApp :: PrimOp -> [Arg b f] -> Expr b f
+
+mkLit lit = Con (Literal lit) []
+mkStringLit str = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
+mkConApp con args = Con (DataCon con) args
+mkPrimApp op args = Con (PrimOp op) args
+
+mkNilExpr :: Type -> CoreExpr
+mkNilExpr ty = Con (DataCon nilDataCon) [Type ty]
+
+varToCoreExpr :: CoreBndr -> CoreExpr
+varToCoreExpr v | isId v = Var v
+ | otherwise = Type (mkTyVarTy v)
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Core-constructing functions with checking}
-%* *
-%************************************************************************
-
-When making @Lets@, we may want to take evasive action if the thing
-being bound has unboxed type. We have different variants ...
-
-@mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
-@mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
-@mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
- (unboxed bindings in a letrec are still prohibited)
+\end{code}
\begin{code}
-mkCoLetAny :: GenCoreBinding Id Id flexi
- -> GenCoreExpr Id Id flexi
- -> GenCoreExpr Id Id flexi
-mkCoLetsAny :: [GenCoreBinding Id Id flexi] ->
- GenCoreExpr Id Id flexi ->
- GenCoreExpr Id Id flexi
+mkLets :: [Bind b f] -> Expr b f -> Expr b f
+mkLets binds body = foldr Let body binds
-mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ flexi)]
- -> GenCoreExpr val_bdr val_occ flexi
- -> GenCoreExpr val_bdr val_occ flexi
-
-mkCoLetrecAny [] body = body
-mkCoLetrecAny binds body = Let (Rec binds) body
-
-mkCoLetsAny [] expr = expr
-mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
-
-mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
-mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
+mkLams :: [b] -> Expr b f -> Expr b f
+mkLams binders body = foldr Lam body binders
\end{code}
\begin{code}
-mkCoLetNoUnboxed bind@(Rec binds) body
- = mkCoLetrecNoUnboxed binds body
-
-mkCoLetNoUnboxed bind@(NonRec binder rhs) body
- = --ASSERT (not (isUnboxedType (idType binder)))
- case body of
- Var binder2 | binder == binder2
- -> rhs -- hey, I have the rhs
- other
- -> Let bind body
-
-mkCoLetsNoUnboxed [] expr = expr
-mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
-
-mkCoLetrecNoUnboxed [] body = body
-mkCoLetrecNoUnboxed binds body
- = ASSERT (all is_boxed_bind binds)
- Let (Rec binds) body
- where
- is_boxed_bind (binder, rhs)
- = (not . isUnboxedType . idType) binder
+bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- (bindNonRec x r b) produces either
+-- let x = r in b
+-- or
+-- case r of x { _DEFAULT_ -> b }
+--
+-- depending on whether x is unlifted or not
+bindNonRec bndr rhs body
+ | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+ | otherwise = Let (NonRec bndr rhs) body
+
+mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+mkIfThenElse guard then_expr else_expr
+ = Case guard (mkWildId boolTy)
+ [ (DataCon trueDataCon, [], then_expr),
+ (DataCon falseDataCon, [], else_expr) ]
\end{code}
-\begin{code}
-mkCoLetUnboxedToCase bind@(Rec binds) body
- = mkCoLetrecNoUnboxed binds body
-
-mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
- = case body of
- Var binder2 | binder == binder2
- -> rhs -- hey, I have the rhs
- other
- -> if (not (isUnboxedType (idType binder))) then
- Let bind body -- boxed...
- else
- Case rhs -- unboxed...
- (PrimAlts []
- (BindDefault binder body))
-
-mkCoLetsUnboxedToCase [] expr = expr
-mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
-\end{code}
+mkNote removes redundant coercions, and SCCs where possible
-%************************************************************************
-%* *
-\subsection{Case alternatives in @GenCoreExpr@}
-%* *
-%************************************************************************
+\begin{code}
+mkNote :: Note f -> Expr b f -> Expr b f
+mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
+ = ASSERT( from_ty1 == to_ty2 )
+ mkNote (Coerce to_ty1 from_ty2) expr
-We have different kinds of @case@s, the differences being reflected in
-the kinds of alternatives a case has. We maintain a distinction
-between cases for scrutinising algebraic datatypes, as opposed to
-primitive types. In both cases, we carry around a @TyCon@, as a
-handle with which we can get info about the case (e.g., total number
-of data constructors for this type).
-
-For example:
-\begin{verbatim}
-let# x=e in b
-\end{verbatim}
-becomes
-\begin{verbatim}
-Case e [ BindDefaultAlt x -> b ]
-\end{verbatim}
+mkNote (SCC cc1) expr@(Note (SCC cc2) _)
+ | isDupdCC cc1 -- Discard the outer SCC provided we don't need
+ = expr -- to track its entry count
-\begin{code}
-data GenCoreCaseAlts val_bdr val_occ flexi
- = AlgAlts [(Id, -- alts: data constructor,
- [val_bdr], -- constructor's parameters,
- GenCoreExpr val_bdr val_occ flexi)] -- rhs.
- (GenCoreCaseDefault val_bdr val_occ flexi)
-
- | PrimAlts [(Literal, -- alts: unboxed literal,
- GenCoreExpr val_bdr val_occ flexi)] -- rhs.
- (GenCoreCaseDefault val_bdr val_occ flexi)
-
--- obvious things: if there are no alts in the list, then the default
--- can't be NoDefault.
-
-data GenCoreCaseDefault val_bdr val_occ flexi
- = NoDefault -- small con family: all
- -- constructor accounted for
- | BindDefault val_bdr -- form: var -> expr;
- (GenCoreExpr val_bdr val_occ flexi) -- "val_bdr" may or may not
- -- be used in RHS.
-\end{code}
+mkNote note@(SCC cc1) expr@(Lam x e) -- Move _scc_ inside lambda
+ = Lam x (mkNote note e)
-\begin{code}
-rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
-rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts]
+-- Slide InlineCall in around the function
+mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
+mkNote InlineCall (Var v) = Note InlineCall (Var v)
+mkNote InlineCall expr = expr
-rhssOfDeflt NoDefault = []
-rhssOfDeflt (BindDefault _ rhs) = [rhs]
+mkNote note expr = Note note expr
\end{code}
%************************************************************************
%* *
-\subsection{Core binders}
+\subsection{Simple access functions}
%* *
%************************************************************************
\begin{code}
-data GenCoreBinder val_bdr flexi
- = ValBinder val_bdr
- | TyBinder (GenTyVar flexi)
-
-isValBinder (ValBinder _) = True
-isValBinder _ = False
+bindersOf :: Bind b f -> [b]
+bindersOf (NonRec binder _) = [binder]
+bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
-notValBinder = not . isValBinder
-\end{code}
+rhssOfBind :: Bind b f -> [Expr b f]
+rhssOfBind (NonRec _ rhs) = [rhs]
+rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
-Clump Lams together if possible.
+rhssOfAlts :: [Alt b f] -> [Expr b f]
+rhssOfAlts alts = [e | (_,_,e) <- alts]
-\begin{code}
-mkValLam :: [val_bdr]
- -> GenCoreExpr val_bdr val_occ flexi
- -> GenCoreExpr val_bdr val_occ flexi
-mkTyLam :: [GenTyVar flexi]
- -> GenCoreExpr val_bdr val_occ flexi
- -> GenCoreExpr val_bdr val_occ flexi
-
-mkValLam binders body = foldr (Lam . ValBinder) body binders
-mkTyLam binders body = foldr (Lam . TyBinder) body binders
-
-mkLam :: [GenTyVar flexi] -> [val_bdr] -- ToDo: could add a [uvar] arg...
- -> GenCoreExpr val_bdr val_occ flexi
- -> GenCoreExpr val_bdr val_occ flexi
-
-mkLam tyvars valvars body
- = mkTyLam tyvars (mkValLam valvars body)
+isDeadBinder :: CoreBndr -> Bool
+isDeadBinder bndr | isId bndr = case getInlinePragma bndr of
+ IAmDead -> True
+ other -> False
+ | otherwise = False -- TyVars count as not dead
\end{code}
We often want to strip off leading lambdas before getting down to
business. @collectBinders@ is your friend.
-We expect (by convention) usage-, type-, and value- lambdas in that
+We expect (by convention) type-, and value- lambdas in that
order.
\begin{code}
-collectBinders ::
- GenCoreExpr val_bdr val_occ flexi ->
- ([GenTyVar flexi], [val_bdr], GenCoreExpr val_bdr val_occ flexi)
+collectBinders :: Expr b f -> ([b], Expr b f)
+collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
+collectValBinders :: CoreExpr -> ([Id], CoreExpr)
+collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
+
+collectTyAndValBinders expr
+ = (tvs, ids, body)
+ where
+ (tvs, body1) = collectTyBinders expr
+ (ids, body) = collectValBinders body1
collectBinders expr
- = case collectValBinders body1 of { (vals,body) -> (tyvars, vals, body) }
+ = go [] expr
where
- (tyvars, body1) = collectTyBinders expr
+ go tvs (Lam b e) = go (b:tvs) e
+ go tvs e = (reverse tvs, e)
collectTyBinders expr
- = tyvars expr []
+ = go [] expr
where
- tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
- tyvars other tacc = (reverse tacc, other)
+ go tvs (Lam b e) | isTyVar b = go (b:tvs) e
+ go tvs e = (reverse tvs, e)
-collectValBinders :: GenCoreExpr val_bdr val_occ flexi ->
- ([val_bdr], GenCoreExpr val_bdr val_occ flexi)
collectValBinders expr
= go [] expr
where
- go acc (Lam (ValBinder v) b) = go (v:acc) b
- go acc body = (reverse acc, body)
-
+ go ids (Lam b e) | isId b = go (b:ids) e
+ go ids body = (reverse ids, body)
\end{code}
-%************************************************************************
-%* *
-\subsection{Core arguments (atoms)}
-%* *
-%************************************************************************
-
-\begin{code}
-data GenCoreArg val_occ flexi
- = LitArg Literal
- | VarArg val_occ
- | TyArg (GenType flexi)
-\end{code}
-
-General and specific forms:
-\begin{code}
-mkGenApp :: GenCoreExpr val_bdr val_occ flexi
- -> [GenCoreArg val_occ flexi]
- -> GenCoreExpr val_bdr val_occ flexi
-mkTyApp :: GenCoreExpr val_bdr val_occ flexi
- -> [GenType flexi]
- -> GenCoreExpr val_bdr val_occ flexi
-mkValApp :: GenCoreExpr val_bdr val_occ flexi
- -> [GenCoreArg val_occ flexi] -- but we ASSERT they are LitArg or VarArg
- -> GenCoreExpr val_bdr val_occ flexi
-
-mkGenApp f args = foldl App f args
-mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args
-mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
-
-#ifndef DEBUG
-is_Lit_or_Var a = a
-#else
-is_Lit_or_Var a
- = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
-#endif
-
-isValArg (LitArg _) = True -- often used for sanity-checking
-isValArg (VarArg _) = True
-isValArg _ = False
-
-notValArg = not . isValArg -- exists only because it's a common use of isValArg
-
-numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
-\end{code}
-
-\begin{code}
-mkApp fun = mk_thing (mkGenApp fun)
-mkCon con = mk_thing (Con con)
-mkPrim op = mk_thing (Prim op)
-
-mk_thing :: ([GenCoreArg val_occ flexi] -> GenCoreExpr val_bdr val_occ flexi)
- -> [GenType flexi]
- -> [GenCoreArg val_occ flexi]
- -> GenCoreExpr val_bdr val_occ flexi
-mk_thing thing tys vals
- = ASSERT( all isValArg vals )
- thing (map TyArg tys ++ vals)
-\end{code}
@collectArgs@ takes an application expression, returning the function
and the arguments to which it is applied.
\begin{code}
-collectArgs :: GenCoreExpr val_bdr val_occ flexi
- -> (GenCoreExpr val_bdr val_occ flexi,
- [GenType flexi],
- [GenCoreArg val_occ flexi]{-ValArgs-})
-
+collectArgs :: Expr b f -> (Expr b f, [Arg b f])
collectArgs expr
- = valvars expr []
+ = go expr []
where
- valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
- valvars fun vacc
- = case (tyvars fun []) of { (expr, tacc) ->
- (expr, tacc, vacc) }
-
- tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc)
- tyvars fun tacc = (fun, tacc)
- -- WAS: tyvars fun tacc = (expr, tacc)
- -- This doesn't look right (i.e., Plain Wrong),
- -- collectArgs should return the the function and
- -- not the whole expr. -- Laszlo 8/98
-
+ go (App f a) as = go f (a:as)
+ go e as = (e, as)
\end{code}
+coreExprCc gets the cost centre enclosing an expression, if any.
+It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
\begin{code}
-initialTyArgs :: [GenCoreArg val_occ flexi]
- -> ([GenType flexi], [GenCoreArg val_occ flexi])
-initialTyArgs (TyArg ty : args) = (ty:tys, args')
- where
- (tys, args') = initialTyArgs args
-initialTyArgs other = ([],other)
-
-initialValArgs :: [GenCoreArg val_occ flexi]
- -> ([GenCoreArg val_occ flexi], [GenCoreArg val_occ flexi])
-initialValArgs args = span isValArg args
+coreExprCc :: Expr b f -> CostCentre
+coreExprCc (Note (SCC cc) e) = cc
+coreExprCc (Note other_note e) = coreExprCc e
+coreExprCc (Lam _ e) = coreExprCc e
+coreExprCc other = noCostCentre
\end{code}
%************************************************************************
%* *
-\subsection{The main @Core*@ instantiation of the @GenCore*@ types}
+\subsection{Predicates}
%* *
%************************************************************************
\begin{code}
-type CoreBinding = GenCoreBinding Id Id Unused
-type CoreExpr = GenCoreExpr Id Id Unused
-type CoreBinder = GenCoreBinder Id Unused
-type CoreArg = GenCoreArg Id Unused
+isValArg (Type _) = False
+isValArg other = True
+
+isTypeArg (Type _) = True
+isTypeArg other = False
-type CoreCaseAlts = GenCoreCaseAlts Id Id Unused
-type CoreCaseDefault = GenCoreCaseDefault Id Id Unused
+valArgCount :: [Arg b f] -> Int
+valArgCount [] = 0
+valArgCount (Type _ : args) = valArgCount args
+valArgCount (other : args) = 1 + valArgCount args
\end{code}
+
%************************************************************************
%* *
-\subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
+\subsection{Annotated core; annotation at every node in the tree}
%* *
%************************************************************************
-Binders are ``tagged'' with a \tr{t}:
\begin{code}
-type Tagged t = (Id, t)
-
-type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id Unused
-type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id Unused
-type TaggedCoreBinder t = GenCoreBinder (Tagged t) Unused
-type TaggedCoreArg t = GenCoreArg Id Unused
-
-type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id Unused
-type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id Unused
+type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
+
+data AnnExpr' bndr annot
+ = AnnVar Id
+ | AnnCon Con [AnnExpr bndr annot]
+ | AnnLam bndr (AnnExpr bndr annot)
+ | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
+ | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
+ | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
+ | AnnNote (Note Unused) (AnnExpr bndr annot)
+ | AnnType Type
+
+type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
+
+data AnnBind bndr annot
+ = AnnNonRec bndr (AnnExpr bndr annot)
+ | AnnRec [(bndr, AnnExpr bndr annot)]
\end{code}
-%************************************************************************
-%* *
-\subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
-%* *
-%************************************************************************
-
-Binders are tagged with @BinderInfo@:
\begin{code}
-type Simplifiable = (Id, BinderInfo)
+deAnnotate :: AnnExpr bndr annot -> Expr bndr Unused
+
+deAnnotate (_, AnnType t) = Type t
+deAnnotate (_, AnnVar v) = Var v
+deAnnotate (_, AnnCon con args) = Con con (map deAnnotate args)
+deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body)
+deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
+deAnnotate (_, AnnNote note body) = Note note (deAnnotate body)
-type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id Unused
-type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id Unused
-type SimplifiableCoreBinder = GenCoreBinder Simplifiable Unused
-type SimplifiableCoreArg = GenCoreArg Id Unused
+deAnnotate (_, AnnLet bind body)
+ = Let (deAnnBind bind) (deAnnotate body)
+ where
+ deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
+ deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
-type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id Unused
-type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id Unused
+deAnnotate (_, AnnCase scrut v alts)
+ = Case (deAnnotate scrut) v (map deAnnAlt alts)
+ where
+ deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
\end{code}
+
_interface_ CoreUnfold 1
_exports_
-CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding;
+CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding;
_declarations_
1 data Unfolding;
1 data UnfoldingGuidance;
-1 mkUnfolding _:_ CoreSyn.CoreExpr -> CoreUnfold.Unfolding ;;
-1 noUnfolding _:_ CoreUnfold.Unfolding ;;
+1 mkUnfolding _:_ CoreSyn.CoreExpr -> Unfolding ;;
+1 noUnfolding _:_ Unfolding ;;
+1 hasUnfolding _:_ Unfolding -> PrelBase.Bool ;;
--- /dev/null
+__interface CoreUnfold 1 0 where
+__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding;
+1 data Unfolding;
+1 data UnfoldingGuidance;
+1 mkUnfolding :: CoreSyn.CoreExpr -> Unfolding ;
+1 noUnfolding :: Unfolding ;
+1 hasUnfolding :: Unfolding -> PrelBase.Bool ;
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[CoreUnfold]{Core-syntax unfoldings}
module CoreUnfold (
Unfolding(..), UnfoldingGuidance(..), -- types
- FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
- exprIsTrivial,
-
noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
+ isEvaldUnfolding, hasUnfolding,
smallEnoughToInline, couldBeSmallEnoughToInline,
- certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
+ certainlySmallEnoughToInline,
okToUnfoldInHiFile,
calcUnfoldingGuidance
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
-import BinderInfo ( BinderInfo, isOneSameSCCFunOcc, isDeadOcc,
- isInlinableOcc, isOneSafeFunOcc
- )
import CoreSyn
-import Literal ( Literal )
-import CoreUtils ( unTagBinders )
import OccurAnal ( occurAnalyseGlobalExpr )
-import CoreUtils ( coreExprType )
-import Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
- idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
- IdSet )
-import PrimOp ( fragilePrimOp, primOpCanTriggerGC, PrimOp(..) )
+import CoreUtils ( coreExprType, exprIsTrivial, mkFormSummary,
+ FormSummary(..) )
+import Id ( Id, idType, isId )
+import Const ( Con(..), isLitLitLit )
+import PrimOp ( PrimOp(..), primOpOutOfLine )
import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
-import Name ( isExported )
-import Literal ( isNoRepLit, isLitLitLit )
import TyCon ( tyConFamilySize )
import Type ( splitAlgTyConApp_maybe )
+import Const ( isNoRepLit )
import Unique ( Unique )
-import Util ( isIn, panic, assertPanic )
+import Util ( isIn, panic )
import Outputable
\end{code}
data Unfolding
= NoUnfolding
- | OtherLit [Literal] -- It ain't one of these
- | OtherCon [Id] -- It ain't one of these
+ | OtherCon [Con] -- It ain't one of these
+ -- (OtherCon xs) also indicates that something has been evaluated
+ -- and hence there's no point in re-evaluating it.
+ -- OtherCon [] is used even for non-data-type values
+ -- to indicated evaluated-ness. Notably:
+ -- data C = C !(Int -> Int)
+ -- case x of { C f -> ... }
+ -- Here, f gets an OtherCon [] unfolding.
| CoreUnfolding -- An unfolding with redundant cached information
FormSummary -- Tells whether the template is a WHNF or bottom
UnfoldingGuidance -- Tells about the *size* of the template.
- SimplifiableCoreExpr -- Template
+ CoreExpr -- Template; binder-info is correct
| MagicUnfolding
Unique -- Unique of the Id whose magic unfolding this is
-- strictness mangling (depends on there being no CSE)
ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr
occ = occurAnalyseGlobalExpr expr
- cuf = CoreUnfolding (mkFormSummary expr) ufg occ
-
- cont = case occ of { Var _ -> cuf; _ -> cuf }
in
- case ufg of { UnfoldAlways -> cont; _ -> cont }
+ CoreUnfolding (mkFormSummary expr) ufg occ
mkMagicUnfolding :: Unique -> Unfolding
mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
getUnfoldingTemplate :: Unfolding -> CoreExpr
-getUnfoldingTemplate (CoreUnfolding _ _ expr)
- = unTagBinders expr
+getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr
getUnfoldingTemplate other = panic "getUnfoldingTemplate"
+isEvaldUnfolding :: Unfolding -> Bool
+isEvaldUnfolding (OtherCon _) = True
+isEvaldUnfolding (CoreUnfolding ValueForm _ expr) = True
+isEvaldUnfolding other = False
+
+hasUnfolding :: Unfolding -> Bool
+hasUnfolding NoUnfolding = False
+hasUnfolding other = True
data UnfoldingGuidance
= UnfoldNever
%************************************************************************
%* *
-\subsection{Figuring out things about expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-data FormSummary
- = VarForm -- Expression is a variable (or scc var, etc)
- | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
- | BottomForm -- Expression is guaranteed to be bottom. We're more gung
- -- ho about inlining such things, because it can't waste work
- | OtherForm -- Anything else
-
-instance Outputable FormSummary where
- ppr VarForm = ptext SLIT("Var")
- ppr ValueForm = ptext SLIT("Value")
- ppr BottomForm = ptext SLIT("Bot")
- ppr OtherForm = ptext SLIT("Other")
-
-mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary
-
-mkFormSummary expr
- = go (0::Int) expr -- The "n" is the number of (value) arguments so far
- where
- go n (Lit _) = ASSERT(n==0) ValueForm
- go n (Con _ _) = ASSERT(n==0) ValueForm
- go n (Prim _ _) = OtherForm
- go n (Note _ e) = go n e
-
- go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
- -- should be treated as a value
- go n (Let _ e) = OtherForm
- go n (Case _ _) = OtherForm
-
- go 0 (Lam (ValBinder x) e) = ValueForm -- NB: \x.bottom /= bottom!
- go n (Lam (ValBinder x) e) = go (n-1) e -- Applied lambda
- go n (Lam other_binder e) = go n e
-
- go n (App fun arg) | isValArg arg = go (n+1) fun
- go n (App fun other_arg) = go n fun
-
- go n (Var f) | isBottomingId f = BottomForm
- | isDataCon f = ValueForm -- Can happen inside imported unfoldings
- go 0 (Var f) = VarForm
- go n (Var f) = case getIdArity f of
- ArityExactly a | n < a -> ValueForm
- ArityAtLeast a | n < a -> ValueForm
- other -> OtherForm
-
-whnfOrBottom :: FormSummary -> Bool
-whnfOrBottom VarForm = True
-whnfOrBottom ValueForm = True
-whnfOrBottom BottomForm = True
-whnfOrBottom OtherForm = False
-\end{code}
-
-@exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
-simple variables and constants, and type applications.
-
-\begin{code}
-exprIsTrivial (Var v) = True
-exprIsTrivial (Lit lit) = not (isNoRepLit lit)
-exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
-exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial other = False
-\end{code}
-
-\begin{code}
-exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
-exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
-exprSmallEnoughToDup (Note _ e) = exprSmallEnoughToDup e
-exprSmallEnoughToDup expr
- = case (collectArgs expr) of { (fun, _, vargs) ->
- case fun of
- Var v | length vargs <= 4 -> True
- _ -> False
- }
-
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
%* *
%************************************************************************
-> CoreExpr -- expression to look at
-> UnfoldingGuidance
calcUnfoldingGuidance bOMB_OUT_SIZE expr
- = case collectBinders expr of { (ty_binders, val_binders, body) ->
+ | exprIsTrivial expr -- Often trivial expressions are never bound
+ -- to an expression, but it can happen. For
+ -- example, the Id for a nullary constructor has
+ -- a trivial expression as its unfolding, and
+ -- we want to make sure that we always unfold it.
+ = UnfoldAlways
+
+ | otherwise
+ = case collectTyAndValBinders expr of { (ty_binders, val_binders, body) ->
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
TooBig -> UnfoldNever
(I# size)
(I# scrut_discount)
where
- discount_for b
- | is_data && b `is_elem` cased_args = tyConFamilySize tycon
- | otherwise = 0
+ discount_for b
+ | num_cases == 0 = 0
+ | otherwise
+ = if is_data
+ then tyConFamilySize tycon * num_cases
+ else num_cases -- prim cases are pretty cheap
+
where
(is_data, tycon)
= case (splitAlgTyConApp_maybe (idType b)) of
Nothing -> (False, panic "discount")
Just (tc,_,_) -> (True, tc)
-
- is_elem = isIn "calcUnfoldingGuidance" }
+ num_cases = length (filter (==b) cased_args)
+ }
\end{code}
\begin{code}
sizeExpr (I# bOMB_OUT_SIZE) args expr
= size_up expr
where
- size_up (Var v) = sizeZero
- size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
- | otherwise = sizeZero
-
- size_up (Note _ body) = size_up body -- Notes cost nothing
+ size_up (Type t) = sizeZero -- Types cost nothing
+ size_up (Note _ body) = size_up body -- Notes cost nothing
+ size_up (Var v) = sizeOne
+ size_up (App fun arg) = size_up fun `addSize` size_up arg
- size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
- -- NB Zero cost for for type applications;
- -- others cost 1 or more
-
- size_up (Con con args) = conSizeN (numValArgs args)
- -- We don't count 1 for the constructor because we're
- -- quite keen to get constructors into the open
-
- size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
- where
- op_cost = if primOpCanTriggerGC op
- then uNFOLDING_DEAR_OP_COST
- -- these *tend* to be more expensive;
- -- number chosen to avoid unfolding (HACK)
- else uNFOLDING_CHEAP_OP_COST
+ size_up (Con con args) = foldr (addSize . size_up)
+ (size_up_con con (valArgCount args))
+ args
- size_up expr@(Lam _ _)
- = let
- (tyvars, args, body) = collectBinders expr
- in
- size_up body `addSizeN` length args
+ size_up (Lam b e) | isId b = size_up e `addSizeN` 1
+ | otherwise = size_up e
size_up (Let (NonRec binder rhs) body)
- = nukeScrutDiscount (size_up rhs)
- `addSize`
- size_up body
- `addSizeN`
+ = nukeScrutDiscount (size_up rhs) `addSize`
+ size_up body `addSizeN`
1 -- For the allocation
size_up (Let (Rec pairs) body)
- = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
- `addSize`
- size_up body
- `addSizeN`
- length pairs -- For the allocation
-
- size_up (Case scrut alts)
- = nukeScrutDiscount (size_up scrut)
- `addSize`
- arg_discount scrut
- `addSize`
- size_up_alts (coreExprType scrut) alts
- -- We charge for the "case" itself in "size_up_alts"
-
- ------------
- -- In an application we charge 0 for type application
- -- 1 for most anything else
- -- N for norep_lits
- size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
- size_up_arg (TyArg _) = sizeZero
- size_up_arg other = sizeOne
-
- ------------
- size_up_alts scrut_ty (AlgAlts alts deflt)
- = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
- `addSizeN`
- alt_cost
+ = nukeScrutDiscount rhs_size `addSize`
+ size_up body `addSizeN`
+ length pairs -- For the allocation
where
- size_alg_alt (con,args,rhs) = size_up rhs
+ rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
+
+ size_up (Case scrut _ alts)
+ = nukeScrutDiscount (size_up scrut) `addSize`
+ arg_discount scrut `addSize`
+ foldr (addSize . size_up_alt) sizeZero alts `addSizeN`
+ case (splitAlgTyConApp_maybe (coreExprType scrut)) of
+ Nothing -> 1
+ Just (tc,_,_) -> tyConFamilySize tc
+
+ ------------
+ size_up_alt (con, bndrs, rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
- -- NB: we charge N for an alg. "case", where N is
- -- the number of constructors in the thing being eval'd.
- -- (You'll eventually get a "discount" of N if you
- -- think the "case" is likely to go away.)
- -- It's important to charge for alternatives. If you don't then you
- -- get size 1 for things like:
- -- case x of { A -> 1#; B -> 2#; ... lots }
-
- alt_cost :: Int
- alt_cost
- = case (splitAlgTyConApp_maybe scrut_ty) of
- Nothing -> 1
- Just (tc,_,_) -> tyConFamilySize tc
-
- size_up_alts _ (PrimAlts alts deflt)
- = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
- -- *no charge* for a primitive "case"!
- where
- size_prim_alt (lit,rhs) = size_up rhs
-
------------
- size_up_deflt NoDefault = sizeZero
- size_up_deflt (BindDefault binder rhs) = size_up rhs
+ size_up_con (Literal lit) nv | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
+ | otherwise = sizeOne
+
+ size_up_con (DataCon dc) n_val_args = conSizeN n_val_args
+
+ size_up_con (PrimOp op) nv = sizeN op_cost
+ where
+ op_cost = if primOpOutOfLine op
+ then uNFOLDING_DEAR_OP_COST
+ -- these *tend* to be more expensive;
+ -- number chosen to avoid unfolding (HACK)
+ else uNFOLDING_CHEAP_OP_COST
------------
-- We want to record if we're case'ing an argument
sizeZero = SizeIs 0# [] 0#
sizeOne = SizeIs 1# [] 0#
sizeN (I# n) = SizeIs n [] 0#
-conSizeN (I# n) = SizeIs n [] n
+conSizeN (I# n) = SizeIs 0# [] n -- We don't count 1 for the constructor because we're
+ -- quite keen to get constructors into the open
scrutArg v = SizeIs 0# [v] 0#
nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
= if enough_args n_vals_wanted arg_is_evald_s &&
size - discount <= opt_UnfoldingUseThreshold
then
- -- pprTrace "small enough" (ppr id <+> int size <+> int discount)
True
else
False
-- We multiple the raw discounts (args_discount and result_discount)
-- ty opt_UnfoldingKeenessFactor because the former have to do with
- -- *size* whereas the discounts imply that there's some extra *efficiency*
- -- to be gained (e.g. beta reductions, case reductions) by inlining.
+ -- *size* whereas the discounts imply that there's some extra
+ -- *efficiency* to be gained (e.g. beta reductions, case reductions)
+ -- by inlining.
+
+ -- we also discount 1 for each argument passed, because these will
+ -- reduce with the lambdas in the function (we count 1 for a lambda
+ -- in size_up).
+
discount :: Int
- discount = round (
+ discount = length (take n_vals_wanted arg_is_evald_s) +
+ round (
opt_UnfoldingKeenessFactor *
fromInt (args_discount + result_discount)
)
certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
\end{code}
-Predicates
-~~~~~~~~~~
-
-@inlineUnconditionally@ decides whether a let-bound thing can
-*definitely* be inlined at each of its call sites. If so, then
-we can drop the binding right away. But remember, you have to be
-certain that every use can be inlined. So, notably, any ArgOccs
-rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc
-
-\begin{code}
-inlineUnconditionally :: (Id,BinderInfo) -> Bool
-
-inlineUnconditionally (id, occ_info)
- | idMustNotBeINLINEd id
- || isExported id
- = False
-
- | isOneSameSCCFunOcc occ_info
- && idWantsToBeINLINEd id = True
-
- | isOneSafeFunOcc occ_info
- = True
-
- | otherwise
- = False
-\end{code}
-
-okToInline is used at call sites, so it is a bit more generous
-
-\begin{code}
-okToInline :: Id -- The Id
- -> Bool -- The thing is WHNF or bottom;
- -> Bool -- It's small enough to duplicate the code
- -> BinderInfo
- -> Bool -- True <=> inline it
-
-okToInline id _ _ _ -- Check the Id first
- | idWantsToBeINLINEd id = True
- | idMustNotBeINLINEd id = False
-
-okToInline id whnf small binder_info
-#ifdef DEBUG
- | isDeadOcc binder_info
- = pprTrace "okToInline: dead" (ppr id) False
- | otherwise
-#endif
- = isInlinableOcc whnf small binder_info
-\end{code}
-
@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
file to determine whether an unfolding candidate really should be unfolded.
The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
okToUnfoldInHiFile e = opt_UnfoldCasms || go e
where
-- Race over an expression looking for CCalls..
- go (Var _) = True
- go (Lit lit) = not (isLitLitLit lit)
- go (Note _ body) = go body
- go (App fun arg) = go fun
- go (Con con args) = True
- go (Prim op args) = okToUnfoldPrimOp op
- go (Lam _ body) = go body
- go (Let (NonRec binder rhs) body) = go rhs && go body
- go (Let (Rec pairs) body) = and (map go (body:rhses))
- where
- rhses = [ rhs | (_, rhs) <- pairs ]
- go (Case scrut alts) = and (map go (scrut:rhses))
- where
- rhses = getAltRhs alts
-
- getAltRhs (PrimAlts alts deflt) =
- let ls = map snd alts in
- case deflt of
- NoDefault -> ls
- BindDefault _ rhs -> rhs:ls
- getAltRhs (AlgAlts alts deflt) =
- let ls = map (\ (_,_,r) -> r) alts in
- case deflt of
- NoDefault -> ls
- BindDefault _ rhs -> rhs:ls
+ go (Var _) = True
+ go (Con (Literal lit) _) = not (isLitLitLit lit)
+ go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args
+ go (Con con args) = True -- con args are always atomic
+ go (App fun arg) = go fun && go arg
+ go (Lam _ body) = go body
+ go (Let binds body) = and (map go (body :rhssOfBind binds))
+ go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts))
+ go (Note _ body) = go body
+ go (Type _) = True
-- ok to unfold a PrimOp as long as it's not a _casm_
- okToUnfoldPrimOp (CCallOp _ is_casm _ _ _ _) = not is_casm
- okToUnfoldPrimOp _ = True
-
+ okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm
+ okToUnfoldPrimOp _ = True
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CoreUtils]{Utility functions on @Core@ syntax}
\begin{code}
module CoreUtils (
- coreExprType, coreAltsType, coreExprCc,
-
- mkCoreIfThenElse,
- argToExpr,
- unTagBinders, unTagBindersAlts,
-
- maybeErrorApp,
- nonErrorRHSs,
- squashableDictishCcExpr,
- idSpecVars
+ IdSubst, SubstCoreExpr(..),
+
+ coreExprType, exprFreeVars, exprSomeFreeVars,
+
+ exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
+ FormSummary(..), mkFormSummary, whnfOrBottom,
+ cheapEqExpr,
+
+ substExpr, substId, substIds,
+ idSpecVars, idFreeVars,
+
+ squashableDictishCcExpr
) where
#include "HsVersions.h"
-import CoreSyn
+import {-# SOURCE #-} CoreUnfold ( noUnfolding, hasUnfolding )
-import CostCentre ( isDictCC, CostCentre, noCostCentre )
-import MkId ( mkSysLocal )
-import Id ( idType, isBottomingId, getIdSpecialisation,
- dataConRepType,
- Id
- )
-import Literal ( literalType, Literal(..) )
-import Maybes ( catMaybes, maybeToBool )
-import PprCore
-import PrimOp ( primOpType, PrimOp(..) )
-import SpecEnv ( specEnvValues )
-import SrcLoc ( noSrcLoc )
-import Type ( mkFunTy, mkForAllTy, mkTyVarTy,
- splitFunTy_maybe, applyTys, isUnpointedType,
- splitSigmaTy, splitFunTys,
- Type
- )
-import TysWiredIn ( trueDataCon, falseDataCon )
-import BasicTypes ( Unused )
-import UniqSupply ( returnUs, thenUs,
- mapAndUnzipUs, getUnique,
- UniqSM
+import CoreSyn
+import PprCore () -- Instances only
+import Var ( IdOrTyVar, isId, isTyVar )
+import VarSet
+import VarEnv
+import Name ( isLocallyDefined )
+import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap )
+import Id ( Id, idType, setIdType, idUnique, isBottomingId,
+ getIdArity, idFreeTyVars,
+ getIdSpecialisation, setIdSpecialisation,
+ getInlinePragma, setInlinePragma,
+ getIdUnfolding, setIdUnfolding
)
-import Outputable ( assertPanic, pprPanic, ppr, vcat, panic )
+import IdInfo ( arityLowerBound, InlinePragInfo(..) )
+import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
+import CostCentre ( isDictCC, CostCentre )
+import Const ( Con, conType )
+import Type ( Type, TyVarSubst, mkFunTy, mkForAllTy,
+ splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes,
+ fullSubstTy, substTyVar )
+import Unique ( buildIdKey, augmentIdKey )
+import Util ( zipWithEqual, mapAccumL )
+import Outputable
+import TysPrim ( alphaTy ) -- Debgging only
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Substitutions}
+%* *
+%************************************************************************
+
+\begin{code}
+type IdSubst = IdEnv SubstCoreExpr -- Maps Ids to SubstCoreExpr
+
+data SubstCoreExpr
+ = Done CoreExpr -- No more substitution needed
+ | SubstMe CoreExpr TyVarSubst IdSubst -- A suspended substitution
\end{code}
%************************************************************************
\begin{code}
coreExprType :: CoreExpr -> Type
-coreExprType (Var var) = idType var
-coreExprType (Lit lit) = literalType lit
-
-coreExprType (Let _ body) = coreExprType body
-coreExprType (Case _ alts) = coreAltsType alts
+coreExprType (Var var) = idType var
+coreExprType (Let _ body) = coreExprType body
+coreExprType (Case _ _ ((_,_,rhs):_)) = coreExprType rhs
coreExprType (Note (Coerce ty _) e) = ty
coreExprType (Note other_note e) = coreExprType e
--- a Con is a fully-saturated application of a data constructor
--- a Prim is <ditto> of a PrimOp
+coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
-coreExprType (Con con args) =
--- pprTrace "appTyArgs" (hsep [ppr con, semi,
--- ppr con_ty, semi,
--- ppr args]) $
- applyTypeToArgs con_ty args
- where
- con_ty = dataConRepType con
+coreExprType (Lam binder expr)
+ | isId binder = idType binder `mkFunTy` coreExprType expr
+ | isTyVar binder = mkForAllTy binder (coreExprType expr)
-coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
+coreExprType e@(App _ _)
+ = case collectArgs e of
+ (fun, args) -> applyTypeToArgs e (coreExprType fun) args
-coreExprType (Lam (ValBinder binder) expr)
- = idType binder `mkFunTy` coreExprType expr
-
-coreExprType (Lam (TyBinder tyvar) expr)
- = mkForAllTy tyvar (coreExprType expr)
-
-coreExprType (App expr (TyArg ty))
- = -- Gather type args; more efficient to instantiate the type all at once
- go expr [ty]
- where
- go (App expr (TyArg ty)) tys = go expr (ty:tys)
- go expr tys = applyTys (coreExprType expr) tys
-
-coreExprType (App expr val_arg)
- = ASSERT(isValArg val_arg)
- let
- fun_ty = coreExprType expr
- in
- case (splitFunTy_maybe fun_ty) of
- Just (_, result_ty) -> result_ty
-#ifdef DEBUG
- Nothing -> pprPanic "coreExprType:\n"
- (vcat [ppr fun_ty, ppr (App expr val_arg)])
-#endif
+coreExprType other = pprTrace "coreExprType" (ppr other) alphaTy
\end{code}
\begin{code}
-coreAltsType :: CoreCaseAlts -> Type
+-- The "e" argument is just for debugging
-coreAltsType (AlgAlts [] deflt) = default_ty deflt
-coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
+applyTypeToArgs e op_ty [] = op_ty
-coreAltsType (PrimAlts [] deflt) = default_ty deflt
-coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
-
-default_ty NoDefault = panic "coreExprType:Case:default_ty"
-default_ty (BindDefault _ rhs) = coreExprType rhs
-\end{code}
-
-\begin{code}
-applyTypeToArgs op_ty (TyArg ty : args)
+applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
- applyTypeToArgs (applyTys op_ty tys) rest_args
+ applyTypeToArgs e (applyTys op_ty tys) rest_args
where
- (tys, rest_args) = go [ty] args
- go tys (TyArg ty : args) = go (ty:tys) args
- go tys rest_args = (reverse tys, rest_args)
+ (tys, rest_args) = go [ty] args
+ go tys (Type ty : args) = go (ty:tys) args
+ go tys rest_args = (reverse tys, rest_args)
-applyTypeToArgs op_ty (val_or_lit_arg:args)
+applyTypeToArgs e op_ty (other_arg : args)
= case (splitFunTy_maybe op_ty) of
- Just (_, res_ty) -> applyTypeToArgs res_ty args
-
-applyTypeToArgs op_ty [] = op_ty
+ Just (_, res_ty) -> applyTypeToArgs e res_ty args
+ Nothing -> pprPanic "applyTypeToArgs" (ppr e)
\end{code}
-coreExprCc gets the cost centre enclosing an expression, if any.
-It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
-
-\begin{code}
-coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
-coreExprCc (Note (SCC cc) e) = cc
-coreExprCc (Note other_note e) = coreExprCc e
-coreExprCc (Lam _ e) = coreExprCc e
-coreExprCc other = noCostCentre
-\end{code}
%************************************************************************
%* *
-\subsection{Routines to manufacture bits of @CoreExpr@}
+\subsection{Figuring out things about expressions}
%* *
%************************************************************************
\begin{code}
-mkCoreIfThenElse (Var bool) then_expr else_expr
- | bool == trueDataCon = then_expr
- | bool == falseDataCon = else_expr
-
-mkCoreIfThenElse guard then_expr else_expr
- = Case guard
- (AlgAlts [ (trueDataCon, [], then_expr),
- (falseDataCon, [], else_expr) ]
- NoDefault )
+data FormSummary
+ = VarForm -- Expression is a variable (or scc var, etc)
+ | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
+ | BottomForm -- Expression is guaranteed to be bottom. We're more gung
+ -- ho about inlining such things, because it can't waste work
+ | OtherForm -- Anything else
+
+instance Outputable FormSummary where
+ ppr VarForm = ptext SLIT("Var")
+ ppr ValueForm = ptext SLIT("Value")
+ ppr BottomForm = ptext SLIT("Bot")
+ ppr OtherForm = ptext SLIT("Other")
+
+whnfOrBottom :: FormSummary -> Bool
+whnfOrBottom VarForm = True
+whnfOrBottom ValueForm = True
+whnfOrBottom BottomForm = True
+whnfOrBottom OtherForm = False
\end{code}
-For making @Apps@ and @Lets@, we must take appropriate evasive
-action if the thing being bound has unboxed type. @mkCoApp@ requires
-a name supply to do its work.
-
-@mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
-arguments-must-be-atoms constraint.
-
\begin{code}
-data CoreArgOrExpr
- = AnArg CoreArg
- | AnExpr CoreExpr
+mkFormSummary :: CoreExpr -> FormSummary
+mkFormSummary expr
+ = go (0::Int) expr -- The "n" is the number of *value* arguments so far
+ where
+ go n (Con con _) | isWHNFCon con = ValueForm
+ | otherwise = OtherForm
-mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
-mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
-mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
+ go n (Note _ e) = go n e
-mkCoApps fun args = co_thing (mkGenApp fun) args
-mkCoCon con args = co_thing (Con con) args
-mkCoPrim op args = co_thing (Prim op) args
+ go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
+ -- should be treated as a value
+ go n (Let _ e) = OtherForm
+ go n (Case _ _ _) = OtherForm
-co_thing :: ([CoreArg] -> CoreExpr)
- -> [CoreArgOrExpr]
- -> UniqSM CoreExpr
+ go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom!
+ | otherwise = go 0 e
+ go n (Lam x e) | isId x = go (n-1) e -- Applied lambda
+ | otherwise = go n e
-co_thing thing arg_exprs
- = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
- returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
- where
- expr_to_arg :: CoreArgOrExpr
- -> UniqSM (CoreArg, Maybe CoreBinding)
-
- expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
- expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
- expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
- expr_to_arg (AnExpr other_expr)
- = let
- e_ty = coreExprType other_expr
- in
- getUnique `thenUs` \ uniq ->
- let
- new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
- in
- returnUs (VarArg new_var, Just (NonRec new_var other_expr))
+ go n (App fun (Type _)) = go n fun -- Ignore type args
+ go n (App fun arg) = go (n+1) fun
+
+ go n (Var f) | isBottomingId f = BottomForm
+ go 0 (Var f) = VarForm
+ go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
+ | otherwise = OtherForm
\end{code}
-\begin{code}
-argToExpr ::
- GenCoreArg val_occ flexi -> GenCoreExpr val_bdr val_occ flexi
+@exprIsTrivial@ is true of expressions we are unconditionally
+ happy to duplicate; simple variables and constants,
+ and type applications.
+
+@exprIsDupable@ is true of expressions that can be duplicated at a modest
+ cost in space, but without duplicating any work.
+
+
+@exprIsBottom@ is true of expressions that are guaranteed to diverge
-argToExpr (VarArg v) = Var v
-argToExpr (LitArg lit) = Lit lit
+
+\begin{code}
+exprIsTrivial (Type _) = True
+exprIsTrivial (Var v) = True
+exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
+exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
+exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
+exprIsTrivial other = False
\end{code}
-All the following functions operate on binders, perform a uniform
-transformation on them; ie. the function @(\ x -> (x,False))@
-annotates all binders with False.
\begin{code}
-unTagBinders :: GenCoreExpr (Id,tag) bdee flexi -> GenCoreExpr Id bdee flexi
-unTagBinders expr = bop_expr fst expr
+exprIsDupable (Type _) = True
+exprIsDupable (Con con args) = conIsCheap con &&
+ all exprIsDupable args &&
+ valArgCount args <= dupAppSize
+
+exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable expr = case collectArgs expr of
+ (Var v, args) -> n_val_args == 0 ||
+ (n_val_args < fun_arity &&
+ all exprIsDupable args &&
+ n_val_args <= dupAppSize)
+ where
+ n_val_args = valArgCount args
+ fun_arity = arityLowerBound (getIdArity v)
+
+ _ -> False
+
+dupAppSize :: Int
+dupAppSize = 4 -- Size of application we are prepared to duplicate
+\end{code}
-unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee flexi -> GenCoreCaseAlts Id bdee flexi
-unTagBindersAlts alts = bop_alts fst alts
+@exprIsCheap@ looks at a Core expression and returns \tr{True} if
+it is obviously in weak head normal form, or is cheap to get to WHNF.
+[Note that that's not the same as exprIsDupable; an expression might be
+big, and hence not dupable, but still cheap.]
+By ``cheap'' we mean a computation we're willing to push inside a lambda
+in order to bring a couple of lambdas together. That might mean it gets
+evaluated more than once, instead of being shared. The main examples of things
+which aren't WHNF but are ``cheap'' are:
+
+ * case e of
+ pi -> ei
+
+ where e, and all the ei are cheap; and
+
+ * let x = e
+ in b
+
+ where e and b are cheap; and
+
+ * op x1 ... xn
+
+ where op is a cheap primitive operator
+
+\begin{code}
+exprIsCheap :: CoreExpr -> Bool
+exprIsCheap (Type _) = True
+exprIsCheap (Var _) = True
+exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
+exprIsCheap (Note _ e) = exprIsCheap e
+exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
+exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
+exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
+ all (\(_,_,rhs) -> exprIsCheap rhs) alts
+
+exprIsCheap other_expr -- look for manifest partial application
+ = case collectArgs other_expr of
+
+ (Var f, _) | isBottomingId f -> True -- Application of a function which
+ -- always gives bottom; we treat this as
+ -- a WHNF, because it certainly doesn't
+ -- need to be shared!
+
+ (Var f, args) ->
+ let
+ num_val_args = valArgCount args
+ in
+ num_val_args == 0 || -- Just a type application of
+ -- a variable (f t1 t2 t3)
+ -- counts as WHNF
+ num_val_args < arityLowerBound (getIdArity f)
+
+ _ -> False
\end{code}
+
\begin{code}
-bop_expr :: (a -> b) -> GenCoreExpr a bdee flexi -> GenCoreExpr b bdee flexi
-
-bop_expr f (Var b) = Var b
-bop_expr f (Lit lit) = Lit lit
-bop_expr f (Con con args) = Con con args
-bop_expr f (Prim op args) = Prim op args
-bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
-bop_expr f (App expr arg) = App (bop_expr f expr) arg
-bop_expr f (Note note expr) = Note note (bop_expr f expr)
-bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
-bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
-
-bop_binder f (ValBinder v) = ValBinder (f v)
-bop_binder f (TyBinder t) = TyBinder t
-
-bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
-bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
-
-bop_alts f (AlgAlts alts deflt)
- = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
- | (con, binders, e) <- alts ]
- (bop_deflt f deflt)
-
-bop_alts f (PrimAlts alts deflt)
- = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
- (bop_deflt f deflt)
-
-bop_deflt f (NoDefault) = NoDefault
-bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
+exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
+exprIsBottom (Note _ e) = exprIsBottom e
+exprIsBottom (Let _ e) = exprIsBottom e
+exprIsBottom (Case e _ _) = exprIsBottom e -- Just chek the scrut
+exprIsBottom (Con _ _) = False
+exprIsBottom (App e _) = exprIsBottom e
+exprIsBottom (Var v) = isBottomingId v
+exprIsBottom (Lam _ _) = False
\end{code}
-OLD (but left here because of the nice example): @singleAlt@ checks
-whether a bunch of case alternatives is actually just one alternative.
-It specifically {\em ignores} alternatives which consist of just a
-call to @error@, because they won't result in any code duplication.
+exprIsWHNF reports True for head normal forms. Note that does not necessarily
+mean *normal* forms; constructors might have non-trivial argument expressions, for
+example. We use a let binding for WHNFs, rather than a case binding, even if it's
+used strictly. We try to expose WHNFs by floating lets out of the RHS of lets.
+
+We treat applications of buildId and augmentId as honorary WHNFs, because we
+want them to get exposed
-Example:
-\begin{verbatim}
- case (case <something> of
- True -> <rhs>
- False -> error "Foo") of
- <alts>
+\begin{code}
+exprIsWHNF :: CoreExpr -> Bool -- True => Variable, value-lambda, constructor, PAP
+exprIsWHNF (Type ty) = True -- Types are honorary WHNFs; we don't mind
+ -- copying them
+exprIsWHNF (Var v) = True
+exprIsWHNF (Lam b e) = isId b || exprIsWHNF e
+exprIsWHNF (Note _ e) = exprIsWHNF e
+exprIsWHNF (Let _ e) = False
+exprIsWHNF (Case _ _ _) = False
+exprIsWHNF (Con con _) = isWHNFCon con
+exprIsWHNF e@(App _ _) = case collectArgs e of
+ (Var v, args) -> n_val_args == 0 ||
+ fun_arity > n_val_args ||
+ v_uniq == buildIdKey ||
+ v_uniq == augmentIdKey
+ where
+ n_val_args = valArgCount args
+ fun_arity = arityLowerBound (getIdArity v)
+ v_uniq = idUnique v
+
+ _ -> False
+\end{code}
-===>
+I don't like this function but I'n not confidnt enough to change it.
- case <something> of
- True -> case <rhs> of
- <alts>
- False -> case error "Foo" of
- <alts>
+\begin{code}
+squashableDictishCcExpr :: CostCentre -> Expr b f -> Bool
+squashableDictishCcExpr cc expr
+ | isDictCC cc = False -- that was easy...
+ | otherwise = squashable expr
+ where
+ squashable (Var _) = True
+ squashable (Con _ _) = True -- I think so... WDP 94/09
+ squashable (App f a)
+ | isTypeArg a = squashable f
+ squashable other = False
+\end{code}
-===>
- case <something> of
- True -> case <rhs> of
- <alts>
- False -> error "Foo"
-\end{verbatim}
-Notice that the \tr{<alts>} don't get duplicated.
+@cheapEqExpr@ is a cheap equality test which bales out fast!
+ True => definitely equal
+ False => may or may not be equal
\begin{code}
-nonErrorRHSs :: GenCoreCaseAlts a Id Unused -> [GenCoreExpr a Id Unused]
+cheapEqExpr :: Expr b f -> Expr b f -> Bool
-nonErrorRHSs alts
- = filter not_error_app (find_rhss alts)
- where
- find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
- find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
+cheapEqExpr (Var v1) (Var v2) = v1==v2
+cheapEqExpr (Con con1 args1) (Con con2 args2)
+ = con1 == con2 &&
+ and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
+
+cheapEqExpr (App f1 a1) (App f2 a2)
+ = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
- deflt_rhs NoDefault = []
- deflt_rhs (BindDefault _ rhs) = [rhs]
+cheapEqExpr (Type t1) (Type t2) = t1 == t2
- not_error_app rhs
- = case (maybeErrorApp rhs Nothing) of
- Just _ -> False
- Nothing -> True
+cheapEqExpr _ _ = False
\end{code}
-maybeErrorApp checks whether an expression is of the form
- error ty args
+%************************************************************************
+%* *
+\section{Finding the free variables of an expression}
+%* *
+%************************************************************************
-If so, it returns
+This function simply finds the free variables of an expression.
+So far as type variables are concerned, it only finds tyvars that are
- Just (error ty' args)
+ * free in type arguments,
+ * free in the type of a binder,
-where ty' is supplied as an argument to maybeErrorApp.
+but not those that are free in the type of variable occurrence.
-Here's where it is useful:
+\begin{code}
+exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars
+exprFreeVars = exprSomeFreeVars isLocallyDefined
- case (error ty "Foo" e1 e2) of <alts>
- ===>
- error ty' "Foo"
+exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
+ -> CoreExpr
+ -> IdOrTyVarSet
+exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
+
+type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting
+\end{code}
-where ty' is the type of any of the alternatives. You might think
-this never occurs, but see the comments on the definition of
-@singleAlt@.
-Note: we *avoid* the case where ty' might end up as a primitive type:
-this is very uncool (totally wrong).
+\begin{code}
+type FV = InterestingVarFun
+ -> IdOrTyVarSet -- In scope
+ -> IdOrTyVarSet -- Free vars
-NOTICE: in the example above we threw away e1 and e2, but not the
-string "Foo". How did we know to do that?
+union :: FV -> FV -> FV
+union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
-Answer: for now anyway, we only handle the case of a function whose
-type is of form
+noVars :: FV
+noVars fv_cand in_scope = emptyVarSet
- bottomingFn :: forall a. t1 -> ... -> tn -> a
- ^---------------------^ NB!
+oneVar :: IdOrTyVar -> FV
+oneVar var fv_cand in_scope
+ | keep_it fv_cand in_scope var = unitVarSet var
+ | otherwise = emptyVarSet
-Furthermore, we only count a bottomingApp if the function is applied
-to more than n args. If so, we transform:
+someVars :: IdOrTyVarSet -> FV
+someVars vars fv_cand in_scope
+ = filterVarSet (keep_it fv_cand in_scope) vars
- bottomingFn ty e1 ... en en+1 ... em
-to
- bottomingFn ty' e1 ... en
+keep_it fv_cand in_scope var
+ | var `elemVarSet` in_scope = False
+ | fv_cand var = True
+ | otherwise = False
-That is, we discard en+1 .. em
-\begin{code}
-maybeErrorApp
- :: GenCoreExpr a Id Unused -- Expr to look at
- -> Maybe Type -- Just ty => a result type *already cloned*;
- -- Nothing => don't know result ty; we
- -- *pretend* that the result ty won't be
- -- primitive -- somebody later must
- -- ensure this.
- -> Maybe (GenCoreExpr b Id Unused)
-
-maybeErrorApp expr result_ty_maybe
- = case (collectArgs expr) of
- (Var fun, [ty], other_args)
- | isBottomingId fun
- && maybeToBool result_ty_maybe -- we *know* the result type
- -- (otherwise: live a fairy-tale existence...)
- && not (isUnpointedType result_ty) ->
-
- case (splitSigmaTy (idType fun)) of
- ([tyvar], [], tau_ty) ->
- case (splitFunTys tau_ty) of { (arg_tys, res_ty) ->
- let
- n_args_to_keep = length arg_tys
- args_to_keep = take n_args_to_keep other_args
- in
- if (res_ty == mkTyVarTy tyvar)
- && n_args_to_keep <= length other_args
- then
- -- Phew! We're in business
- Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
- else
- Nothing
- }
-
- other -> Nothing -- Function type wrong shape
- other -> Nothing
+addBndr :: CoreBndr -> FV -> FV
+addBndr bndr fv fv_cand in_scope
+ | isId bndr = inside_fvs `unionVarSet` someVars (idFreeVars bndr) fv_cand in_scope
+ | otherwise = inside_fvs
where
- Just result_ty = result_ty_maybe
+ inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
+
+addBndrs :: [CoreBndr] -> FV -> FV
+addBndrs bndrs fv = foldr addBndr fv bndrs
\end{code}
+
\begin{code}
-squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c -> Bool
+expr_fvs :: CoreExpr -> FV
-squashableDictishCcExpr cc expr
- = if not (isDictCC cc) then
- False -- that was easy...
- else
- squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
+expr_fvs (Type ty) = someVars (tyVarsOfType ty)
+expr_fvs (Var var) = oneVar var
+expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args
+expr_fvs (Note _ expr) = expr_fvs expr
+expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
+expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
+
+expr_fvs (Case scrut bndr alts)
+ = expr_fvs scrut `union` addBndr bndr (foldr (union. alt_fvs) noVars alts)
where
- squashable (Var _) = True
- squashable (Con _ _) = True -- I think so... WDP 94/09
- squashable (Prim _ _) = True -- ditto
- squashable (App f a)
- | notValArg a = squashable f
- squashable other = False
+ alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
+
+expr_fvs (Let (NonRec bndr rhs) body)
+ = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
+
+expr_fvs (Let (Rec pairs) body)
+ = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
+ where
+ (bndrs,rhss) = unzip pairs
\end{code}
we regard an Id's specialisations as free in the Id's definition.
\begin{code}
-idSpecVars :: Id -> [Id]
+idSpecVars :: Id -> IdOrTyVarSet
idSpecVars id
- = map get_spec (specEnvValues (getIdSpecialisation id))
+ = foldr (unionVarSet . spec_item_fvs)
+ emptyVarSet
+ (specEnvToList (getIdSpecialisation id))
where
- -- get_spec is another cheapo function like dictRhsFVs
- -- It knows what these specialisation temlates look like,
- -- and just goes for the jugular
- get_spec (App f _) = get_spec f
- get_spec (Lam _ b) = get_spec b
- get_spec (Var v) = v
+ spec_item_fvs (tyvars, tys, rhs) = foldl delVarSet
+ (tyVarsOfTypes tys `unionVarSet` exprFreeVars rhs)
+ tyvars
+
+idFreeVars :: Id -> IdOrTyVarSet
+idFreeVars id = idSpecVars id `unionVarSet` idFreeTyVars id
\end{code}
+
+
+%************************************************************************
+%* *
+\section{Substitution}
+%* *
+%************************************************************************
+
+This expression substituter deals correctly with name capture, much
+like Type.substTy.
+
+BUT NOTE that substExpr silently discards the
+ unfolding, and
+ spec env
+IdInfo attached to any binders in the expression. It's quite
+tricky to do them 'right' in the case of mutually recursive bindings,
+and so far has proved unnecessary.
+
+\begin{code}
+substExpr :: TyVarSubst -> IdSubst -- Substitution
+ -> IdOrTyVarSet -- Superset of in-scope
+ -> CoreExpr
+ -> CoreExpr
+
+substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr
+
+subst_expr env@(te, ve, in_scope) expr
+ = go expr
+ where
+ go (Var v) = case lookupVarEnv ve v of
+ Just (Done e')
+ -> e'
+
+ Just (SubstMe e' te' ve')
+ -> subst_expr (te', ve', in_scope) e'
+
+ Nothing -> case lookupVarSet in_scope v of
+ Just v' -> Var v'
+ Nothing -> Var v
+ -- NB: we look up in the in_scope set because the variable
+ -- there may have more info. In particular, when substExpr
+ -- is called from the simplifier, the type inside the *occurrences*
+ -- of a variable may not be right; we should replace it with the
+ -- binder, from the in_scope set.
+
+ go (Type ty) = Type (go_ty ty)
+ go (Con con args) = Con con (map go args)
+ go (App fun arg) = App (go fun) (go arg)
+ go (Note note e) = Note (go_note note) (go e)
+
+ go (Lam bndr body) = Lam bndr' (subst_expr env' body)
+ where
+ (env', bndr') = go_bndr env bndr
+
+ go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr env' body)
+ where
+ (env', bndr') = go_bndr env bndr
+
+ go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr env' body)
+ where
+ (ve', in_scope', _, bndrs')
+ = substIds clone_fn te ve in_scope undefined (map fst pairs)
+ env' = (te, ve', in_scope')
+ pairs' = bndrs' `zip` rhss'
+ rhss' = map (subst_expr env' . snd) pairs
+
+ go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt env') alts)
+ where
+ (env', bndr') = go_bndr env bndr
+
+ go_alt env (con, bndrs, rhs) = (con, bndrs', subst_expr env' rhs)
+ where
+ (env', bndrs') = mapAccumL go_bndr env bndrs
+
+ go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
+ go_note note = note
+
+ go_ty ty = fullSubstTy te in_scope ty
+
+ go_bndr (te, ve, in_scope) bndr
+ | isTyVar bndr
+ = case substTyVar te in_scope bndr of
+ (te', in_scope', bndr') -> ((te', ve, in_scope'), bndr')
+
+ | otherwise
+ = case substId clone_fn te ve in_scope undefined bndr of
+ (ve', in_scope', _, bndr') -> ((te, ve', in_scope'), bndr')
+
+
+ clone_fn in_scope _ bndr
+ | bndr `elemVarSet` in_scope = Just (uniqAway in_scope bndr, undefined)
+ | otherwise = Nothing
+
+\end{code}
+
+Substituting in binders is a rather tricky part of the whole compiler.
+
+\begin{code}
+substIds :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
+ -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
+ -> us -- Unique supply
+ -> [Id]
+ -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
+ us, -- New unique supply
+ [Id])
+
+substIds clone_fn ty_subst id_subst in_scope us []
+ = (id_subst, in_scope, us, [])
+
+substIds clone_fn ty_subst id_subst in_scope us (id:ids)
+ = case (substId clone_fn ty_subst id_subst in_scope us id) of {
+ (id_subst', in_scope', us', id') ->
+
+ case (substIds clone_fn ty_subst id_subst' in_scope' us' ids) of {
+ (id_subst'', in_scope'', us'', ids') ->
+
+ (id_subst'', in_scope'', us'', id':ids')
+ }}
+
+
+substId :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
+ -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
+ -> us -- Unique supply
+ -> Id
+ -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
+ us, -- New unique supply
+ Id)
+
+-- Returns an Id with empty unfolding and spec-env.
+-- It's up to the caller to sort these out.
+
+substId clone_fn
+ ty_subst id_subst in_scope
+ us id
+ | old_id_will_do
+ -- No need to clone, but we *must* zap any current substitution
+ -- for the variable. For example:
+ -- (\x.e) with id_subst = [x |-> e']
+ -- Here we must simply zap the substitution for x
+ = (delVarEnv id_subst id, extendVarSet in_scope id, us, id)
+
+ | otherwise
+ = (extendVarEnv id_subst id (Done (Var new_id)),
+ extendVarSet in_scope new_id,
+ new_us,
+ new_id)
+ where
+ id_ty = idType id
+ old_id_will_do = old1 && old2 && old3 && {-old4 && -}not cloned
+
+ -- id1 has its type zapped
+ (id1,old1) | isEmptyVarEnv ty_subst
+ || isEmptyVarSet (tyVarsOfType id_ty) = (id, True)
+ | otherwise = (setIdType id ty', False)
+
+ ty' = fullSubstTy ty_subst in_scope id_ty
+
+ -- id2 has its SpecEnv zapped
+ -- It's filled in later by
+ (id2,old2) | isEmptySpecEnv spec_env = (id1, True)
+ | otherwise = (setIdSpecialisation id1 emptySpecEnv, False)
+ spec_env = getIdSpecialisation id
+
+ -- id3 has its Unfolding zapped
+ -- This is very important; occasionally a let-bound binder is used
+ -- as a binder in some lambda, in which case its unfolding is utterly
+ -- bogus. Also the unfolding uses old binders so if we left it we'd
+ -- have to substitute it. Much better simply to give the Id a new
+ -- unfolding each time, which is what the simplifier does.
+ (id3,old3) | hasUnfolding (getIdUnfolding id) = (id2 `setIdUnfolding` noUnfolding, False)
+ | otherwise = (id2, True)
+
+ -- new_id is cloned if necessary
+ (new_us, new_id, cloned) = case clone_fn in_scope us id3 of
+ Nothing -> (us, id3, False)
+ Just (us', id') -> (us', id', True)
+
+ -- new_id_bndr has its Inline info neutered. We must forget about whether it
+ -- was marked safe-to-inline, because that isn't necessarily true in
+ -- the simplified expression. We do this for the *binder* which will
+ -- be used at the binding site, but we *dont* do it for new_id, which
+ -- is put into the in_scope env. Why not? Because the in_scope env
+ -- carries down the occurrence information to usage sites!
+ --
+ -- Net result: post-simplification, occurrences may have over-optimistic
+ -- occurrence info, but binders won't.
+{- (new_id_bndr, old4)
+ = case getInlinePragma id of
+ ICanSafelyBeINLINEd _ _ -> (setInlinePragma new_id NoInlinePragInfo, False)
+ other -> (new_id, True)
+-}
+\end{code}
+
+
+
+
+
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Taken quite directly from the Peyton Jones/Lester paper.
\begin{code}
module FreeVars (
- -- Cheap and cheerful variant...
- exprFreeVars, exprFreeTyVars,
-
- -- Complicated and expensive variant for float-out
freeVars,
- freeVarsOf, freeTyVarsOf,
- CoreExprWithFVs, -- For the above functions
- AnnCoreExpr, -- Dito
- FVInfo(..), LeakInfo(..)
+ freeVarsOf,
+ CoreExprWithFVs, CoreBindWithFVs
) where
#include "HsVersions.h"
-import AnnCoreSyn -- output
-
import CoreSyn
-import CoreUtils ( idSpecVars )
-import Id ( idType, getIdArity, isBottomingId,
- emptyIdSet, unitIdSet, mkIdSet, unionIdSets,
- elementOfIdSet, minusIdSet, unionManyIdSets,
- IdSet, Id
- )
-import IdInfo ( ArityInfo(..) )
-import PrimOp ( PrimOp(CCallOp) )
+import CoreUtils ( idFreeVars )
+import Id ( Id )
+import VarSet
+import Var ( IdOrTyVar, isId )
+import Name ( isLocallyDefined )
import Type ( tyVarsOfType, Type )
-import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
- intersectTyVarSets, unionManyTyVarSets,
- TyVarSet, TyVar
- )
-import BasicTypes ( Unused )
-
-import UniqSet ( unionUniqSets, addOneToUniqSet, delOneFromUniqSet )
-import Util ( panic, assertPanic )
-
+import Util ( mapAndUnzip )
\end{code}
%************************************************************************
The free variable pass annotates every node in the expression with its
NON-GLOBAL free variables and type variables.
-The ``free type variables'' are defined to be those which are mentioned
-in type applications, {\em not} ones which lie buried in the types of Ids.
-
-*** ALAS: we *do* need to collect tyvars from lambda-bound ids. ***
-I've half-convinced myself we don't for case- and letrec bound ids
-but I might be wrong. (SLPJ, date unknown)
-
-\begin{code}
-type CoreExprWithFVs = AnnCoreExpr Id Id Unused FVInfo
-
-type TyVarCands = TyVarSet -- for when we carry around lists of
-type IdCands = IdSet -- "candidate" TyVars/Ids.
-noTyVarCands = emptyTyVarSet
-noIdCands = emptyIdSet
-
-data FVInfo
- = FVInfo IdSet -- Free ids
- TyVarSet -- Free tyvars
- LeakInfo
-
-noFreeIds = emptyIdSet
-noFreeTyVars = emptyTyVarSet
-noFreeAnything = (noFreeIds, noFreeTyVars)
-aFreeId i = unitIdSet i
-aFreeTyVar t = unitTyVarSet t
-is_among = elementOfIdSet
-munge_id_ty i = tyVarsOfType (idType i)
-combine = unionUniqSets -- used both for {Id,TyVar}Sets
-without = delOneFromUniqSet
-add = addOneToUniqSet
-
-combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
- = FVInfo (fvs1 `combine` fvs2)
- (tfvs1 `combine` tfvs2)
- (leak1 `orLeak` leak2)
-\end{code}
-
-Leak-free-ness is based only on the value, not the type. In
-particular, nested collections of constructors are guaranteed leak
-free. Function applications are not, except for PAPs.
-
-Applications of error gets (LeakFree bigArity) -- a hack!
-
\begin{code}
-data LeakInfo
- = MightLeak
- | LeakFree Int -- Leak free, and guarantees to absorb this # of
- -- args before becoming leaky.
+type CoreBindWithFVs = AnnBind Id IdOrTyVarSet
+type CoreExprWithFVs = AnnExpr Id IdOrTyVarSet
+ -- Every node annotated with its free variables,
+ -- both Ids and TyVars
-lEAK_FREE_0 = LeakFree 0
-lEAK_FREE_BIG = LeakFree bigArity
- where
- bigArity = 1000::Int -- NB: arbitrary
-
-orLeak :: LeakInfo -> LeakInfo -> LeakInfo
-orLeak MightLeak _ = MightLeak
-orLeak _ MightLeak = MightLeak
-orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
+freeVarsOf :: CoreExprWithFVs -> IdSet
+freeVarsOf (free_vars, _) = free_vars
+
+noFVs = emptyVarSet
+aFreeVar = unitVarSet
+unionFVs = unionVarSet
+
+filters :: IdOrTyVar -> IdOrTyVarSet -> IdOrTyVarSet
+
+-- (b `filters` s) removes the binder b from the free variable set s,
+-- but *adds* to s
+-- (a) the free variables of b's type
+-- (b) the idSpecVars of b
+--
+-- This is really important for some lambdas:
+-- In (\x::a -> x) the only mention of "a" is in the binder.
+--
+-- Also in
+-- let x::a = b in ...
+-- we should really note that "a" is free in this expression.
+-- It'll be pinned inside the /\a by the binding for b, but
+-- it seems cleaner to make sure that a is in the free-var set
+-- when it is mentioned.
+--
+-- This also shows up in recursive bindings. Consider:
+-- /\a -> letrec x::a = x in E
+-- Now, there are no explicit free type variables in the RHS of x,
+-- but nevertheless "a" is free in its definition. So we add in
+-- the free tyvars of the types of the binders, and include these in the
+-- free vars of the group, attached to the top level of each RHS.
+--
+-- This actually happened in the defn of errorIO in IOBase.lhs:
+-- errorIO (ST io) = case (errorIO# io) of
+-- _ -> bottom
+-- where
+-- bottom = bottom -- Never evaluated
+
+filters b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
+ | otherwise = s `delVarSet` b
\end{code}
-Main public interface:
-\begin{code}
-freeVars :: CoreExpr -> CoreExprWithFVs
-
-freeVars expr = fvExpr noIdCands noTyVarCands expr
-
-\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-We do the free-variable stuff by passing around ``candidates lists''
-of @Ids@ and @TyVars@ that may be considered free. This is useful,
-e.g., to avoid considering top-level binders as free variables---don't
-put them on the candidates list.
-
\begin{code}
+freeVars :: CoreExpr -> CoreExprWithFVs
-fvExpr :: IdCands -- In-scope Ids
- -> TyVarCands -- In-scope tyvars
- -> CoreExpr
- -> CoreExprWithFVs
-
-fvExpr id_cands tyvar_cands (Var v)
- = (FVInfo fvs noFreeTyVars leakiness, AnnVar v)
- where
- {-
- ToDo: insert motivating example for why we *need*
- to include the idSpecVars in the FV list.
- -}
- fvs = fvs_v `unionIdSets` mkIdSet (idSpecVars v)
-
- fvs_v
- | v `is_among` id_cands = aFreeId v
- | otherwise = noFreeIds
-
- leakiness
- | isBottomingId v = lEAK_FREE_BIG -- Hack
- | otherwise = case getIdArity v of
- UnknownArity -> lEAK_FREE_0
- ArityAtLeast arity -> LeakFree arity
- ArityExactly arity -> LeakFree arity
-
-fvExpr id_cands tyvar_cands (Lit k)
- = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
-
-fvExpr id_cands tyvar_cands (Con c args)
- = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
- where
- (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
-
-fvExpr id_cands tyvar_cands (Prim op args)
- = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
+freeVars (Var v)
+ = (fvs, AnnVar v)
where
- (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
- args_to_use
- = case op of
- CCallOp _ _ _ _ _ res_ty -> TyArg res_ty : args
- _ -> args
+ -- ToDo: insert motivating example for why we *need*
+ -- to include the idSpecVars in the FV list.
+ -- Actually [June 98] I don't think it's necessary
+ -- fvs = fvs_v `unionVarSet` idSpecVars v
--- this Lam stuff could probably be improved by rewriting (WDP 96/03)
+ fvs | isLocallyDefined v = aFreeVar v
+ | otherwise = noFVs
-fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
- = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder)
- (freeTyVarsOf body2 `combine` munge_id_ty binder)
- leakiness,
- AnnLam b body2)
+freeVars (Con con args)
+ = (foldr (unionFVs . freeVarsOf) noFVs args2, AnnCon con args2)
where
- -- We need to collect free tyvars from the binders
- body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
-
- leakiness = case leakinessOf body2 of
- MightLeak -> LeakFree 1
- LeakFree n -> LeakFree (n + 1)
+ args2 = map freeVars args
-fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
- = (FVInfo (freeVarsOf body2)
- (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
- (leakinessOf body2),
- AnnLam b body2)
+freeVars (Lam b body)
+ = (b `filters` freeVarsOf body', AnnLam b body')
where
- body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
-
--- ditto on rewriting this App stuff (WDP 96/03)
+ body' = freeVars body
-fvExpr id_cands tyvar_cands (App fun arg)
- = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
- (freeTyVarsOf fun2 `combine` tfvs_arg)
- leakiness,
- AnnApp fun2 arg)
+freeVars (App fun arg)
+ = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
where
- fun2 = fvExpr id_cands tyvar_cands fun
- fun2_leakiness = leakinessOf fun2
+ fun2 = freeVars fun
+ arg2 = freeVars arg
- (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
-
- leakiness = if (notValArg arg) then
- fun2_leakiness
- else
- case fun2_leakiness of
- LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
- other -> MightLeak
-
-fvExpr id_cands tyvar_cands (Case expr alts)
- = (combineFVInfo expr_fvinfo alts_fvinfo,
- AnnCase expr2 alts')
+freeVars (Case scrut bndr alts)
+ = ((bndr `filters` alts_fvs) `unionFVs` freeVarsOf scrut2,
+ AnnCase scrut2 bndr alts2)
where
- expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
- (alts_fvinfo, alts') = annotate_alts alts
-
- annotate_alts (AlgAlts alts deflt)
- = (fvinfo, AnnAlgAlts alts' deflt')
- where
- (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
- (deflt_fvinfo, deflt') = annotate_default deflt
- fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
-
- ann_boxed_alt (con, params, rhs)
- = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
- (freeTyVarsOf rhs' `combine` param_ftvs)
- (leakinessOf rhs'),
- (con, params, rhs'))
- where
- rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
- param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
- -- We need to collect free tyvars from the binders
-
- annotate_alts (PrimAlts alts deflt)
- = (fvinfo, AnnPrimAlts alts' deflt')
- where
- (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
- (deflt_fvinfo, deflt') = annotate_default deflt
- fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
-
- ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
- where
- rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
+ scrut2 = freeVars scrut
- annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
- AnnNoDefault)
+ (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
+ alts_fvs = foldr1 unionFVs alts_fvs_s
- annotate_default (BindDefault binder rhs)
- = (FVInfo (freeVarsOf rhs' `minusIdSet` aFreeId binder)
- (freeTyVarsOf rhs' `combine` binder_ftvs)
- (leakinessOf rhs'),
- AnnBindDefault binder rhs')
- where
- rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
- binder_ftvs = munge_id_ty binder
- -- We need to collect free tyvars from the binder
+ fv_alt (con,args,rhs) = (foldr filters (freeVarsOf rhs2) args,
+ (con, args, rhs2))
+ where
+ rhs2 = freeVars rhs
--- Don't forget to notice that the idSpecVars of the binder
--- are free in the whole expression; albeit not in the RHS or body
-
-fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
- = (FVInfo (freeVarsOf rhs' `combine` body_fvs `combine` mkIdSet (idSpecVars binder))
- (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
- (leakinessOf rhs' `orLeak` leakinessOf body2),
- AnnLet (AnnNonRec binder rhs') body2)
+freeVars (Let (NonRec binder rhs) body)
+ = (freeVarsOf rhs2 `unionFVs` body_fvs,
+ AnnLet (AnnNonRec binder rhs2) body2)
where
- rhs' = fvRhs id_cands tyvar_cands (binder, rhs)
- body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
- body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder
- binder_ftvs = munge_id_ty binder
- -- We need to collect free tyvars from the binder
-
-fvExpr id_cands tyvar_cands (Let (Rec binds) body)
- = (FVInfo (binds_fvs `combine` body_fvs)
- (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
- (leakiness_of_rhss `orLeak` leakinessOf body2),
- AnnLet (AnnRec (binders `zip` rhss')) body2)
+ rhs2 = freeVars rhs
+ body2 = freeVars body
+ body_fvs = binder `filters` freeVarsOf body2
+
+freeVars (Let (Rec binds) body)
+ = (foldl delVarSet group_fvs binders,
+ -- The "filters" part may have added one of the binders
+ -- via the idSpecVars part, so we must delete it again
+ AnnLet (AnnRec (binders `zip` rhss2)) body2)
where
- (binders, rhss) = unzip binds
- new_id_cands = binders_set `combine` id_cands
- binders_set = mkIdSet binders
- rhss' = map (fvRhs new_id_cands tyvar_cands) binds
+ (binders, rhss) = unzip binds
- FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
- = foldr1 combineFVInfo [info | (info,_) <- rhss']
+ rhss2 = map freeVars rhss
+ all_fvs = foldr (unionFVs . fst) body_fvs rhss2
+ group_fvs = foldr filters all_fvs binders
- -- Don't forget to notice that the idSpecVars of the binder
- -- are free in the whole expression; albeit not in the RHS or body
- binds_fvs = (foldr (unionIdSets . mkIdSet . idSpecVars) rhss_fvs binders)
- `minusIdSet`
- binders_set
+ body2 = freeVars body
+ body_fvs = freeVarsOf body2
- body2 = fvExpr new_id_cands tyvar_cands body
- body_fvs = freeVarsOf body2 `minusIdSet` binders_set
- binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
- -- We need to collect free tyvars from the binders
-
-fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr)
- = (FVInfo (freeVarsOf expr2)
- (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2)
- (leakinessOf expr2),
+freeVars (Note (Coerce to_ty from_ty) expr)
+ = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
AnnNote (Coerce to_ty from_ty) expr2)
where
- expr2 = fvExpr id_cands tyvar_cands expr
- tfvs1 = freeTy tyvar_cands from_ty
- tfvs2 = freeTy tyvar_cands to_ty
+ expr2 = freeVars expr
+ tfvs1 = tyVarsOfType from_ty
+ tfvs2 = tyVarsOfType to_ty
-fvExpr id_cands tyvar_cands (Note other_note expr)
- = (fvinfo, AnnNote other_note expr2)
+freeVars (Note other_note expr)
+ = (freeVarsOf expr2, AnnNote other_note expr2)
where
- expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
+ expr2 = freeVars expr
-fvRhs id_cands tyvar_cands (bndr,rhs)
- = fvExpr id_cands tyvar_cands rhs
+freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
\end{code}
-\begin{code}
-freeArgs :: IdCands -> TyVarCands
- -> [CoreArg]
- -> (IdSet, TyVarSet)
-
-freeArgs icands tcands [] = noFreeAnything
-freeArgs icands tcands (arg:args)
- -- this code is written this funny way only for "efficiency" purposes
- = let
- free_first_arg@(arg_fvs, tfvs) = free_arg arg
- in
- if (null args) then
- free_first_arg
- else
- case (freeArgs icands tcands args) of { (irest, trest) ->
- (arg_fvs `combine` irest, tfvs `combine` trest) }
- where
- free_arg (LitArg _) = noFreeAnything
- free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty)
- free_arg (VarArg v)
- | v `is_among` icands = (aFreeId v, noFreeTyVars)
- | otherwise = noFreeAnything
-
----------
-freeTy :: TyVarCands -> Type -> TyVarSet
-
-freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
-
-freeVarsOf :: CoreExprWithFVs -> IdSet
-freeVarsOf (FVInfo free_vars _ _, _) = free_vars
-
-freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
-freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
-
-leakinessOf :: CoreExprWithFVs -> LeakInfo
-leakinessOf (FVInfo _ _ leakiness, _) = leakiness
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Finding the free variables of an expression}
-%* *
-%************************************************************************
-
-This function simply finds the free variables of an expression.
-
-\begin{code}
-type InterestingIdFun
- = Id -- The Id being looked at
- -> Bool -- True <=> interesting
-
-exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
-exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
-\end{code}
-
-
-\begin{code}
-expr_fvs :: InterestingIdFun -- "Interesting id" predicate
- -> IdSet -- In scope ids
- -> CoreExpr
- -> IdSet
-
-expr_fvs fv_cand in_scope (Var v) = id_fvs fv_cand in_scope v
-expr_fvs fv_cand in_scope (Lit lit) = noFreeIds
-expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args
-expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args
-expr_fvs fv_cand in_scope (Note _ expr) = expr_fvs fv_cand in_scope expr
-expr_fvs fv_cand in_scope (App fun arg) = expr_fvs fv_cand in_scope fun `combine`
- arg_fvs fv_cand in_scope arg
-
-
-expr_fvs fv_cand in_scope (Lam (ValBinder b) body)
- = (expr_fvs fv_cand (in_scope `add` b) body)
-expr_fvs fv_cand in_scope (Lam (TyBinder b) body)
- = expr_fvs fv_cand in_scope body
-
-expr_fvs fv_cand in_scope (Case scrut alts)
- = expr_fvs fv_cand in_scope scrut `combine` alts_fvs
- where
- alts_fvs
- = case alts of
- AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
- where
- alt_fvs = map do_alg_alt alg_alts
- deflt_fvs = do_deflt deflt
-
- PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
- where
- alt_fvs = map do_prim_alt prim_alts
- deflt_fvs = do_deflt deflt
-
- do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet
- do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs
- where
- new_in_scope = in_scope `combine` mkIdSet args
-
- do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
-
- do_deflt NoDefault = noFreeIds
- do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
-
-expr_fvs fv_cand in_scope (Let (NonRec b r) body)
- = expr_fvs fv_cand in_scope r `combine`
- expr_fvs fv_cand (in_scope `add` b) body
-
-expr_fvs fv_cand in_scope (Let (Rec pairs) body)
- = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine`
- expr_fvs fv_cand in_scope' body
- where
- in_scope' = in_scope `combine` mkIdSet (map fst pairs)
-
-
-
-
---------------------------------------
-arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
-arg_fvs fv_cand in_scope other_arg = noFreeIds
-
---------------------------------------
-args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
-
-
---------------------------------------
-id_fvs fv_cand in_scope v
- | v `elementOfIdSet` in_scope = noFreeIds
- | fv_cand v = aFreeId v
- | otherwise = noFreeIds
-\end{code}
-
-
-\begin{code}
-exprFreeTyVars :: CoreExpr -> TyVarSet
-exprFreeTyVars = expr_ftvs
-
-expr_ftvs :: CoreExpr -> TyVarSet
-expr_ftvs (Var v) = noFreeTyVars
-expr_ftvs (Lit lit) = noFreeTyVars
-expr_ftvs (Con con args) = args_ftvs args
-expr_ftvs (Prim op args) = args_ftvs args
-expr_ftvs (Note _ expr) = expr_ftvs expr
-expr_ftvs (App fun arg) = expr_ftvs fun `combine` arg_ftvs arg
-
-expr_ftvs (Lam (ValBinder b) body) = expr_ftvs body
-expr_ftvs (Lam (TyBinder b) body) = expr_ftvs body `without` b
-
-expr_ftvs (Case scrut alts)
- = expr_ftvs scrut `combine` alts_ftvs
- where
- alts_ftvs
- = case alts of
- AlgAlts alg_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
- where
- alt_ftvs = map do_alg_alt alg_alts
- deflt_ftvs = do_deflt deflt
-
- PrimAlts prim_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
- where
- alt_ftvs = map do_prim_alt prim_alts
- deflt_ftvs = do_deflt deflt
-
- do_alg_alt :: (Id, [Id], CoreExpr) -> TyVarSet
- do_alg_alt (con, args, rhs) = expr_ftvs rhs
-
- do_prim_alt (lit, rhs) = expr_ftvs rhs
-
- do_deflt NoDefault = noFreeTyVars
- do_deflt (BindDefault b rhs) = expr_ftvs rhs
-
-expr_ftvs (Let (NonRec b r) body)
- = bind_ftvs (b,r) `combine` expr_ftvs body
-
-expr_ftvs (Let (Rec pairs) body)
- = foldr (combine . bind_ftvs) noFreeTyVars pairs `combine`
- expr_ftvs body
-
---------------------------------------
-bind_ftvs (b,e) = tyVarsOfType (idType b) `combine` expr_ftvs e
-
---------------------------------------
-arg_ftvs (TyArg ty) = tyVarsOfType ty
-arg_ftvs other_arg = noFreeTyVars
-
---------------------------------------
-args_ftvs args = foldr (combine . arg_ftvs) noFreeTyVars args
-\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
%************************************************************************
%* *
\begin{code}
module PprCore (
pprCoreExpr, pprIfaceUnfolding,
- pprCoreBinding, pprCoreBindings,
- pprGenericBindings
+ pprCoreBinding, pprCoreBindings, pprIdBndr
) where
#include "HsVersions.h"
import CoreSyn
-import CostCentre ( showCostCentre )
-import Id ( idType, idInfo, isTupleCon,
- GenId{-instances-}, Id
- )
+import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
+import Var ( isTyVar )
import IdInfo ( ppIdInfo )
-import Outputable -- quite a few things
-import PprEnv
+import Const ( Con(..), DataCon )
+import DataCon ( isTupleCon, isUnboxedTupleCon )
import PprType ( pprParendType, pprTyVarBndr )
-
+import PprEnv
+import Outputable
\end{code}
%************************************************************************
Un-annotated core dumps
~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprCoreBindings :: [CoreBinding] -> SDoc
-pprCoreBinding :: CoreBinding -> SDoc
-pprCoreExpr :: CoreExpr -> SDoc
+pprCoreBindings :: [CoreBind] -> SDoc
+pprCoreBinding :: CoreBind -> SDoc
+pprCoreExpr :: CoreExpr -> SDoc
pprCoreBindings = pprTopBinds pprCoreEnv
pprCoreBinding = pprTopBind pprCoreEnv
pprCoreExpr = ppr_expr pprCoreEnv
-pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
+pprCoreEnv = initCoreEnv pprCoreBinder
\end{code}
Printer for unfoldings in interfaces
pprIfaceUnfolding :: CoreExpr -> SDoc
pprIfaceUnfolding = ppr_expr pprIfaceEnv
-pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
+pprIfaceEnv = initCoreEnv pprIfaceBinder
\end{code}
-Generic Core (possibly annotated binders etc)
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
-pprGenericBindings = pprTopBinds pprGenericEnv
-
-pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
-pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
-
-pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
-pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
+instance Outputable b => Outputable (Bind b f) where
ppr bind = ppr_bind pprGenericEnv bind
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
+instance Outputable b => Outputable (Expr b f) where
ppr expr = ppr_expr pprGenericEnv expr
-instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
- ppr arg = ppr_arg pprGenericArgEnv arg
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
- ppr alts = ppr_alts pprGenericEnv alts
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
- ppr deflt = ppr_default pprGenericEnv deflt
+pprGenericEnv :: Outputable b => PprEnv b f
+pprGenericEnv = initCoreEnv (\site -> ppr)
\end{code}
-
%************************************************************************
%* *
\subsection{Instance declarations for Core printing}
\begin{code}
-init_ppr_env tvbndr pbdr pocc
+initCoreEnv pbdr
= initPprEnv
- (Just ppr) -- literals
- (Just ppr) -- data cons
- (Just ppr_prim) -- primops
- (Just (\ cc -> text (showCostCentre True cc)))
+ (Just ppr) -- Constants
+ (Just ppr) -- Cost centres
- (Just tvbndr) -- tyvar binders
(Just ppr) -- tyvar occs
(Just pprParendType) -- types
- (Just pbdr) (Just pocc) -- value vars
- where
-
- -- We add a "!" to distinguish Primitive applications from ordinary applications.
- -- But not when printing for interfaces, where they are treated
- -- as ordinary applications
- ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
- ppr prim
- else
- ppr prim <> char '!')
-
+ (Just pbdr) (Just pprIdBndr) -- value vars
+ -- The pprIdBndr part here is a temporary debugging aid
+ -- Revert to ppr if it gets tiresome
\end{code}
%************************************************************************
\end{code}
\begin{code}
+ppr_bind :: PprEnv b f -> Bind b f -> SDoc
+
ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
ppr_bind pe (Rec binds) = vcat (map pp binds)
where
pp bind = ppr_binding_pe pe bind <> semi
+ppr_binding_pe :: PprEnv b f -> (b, Expr b f) -> SDoc
ppr_binding_pe pe (val_bdr, expr)
- = sep [pValBndr pe LetBind val_bdr,
+ = sep [pBndr pe LetBind val_bdr,
nest 2 (equals <+> ppr_expr pe expr)]
\end{code}
\begin{code}
ppr_parend_expr pe expr
- = let
- parenify
- = case expr of
- Var _ -> id -- leave unchanged
- Lit _ -> id
- _ -> parens -- wraps in parens
- in
- parenify (ppr_expr pe expr)
+ | no_parens = ppr_expr pe expr
+ | otherwise = parens (ppr_expr pe expr)
+ where
+ no_parens = case expr of
+ Var _ -> True
+ Con con [] -> True
+ Con (DataCon dc) _ -> isTupleCon dc
+ _ -> False
\end{code}
\begin{code}
-ppr_expr pe (Var name) = pOcc pe name
-ppr_expr pe (Lit lit) = pLit pe lit
+ppr_expr :: PprEnv b f -> Expr b f -> SDoc
+
+ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd
+
+ppr_expr pe (Var name) = pOcc pe name
+
+ppr_expr pe (Con con [])
+ = ppr con -- Nullary constructors too
+
+ppr_expr pe (Con (DataCon dc) args)
+ -- Drop the type arguments and print in (a,b,c) notation
+ | isTupleCon dc
+ = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
+ | isUnboxedTupleCon dc
+ = text "(# " <>
+ hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
+ text " #)"
ppr_expr pe (Con con args)
= pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
-ppr_expr pe (Prim prim args)
- = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
-
ppr_expr pe expr@(Lam _ _)
= let
- (tyvars, vars, body) = collectBinders expr
+ (bndrs, body) = collectBinders expr
in
- hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
- pp_vars SLIT("\\") (pValBndr pe LambdaBind) vars])
+ hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
4 (ppr_expr pe body)
- where
- pp_vars lam pp [] = empty
- pp_vars lam pp vs
- = hsep [ptext lam, vcat (map pp vs), ptext SLIT("->")]
ppr_expr pe expr@(App fun arg)
= let
in
hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
-ppr_expr pe (Case expr alts)
- | only_one_alt alts
- -- johan thinks that single case patterns should be on same line as case,
- -- and no indent; all sane persons agree with him.
- = let
- ppr_bndr = pValBndr pe CaseBind
-
- ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
- ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
- ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
- ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
- = hsep [pCon pe con,
- hsep (map ppr_bndr params),
- ppr_arrow]
-
- ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
- ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
- ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
- ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
-
-
- ppr_arrow = ptext SLIT(" ->")
- in
- sep
- [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
- (<>) (ppr_rhs alts) (text ";}")]
-
- | otherwise -- default "case" printing
- = sep
- [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
- nest 2 (ppr_alts pe alts),
- text "}"]
+ppr_expr pe (Case expr var [(con,args,rhs)])
+ = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
+ hsep [ptext SLIT("of"),
+ ppr_bndr var,
+ char '{',
+ ppr_case_pat pe con args
+ ]],
+ ppr_expr pe rhs,
+ char '}'
+ ]
where
- pp_keyword = case alts of
- AlgAlts _ _ -> ptext SLIT("case")
- PrimAlts _ _ -> ptext SLIT("case#")
+ ppr_bndr = pBndr pe CaseBind
+
+ppr_expr pe (Case expr var alts)
+ = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
+ ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
+ nest 4 (sep (punctuate semi (map ppr_alt alts))),
+ char '}'
+ ]
+ where
+ ppr_bndr = pBndr pe CaseBind
+
+ ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
+ 4 (ppr_expr pe rhs)
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
= vcat [
- hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
+ hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
nest 2 (ppr_expr pe rhs),
ptext SLIT("} in"),
ppr_expr pe body ]
ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
- = ($$)
- (hang (ptext SLIT("let {"))
- 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
+ = hang (ptext SLIT("let {"))
+ 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
4 (ppr_expr pe rhs),
- ptext SLIT("} in")]))
- (ppr_expr pe expr)
+ ptext SLIT("} in")])
+ $$
+ ppr_expr pe expr
-- general case (recursive case, too)
ppr_expr pe (Let bind expr)
= sep [hang (ptext keyword) 2 (ppr_bind pe bind),
- hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
+ hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
where
keyword = case bind of
- Rec _ -> SLIT("_letrec_ {")
+ Rec _ -> SLIT("__letrec {")
NonRec _ _ -> SLIT("let {")
ppr_expr pe (Note (SCC cc) expr)
- = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
+ = sep [hsep [ptext SLIT("__scc"), pSCC pe cc],
ppr_parend_expr pe expr ]
#ifdef DEBUG
ppr_expr pe (Note (Coerce to_ty from_ty) expr)
= \ sty ->
if debugStyle sty && not (ifaceStyle sty) then
- sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty, pTy pe from_ty],
+ sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty, pTy pe from_ty],
ppr_parend_expr pe expr] sty
else
- sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
+ sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
ppr_parend_expr pe expr] sty
#else
ppr_expr pe (Note (Coerce to_ty from_ty) expr)
- = sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
+ = sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
ppr_parend_expr pe expr]
#endif
ppr_expr pe (Note InlineCall expr)
- = ptext SLIT("_inline_") <+> ppr_parend_expr pe expr
-
-only_one_alt (AlgAlts [] (BindDefault _ _)) = True
-only_one_alt (AlgAlts (_:[]) NoDefault) = True
-only_one_alt (PrimAlts [] (BindDefault _ _)) = True
-only_one_alt (PrimAlts (_:[]) NoDefault) = True
-only_one_alt _ = False
-\end{code}
-
-\begin{code}
-ppr_alts pe (AlgAlts alts deflt)
- = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
+ = ptext SLIT("__inline") <+> ppr_parend_expr pe expr
+
+ppr_case_pat pe con@(DataCon dc) args
+ | isTupleCon dc
+ = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
+ | isUnboxedTupleCon dc
+ = hsep [text "(# " <>
+ hsep (punctuate comma (map ppr_bndr args)) <>
+ text " #)",
+ arrow]
where
- ppr_arrow = ptext SLIT("->")
- ppr_bndr = pValBndr pe CaseBind
-
- ppr_alt (con, params, expr)
- = hang (if isTupleCon con then
- hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
- ppr_arrow]
- else
- hsep [pCon pe con,
- hsep (map ppr_bndr params),
- ppr_arrow]
- )
- 4 (ppr_expr pe expr <> semi)
-
-ppr_alts pe (PrimAlts alts deflt)
- = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
+ ppr_bndr = pBndr pe CaseBind
+
+ppr_case_pat pe con args
+ = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow
where
- ppr_alt (lit, expr)
- = hang (hsep [pLit pe lit, ptext SLIT("->")])
- 4 (ppr_expr pe expr <> semi)
-\end{code}
+ ppr_bndr = pBndr pe CaseBind
-\begin{code}
-ppr_default pe NoDefault = empty
+ppr_arg pe (Type ty) = ptext SLIT("__a") <+> pTy pe ty
+ppr_arg pe expr = ppr_parend_expr pe expr
-ppr_default pe (BindDefault val_bdr expr)
- = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
- 4 (ppr_expr pe expr <> semi)
-\end{code}
-
-\begin{code}
-ppr_arg pe (LitArg lit) = pLit pe lit
-ppr_arg pe (VarArg v) = pOcc pe v
-ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
+arrow = ptext SLIT("->")
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
= vcat [sig, pragmas, ppr binder]
where
sig = pprTypedBinder binder
- pragmas = ppIdInfo False{-no specs, thanks-} (idInfo binder)
+ pragmas = ppIdInfo (idInfo binder)
-pprCoreBinder LambdaBind binder = pprTypedBinder binder
-pprCoreBinder CaseBind binder = ppr binder
+-- Lambda bound type variables are preceded by "__a"
+pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
+-- Case bound things don't get a signature or a herald
+pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
-- Used for printing interface-file unfoldings
-pprIfaceBinder CaseBind binder = ppr binder
+pprIfaceBinder CaseBind binder = pprUntypedBinder binder
pprIfaceBinder other binder = pprTypedBinder binder
+pprUntypedBinder binder
+ | isTyVar binder = pprTyVarBndr binder
+ | otherwise = pprIdBndr binder
+
pprTypedBinder binder
- = ppr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
+ | isTyVar binder = ptext SLIT("__a") <+> pprTyVarBndr binder
+ | otherwise = pprIdBndr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
-- The space before the :: is important; it helps the lexer
-- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
--
-- It's important that the type is parenthesised too, at least when
-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
+
+-- When printing any Id binder in debug mode, we print its inline pragma
+pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id))
\end{code}
import DsUtils ( EquationInfo(..),
MatchResult(..),
- EqnNo,
EqnSet,
CanItFail(..)
)
-import Id ( idType,
- Id,
- isTupleCon,
- getIdArity
- )
-import IdInfo ( ArityInfo(..) )
-import Lex ( isLexConSym )
-import Name ( occNameString,
- Name,
- getName,
- nameUnique,
- getOccName,
- getOccString
+import Id ( idType )
+import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon,
+ dataConSourceArity )
+import Name ( Name, occNameString,
+ getOccName, getOccString, isLexConSym
)
import Type ( Type,
isUnboxedType,
splitTyConApp_maybe
)
-import TyVar ( TyVar )
import TysPrim ( intPrimTy,
charPrimTy,
floatPrimTy,
)
import TysWiredIn ( nilDataCon, consDataCon,
mkTupleTy, tupleCon,
+ mkUnboxedTupleTy, unboxedTupleCon,
mkListTy,
charTy, charDataCon,
intTy, intDataCon,
)
import TyCon ( tyConDataCons )
import UniqSet
-import Unique ( Unique )
import Outputable
#include "HsVersions.h"
untidy b (ConOpPatIn pat1 name fixity pat2) =
pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
-untidy _ (TuplePatIn pats) = TuplePatIn (map untidy_no_pars pats)
+untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
untidy _ (LazyPatIn pat) = panic "Check.untidy: LazyPatIn"
untidy _ (AsPatIn name pat) = panic "Check.untidy: AsPatIn"
check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
check' [] = ([([],[])],emptyUniqSet)
-check' [EqnInfo n ctx ps (MatchResult CanFail _ _)]
+check' [EqnInfo n ctx ps (MatchResult CanFail _)]
| all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
-check' qs@((EqnInfo n ctx ps (MatchResult CanFail _ _)):_)
+check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):_)
| all_vars ps = (pats, addOneToUniqSet indexs n)
where
(pats,indexs) = check' (tail qs)
pats_indexs = map (\x -> construct_matrix x qs) cons
(pats,indexs) = unzip pats_indexs
-need_default_case :: [TypecheckedPat] -> [Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
need_default_case used_cons unused_cons qs
| length default_eqns == 0 = (pats_default_no_eqns,indexs)
| otherwise = (pats_default,indexs_default)
construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
construct_matrix con qs =
-
(map (make_con con) pats,indexs)
where
(pats,indexs) = (check' (remove_first_column con qs))
remove_first_column :: TypecheckedPat -- Constructor
-> [EquationInfo]
-> [EquationInfo]
-remove_first_column (ConPat con _ con_pats) qs =
+remove_first_column (ConPat con _ _ _ con_pats) qs =
map shift_var (filter (is_var_con con) qs)
where
new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
- shift_var (EqnInfo n ctx (ConPat _ _ ps':ps) result) =
- EqnInfo n ctx (ps'++ps) result
- shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
- EqnInfo n ctx (new_wilds ++ ps) result
- shift_var _ = panic "Check.shift_var: Not implemented"
+ shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
+ EqnInfo n ctx (ps'++ps) result
+ shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
+ EqnInfo n ctx (new_wilds ++ ps) result
+ shift_var _ = panic "Check.Shift_var:No done"
make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
make_row_vars used_lits (EqnInfo _ _ pats _ ) =
make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
-compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2
+compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
remove_dups [] = []
| otherwise = x : remove_dups xs
get_used_cons :: [EquationInfo] -> [TypecheckedPat]
-get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _):_) _) <- qs]
+get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs]
remove_dups' :: [HsLit] -> [HsLit]
remove_dups' [] = []
get_used_lits' (q:qs) =
get_used_lits qs
-get_unused_cons :: [TypecheckedPat] -> [Id]
+get_unused_cons :: [TypecheckedPat] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
- (ConPat _ ty _) = head used_cons
- Just (ty_con,_) = splitTyConApp_maybe ty
- all_cons = tyConDataCons ty_con
- used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons
- unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
+ (ConPat _ ty _ _ _) = head used_cons
+ Just (ty_con,_) = splitTyConApp_maybe ty
+ all_cons = tyConDataCons ty_con
+ used_cons_as_id = map (\ (ConPat id _ _ _ _) -> id) used_cons
+ unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
all_vars :: [TypecheckedPat] -> Bool
all_vars [] = True
remove_var _ = panic "Check:remove_var: equation not begin with a variable"
is_con :: EquationInfo -> Bool
-is_con (EqnInfo _ _ ((ConPat _ _ _):_) _) = True
+is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
is_con _ = False
is_lit :: EquationInfo -> Bool
is_var (EqnInfo _ _ ((WildPat _):_) _) = True
is_var _ = False
-is_var_con :: Id -> EquationInfo -> Bool
-is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
-is_var_con con (EqnInfo _ _ ((ConPat id _ _):_) _) | id == con = True
-is_var_con con _ = False
+is_var_con :: DataCon -> EquationInfo -> Bool
+is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
+is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
+is_var_con con _ = False
is_var_lit :: HsLit -> EquationInfo -> Bool
is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
is_var_lit lit _ = False
\end{code}
-The difference between make_con and make_whole_con is that make_whole_con
-creates a new constructor with all their arguments, and make_con takes a
-list of arguments, creates the constructor getting their arguments from the
-list. See where are used for details.
+The difference beteewn make_con and make_whole_con is that
+make_wole_con creates a new constructor with all their arguments, and
+make_Con takes a list of argumntes, creates the contructor geting thir
+argumnts from the list. See where are used for details.
-We need to reconstruct the patterns (make the constructors infix and
+We need to reconstruct the patterns (make the constructors infix and
similar) at the same time that we create the constructors.
You can tell tuple constructors using
Rather clumsy but it works. (Simon Peyton Jones)
-We don't mind the nilDataCon because it doesn't change the way to print the
-message, we are searching only for things like: [1,2,3], not x:xs ....
-
+We con't mind the nilDataCon because it doesn't change the way to
+print the messsage, we are searching only for things like: [1,2,3],
+not x:xs ....
In reconstruct_pat we want to "undo" the work that we have done in simplify_pat
In particular:
((:) x xs) returns to be (x:xs)
(x:(...:[]) returns to be [x,...]
-The difficult case is the third one because we need to follow all the
-constructors until the [] to know that we need to use the second case,
+The difficult case is the third one becouse we need to follow all the
+contructors until the [] to know taht we need to use the second case,
not the second.
\begin{code}
make_list _ _ = panic "Check.make_list: Invalid argument"
make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
-make_con (ConPat id ty pats) (p:q:ps, constraints)
+make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
| return_list id q = (make_list p q : ps, constraints)
| isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
where name = BS (getOccString id)
fixity = panic "Check.make_con: Guessing fixity"
-make_con (ConPat id ty pats) (ps,constraints)
- | isTupleCon id = (TuplePatIn pats_con : rest_pats, constraints)
+
+make_con (ConPat id _ _ _ pats) (ps,constraints)
+ | isTupleCon id = (TuplePatIn pats_con True : rest_pats, constraints)
+ | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
| otherwise = (ConPatIn name pats_con : rest_pats, constraints)
where num_args = length pats
name = BS (getOccString id)
rest_pats = drop num_args ps
-make_whole_con :: Id -> WarningPat
+make_whole_con :: DataCon -> WarningPat
make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
| otherwise = ConPatIn name pats
where
fixity = panic "Check.make_whole_con: Guessing fixity"
name = BS (getOccString con)
- arity = get_int_arity con
+ arity = dataConSourceArity con
pats = take arity (repeat new_wild_pat)
new_wild_pat :: WarningPat
new_wild_pat = WildPatIn
-
-get_int_arity :: Id -> Int
-get_int_arity id = arity_to_int (getIdArity id)
- where
- arity_to_int (ArityExactly n) = n
- arity_to_int _ = panic "Check.getIntArity: Unknown arity"
-
\end{code}
This equation makes the same thing that tidy in Match.lhs, the
simplify_pat (AsPat id p) = simplify_pat p
-simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
-
-simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2])
+simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
-simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
- (ConPat nilDataCon list_ty [])
+simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
+ (ConPat nilDataCon list_ty [] [] [])
(map simplify_pat ps)
where list_ty = mkListTy ty
-simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType ps))
- (map simplify_pat ps)
+simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
+ (mkTupleTy arity (map outPatType ps)) [] []
+ (map simplify_pat ps)
where
arity = length ps
-simplify_pat (RecPat id ty []) = ConPat id ty [wild_pat]
- where
- wild_pat = WildPat gt
- gt = panic "Check.symplify_pat: gessing gt"
-simplify_pat (RecPat id ty idps) = ConPat id ty pats
- where
- pats = map (\ (id,p,_)-> simplify_pat p) idps
+simplify_pat (TuplePat ps False)
+ = ConPat (unboxedTupleCon arity)
+ (mkUnboxedTupleTy arity (map outPatType ps)) [] []
+ (map simplify_pat ps)
+ where
+ arity = length ps
+
+simplify_pat (RecPat id ty tvs dicts [])
+ = ConPat id ty tvs dicts [wild_pat]
+ where
+ wild_pat = WildPat gt
+ gt = panic "Check.symplify_pat: gessing gt"
+
+simplify_pat (RecPat id ty tvs dicts idps)
+ = ConPat id ty tvs dicts pats
+ where
+ pats = map (\ (id,p,_)-> simplify_pat p) idps
simplify_pat pat@(LitPat lit lit_ty)
| isUnboxedType lit_ty = pat
- | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
+ | lit_ty == charTy = ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy]
| otherwise = pprPanic "Check.simplify_pat: LitPat:" (ppr pat)
where
simplify_pat (NPat lit lit_ty hsexpr) = better_pat
where
better_pat
- | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
- | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
- | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
- | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
- | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
- | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
-
- -- Convert the literal pattern "" to the constructor pattern [].
- | null_str_lit lit = ConPat nilDataCon lit_ty []
-
+ | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy]
+ | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
+ | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy]
+ | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy]
+ | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
+ | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
+
+ -- Convert the literal pattern "" to the constructor pattern [].
+ | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
| lit_ty == stringTy =
- foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
- (ConPat nilDataCon list_ty [])
+ foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
+ (ConPat nilDataCon list_ty [] [] [])
(mk_string lit)
-
| otherwise = NPat lit lit_ty hsexpr
list_ty = mkListTy lit_ty
mk_head_char (HsString s) = HsCharPrim (_HEAD_ s)
mk_string (HsString s) =
- map (\ c -> ConPat charDataCon charTy
+ map (\ c -> ConPat charDataCon charTy [] []
[LitPat (HsCharPrim c) charPrimTy])
(_UNPK_ s)
simplify_pat (DictPat dicts methods) =
case num_of_d_and_ms of
- 0 -> simplify_pat (TuplePat [])
+ 0 -> simplify_pat (TuplePat [] True)
1 -> simplify_pat (head dict_and_method_pats)
- _ -> simplify_pat (TuplePat dict_and_method_pats)
+ _ -> simplify_pat (TuplePat dict_and_method_pats True)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Desugar]{@deSugar@: the main function}
\begin{code}
-module Desugar ( deSugar, pprDsWarnings ) where
+module Desugar ( deSugar ) where
#include "HsVersions.h"
import CmdLineOpts ( opt_D_dump_ds )
import HsSyn ( MonoBinds )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl )
-
import CoreSyn
-import PprCore ( pprCoreBindings )
import DsMonad
import DsBinds ( dsMonoBinds )
import DsForeign ( dsForeigns )
import DsUtils
+import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
+ -- depends on DsExpr.hi-boot.
import Bag ( isEmptyBag )
import BasicTypes ( Module )
import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn )
-import CoreLift ( liftCoreBindings )
-import CoreLint ( lintCoreBindings )
-import Id ( nullIdEnv, GenId, Id )
-import ErrUtils ( dumpIfSet, doIfSet )
+import CoreLint ( beginPass, endPass )
+import ErrUtils ( doIfSet )
import Outputable
import UniqSupply ( splitUniqSupply, UniqSupply )
\end{code}
\begin{code}
deSugar :: UniqSupply -- name supply
+ -> GlobalValueEnv -- value env
-> Module -- module name
-> TypecheckedMonoBinds
-> [TypecheckedForeignDecl]
- -> IO ([CoreBinding], SDoc, SDoc, SDoc) -- output
-
-deSugar us mod_name all_binds fo_decls
- = let
- (us1, us2) = splitUniqSupply us
- (us3, us4) = splitUniqSupply us2
-
- module_and_group = (mod_name, grp_name)
- grp_name = case opt_SccGroup of
- Just xx -> _PK_ xx
- Nothing -> mod_name -- default: module name
+ -> IO ([CoreBind], SDoc, SDoc) -- output
- (core_prs, ds_warns) = initDs us1 nullIdEnv module_and_group
- (dsMonoBinds opt_SccProfilingOn all_binds [])
+deSugar us global_val_env mod_name all_binds fo_decls = do
+ beginPass "Desugar"
+ -- Do desugaring
+ let (core_prs, ds_warns) = initDs us1 global_val_env module_and_group
+ (dsMonoBinds opt_SccProfilingOn all_binds [])
+ ds_binds' = [Rec core_prs]
- ((fi_binds, fe_binds, hc_code, h_code, c_code), ds_warns2) =
- initDs us3 nullIdEnv module_and_group
- (dsForeigns fo_decls)
+ ((fi_binds, fe_binds, h_code, c_code), ds_warns2) =
+ initDs us3 global_val_env module_and_group (dsForeigns fo_decls)
- ds_binds' = liftCoreBindings us4 [Rec (core_prs)]
- ds_binds = fi_binds ++ ds_binds' ++ fe_binds
- in
+ ds_binds = fi_binds ++ ds_binds' ++ fe_binds
- -- Display any warnings
- doIfSet (not (isEmptyBag ds_warns))
- (printErrs (pprDsWarnings ds_warns)) >>
+ -- Display any warnings
+ doIfSet (not (isEmptyBag ds_warns))
+ (printErrs (pprDsWarnings ds_warns))
- -- Lint result if necessary
- lintCoreBindings "Desugarer" False ds_binds >>
+ -- Lint result if necessary
+ endPass "Desugar" opt_D_dump_ds ds_binds
+ return (ds_binds, h_code, c_code)
+ where
+ (us1, us2) = splitUniqSupply us
+ (us3, us4) = splitUniqSupply us2
- -- Dump output
- dumpIfSet opt_D_dump_ds "Desugared:"
- (pprCoreBindings ds_binds) >>
+ module_and_group = (mod_name, grp_name)
+ grp_name = case opt_SccGroup of
+ Just xx -> _PK_ xx
+ Nothing -> mod_name -- default: module name
- return (ds_binds, hc_code, h_code, c_code)
\end{code}
+++ /dev/null
-_interface_ DsBinds 1
-_exports_
-DsBinds dsBinds;
-_declarations_
-1 dsBinds _:_ PrelBase.Bool -> TcHsSyn.TypecheckedHsBinds -> DsMonad.DsM [CoreSyn.CoreBinding] ;;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
-module DsBinds ( dsBinds, dsMonoBinds ) where
+module DsBinds ( dsMonoBinds ) where
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr
+
+import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils ( coreExprType )
-import TcHsSyn ( TypecheckedHsBinds, TypecheckedHsExpr,
- TypecheckedMonoBinds,
- TypecheckedPat
- )
+import TcHsSyn ( TypecheckedMonoBinds )
import DsMonad
import DsGRHSs ( dsGuarded )
import DsUtils
)
import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC )
import Id ( idType, Id )
+import VarEnv
import Name ( isExported )
-import Type ( mkTyVarTy, isDictTy, instantiateTy
+import Type ( mkTyVarTy, isDictTy, substTy
)
-import TyVar ( zipTyVarEnv )
-import TysPrim ( voidTy )
-import Outputable ( assertPanic )
+import TysWiredIn ( voidTy )
+import Outputable
\end{code}
%************************************************************************
%* *
-\subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
-%* *
-%************************************************************************
-
-Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
-that some of the binders are of unboxed type. This is sorted out when
-the caller wraps the bindings round an expression.
-
-\begin{code}
-
-dsBinds :: Bool -- if candidate, auto add scc's on toplevs ?
- -> TypecheckedHsBinds
- -> DsM [CoreBinding]
-
-dsBinds _ EmptyBinds = returnDs []
-dsBinds auto_scc (ThenBinds binds_1 binds_2)
- = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2)
-
-dsBinds auto_scc (MonoBind binds sigs is_rec)
- = dsMonoBinds auto_scc binds [] `thenDs` \ prs ->
- returnDs (case is_rec of
- Recursive -> [Rec prs]
- NonRecursive -> [NonRec binder rhs | (binder,rhs) <- prs]
- )
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
%* *
%************************************************************************
dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
= putSrcLocDs locn $
matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
- addAutoScc auto_scc (fun, mkValLam args body) `thenDs` \ pair ->
+ addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
returnDs (pair : rest)
where
- error_string = "function " ++ showForErr fun
+ error_string = "function " ++ showSDoc (ppr fun)
dsMonoBinds _ (PatMonoBind pat grhss_and_binds locn) rest
= putSrcLocDs locn $
-- makes rather mixed-up dictionary bindings
core_binds = [Rec core_prs]
in
- addAutoScc auto_scc (global, mkLam tyvars dicts $
- mkCoLetsAny core_binds (Var local)) `thenDs` \ global' ->
+ addAutoScc auto_scc (global, mkLams tyvars $ mkLams dicts $
+ mkLets core_binds (Var local)) `thenDs` \ global' ->
returnDs (global' : rest)
dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports binds) rest
let
core_binds = [Rec core_prs]
- tup_expr = mkLam all_tyvars dicts $
- mkCoLetsAny core_binds $
- mkTupleExpr locals
- locals = [local | (_, _, local) <- exports]
- local_tys = map idType locals
+ tup_expr = mkTupleExpr locals
+ tup_ty = coreExprType tup_expr
+ poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
+ mkLets core_binds tup_expr
+ locals = [local | (_, _, local) <- exports]
+ local_tys = map idType locals
in
- newSysLocalDs (coreExprType tup_expr) `thenDs` \ tup_id ->
+ newSysLocalDs (coreExprType poly_tup_expr) `thenDs` \ poly_tup_id ->
let
- dict_args = map VarArg dicts
+ dict_args = map Var dicts
mk_bind (tyvars, global, local) n -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to voidTy
- newSysLocalsDs (map (instantiateTy env) local_tys) `thenDs` \ locals' ->
+ newSysLocalsDs (map (substTy env) local_tys) `thenDs` \ locals' ->
+ newSysLocalDs (substTy env tup_ty) `thenDs` \ tup_id ->
addAutoScc auto_scc
- (global, mkLam tyvars dicts $
- mkTupleSelector locals' (locals' !! n) $
- mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)
+ (global, mkLams tyvars $ mkLams dicts $
+ mkTupleSelector locals' (locals' !! n) tup_id $
+ mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
ty_args = map mk_ty_arg all_tyvars
- env = all_tyvars `zipTyVarEnv` ty_args
+ env = all_tyvars `zipVarEnv` ty_args
in
zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
-- don't scc (auto-)annotate the tuple itself.
- returnDs ((tup_id, tup_expr) : (export_binds ++ rest))
+ returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest))
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
\begin{code}
module DsCCall
- (
- dsCCall
- , getIoOkDataCon
- , unboxArg
- , boxResult
+ ( dsCCall
+ , unboxArg
+ , boxResult
, wrapUnboxedValue
- , can'tSeeDataConsPanic
+ , can'tSeeDataConsPanic
+
) where
#include "HsVersions.h"
import TcHsSyn ( maybeBoxedPrimType )
import CoreUtils ( coreExprType )
-import Id ( Id, dataConArgTys, idType )
+import Id ( Id, mkWildId )
+import Const ( Con(..) )
import Maybes ( maybeToBool )
-import PrelVals ( packStringForCId )
+import PrelInfo ( packStringForCId )
import PrimOp ( PrimOp(..) )
+import DataCon ( DataCon, dataConId, dataConArgTys )
import CallConv
-import Type ( isUnpointedType, splitAlgTyConApp_maybe,
- splitTyConApp_maybe, splitFunTys, splitForAllTys,
- Type
+import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
+ splitTyConApp_maybe, Type
)
-import TyCon ( tyConDataCons )
import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
-import TysWiredIn ( getStatePairingConInfo,
- unitDataCon, stringTy,
- realWorldStateTy, stateDataCon
+import TysWiredIn ( unitDataCon, stringTy,
+ mkUnboxedTupleTy, unboxedPairDataCon,
+ mkUnboxedTupleTy, unboxedTupleCon
)
import Outputable
\end{code}
-> Type -- Type of the result (a boxed-prim IO type)
-> DsM CoreExpr
-dsCCall label args may_gc is_asm io_result_ty
+dsCCall label args may_gc is_asm result_ty
= newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
+ boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
+
let
- final_args = Var old_s : unboxed_args
- (ioOkDataCon, _, result_ty) = getIoOkDataCon io_result_ty
- in
+ val_args = Var old_s : unboxed_args
+ final_args = Type inst_ty : val_args
- boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
+ -- A CCallOp has type (forall a. a), so we must instantiate
+ -- it at the full type, including the state argument
+ inst_ty = mkFunTys (map coreExprType val_args) final_result_ty
- let
the_ccall_op = CCallOp (Left label) is_asm may_gc cCallConv
- (map coreExprType final_args)
- final_result_ty
- in
- mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
- let
+ the_prim_app = mkPrimApp the_ccall_op final_args
+
the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
in
- returnDs (Lam (ValBinder old_s) the_body)
+ returnDs (Lam old_s the_body)
\end{code}
\begin{code}
-- which generates the boiler-plate box-unbox code for you, i.e., it may help
-- us nuke this very module :-)
--
- | isUnpointedType arg_ty
+ | isUnLiftedType arg_ty
= returnDs (arg, \body -> body)
-- Strings
| arg_ty == stringTy
+ -- ToDo (ADR): - allow synonyms of Strings too?
= newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
- mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
returnDs (Var prim_arg,
- \body -> Case pack_appn (PrimAlts []
- (BindDefault prim_arg body))
- )
+ \body -> Case (App (Var packStringForCId) arg)
+ prim_arg [(DEFAULT,[],body)])
| null data_cons
-- oops: we can't see the data constructors!!!
(arg2_tycon == byteArrayPrimTyCon ||
arg2_tycon == mutableByteArrayPrimTyCon)
-- and, of course, it is an instance of CCallable
- = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
+ = newSysLocalDs arg_ty `thenDs` \ case_bndr ->
+ newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
returnDs (Var arr_cts_var,
- \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
- NoDefault)
+ \ body -> Case arg case_bndr [(DataCon the_data_con,vars,body)]
)
-- Data types with a single constructor, which has a single, primitive-typed arg
| maybeToBool maybe_boxed_prim_arg_ty
- = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
+ = newSysLocalDs arg_ty `thenDs` \ case_bndr ->
+ newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
- \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
- NoDefault)
+ \ body -> Case arg case_bndr [(DataCon box_data_con,[prim_arg],body)]
)
| otherwise
can'tSeeDataConsPanic thing ty
= pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration"
(hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"])
+
\end{code}
\begin{code}
-boxResult :: Id -- IOok constructor
- -> Type -- Type of desired result
+boxResult :: Type -- Type of desired result
-> DsM (Type, -- Type of the result of the ccall itself
CoreExpr -> CoreExpr) -- Wrapper for the ccall
-- to box the result
-boxResult ioOkDataCon result_ty
+boxResult result_ty
| null data_cons
-- oops! can't see the data constructors
= can'tSeeDataConsPanic "result" result_ty
- -- Data types with a single constructor, which has a single, primitive-typed arg
+ -- Data types with a single nullary constructor
| (maybeToBool maybe_data_type) && -- Data type
(null other_data_cons) && -- Just one constr
- not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
- isUnpointedType the_prim_result_ty -- of primitive type
+ (null data_con_arg_tys)
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
+{-
wrapUnboxedValue result_ty `thenDs` \ (state_and_prim_datacon,
state_and_prim_ty, prim_result_id, the_result) ->
mkConDs ioOkDataCon
[TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
`thenDs` \ the_pair ->
+-}
let
- the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
+ the_pair = mkConApp unboxedPairDataCon
+ [Type realWorldStatePrimTy, Type result_ty,
+ Var prim_state_id,
+ Con (DataCon unitDataCon) []]
+ the_alt = (DataCon (unboxedTupleCon 1), [prim_state_id], the_pair)
+ scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
in
- returnDs (state_and_prim_ty,
- \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
+ returnDs (scrut_ty, \prim_app -> Case prim_app (mkWildId scrut_ty) [the_alt]
)
- -- Data types with a single nullary constructor
+ -- Data types with a single constructor, which has a single, primitive-typed arg
| (maybeToBool maybe_data_type) && -- Data type
(null other_data_cons) && -- Just one constr
- (null data_con_arg_tys)
+ not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
+ isUnLiftedType the_prim_result_ty -- of primitive type
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
-
- mkConDs ioOkDataCon
- [TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
- `thenDs` \ the_pair ->
+ newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
+ newSysLocalDs ccall_res_type `thenDs` \ case_bndr ->
let
- the_alt = (stateDataCon, [prim_state_id], the_pair)
+ the_result = mkConApp the_data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
+ the_pair = mkConApp unboxedPairDataCon
+ [Type realWorldStatePrimTy, Type result_ty,
+ Var prim_state_id, the_result]
+ the_alt = (DataCon unboxedPairDataCon, [prim_state_id, prim_result_id], the_pair)
in
- returnDs (realWorldStateTy,
- \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
+ returnDs (ccall_res_type, \prim_app -> Case prim_app case_bndr [the_alt]
)
| otherwise
maybe_data_type = splitAlgTyConApp_maybe result_ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
+ ccall_res_type = mkUnboxedTupleTy 2
+ [realWorldStatePrimTy, the_prim_result_ty]
data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
--- (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
-
-- wrap up an unboxed value.
-wrapUnboxedValue :: Type -> DsM (Id, Type, Id, CoreExpr)
+wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr)
wrapUnboxedValue ty
| null data_cons
-- oops! can't see the data constructors
| (maybeToBool maybe_data_type) && -- Data type
(null other_data_cons) && -- Just one constr
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
- isUnpointedType the_prim_result_ty -- of primitive type
+ isUnLiftedType the_prim_result_ty -- of primitive type
=
newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
- mkConDs the_data_con (map TyArg tycon_arg_tys ++
- [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
- returnDs (state_and_prim_datacon, state_and_prim_ty, prim_result_id, the_result)
+ let
+ the_result = mkConApp the_data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
+ in
+ returnDs (ccall_res_type, prim_result_id, the_result)
-- Data types with a single nullary constructor
| (maybeToBool maybe_data_type) && -- Data type
(null other_data_cons) && -- Just one constr
(null data_con_arg_tys)
=
- let unit = unitDataCon in
- returnDs (stateDataCon, realWorldStateTy, unit, Var unit)
+ let unit = dataConId unitDataCon
+ scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
+ in
+ returnDs (scrut_ty, unit, mkConApp unitDataCon [])
| otherwise
= pprPanic "boxResult: " (ppr ty)
where
maybe_data_type = splitAlgTyConApp_maybe ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
+ ccall_res_type = mkUnboxedTupleTy 2
+ [realWorldStatePrimTy, the_prim_result_ty]
data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
- (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
-
-\end{code}
-This grimy bit of code is for digging out the IOok constructor from an
-application of the the IO type. The constructor is needed for
-wrapping the result of a _ccall_. The alternative is to wire-in IO,
-which brings a whole heap of junk with it.
-
-If the representation of IO changes, this will probably have to be
-brought in line with the new definition.
-
-newtype IO a = IO (State# RealWorld -> IOResult a)
-
-the constructor IO has type (State# RealWorld -> IOResult a) -> IO a
-
-\begin{code}
-getIoOkDataCon :: Type -- IO t
- -> (Id, Id, Type) -- Returns (IOok, IO, t)
-
-getIoOkDataCon io_ty
- = let
- Just (ioTyCon, [t]) = splitTyConApp_maybe io_ty
- [ioDataCon] = tyConDataCons ioTyCon
- ioDataConTy = idType ioDataCon
- (_, ioDataConTy') = splitForAllTys ioDataConTy
- ([arg_ty], _) = splitFunTys ioDataConTy'
- (_, io_result_ty) = splitFunTys arg_ty
- Just (io_result_tycon, _) = splitTyConApp_maybe io_result_ty
- [ioOkDataCon,ioFailDataCon] = tyConDataCons io_result_tycon
- in
- (ioOkDataCon, ioDataCon, t)
\end{code}
-
-Another way to do it, more sensitive:
-
- case ioDataConTy of
- ForAll _ (FunTy (FunTy _ (AppTy (TyConTy ioResultTyCon _) _)) _) ->
- let [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
- in
- (ioOkDataCon, result_ty)
- _ -> pprPanic "getIoOkDataCon: " (ppr PprDebug ioDataConTy)
_interface_ DsExpr 1
_exports_
-DsExpr dsExpr;
+DsExpr dsExpr dsLet;
_declarations_
1 dsExpr _:_ TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
+1 dsLet _:_ TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
--- /dev/null
+__interface DsExpr 1 0 where
+__export DsExpr dsExpr dsLet;
+1 dsExpr :: TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 dsLet :: TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsExpr]{Matching expressions (Exprs)}
\begin{code}
-module DsExpr ( dsExpr ) where
+module DsExpr ( dsExpr, dsLet ) where
#include "HsVersions.h"
-import {-# SOURCE #-} DsBinds (dsBinds )
import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), DoOrListComp(..), Match(..), HsBinds, HsType, Fixity,
- GRHSsAndBinds
+ Stmt(..), StmtCtxt(..), Match(..), HsBinds(..), MonoBinds(..),
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
- TypecheckedRecordBinds, TypecheckedPat,
TypecheckedStmt,
maybeBoxedPrimType
import CoreSyn
import DsMonad
+import DsBinds ( dsMonoBinds )
+import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall )
import DsListComp ( dsListComp )
-import DsUtils ( mkAppDs, mkConDs, dsExprToAtomGivenTy,
- mkErrorAppDs, showForErr, DsCoreArg
- )
-import Match ( matchWrapper )
+import DsUtils ( mkErrorAppDs )
+import Match ( matchWrapper, matchSimply )
-import CoreUtils ( coreExprType, mkCoreIfThenElse )
+import CoreUtils ( coreExprType )
import CostCentre ( mkUserCC )
import FieldLabel ( FieldLabel )
-import Id ( dataConTyCon, dataConArgTys, dataConFieldLabels,
- recordSelectorFieldLabel, Id
- )
-import Literal ( mkMachInt, Literal(..) )
-import Name ( Name{--O only-} )
-import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID )
+import Id ( Id, idType, recordSelectorFieldLabel )
+import Const ( Con(..) )
+import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
+import Const ( mkMachInt, Literal(..) )
+import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import TyCon ( isNewTyCon )
-import Type ( splitFunTys, typePrimRep, mkTyConApp,
+import DataCon ( isExistentialDataCon )
+import Type ( splitFunTys, mkTyConApp,
splitAlgTyConApp, splitTyConApp_maybe,
- splitAppTy, Type
+ splitAppTy, isUnLiftedType, Type
)
-import TysWiredIn ( tupleCon, nilDataCon, consDataCon, listTyCon, mkListTy,
- charDataCon, charTy
+import TysWiredIn ( tupleCon, unboxedTupleCon,
+ consDataCon, listTyCon, mkListTy,
+ charDataCon, charTy, stringTy
)
-import TyVar ( GenTyVar{-instance Eq-} )
+import BasicTypes ( RecFlag(..) )
import Maybes ( maybeToBool )
-import Util ( zipEqual )
+import Util ( zipEqual, zipWithEqual )
import Outputable
-
-mk_nil_con ty = mkCon nilDataCon [ty] [] -- micro utility...
\end{code}
-The funny business to do with variables is that we look them up in the
-Id-to-Id and Id-to-Id maps that the monadery is carrying
-around; if we get hits, we use the value accordingly.
+
+%************************************************************************
+%* *
+\subsection{dsLet}
+%* *
+%************************************************************************
+
+@dsLet@ is a match-result transformer, taking the MatchResult for the body
+and transforming it into one for the let-bindings enclosing the body.
+
+This may seem a bit odd, but (source) let bindings can contain unboxed
+binds like
+
+ C x# = e
+
+This must be transformed to a case expression and, if the type has
+more than one constructor, may fail.
+
+\begin{code}
+dsLet :: TypecheckedHsBinds -> CoreExpr -> DsM CoreExpr
+
+dsLet EmptyBinds body
+ = returnDs body
+
+dsLet (ThenBinds b1 b2) body
+ = dsLet b2 body `thenDs` \ body' ->
+ dsLet b1 body'
+
+-- Special case for bindings which bind unlifted variables
+dsLet (MonoBind (AbsBinds [] [] binder_triples bind) sigs is_rec) body
+ | or [isUnLiftedType (idType g) | (_, g, l) <- binder_triples]
+ = ASSERT (case is_rec of {NonRecursive -> True; other -> False})
+ putSrcLocDs loc $
+ dsGuarded grhss `thenDs` \ rhs ->
+ let
+ body' = foldr bind body binder_triples
+ bind (tyvars, g, l) body = ASSERT( null tyvars )
+ bindNonRec g (Var l) body
+ in
+ mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
+ matchSimply rhs PatBindMatch pat body' error_expr
+ where
+ PatMonoBind pat grhss loc = bind
+ result_ty = coreExprType body
+
+-- Ordinary case for bindings
+dsLet (MonoBind binds sigs is_rec) body
+ = dsMonoBinds False binds [] `thenDs` \ prs ->
+ case is_rec of
+ Recursive -> returnDs (Let (Rec prs) body)
+ NonRecursive -> returnDs (foldr mk_let body prs)
+ where
+ mk_let (bndr,rhs) body = Let (NonRec bndr rhs) body
+\end{code}
%************************************************************************
%* *
\begin{code}
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
-dsExpr e@(HsVar var) = dsId var
+dsExpr e@(HsVar var) = returnDs (Var var)
\end{code}
%************************************************************************
\begin{code}
dsExpr (HsLitOut (HsString s) _)
| _NULL_ s
- = returnDs (mk_nil_con charTy)
+ = returnDs (mkNilExpr charTy)
| _LENGTH_ s == 1
= let
- the_char = mkCon charDataCon [] [LitArg (MachChar (_HEAD_ s))]
- the_nil = mk_nil_con charTy
+ the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_ s))]
+ the_nil = mkNilExpr charTy
+ the_cons = mkConApp consDataCon [Type charTy, the_char, the_nil]
in
- mkConDs consDataCon [TyArg charTy, VarArg the_char, VarArg the_nil]
+ returnDs the_cons
+
-- "_" => build (\ c n -> c 'c' n) -- LATER
-- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
dsExpr (HsLitOut (HsString str) _)
- = returnDs (Lit (NoRepStr str))
+ = returnDs (mkLit (NoRepStr str stringTy))
-dsExpr (HsLitOut (HsLitLit s) ty)
- = returnDs ( mkCon data_con [] [LitArg (MachLitLit s kind)] )
+dsExpr (HsLitOut (HsLitLit str) ty)
+ = returnDs ( mkConApp data_con [mkLit (MachLitLit str prim_ty)] )
where
- (data_con, kind)
+ (data_con, prim_ty)
= case (maybeBoxedPrimType ty) of
- Just (boxing_data_con, prim_ty)
- -> (boxing_data_con, typePrimRep prim_ty)
+ Just (boxing_data_con, prim_ty) -> (boxing_data_con, prim_ty)
Nothing
-> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
- (hcat [ptext s, text "; type: ", ppr ty])
+ (hcat [ptext str, text "; type: ", ppr ty])
dsExpr (HsLitOut (HsInt i) ty)
- = returnDs (Lit (NoRepInteger i ty))
+ = returnDs (mkLit (NoRepInteger i ty))
dsExpr (HsLitOut (HsFrac r) ty)
- = returnDs (Lit (NoRepRational r ty))
+ = returnDs (mkLit (NoRepRational r ty))
-- others where we know what to do:
dsExpr (HsLitOut (HsIntPrim i) _)
- | i >= toInteger minInt && i <= toInteger maxInt
- = returnDs (Lit (mkMachInt (fromInteger i)))
- | otherwise
+ | (i >= toInteger minInt && i <= toInteger maxInt)
+ = returnDs (mkLit (mkMachInt i))
+ | otherwise
= error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
dsExpr (HsLitOut (HsFloatPrim f) _)
- = returnDs (Lit (MachFloat f))
+ = returnDs (mkLit (MachFloat f))
-- ToDo: range checking needed!
dsExpr (HsLitOut (HsDoublePrim d) _)
- = returnDs (Lit (MachDouble d))
+ = returnDs (mkLit (MachDouble d))
-- ToDo: range checking needed!
dsExpr (HsLitOut (HsChar c) _)
- = returnDs ( mkCon charDataCon [] [LitArg (MachChar c)] )
+ = returnDs ( mkConApp charDataCon [mkLit (MachChar c)] )
dsExpr (HsLitOut (HsCharPrim c) _)
- = returnDs (Lit (MachChar c))
+ = returnDs (mkLit (MachChar c))
dsExpr (HsLitOut (HsStringPrim s) _)
- = returnDs (Lit (MachStr s))
+ = returnDs (mkLit (MachStr s))
-- end of literals magic. --
dsExpr expr@(HsLam a_Match)
= matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
- returnDs ( mkValLam binders matching_code )
+ returnDs (mkLams binders matching_code)
dsExpr expr@(HsApp fun arg)
= dsExpr fun `thenDs` \ core_fun ->
dsExpr arg `thenDs` \ core_arg ->
- dsExprToAtomGivenTy core_arg (coreExprType core_arg) $ \ atom_arg ->
- returnDs (core_fun `App` atom_arg)
+ returnDs (core_fun `App` core_arg)
\end{code}
in
dsExpr e1 `thenDs` \ x_core ->
dsExpr e2 `thenDs` \ y_core ->
- dsExprToAtomGivenTy x_core x_ty $ \ x_atom ->
- dsExprToAtomGivenTy y_core y_ty $ \ y_atom ->
- returnDs (core_op `App` x_atom `App` y_atom)
+ returnDs (mkApps core_op [x_core, y_core])
dsExpr (SectionL expr op)
= dsExpr op `thenDs` \ core_op ->
(x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
in
dsExpr expr `thenDs` \ x_core ->
- dsExprToAtomGivenTy x_core x_ty $ \ x_atom ->
-
+ newSysLocalDs x_ty `thenDs` \ x_id ->
newSysLocalDs y_ty `thenDs` \ y_id ->
- returnDs (mkValLam [y_id] (core_op `App` x_atom `App` VarArg y_id))
+
+ returnDs (bindNonRec x_id x_core $
+ Lam y_id (mkApps core_op [Var x_id, Var y_id]))
-- dsExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr)
let
(x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
in
- dsExpr expr `thenDs` \ y_expr ->
- dsExprToAtomGivenTy y_expr y_ty $ \ y_atom ->
-
+ dsExpr expr `thenDs` \ y_core ->
newSysLocalDs x_ty `thenDs` \ x_id ->
- returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
+ newSysLocalDs y_ty `thenDs` \ y_id ->
+
+ returnDs (bindNonRec y_id y_core $
+ Lam x_id (mkApps core_op [Var x_id, Var y_id]))
dsExpr (CCall label args may_gc is_asm result_ty)
= mapDs dsExpr args `thenDs` \ core_args ->
getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
returnDs (Note (SCC (mkUserCC cc mod_name group_name)) core_expr)
-dsExpr expr@(HsCase discrim matches src_loc)
- = putSrcLocDs src_loc $
+-- special case to handle unboxed tuple patterns
+
+dsExpr (HsCase discrim matches@[PatMatch (TuplePat ps boxed) (GRHSMatch rhs)]
+ src_loc)
+ | all var_pat ps
+ = putSrcLocDs src_loc $
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
- returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
+ case matching_code of
+ Case (Var x) bndr alts | x == discrim_var ->
+ returnDs (Case core_discrim bndr alts)
+ _ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
-dsExpr (HsLet binds expr)
- = dsBinds False binds `thenDs` \ core_binds ->
- dsExpr expr `thenDs` \ core_expr ->
- returnDs ( mkCoLetsAny core_binds core_expr )
+dsExpr (HsCase discrim matches src_loc)
+ = putSrcLocDs src_loc $
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
+ returnDs (bindNonRec discrim_var core_discrim matching_code)
+dsExpr (HsLet binds body)
+ = dsExpr body `thenDs` \ body' ->
+ dsLet binds body'
+
dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc)
| maybeToBool maybe_list_comp
= -- Special case for list comprehensions
dsExpr guard_expr `thenDs` \ core_guard ->
dsExpr then_expr `thenDs` \ core_then ->
dsExpr else_expr `thenDs` \ core_else ->
- returnDs (mkCoreIfThenElse core_guard core_then core_else)
+ returnDs (mkIfThenElse core_guard core_then core_else)
\end{code}
\begin{code}
dsExpr (TyLam tyvars expr)
= dsExpr expr `thenDs` \ core_expr ->
- returnDs (mkTyLam tyvars core_expr)
+ returnDs (mkLams tyvars core_expr)
dsExpr (TyApp expr tys)
= dsExpr expr `thenDs` \ core_expr ->
- returnDs (mkTyApp core_expr tys)
+ returnDs (mkTyApps core_expr tys)
\end{code}
where
list_ty = mkListTy ty
- -- xs can ocasaionlly be huge, so don't try to take
- -- coreExprType of core_xs, as dsArgToAtom does
- -- (that gives a quadratic algorithm)
- go [] = returnDs (mk_nil_con ty)
+ go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
- dsExprToAtomGivenTy core_x ty $ \ arg_x ->
go xs `thenDs` \ core_xs ->
- dsExprToAtomGivenTy core_xs list_ty $ \ arg_xs ->
- returnDs (Con consDataCon [TyArg ty, arg_x, arg_xs])
+ returnDs (mkConApp consDataCon [Type ty, core_x, core_xs])
-dsExpr (ExplicitTuple expr_list)
+dsExpr (ExplicitTuple expr_list boxed)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
- mkConDs (tupleCon (length expr_list))
- (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
+ returnDs (mkConApp ((if boxed
+ then tupleCon
+ else unboxedTupleCon) (length expr_list))
+ (map (Type . coreExprType) core_exprs ++ core_exprs))
dsExpr (HsCon con_id [ty] [arg])
| isNewTyCon tycon
dsExpr (HsCon con_id tys args)
= mapDs dsExpr args `thenDs` \ args2 ->
- mkConDs con_id (map TyArg tys ++ map VarArg args2)
+ returnDs (mkConApp con_id (map Type tys ++ args2))
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
- mkAppDs expr2 [VarArg from2]
+ returnDs (App expr2 from2)
dsExpr (ArithSeqOut expr (FromTo from two))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr two `thenDs` \ two2 ->
- mkAppDs expr2 [VarArg from2, VarArg two2]
+ returnDs (mkApps expr2 [from2, two2])
dsExpr (ArithSeqOut expr (FromThen from thn))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr thn `thenDs` \ thn2 ->
- mkAppDs expr2 [VarArg from2, VarArg thn2]
+ returnDs (mkApps expr2 [from2, thn2])
dsExpr (ArithSeqOut expr (FromThenTo from thn two))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr thn `thenDs` \ thn2 ->
dsExpr two `thenDs` \ two2 ->
- mkAppDs expr2 [VarArg from2, VarArg thn2, VarArg two2]
+ returnDs (mkApps expr2 [from2, thn2, two2])
\end{code}
Record construction and update
\begin{code}
-dsExpr (RecordCon con_id con_expr rbinds)
+dsExpr (RecordConOut data_con con_expr rbinds)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
(arg_tys, _) = splitFunTys (coreExprType con_expr')
lbl == recordSelectorFieldLabel sel_id] of
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
- [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
+ [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
in
- mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels con_id)) `thenDs` \ con_args ->
- mkAppDs con_expr' (map VarArg con_args)
+ mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels data_con)) `thenDs` \ con_args ->
+ returnDs (mkApps con_expr' con_args)
\end{code}
Record update is a little harder. Suppose we have the decl:
\begin{code}
dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
- = dsExpr record_expr `thenDs` \ record_expr' ->
+ = dsExpr record_expr `thenDs` \ record_expr' ->
-- Desugar the rbinds, and generate let-bindings if
-- necessary so that we don't lose sharing
- dsRbinds rbinds $ \ rbinds' ->
+
+ let
+ ds_rbind (sel_id, rhs, pun_flag)
+ = dsExpr rhs `thenDs` \ rhs' ->
+ returnDs (recordSelectorFieldLabel sel_id, rhs')
+ in
+ mapDs ds_rbind rbinds `thenDs` \ rbinds' ->
let
record_in_ty = coreExprType record_expr'
(tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
cons_to_upd = filter has_all_fields cons
-- initial_args are passed to every constructor
- initial_args = map TyArg out_inst_tys ++ map VarArg dicts
+ initial_args = map Type out_inst_tys ++ map Var dicts
- mk_val_arg (field, arg_id)
- = case [arg | (f, arg) <- rbinds',
- field == recordSelectorFieldLabel f] of
- (arg:args) -> ASSERT(null args)
- arg
- [] -> VarArg arg_id
+ mk_val_arg field old_arg_id
+ = case [rhs | (f, rhs) <- rbinds', field == f] of
+ (rhs:rest) -> ASSERT(null rest) rhs
+ [] -> Var old_arg_id
mk_alt con
= newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids ->
let
- val_args = map mk_val_arg (zipEqual "dsExpr:RecordUpd" (dataConFieldLabels con) arg_ids)
+ val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
+ (dataConFieldLabels con) arg_ids
+ rhs = mkApps (mkApps (Var (dataConId con)) initial_args) val_args
in
- returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args)
+ returnDs (DataCon con, arg_ids, rhs)
mk_default
| length cons_to_upd == length cons
- = returnDs NoDefault
+ = returnDs []
| otherwise
- = newSysLocalDs record_in_ty `thenDs` \ deflt_id ->
- mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty "" `thenDs` \ err ->
- returnDs (BindDefault deflt_id err)
+ = mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty "" `thenDs` \ err ->
+ returnDs [(DEFAULT, [], err)]
in
+ -- Record stuff doesn't work for existentials
+ ASSERT( all (not . isExistentialDataCon) cons )
+
+ newSysLocalDs record_in_ty `thenDs` \ case_bndr ->
mapDs mk_alt cons_to_upd `thenDs` \ alts ->
mk_default `thenDs` \ deflt ->
- returnDs (Case record_expr' (AlgAlts alts deflt))
-
+ returnDs (Case record_expr' case_bndr (alts ++ deflt))
where
- has_all_fields :: Id -> Bool
+ has_all_fields :: DataCon -> Bool
has_all_fields con_id
= all ok rbinds
where
\begin{code}
dsExpr (DictLam dictvars expr)
= dsExpr expr `thenDs` \ core_expr ->
- returnDs (mkValLam dictvars core_expr)
+ returnDs (mkLams dictvars core_expr)
------------------
dsExpr (DictApp expr dicts) -- becomes a curried application
- = mapDs lookupEnvDs dicts `thenDs` \ core_dicts ->
- dsExpr expr `thenDs` \ core_expr ->
- returnDs (foldl (\f d -> f `App` (VarArg d)) core_expr core_dicts)
+ = dsExpr expr `thenDs` \ core_expr ->
+ returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
\end{code}
\begin{code}
= " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
\end{code}
-
%--------------------------------------------------------------------
-\begin{code}
-dsId v
- = lookupEnvDs v `thenDs` \ v' ->
- returnDs (Var v')
-\end{code}
-
-\begin{code}
-dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied
- -> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field
- -- bindings with atomic rhss
- -> DsM CoreExpr -- The result of the continuation,
- -- wrapped in suitable Lets
-
-dsRbinds [] continue_with
- = continue_with []
-
-dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
- = dsExpr rhs `thenDs` \ rhs' ->
- dsExprToAtomGivenTy rhs' (coreExprType rhs') $ \ rhs_atom ->
- dsRbinds rbinds $ \ rbinds' ->
- continue_with ((sel_id, rhs_atom) : rbinds')
-\end{code}
-
Basically does the translation given in the Haskell~1.3 report:
+
\begin{code}
-dsDo :: DoOrListComp
+dsDo :: StmtCtxt
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
-> DsM CoreExpr
dsDo do_or_lc stmts return_id then_id zero_id result_ty
- = dsId return_id `thenDs` \ return_ds ->
- dsId then_id `thenDs` \ then_ds ->
- dsId zero_id `thenDs` \ zero_ds ->
- let
+ = let
(_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
go [ReturnStmt expr]
= dsExpr expr `thenDs` \ expr2 ->
- mkAppDs return_ds [TyArg b_ty, VarArg expr2]
+ returnDs (mkApps (Var return_id) [Type b_ty, expr2])
go (GuardStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- mkAppDs zero_ds [TyArg b_ty] `thenDs` \ zero_expr ->
- returnDs (mkCoreIfThenElse expr2 rest zero_expr)
+ returnDs (mkIfThenElse expr2 rest (App (Var zero_id) (Type b_ty)))
go (ExprStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
else
go stmts `thenDs` \ rest ->
newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
- mkAppDs then_ds [TyArg a_ty, TyArg b_ty, VarArg expr2,
- VarArg (mkValLam [ignored_result_id] rest)]
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
+ Lam ignored_result_id rest])
go (LetStmt binds : stmts )
- = dsBinds False binds `thenDs` \ binds2 ->
- go stmts `thenDs` \ rest ->
- returnDs (mkCoLetsAny binds2 rest)
-
+ = go stmts `thenDs` \ rest ->
+ dsLet binds rest
+
go (BindStmt pat expr locn : stmts)
= putSrcLocDs locn $
dsExpr expr `thenDs` \ expr2 ->
zero_expr = TyApp (HsVar zero_id) [b_ty]
main_match = PatMatch pat (SimpleMatch (
HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn))
-
the_matches
- | failureFreePat pat = [main_match]
- | otherwise =
- [ main_match
- , PatMatch (WildPat a_ty) (SimpleMatch zero_expr)
- ]
+ = if failureFreePat pat
+ then [main_match]
+ else [main_match, PatMatch (WildPat a_ty) (SimpleMatch zero_expr)]
in
matchWrapper DoBindMatch the_matches match_msg
`thenDs` \ (binders, matching_code) ->
- mkAppDs then_ds [TyArg a_ty, TyArg b_ty,
- VarArg expr2, VarArg (mkValLam binders matching_code)]
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
+ mkLams binders matching_code])
in
go stmts
DoStmt -> "`do' statement"
ListComp -> "comprehension"
\end{code}
+
+\begin{code}
+var_pat (WildPat _) = True
+var_pat (VarPat _) = True
+var_pat _ = False
+\end{code}
+
\begin{code}
module DsForeign ( dsForeigns ) where
-
#include "HsVersions.h"
import CoreSyn
-import DsCCall ( getIoOkDataCon, boxResult, unboxArg,
- can'tSeeDataConsPanic, wrapUnboxedValue
- )
+import DsCCall ( dsCCall, boxResult, unboxArg, wrapUnboxedValue )
import DsMonad
import DsUtils
import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
import CallConv
-import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl )
+import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( coreExprType )
-import Id ( Id, dataConArgTys, idType, idName,
- mkVanillaId, dataConRawArgTys,
- dataConTyCon, mkIdVisible
+import Const ( Con(..), mkMachInt )
+import DataCon ( DataCon, dataConId )
+import Id ( Id, idType, idName,
+ mkIdVisible, mkWildId
)
-import IdInfo ( noIdInfo )
-import Literal ( Literal(..), mkMachInt )
-import Maybes ( maybeToBool )
-import Name ( nameString, occNameString, nameOccName, nameUnique )
-import PrelVals ( packStringForCId, eRROR_ID, realWorldPrimId )
-import PrimOp ( PrimOp(..) )
-import Type ( isUnpointedType, splitAlgTyConApp_maybe,
+import Const ( Literal(..) )
+import Name ( getOccString, NamedThing(..) )
+import PrelVals ( realWorldPrimId )
+import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
+import Type ( splitAlgTyConApp_maybe,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
- Type, mkFunTys, applyTy, mkForAllTys, mkTyConApp,
- typePrimRep, mkTyVarTy, mkFunTy, splitAppTy
+ Type, mkFunTys, mkForAllTys, mkTyConApp,
+ mkTyVarTy, mkFunTy, splitAppTy
)
-import PrimRep ( showPrimRepToUser, PrimRep(..) )
-import TyVar ( TyVar )
-import TyCon ( tyConDataCons )
-import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
- byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
- realWorldTy, addrPrimTy, mkStablePtrPrimTy,
- intPrimTy
- )
-import TysWiredIn ( getStatePairingConInfo,
- unitDataCon, stringTy,
- realWorldStateTy, stateDataCon,
- isFFIArgumentTy, unitTy,
- addrTy, stablePtrTyCon,
- stateAndPtrPrimDataCon,
- addrDataCon
+import PrimOp ( PrimOp(..) )
+import Var ( TyVar )
+import TysPrim ( realWorldStatePrimTy, addrPrimTy )
+import TysWiredIn ( unitTyCon, addrTy, stablePtrTyCon,
+ unboxedTupleCon, addrDataCon
)
import Unique
import Outputable
\begin{code}
dsForeigns :: [TypecheckedForeignDecl]
- -> DsM ( [CoreBinding] -- desugared foreign imports
- , [CoreBinding] -- helper functions for foreign exports
- , SDoc -- auxilliary code to emit into .hc file
- , SDoc -- Header file prototypes for "foreign exported" functions.
- , SDoc -- C stubs to use when calling "foreign exported" funs.
+ -> DsM ( [CoreBind] -- desugared foreign imports
+ , [CoreBind] -- helper functions for foreign exports
+ , SDoc -- Header file prototypes for "foreign exported" functions.
+ , SDoc -- C stubs to use when calling "foreign exported" funs.
)
-dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
+dsForeigns fos = foldlDs combine ([],[],empty,empty) fos
where
- combine (acc_fi, acc_fe, acc_hc, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
- | isForeignImport =
+ combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
+ | isForeignImport = -- foreign import (dynamic)?
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b ->
- returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
+ returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
| isForeignLabel =
dsFLabel i ext_nm `thenDs` \ b ->
- returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
+ returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
| isDynamic ext_nm =
- dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,hc,h,c) ->
- returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
- | otherwise =
- dsFExport i (idType i) ext_nm cconv False `thenDs` \ (fe,hc,h,c) ->
- returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
+ dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,h,c) ->
+ returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
+ | otherwise = -- foreign export
+ dsFExport i (idType i) ext_nm cconv False `thenDs` \ (fe,h,c) ->
+ returnDs (acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
where
isForeignImport =
case imp_exp of
-> Bool -- True <=> might cause Haskell GC
-> ExtName
-> CallConv
- -> DsM CoreBinding
+ -> DsM CoreBind
dsFImport nm ty may_not_gc ext_name cconv =
newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
- mkArgs ty `thenDs` \ (tvs, args, io_res_ty) ->
- mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
+ splitForeignTyDs ty `thenDs` \ (tvs, args, mbIoDataCon, io_res_ty) ->
let
the_state_arg
| is_io_action = old_s
| otherwise = realWorldPrimId
- final_args = Var the_state_arg : unboxed_args
- (ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
+ arg_exprs = map (Var) args
is_io_action =
- case (splitTyConApp_maybe io_res_ty) of
- Just (iot,[_]) -> (uniqueOf iot) == ioTyConKey
- _ -> False
+ case mbIoDataCon of
+ Nothing -> False
+ _ -> True
in
+ mapAndUnzipDs unboxArg arg_exprs `thenDs` \ (unboxed_args, arg_wrappers) ->
(if not is_io_action then
- newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
- wrapUnboxedValue io_res_ty `thenDs` \ (state_and_foo, state_and_foo_ty, v, res_v) ->
- let the_alt = (state_and_foo, [state_tok,v], res_v) in
- returnDs (state_and_foo_ty, \ prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault))
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
+ wrapUnboxedValue io_res_ty `thenDs` \ (ccall_result_ty, v, res_v) ->
+ returnDs ( ccall_result_ty
+ , \ prim_app -> Case prim_app (mkWildId ccall_result_ty)
+ [(DataCon (unboxedTupleCon 2), [state_tok, v], res_v)])
else
- boxResult ioOkDataCon result_ty) `thenDs` \ (final_result_ty, res_wrapper) ->
+ boxResult io_res_ty) `thenDs` \ (final_result_ty, res_wrapper) ->
(case ext_name of
Dynamic -> getUniqueDs `thenDs` \ u ->
returnDs (Right u)
- ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
+ ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
let
+ val_args = Var the_state_arg : unboxed_args
+ final_args = Type inst_ty : val_args
+
+ -- A CCallOp has type (forall a. a), so we must instantiate
+ -- it at the full type, including the state argument
+ inst_ty = mkFunTys (map coreExprType val_args) final_result_ty
+
the_ccall_op = CCallOp label False (not may_not_gc) cconv
- (map coreExprType final_args)
- final_result_ty
- in
- mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
- let
- body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
- the_body
+ the_prim_app = mkPrimApp the_ccall_op (final_args :: [CoreArg])
+
+ body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
+
+ the_body
| not is_io_action = body
- | otherwise = mkValLam [old_s] body
+ | otherwise = Lam old_s body
in
newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
let
- io_app
- | is_io_action = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
- | otherwise = Var ds
-
- fo_rhs = mkTyLam tvs $
- mkValLam (map (\ (Var x) -> x) args)
- (mkCoLetAny (NonRec ds the_body) io_app)
+ io_app =
+ case mbIoDataCon of
+ Nothing -> Var ds
+ Just ioDataCon ->
+ mkApps (Var (dataConId ioDataCon))
+ [Type io_res_ty, Var ds]
+
+ fo_rhs = mkLams (tvs ++ args)
+ (Let (NonRec ds (the_body::CoreExpr)) io_app)
in
returnDs (NonRec nm fo_rhs)
+\end{code}
+
+Given the type of a foreign import declaration, split it up into
+its constituent parts.
-mkArgs :: Type -> DsM ([TyVar], [CoreExpr], Type)
-mkArgs ty =
- case splitFunTys sans_foralls of
- (arg_tys, res_ty) ->
- newSysLocalsDs arg_tys `thenDs` \ ds_args ->
- returnDs (tvs, map Var ds_args, res_ty)
+\begin{code}
+splitForeignTyDs :: Type -> DsM ([TyVar], [Id], Maybe DataCon, Type)
+splitForeignTyDs ty =
+ newSysLocalsDs arg_tys `thenDs` \ ds_args ->
+ case splitAlgTyConApp_maybe res_ty of
+ Just (_,(io_res_ty:_),(ioCon:_)) -> -- .... -> IO t
+ returnDs (tvs, ds_args, Just ioCon, io_res_ty)
+ _ -> -- .... -> t
+ returnDs (tvs, ds_args, Nothing, res_ty)
where
+ (arg_tys, res_ty) = splitFunTys sans_foralls
(tvs, sans_foralls) = splitForAllTys ty
-
+
\end{code}
+foreign labels
\begin{code}
-dsFLabel :: Id -> ExtName -> DsM CoreBinding
-dsFLabel nm ext_name =
- returnDs (NonRec nm fo_rhs)
+dsFLabel :: Id -> ExtName -> DsM CoreBind
+dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs)
where
- fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
+ fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)]
enm =
case ext_name of
ExtName f _ -> f
+ Dynamic -> panic "dsFLabel: Dynamic - shouldn't ever happen."
\end{code}
-
+The function that does most of the work for 'foreign export' declarations.
+(see below for the boilerplate code a 'foreign export' declaration expands
+ into.)
\begin{code}
dsFExport :: Id
-> CallConv
-> Bool -- True => invoke IO action that's hanging off
-- the first argument's stable pointer
- -> DsM (CoreBinding, SDoc, SDoc, SDoc)
+ -> DsM ( CoreBind
+ , SDoc
+ , SDoc
+ )
dsFExport i ty ext_name cconv isDyn =
- newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 ->
newSysLocalDs helper_ty `thenDs` \ f_helper ->
- newSysLocalsDs helper_arg_tys `thenDs` \ helper_args ->
- newSysLocalDs res_ty `thenDs` \ v1 ->
- unboxResult the_prim_result_ty res_ty s3 v1 `thenDs` \ (state_and_prim_ty, unpack_result) ->
- zipWithDs boxArg fe_arg_tys helper_args `thenDs` \ stuff ->
+ newSysLocalsDs fe_arg_tys `thenDs` \ fe_args ->
(if isDyn then
- newSysLocalDs realWorldStatePrimTy `thenDs` \ s11 ->
newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr ->
- newSysLocalDs stbl_ptr_to_ty `thenDs` \ f ->
- mkPrimDs DeRefStablePtrOp
- [TyArg stbl_ptr_to_ty,
- VarArg (Var stbl_ptr),
- VarArg (Var s1)] `thenDs` \ the_deref_app ->
+ newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value ->
+ dsLookupGlobalValue deRefStablePtr_NAME `thenDs` \ deRefStablePtrId ->
let
- stbl_app = \ cont ->
- Case the_deref_app
- (AlgAlts [(stateAndPtrPrimDataCon, [s11, f], cont)]
- NoDefault)
+ the_deref_app = mkApps (Var deRefStablePtrId)
+ [ Type stbl_ptr_to_ty, Var stbl_ptr ]
in
- returnDs (f, stbl_app, s11, stbl_ptr)
+ newSysLocalDs (coreExprType the_deref_app) `thenDs` \ x_deref_app ->
+ dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId ->
+ newSysLocalDs (mkFunTy stbl_ptr_to_ty
+ (mkTyConApp ioTyCon [res_ty])) `thenDs` \ x_cont ->
+ let
+ stbl_app = \ cont ->
+ bindNonRec x_cont (mkLams [stbl_value] cont) $
+ bindNonRec x_deref_app the_deref_app
+ (mkApps (Var bindIOId)
+ [ Type stbl_ptr_to_ty
+ , Type res_ty
+ , Var x_deref_app
+ , Var x_cont])
+ in
+ returnDs (stbl_value, stbl_app, stbl_ptr)
else
returnDs (i,
\ body -> body,
- s1,
panic "stbl_ptr" -- should never be touched.
- )) `thenDs` \ (i, getFun_wrapper, s2, stbl_ptr) ->
+ )) `thenDs` \ (i, getFun_wrapper, stbl_ptr) ->
let
- (boxed_args, arg_wrappers) = unzip stuff
-
wrapper_args
- | isDyn = stbl_ptr:helper_args
- | otherwise = helper_args
+ | isDyn = stbl_ptr:fe_args
+ | otherwise = fe_args
wrapper_arg_tys
| isDyn = stbl_ptr_ty:helper_arg_tys
| otherwise = helper_arg_tys
- fe_app = mkGenApp (Var i) (map (TyArg . mkTyVarTy) tvs ++ map VarArg boxed_args)
the_app =
- getFun_wrapper $
- mkValApp (Note (Coerce io_result_ty io_res) fe_app)
- [VarArg s2]
+ getFun_wrapper $
+ mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args)
in
- newFailLocalDs (coreExprType the_app) `thenDs` \ wild ->
- getModuleAndGroupDs `thenDs` \ (mod,_) ->
- getUniqueDs `thenDs` \ uniq ->
+ getModuleAndGroupDs `thenDs` \ (mod,_) ->
+ getUniqueDs `thenDs` \ uniq ->
let
-
- the_body =
- mkTyLam tvs $
- mkValLam wrapper_args $
- mkValLam [s1] $
- foldr ($) (perform_and_unpack) arg_wrappers
-
- perform_and_unpack =
- Case the_app (AlgAlts [(ioOkDataCon, [s3, v1], unpack_result)]
- (BindDefault wild err))
+ the_body = mkLams (tvs ++ wrapper_args) the_app
c_nm =
case ext_name of
ExtName fs _ -> fs
+ Dynamic -> panic "dsFExport: Dynamic - shouldn't ever happen."
- full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
- msg = NoRepStr (_PK_ full_msg)
- err = mkApp (Var eRROR_ID) [state_and_prim_ty] [LitArg msg]
-
- f_helper_glob = (mkIdVisible mod uniq f_helper)
- (hc_stub, h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_prim_result_ty cconv
+ f_helper_glob = mkIdVisible mod uniq f_helper
+ (h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_result_ty cconv
in
- returnDs (NonRec f_helper_glob the_body, hc_stub, h_stub, c_stub)
+ returnDs (NonRec f_helper_glob the_body, h_stub, c_stub)
+
where
- (tvs,sans_foralls) = splitForAllTys ty
- (fe_arg_tys', io_res) = splitFunTys sans_foralls
- (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res
- maybe_data_type = splitAlgTyConApp_maybe res_ty
- Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
- (the_data_con : other_data_cons) = data_cons
+ (tvs,sans_foralls) = splitForAllTys ty
+ (fe_arg_tys', io_res) = splitFunTys sans_foralls
- data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
- (prim_result_ty : other_args_tys) = data_con_arg_tys
- ioDataConTy = idType ioDataCon
- (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy
- ([arg_ty], _) = splitFunTys ioDataConTy'
- io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty
+ Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res
(_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
(_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
| otherwise = fe_arg_tys'
(stbl_ptr_ty, helper_arg_tys) =
- case (map unboxTy fe_arg_tys') of
+ case fe_arg_tys' of
(x:xs) | isDyn -> (x,xs)
ls -> (error "stbl_ptr_ty", ls)
helper_ty =
mkForAllTys tvs $
- mkFunTys (arg_tys ++ [realWorldStatePrimTy])
- state_and_prim_ty
+ mkFunTys arg_tys io_res
where
arg_tys
| isDyn = stbl_ptr_ty : helper_arg_tys
| otherwise = helper_arg_tys
- the_prim_result_ty
- | null data_con_arg_tys = Nothing
- | otherwise = Just prim_result_ty
-
- state_and_prim_ty
- | (null other_data_cons) &&
- (null data_con_arg_tys) = realWorldStateTy
- | otherwise = snd (getStatePairingConInfo (unboxTy res_ty))
+ the_result_ty =
+ case splitTyConApp_maybe io_res of
+ Just (_,[res_ty]) ->
+ case splitTyConApp_maybe res_ty of
+ Just (tc,_) | getUnique tc /= getUnique unitTyCon -> Just res_ty
+ _ -> Nothing
+ _ -> Nothing
+
\end{code}
"foreign export dynamic" lets you dress up Haskell IO actions
-> Type -- Type of foreign export.
-> ExtName
-> CallConv
- -> DsM (CoreBinding, CoreBinding, SDoc, SDoc, SDoc)
+ -> DsM (CoreBind, CoreBind, SDoc, SDoc)
dsFExportDynamic i ty ext_name cconv =
newSysLocalDs ty `thenDs` \ fe_id ->
let
-- hack: need to get at the name of the C stub we're about to generate.
- fe_nm = toCName fe_id
+ fe_nm = toCName fe_id
fe_ext_name = ExtName (_PK_ fe_nm) Nothing
in
- dsFExport i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), hc_code, h_code, c_code) ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ s2 ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 ->
- newSysLocalDs arg_ty `thenDs` \ cback_arg ->
- newSysLocalDs arg_ty `thenDs` \ cback ->
- newSysLocalDs (mkStablePtrPrimTy arg_ty) `thenDs` \ stbl ->
- newSysLocalDs addrPrimTy `thenDs` \ addrPrim ->
- newSysLocalDs addrTy `thenDs` \ addr ->
- mkPrimDs MakeStablePtrOp [TyArg arg_ty,
- VarArg (Var cback),
- VarArg (Var s1)] `thenDs` \ mkStablePtr_app ->
- mkPrimDs Addr2IntOp [VarArg (Var addrPrim)] `thenDs` \ the_addr2Int_app ->
- boxArg addrTy addrPrim `thenDs` \ (addr_result, addrPrim_wrapper) ->
+ dsFExport i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
+ newSysLocalDs arg_ty `thenDs` \ cback ->
+ dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId ->
let
- (stateAndStablePtrPrimDataCon, _) = getStatePairingConInfo (mkStablePtrPrimTy arg_ty)
- (stateAndAddrPrimDataCon, stateAndAddrPrimTy) = getStatePairingConInfo addrPrimTy
-
- cc
- | cconv == stdCallConv = 1
- | otherwise = 0
-
- ccall_args = [Var s2, Lit (mkMachInt cc),
- Var stbl,
- Lit (MachLitLit (_PK_ fe_nm) AddrRep)]
-
- label = Left SLIT("createAdjustor")
- the_ccall_op = CCallOp label False False{-won't GC-} cCallConv
- (map coreExprType ccall_args)
- stateAndAddrPrimTy
+ mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ]
+ mk_stbl_ptr_app_ty = coreExprType mk_stbl_ptr_app
in
- mkPrimDs the_ccall_op (map VarArg ccall_args) `thenDs` \ the_ccall_app ->
- mkConDs ioOkDataCon
- [TyArg res_ty, VarArg (Var s3), VarArg (Var addr_result)]
- `thenDs` \ ioOkApp ->
- newSysLocalDs intPrimTy `thenDs` \ default_val ->
+ newSysLocalDs mk_stbl_ptr_app_ty `thenDs` \ x_mk_stbl_ptr_app ->
+ dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId ->
+ newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
let
- the_mkStablePtr = \ cont ->
- Case mkStablePtr_app
- (AlgAlts [(stateAndStablePtrPrimDataCon, [s2, stbl], cont)]
- NoDefault)
-
- the_ccall = \ cont ->
- Case the_ccall_app
- (AlgAlts [(stateAndAddrPrimDataCon, [s3, addrPrim], cont)]
- NoDefault)
- the_addr2Int = \ cont ->
- Case the_addr2Int_app
- (PrimAlts [(mkMachInt 0, io_fail)]
- (BindDefault default_val cont))
-
- io_fail = mkApp (Var eRROR_ID) [coreExprType wrap_res] [LitArg msg]
- full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
- msg = NoRepStr (_PK_ full_msg)
-
- wrap_res = addrPrim_wrapper ioOkApp
- the_body =
- mkTyLam tvs $
- mkValLam [cback,s1] $
- the_mkStablePtr $
- the_ccall $
- the_addr2Int wrap_res
-
- in
- newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
- newSysLocalDs (mkFunTy realWorldStatePrimTy
- (coreExprType ioOkApp)) `thenDs` \ ap ->
- let
- io_app = mkValApp (mkTyApp (Var ioDataCon) [res_ty]) [VarArg ap]
- io_action =
- mkTyLam tvs $
- mkValLam [cback_arg] $
- mkCoLetAny (NonRec ds the_body) $
- mkCoLetAny (NonRec ap (mkValApp (mkTyApp (Var ds) (map mkTyVarTy tvs)) [VarArg cback_arg])) $
- io_app
- in
- returnDs (NonRec i io_action, fe, hc_code, h_code, c_code)
+ stbl_app = \ x_cont cont ret_ty ->
+ bindNonRec x_cont cont $
+ bindNonRec x_mk_stbl_ptr_app mk_stbl_ptr_app $
+ (mkApps (Var bindIOId)
+ [ Type (mkTyConApp stablePtrTyCon [arg_ty])
+ , Type ret_ty
+ , Var x_mk_stbl_ptr_app
+ , Var x_cont
+ ])
+
+ {-
+ The arguments to the external function which will
+ create a little bit of (template) code on the fly
+ for allowing the (stable pointed) Haskell closure
+ to be entered using an external calling convention
+ (stdcall, ccall).
+ -}
+ adj_args = [ mkLit (mkMachInt (fromInt (callConvToInt cconv)))
+ , Var stbl_value
+ , mkLit (MachLitLit (_PK_ fe_nm) addrPrimTy)
+ ]
+ -- name of external entry point providing these services.
+ -- (probably in the RTS.)
+ adjustor = SLIT("createAdjustor")
+ in
+ dsCCall adjustor adj_args False False addrTy `thenDs` \ ccall_adj ->
+ let ccall_adj_ty = coreExprType ccall_adj
+ in
+ newSysLocalDs ccall_adj_ty `thenDs` \ x_ccall_adj ->
+ let ccall_io_adj =
+ mkLams [stbl_value] $
+ bindNonRec x_ccall_adj ccall_adj $
+ Note (Coerce (mkTyConApp ioTyCon [res_ty]) ccall_adj_ty)
+ (Var x_ccall_adj)
+ in
+ newSysLocalDs (coreExprType ccall_io_adj) `thenDs` \ x_ccall_io_adj ->
+ let io_app = mkLams tvs $
+ mkLams [cback] $
+ stbl_app x_ccall_io_adj ccall_io_adj addrTy
+ in
+ returnDs (NonRec i io_app, fe, h_code, c_code)
+
where
(tvs,sans_foralls) = splitForAllTys ty
([arg_ty], io_res) = splitFunTys sans_foralls
- (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res
- ioDataConTy = idType ioDataCon
- (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy
--- ([arg_ty], _) = splitFunTys ioDataConTy'
- io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty
+ Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res
export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
%*
%
-\subsection{Helper functions}
-%
-%*
-
-@boxArg@ boxes up an argument in preparation for calling
-a function that maybe expects a boxed version of it, i.e.,
-
-\begin{verbatim}
-boxArg Addr a# ==> let ds_foo :: Addr ; ds_foo = A# a# in f ...ds_foo..
-\end{verbatim}
-
-\begin{code}
-boxArg :: Type -- Expected type after possible boxing of arg.
- -> Id -- The (unboxed) argument
- -> DsM (Id, -- To pass as the actual, boxed argument
- CoreExpr -> CoreExpr -- Wrapper to box the arg
- )
-boxArg box_ty prim_arg
- | isUnpointedType box_ty = returnDs (prim_arg, \body -> body)
- -- Data types with a single constructor,
- -- which has a single, primitive-typed arg
- | otherwise
- = newSysLocalDs box_ty `thenDs` \ box_arg ->
- returnDs ( box_arg
- , Let (NonRec box_arg (mkCon box_data_con tys_applied [VarArg prim_arg]))
- )
- where
- maybe_boxed_prim_arg_ty = maybeBoxedPrimType box_ty
- (Just (_,tys_applied,_)) = splitAlgTyConApp_maybe box_ty
- (Just (box_data_con, _)) = maybe_boxed_prim_arg_ty
-\end{code}
-
-@foreign export@ed functions may return a value back to the outside world.
-@unboxResult@ takes care of converting from the (boxed) value that the
-exported action returns to the (unboxed) value that is returned across
-the border.
-
-\begin{code}
-unboxResult :: Maybe Type -- the (unboxed) type we want to return (along with the state token)
- -- Nothing => no result, just the state token.
- -> Type -- the (boxed) type we have in our hand.
- -> Id -- the state token
- -> Id -- boxed arg
- -> DsM (Type, -- type of returned expression.
- CoreExpr) -- expr that unboxes result and returns state+unboxed result.
-
-unboxResult mb_res_uboxed_ty res_ty new_s v_boxed
- | not (maybeToBool mb_res_uboxed_ty)
- = -- no result, just return state token
- mkConDs stateDataCon [ TyArg realWorldTy
- , VarArg (Var new_s)] `thenDs` \ the_st ->
- returnDs (realWorldStateTy, the_st)
-
- | null data_cons
- -- oops! can't see the data constructors
- = can'tSeeDataConsPanic "result" res_ty
-
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- - with one constructor,
- isUnpointedType res_uboxed_ty -- - and of primitive type.
- -- (Glasgow extension)
- =
- newSysLocalDs res_uboxed_ty `thenDs` \ v_unboxed ->
- mkConDs state_and_prim_datacon
- ((TyArg realWorldTy):map (TyArg ) tycon_arg_tys ++
- [ VarArg (Var new_s)
- , VarArg (Var v_unboxed)]) `thenDs` \ the_result ->
- let
- the_alt = (the_data_con, [v_unboxed], the_result)
- in
- returnDs (state_and_prim_ty,
- Case (Var v_boxed) (AlgAlts [the_alt] NoDefault))
-
- | otherwise
- = pprPanic "unboxResult: " (ppr res_ty)
- where
- (Just res_uboxed_ty) = mb_res_uboxed_ty
-
- maybe_data_type = splitAlgTyConApp_maybe res_ty
- Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
- (the_data_con : other_data_cons) = data_cons
-
- (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo res_uboxed_ty
-
-\end{code}
-
-Returned the unboxed type of a (primitive) type:
-
-\begin{code}
-unboxTy :: Type -> Type
-unboxTy ty
- | isUnpointedType ty || (ty == unitTy) = ty
- | otherwise =
- ASSERT( isFFIArgumentTy ty ) -- legal arg types subsume result types.
- case splitTyConApp_maybe ty of
- Just (tyc,ts) ->
- case (tyConDataCons tyc) of
- [dc] -> case (dataConArgTys dc ts) of
- [ubox] -> ubox
- -- HACK: for the array types, the prim type is
- -- the second tycon arg.
- [_,ubox] -> ubox
- _ -> pprPanic "unboxTy: " (ppr ty)
- _ -> pprPanic "unboxTy: " (ppr ty)
- _ -> pprPanic "unboxTy: " (ppr ty)
-
-\end{code}
-
-%*
-%
\subsection{Generating @foreign export@ stubs}
%
%*
-[Severe hack to get @foreign export@ off the ground:]
-
-For each @foreign export@ function, a C stub together with a @.hc@ stub
-is generated. The C stub enters the .hc stub, setting up the passing of
-parameters from C land to STG land through the use of global variables
-(don't worry, this just a temporary solution!). Ditto for the result.
-
-[
-The generation of .hc code will go once the transition is
-made over to the new rts. Hence the hack, instead of extending
-AbsCSyn to cope with the .hc code generated.
-]
+For each @foreign export@ function, a C stub function is generated.
+The C stub constructs the application of the exported Haskell function
+using the hugs/ghc rts invocation API.
\begin{code}
-fexportEntry :: FAST_STRING -> Id -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc, SDoc)
-fexportEntry c_nm helper args res cc =
- ( paramArea $$ stopTemplate $$ startTemplate $$ vtblTemplate, h_code, c_code )
+fexportEntry :: FAST_STRING -> Id -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc)
+fexportEntry c_nm helper args res cc = (header_bits, c_bits)
where
- (h_code, c_code) = mkCStub c_nm h_stub_nm args res cc
-
- paramArea =
- vcat (zipWith declVar ( res_ty : param_tys ) ( res_name : param_names ) )
-
-- name of the (Haskell) helper function generated by the desugarer.
- h_nm = ppr helper
- h_stub_nm = text foreign_export_prefix <> h_nm
- closure = h_nm <> text "_closure"
+ h_nm = ppr helper <> text "_closure"
+ -- prototype for the exported function.
+ header_bits = ptext SLIT("extern") <+> fun_proto <> semi
- param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
- param_tys = map (ppr.typePrimRep) args
+ fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
+ parens (hsep (punctuate comma (zipWith (<+>) cParamTypes c_args)))
- (res_name, res_ty) =
- case res of
- Nothing -> (empty, empty)
- Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
-
- startTemplate =
+ c_bits =
+ externDecl $$
+ fun_proto $$
vcat
- [ text "extern void* realWorldZh_closure;"
- , ptext SLIT("STGFUN") <> parens (h_stub_nm)
- , lbrace
- , ptext SLIT("FUNBEGIN;")
- , text "RestoreAllStgRegs();"
- , stackCheck param_names
- , pushRetReg
- , pushCont
- , pushRealWorld
- , vcat (map pushArg (reverse param_names))
- , text "Node=" <> closure <> semi
- , text "ENT_VIA_NODE();" -- ticky count
- , text "InfoPtr=(D_)(INFO_PTR(Node));"
- , text "JMP_(ENTRY_CODE(InfoPtr));"
- , text "FUNEND;"
- , rbrace
- ]
-
- stopTemplate =
- vcat
- [ ptext SLIT("STGFUN") <> parens (text "stop" <> h_stub_nm <> text "DirectReturn")
- , lbrace
- , ptext SLIT("FUNBEGIN;")
- , assignResult
- , popRetReg
- , text "#if defined(__STG_GCC_REGS__)"
- , text "SaveAllStgRegs();"
- , text "#else"
- , text "SAVE_Hp = Hp;"
- , text "SAVE_HpLim = HpLim;"
- , text "#endif"
- , text "JMP_(miniInterpretEnd);"
- , text "FUNEND;"
- , rbrace
- ]
-
- vtblTemplate =
- vcat
- [ text "const W_ vtbl_" <> h_stub_nm <> text "[] = {"
- , vcat (punctuate comma (replicate 8 dir_ret))
- , text "};"
- ]
- where
- dir_ret = text "(W_)stop" <> h_stub_nm <> text "DirectReturn"
-
- assignResult =
- case res of
- Nothing -> empty
- Just _ -> res_name <> equals <> text "R3.i;" -- wrong
-
- pushRetReg =
- text "SpB -= BREL(1);" $$
- text "*SpB = (W_)RetReg;"
-
- popRetReg =
- text "RetReg=(StgRetAddr)*SpB;" $$
- text "SpB += BREL(1);"
-
- pushCont =
- text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <>
- text "DirectReturn,vtbl_" <> h_stub_nm <> text ");"
-
- pushRealWorld =
- text "SpB -= BREL(1);" $$
- text "*SpB = (W_)realWorldZh_closure;"
+ [ lbrace
+ , text "SchedulerStatus rc;"
+ , declareResult
+ -- create the application + perform it.
+ , text "rc=rts_evalIO" <>
+ parens (foldl appArg (text "(StgClosure*)&" <> h_nm) (zip args c_args) <> comma <> text "&ret") <> semi
+ , returnResult
+ , rbrace
+ ]
+ appArg acc (a,c_a) =
+ text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a)
- pushArg nm =
- text "SpB -= BREL(1);" $$
- text "*SpB = (W_)" <> nm <> semi
+ cParamTypes = map showStgType args
- stackCheck args =
- text "STK_CHK(LivenessReg,0," <> sz <> text ",0,0,0,0);"
- where
- sz = parens $
- hsep $ punctuate (text " + ") (text "1":(map sizer args))
-
- sizer x = text "BYTES_TO_STGWORDS" <> parens (text "sizeof" <> parens x)
-
-foreign_export_prefix :: String
-foreign_export_prefix = "__fexp_"
-
-mkCStub :: FAST_STRING -> SDoc -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc)
-mkCStub c_nm h_stub_nm args res cc =
- ( hsep [ ptext SLIT("extern")
- , cResType
- , pprCconv
- , ptext c_nm
- , parens (hsep (punctuate comma (zipWith (<+>) stubParamTypes stubArgs)))
- , semi
- ]
- , vcat
- [ externDecls
- , cResType
- , pprCconv
- , ptext c_nm <> parens (hsep (punctuate comma stubArgs))
- , vcat (zipWith declVar stubParamTypes stubArgs)
- , lbrace
- , vcat (zipWith assignArgs param_names c_args)
- , text "miniInterpret" <> parens (parens (text "StgFunPtr") <> h_stub_nm) <> semi
- , returnResult
- , rbrace
- ]
- )
- where
- -- tedious hack to let us deal with caller-cleans-up-stack
- -- discipline that the C calling convention uses.
- stubParamTypes
- | cc == cCallConv = ptext SLIT("void*") : cParamTypes
- | otherwise = cParamTypes
- stubArgs
- | cc == cCallConv = ptext SLIT("_a0") : c_args
- | otherwise = c_args
-
- param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
- cParamTypes = map (text.showPrimRepToUser.typePrimRep) args
- (cResType, cResDecl) =
+ cResType =
case res of
- Nothing -> (text "void", empty)
- Just t -> (text (showPrimRepToUser (typePrimRep t)),
- text "extern" <+> cResType <+> res_name <> semi)
+ Nothing -> text "void"
+ Just t -> showStgType t
pprCconv
| cc == cCallConv = empty
| otherwise = pprCallConv cc
- externDecls =
- vcat (zipWith mkExtern cParamTypes param_names) $$
- cResDecl $$
- text "extern void" <+> h_stub_nm <> text "();"
+ declareResult = text "HaskellObj ret;"
- mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
-
- c_args = zipWith (\ _ n -> text ('a':show n)) args [0..]
+ externDecl = mkExtern (text "HaskellObj") h_nm
- assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi
+ mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
returnResult =
+ text "rts_checkSchedStatus" <>
+ parens (doubleQuotes (ptext c_nm) <> comma <> text "rc") <> semi $$
+ (case res of
+ Nothing -> text "return"
+ Just _ -> text "return" <> parens (res_name)) <> semi
+
+ res_name =
case res of
Nothing -> empty
- Just _ -> text "return" <+> res_name <> semi
+ Just t -> unpackHObj t <> parens (text "ret")
- (res_name, res_ty) =
- case res of
- Nothing -> (empty, empty)
- Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
+ c_args = zipWith (\ _ n -> text ('a':show n)) args [0..]
-declVar :: SDoc -> SDoc -> SDoc
-declVar ty var = ty <+> var <> semi
+mkHObj :: Type -> SDoc
+mkHObj t = text "rts_mk" <> showFFIType t
-\end{code}
+unpackHObj :: Type -> SDoc
+unpackHObj t = text "rts_get" <> showFFIType t
+
+showStgType :: Type -> SDoc
+showStgType t = text "Stg" <> showFFIType t
-When exporting
-
- f :: Int -> Int -> Int -> IO Int
-
-we'll emit the following stuff into the .hc file
-
-\begin{pseudocode}
-StgInt __f_param_1;
-StgInt __f_param_2;
-StgInt __f_param_3;
-StgInt __f_res;
-
-STGFUN(ds_f)
-{
- FUNBEGIN;
- RestoreAllStgRegs();
- STK_CHK(LivenessReg,0/*A*/,(SIZE_IN_WORDS(StgInt) +
- SIZE_IN_WORDS(StgInt) +
- SIZE_IN_WORDS(StgInt) + 1)/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/);
- RetReg = (StgRetAddr) UNVEC(stopds_fDirectReturn,vtbl_stopds_f);
- SpB -= BREL(1);
- *SpB = (W_)__f_param_3;
- SpB -= BREL(1);
- *SpB = (W_)__f_param_2;
- SpB -= BREL(1);
- *SpB = (W_)__f_param_1;
-
- SpB -= BREL(1);
- *SpB = (W_) realWorldZh_closure;
-
- Node = ds_f_helper_closure;
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FUNEND;
-}
-
-STGFUN(stop_ds_fDirectReturn)
-{
- FUNBEGIN;
- __f_res=R1.i;
- SaveAllStgRegs();
- RESUME(miniInterpretEnd);
- FUNEND;
-}
-
-const W_ vtbl_stopds_f[] = {
- (W_) stopds_fDirectReturn,
- (W_) stopds_fDirectReturn,
- (W_) stopds_fDirectReturn,
- (W_) stopds_fDirectReturn,
- (W_) stopds_fDirectReturn,
- (W_) stopds_fDirectReturn,
- (W_) stopds_fDirectReturn,
- (W_) stopds_fDirectReturn
-};
-
-\end{pseudocode}
-
-and a C stub
-
-\begin{pseudocode}
-extern StgInt __f_param_1;
-extern StgInt __f_param_2;
-extern StgInt __f_param_3;
-extern StgInt __f_res;
-
-extern void ds_f();
-extern void miniInterpret(StgAddr);
-
-int
-f(a1,a2,a3)
-int a1;
-int a2;
-int a3;
-{
- __f_param_1=a1;
- __f_param_2=a2;
- __f_param_3=a3;
- miniInterpret((StgAddr)ds_f);
- return (__f_res);
-}
-
-\end{pseudocode}
+showFFIType :: Type -> SDoc
+showFFIType t = text (getOccString (getName tc))
+ where
+ tc = case splitTyConApp_maybe t of
+ Just (tc,_) -> tc
+ Nothing -> pprPanic "showFFIType" (ppr t)
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsExpr )
-import {-# SOURCE #-} DsBinds ( dsBinds )
-import {-# SOURCE #-} Match ( matchExport )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
+import {-# SOURCE #-} Match ( matchSinglePat )
-import HsSyn ( GRHSsAndBinds(..), GRHS(..),
- HsExpr(..), HsBinds, Stmt(..),
- HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
- )
+import HsSyn ( GRHSsAndBinds(..), Stmt(..), HsExpr(..), GRHS(..) )
import TcHsSyn ( TypecheckedGRHSsAndBinds, TypecheckedGRHS,
- TypecheckedPat, TypecheckedHsBinds,
- TypecheckedHsExpr, TypecheckedStmt
+ TypecheckedPat, TypecheckedStmt
)
-import CoreSyn ( CoreBinding, GenCoreBinding(..), CoreExpr, mkCoLetsAny )
+import CoreSyn ( CoreExpr, Bind(..) )
import DsMonad
import DsUtils
-import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
-import SrcLoc ( SrcLoc{-instance-} )
-import Type ( Type )
-import Unique ( Unique, otherwiseIdKey, trueDataConKey, Uniquable(..) )
+import Unique ( otherwiseIdKey, trueDataConKey, Uniquable(..) )
import Outputable
\end{code}
-> DsM CoreExpr
dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
- = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
- dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn) ->
- case can_it_fail of
- CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
- CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
- returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
+ = dsGRHSs PatBindMatch [] grhss `thenDs` \ match_result ->
+ mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
+ extractMatchResult match_result error_expr `thenDs` \ body ->
+ dsLet binds body
\end{code}
Desugar a list of (grhs, expr) pairs [grhs = guarded
the guards fail.
\begin{code}
-dsGRHSs :: Type -- Type of RHSs
- -> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
+dsGRHSs :: DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
-> [TypecheckedGRHS] -- Guarded RHSs
-> DsM MatchResult
-dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
+dsGRHSs kind pats [grhs] = dsGRHS kind pats grhs
-dsGRHSs ty kind pats (grhs:grhss)
- = dsGRHS ty kind pats grhs `thenDs` \ match_result1 ->
- dsGRHSs ty kind pats grhss `thenDs` \ match_result2 ->
- combineGRHSMatchResults match_result1 match_result2
+dsGRHSs kind pats (grhs:grhss)
+ = dsGRHS kind pats grhs `thenDs` \ match_result1 ->
+ dsGRHSs kind pats grhss `thenDs` \ match_result2 ->
+ returnDs (combineMatchResults match_result1 match_result2)
-dsGRHS ty kind pats (GRHS guard expr locn)
- = putSrcLocDs locn $
- dsExpr expr `thenDs` \ core_expr ->
- let
- expr_fn = \ ignore -> core_expr
- in
- matchGuard guard (DsMatchContext kind pats locn) (MatchResult CantFail ty expr_fn)
+dsGRHS kind pats (GRHS guard locn)
+ = matchGuard guard (DsMatchContext kind pats locn)
\end{code}
-
-
%************************************************************************
%* *
%* matchGuard : make a MatchResult from a guarded RHS *
\begin{code}
matchGuard :: [TypecheckedStmt] -- Guard
-> DsMatchContext -- Context
- -> MatchResult -- What to do if the guard succeeds
-> DsM MatchResult
-matchGuard [] ctx body_result = returnDs body_result
+matchGuard (ExprStmt expr locn : should_be_null) ctx
+ = putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr ->
+ returnDs (cantFailMatchResult core_expr)
-- Turn an "otherwise" guard is a no-op
-matchGuard (GuardStmt (HsVar v) _ : stmts) ctx body_result
+matchGuard (GuardStmt (HsVar v) _ : stmts) ctx
| uniq == otherwiseIdKey
|| uniq == trueDataConKey
- = matchGuard stmts ctx body_result
+ = matchGuard stmts ctx
where
- uniq = uniqueOf v
-
-matchGuard (GuardStmt expr _ : stmts) ctx body_result
- = matchGuard stmts ctx body_result `thenDs` \ (MatchResult _ ty body_fn) ->
- dsExpr expr `thenDs` \ core_expr ->
- let
- expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
- in
- returnDs (MatchResult CanFail ty expr_fn)
-
-matchGuard (LetStmt binds : stmts) ctx body_result
- = matchGuard stmts ctx body_result `thenDs` \ match_result ->
- dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
- returnDs (mkCoLetsMatchResult core_binds match_result)
-
-matchGuard (BindStmt pat rhs _ : stmts) ctx body_result
- = matchGuard stmts ctx body_result `thenDs` \ match_result ->
- dsExpr rhs `thenDs` \ core_rhs ->
- newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
- matchExport [scrut_var] [EqnInfo 1 ctx [pat] match_result] `thenDs` \ match_result' ->
- returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
+ uniq = getUnique v
+
+matchGuard (GuardStmt expr locn : stmts) ctx
+ = matchGuard stmts ctx `thenDs` \ match_result ->
+ putSrcLocDs locn (dsExpr expr) `thenDs` \ pred_expr ->
+ returnDs (mkGuardedMatchResult pred_expr match_result)
+
+matchGuard (LetStmt binds : stmts) ctx
+ = matchGuard stmts ctx `thenDs` \ match_result ->
+ returnDs (adjustMatchResultDs (dsLet binds) match_result)
+ -- NB the dsLet occurs inside the match_result
+
+matchGuard (BindStmt pat rhs locn : stmts) ctx
+ = matchGuard stmts ctx `thenDs` \ match_result ->
+ putSrcLocDs locn (dsExpr rhs) `thenDs` \ core_rhs ->
+ matchSinglePat core_rhs ctx pat match_result
\end{code}
+
+-- Should *fail* if e returns D
+
+f x | p <- e', let C y# = e, f y# = r1
+ | otherwise = r2
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[DsHsSyn]{Haskell abstract syntax---added things for desugarer}
#include "HsVersions.h"
-import HsSyn ( OutPat(..), MonoBinds(..),
- HsExpr, GRHSsAndBinds, Match, HsLit )
+import HsSyn ( OutPat(..), MonoBinds(..) )
import TcHsSyn ( TypecheckedPat,
TypecheckedMonoBinds )
import Id ( idType, Id )
import Type ( Type )
-import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
+import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy, unitTy )
import Util ( panic )
\end{code}
outPatType (VarPat var) = idType var
outPatType (LazyPat pat) = outPatType pat
outPatType (AsPat var pat) = idType var
-outPatType (ConPat _ ty _) = ty
-outPatType (ConOpPat _ _ _ ty) = ty
+outPatType (ConPat _ ty _ _ _) = ty
outPatType (ListPat ty _) = mkListTy ty
-outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats)
-outPatType (RecPat _ ty _) = ty
+outPatType (TuplePat pats True) = mkTupleTy (length pats) (map outPatType pats)
+outPatType (TuplePat pats False)= mkUnboxedTupleTy (length pats) (map outPatType pats)
+outPatType (RecPat _ ty _ _ _) = ty
outPatType (LitPat lit ty) = ty
outPatType (NPat lit ty _) = ty
outPatType (NPlusKPat _ _ ty _ _) = ty
= [global | (_, global, local) <- exports]
collectTypedPatBinders :: TypecheckedPat -> [Id]
-collectTypedPatBinders (VarPat var) = [var]
-collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
-collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
-collectTypedPatBinders (ConPat _ _ pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (ConOpPat p1 _ p2 _) = collectTypedPatBinders p1 ++ collectTypedPatBinders p2
-collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (TuplePat pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (RecPat _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) fields)
-collectTypedPatBinders (DictPat ds ms) = ds ++ ms
-collectTypedPatBinders any_other_pat = [ {-no binders-} ]
+collectTypedPatBinders (VarPat var) = [var]
+collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
+collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
+collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
+ fields)
+collectTypedPatBinders (DictPat ds ms) = ds ++ ms
+collectTypedPatBinders any_other_pat = [ {-no binders-} ]
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsListComp]{Desugaring list comprehensions}
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsExpr )
-import {-# SOURCE #-} DsBinds ( dsBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
-import HsSyn ( Stmt(..), HsExpr, HsBinds )
-import TcHsSyn ( TypecheckedStmt, TypecheckedHsExpr , TypecheckedHsBinds )
+import HsSyn ( Stmt(..), HsExpr )
+import TcHsSyn ( TypecheckedStmt, TypecheckedHsExpr )
import DsHsSyn ( outPatType )
import CoreSyn
import DsUtils
import CmdLineOpts ( opt_FoldrBuildOn )
-import CoreUtils ( coreExprType, mkCoreIfThenElse )
-import Id ( Id )
-import PrelVals ( mkBuild, foldrId )
+import CoreUtils ( coreExprType )
+import Var ( Id, TyVar )
+import Const ( Con(..) )
+import PrelInfo ( foldrId )
import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type )
-import TysPrim ( alphaTy )
+import TysPrim ( alphaTyVar, alphaTy )
import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
-import TyVar ( alphaTyVar )
import Match ( matchSimply )
-import Util ( panic )
+import Outputable
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
returnDs (mkBuild elt_ty n_tyvar c n g result)
where
- nil_expr = mkCon nilDataCon [elt_ty] []
+ nil_expr = mkNilExpr elt_ty
\end{code}
%************************************************************************
is the TE translation scheme. Note that we carry around the @L@ list
already desugared. @dsListComp@ does the top TE rule mentioned above.
+deListComp :: [TypecheckedStmt]
+ -> CoreExpr -> CoreExpr -- Cons and nil resp; can be copied freely
+ -> DsM CoreExpr
+
+deListComp [ReturnStmt expr] cons nil
+ = dsExpr expr `thenDs` \ expr' ->
+ returnDs (mkApps cons [expr', nil])
+
+deListComp (GuardStmt guard locn : quals) cons nil
+ = dsExpr guard `thenDs` \ guard' ->
+ deListComp quals cons nil `thenDs` \ rest' ->
+ returnDs (mkIfThenElse guard' rest' nil)
+
+deListComp (LetStmt binds : quals) cons nil
+ = deListComp quals cons nil `thenDs` \ rest' ->
+ dsLet binds rest'
+
+deListComp (BindStmt pat list locn : quals) cons nil
+ = dsExpr list `thenDs` \ list' ->
+ let
+ pat_ty = outPatType pat
+ nil_ty = coreExprType nil
+ in
+ newSysLocalsDs [pat_ty, nil_ty] `thenDs` \ [x,ys] ->
+
+ dsListComp quals cons (Var ys) `thenDs` \ rest ->
+ matchSimply (Var x) ListCompMatch pat
+ rest (Var ys) `thenDs` \ core_match ->
+ bindNonRecDs (mkLams [x,ys] fn_body) $ \ fn ->
+ dsListExpr list (Var fn) nil
+
+
+data FExpr = FEOther CoreExpr -- Default case
+ | FECons -- cons
+ | FEConsComposedWith CoreExpr -- (cons . e)
+ | FENil -- nil
+
+feComposeWith FECons g
+ = returnDs (FEConsComposedWith g)
+
+feComposeWith (FEOther f) g
+ = composeWith f f `thenDs` \ h ->
+ returnDs (FEOther h)
+
+feComposeWith (FEConsComposedWith f) g
+ = composeWith f f `thenDs` \ h ->
+ returnDs (FEConsComposedWith h)
+
+
+composeWith f g
+ = newSysLocalDs arg_ty `thenDs` \ x ->
+ returnDs (Lam x (App e (App f (Var x))))
+ where
+ arg_ty = case splitFunTy_maybe (coreExprType g) of
+ Just (arg_ty,_) -> arg_ty
+ other -> panic "feComposeWith"
+
+deListExpr :: TypecheckedHsExpr
+ -> FExpr -> FExpr -- Cons and nil expressions
+ -> DsM CoreExpr
+
+deListExpr cons nil (HsDoOut ListComp stmts _ _ _ result_ty src_loc)
+ = deListComp stmts cons nil
+
+deListExpr cons nil (HsVar map, _, [f,xs])
+ | goodInst var mapIdKey = dsExpr f `thenDs` \ f' ->
+ feComposeWith cons f' `thenDs` \ cons' ->
+ in
+ deListExpr xs cons' nil
+
+
+data HsExprForm = GoodForm What [Type] [TypecheckedHsExpr]
+ | BadForm
+
+data What = HsMap | HsConcat | HsFilter | HsZip | HsFoldr
+
+analyseListProducer (HsVar v) ty_args val_args
+ | good_inst mapIdKey 2 = GoodForm HsMap ty_args val_args
+ | good_inst concatIdKey 1 = GoodForm HsConcat ty_args val_args
+ | good_inst filterIdKey 2 = GoodForm HsFilter ty_args val_args
+ | good_id zipIdKey 2 = GoodForm HsZip ty_args val_args
+ | otherwise =
+ where
+ good_inst key arity = isInstIdOf key v && result_is_list && n_args == arity
+ good_id key arity = getUnique v == key && result_is_list && n_args == arity
+
+ n_args :: Int
+ n_args = length val_args
+
+ result_is_list = resultTyIsList (idType v) ty_args val_args
+
+resultTyIsList ty ty_args val_args
+ = go ty ty_args
+ where
+ go1 ty (_:tys) = case splitForAllTy_maybe ty of
+ Just (_,ty) -> go1 ty tys
+ Nothing -> False
+ go1 ty [] = go2 ty val_args
+
+ go2 ty (_:args) = case splitFunTy_maybe of
+ Just (_,ty) -> go2 ty args
+ Nothing -> False
+
+ go2 ty [] = case splitTyConApp_maybe of
+ Just (tycon, [_]) | tycon == listTyCon -> True
+ other -> False
+
+
\begin{code}
deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above
= dsExpr expr `thenDs` \ core_expr ->
- mkConDs consDataCon [TyArg (coreExprType core_expr), VarArg core_expr, VarArg list]
+ returnDs (mkConApp consDataCon [Type (coreExprType core_expr), core_expr, list])
deListComp (GuardStmt guard locn : quals) list -- rule B above
= dsExpr guard `thenDs` \ core_guard ->
deListComp quals list `thenDs` \ core_rest ->
- returnDs (mkCoreIfThenElse core_guard core_rest list)
+ returnDs (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) list
- = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
- deListComp quals list `thenDs` \ core_rest ->
- returnDs (mkCoLetsAny core_binds core_rest)
+ = deListComp quals list `thenDs` \ core_rest ->
+ dsLet binds core_rest
deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
= dsExpr list1 `thenDs` \ core_list1 ->
newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] ->
-- the "fail" value ...
- mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail ->
+ let
+ core_fail = App (Var h) (Var u3)
+ letrec_body = App (Var h) core_list1
+ in
deListComp quals core_fail `thenDs` \ rest_expr ->
- matchSimply (Var u2) ListCompMatch pat res_ty
+ matchSimply (Var u2) ListCompMatch pat
rest_expr core_fail `thenDs` \ core_match ->
- mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body ->
-
- returnDs (
- mkCoLetrecAny [
- ( h,
- (Lam (ValBinder u1)
- (Case (Var u1)
- (AlgAlts
- [(nilDataCon, [], core_list2),
- (consDataCon, [u2, u3], core_match)]
- NoDefault)))
- )] letrec_body
- )
+ let
+ rhs = Lam u1 $
+ Case (Var u1) u1 [(DataCon nilDataCon, [], core_list2),
+ (DataCon consDataCon, [u2, u3], core_match)]
+ in
+ returnDs (Let (Rec [(h, rhs)]) letrec_body)
\end{code}
%************************************************************************
dfListComp c_ty c_id n_ty n_id [ReturnStmt expr]
= dsExpr expr `thenDs` \ core_expr ->
- mkAppDs (Var c_id) [VarArg core_expr, VarArg (Var n_id)]
+ returnDs (mkApps (Var c_id) [core_expr, Var n_id])
dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals)
= dsExpr guard `thenDs` \ core_guard ->
dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
- returnDs (mkCoreIfThenElse core_guard core_rest (Var n_id))
+ returnDs (mkIfThenElse core_guard core_rest (Var n_id))
dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals)
-- new in 1.3, local bindings
- = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
- dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
- returnDs (mkCoLetsAny core_binds core_rest)
+ = dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ dsLet binds core_rest
dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals)
-- evaluate the two lists
dfListComp c_ty c_id b_ty b quals `thenDs` \ core_rest ->
-- build the pattern match
- matchSimply (Var p) ListCompMatch pat b_ty core_rest (Var b) `thenDs` \ core_expr ->
+ matchSimply (Var p) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
returnDs (
- mkCoLetsAny
- [NonRec fn (mkValLam [p, b] core_expr),
+ mkLets
+ [NonRec fn (mkLams [p, b] core_expr),
NonRec lst core_list1]
(mkFoldr p_ty n_ty fn n_id lst)
)
+\end{code}
+
+
+@mkBuild@ is sugar for building a build!
+
+@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
+@ty@ is the type of the list.
+@tv@ is always a new type variable.
+@c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
+ c :: a -> b -> b
+ n :: b
+ v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
+-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
+@e@ is the object right inside the @build@
+
+\begin{code}
+mkBuild :: Type
+ -> TyVar
+ -> Id
+ -> Id
+ -> Id
+ -> CoreExpr -- template
+ -> CoreExpr -- template
+
+mkBuild ty tv c n g expr
+ = Let (NonRec g (mkLams [tv, c,n] expr))
+ (mkApps (Var buildId) [Type ty, Var g])
+
+buildId = error "DsListComp: buildId"
mkFoldr a b f z xs
- = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
+ = mkApps (mkTyApps (Var foldrId) [a,b]) [Var f, Var z, Var xs]
\end{code}
+
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsMonad]{@DsMonad@: monadery used in desugaring}
duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
- getModuleAndGroupDs, getUniqueDs,
- extendEnvDs, lookupEnvDs,
- DsIdEnv,
+ getModuleAndGroupDs,
+ getUniqueDs,
+ dsLookupGlobalValue,
+ GlobalValueEnv,
dsWarn,
DsWarnings,
DsMatchContext(..), DsMatchKind(..), pprDsWarnings
import BasicTypes ( Module )
import ErrUtils ( WarnMsg )
import HsSyn ( OutPat )
-import MkId ( mkSysLocal )
-import Id ( mkIdWithNewUniq,
- lookupIdEnv, growIdEnvList, IdEnv, Id
- )
+import Id ( mkUserLocal, mkSysLocal, setIdUnique, Id )
+import Name ( Name, varOcc, maybeWiredInIdName )
+import Var ( TyVar, setTyVarUnique )
+import VarEnv
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
import TcHsSyn ( TypecheckedPat )
+import TcEnv ( GlobalValueEnv )
import Type ( Type )
-import TyVar ( cloneTyVar, TyVar )
-import UniqSupply ( splitUniqSupply, getUnique, getUniques,
+import UniqSupply ( initUs, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
-import Unique ( Unique )
+import Unique ( Unique )
+import UniqFM ( lookupWithDefaultUFM )
import Util ( zipWithEqual, panic )
infixr 9 `thenDs`
\begin{code}
type DsM result =
UniqSupply
+ -> GlobalValueEnv
-> SrcLoc -- to put in pattern-matching error msgs
-> (Module, Group) -- module + group name : for SCC profiling
- -> DsIdEnv
-> DsWarnings
-> (result, DsWarnings)
-- initDs returns the UniqSupply out the end (not just the result)
initDs :: UniqSupply
- -> DsIdEnv
+ -> GlobalValueEnv
-> (Module, Group) -- module name: for profiling; (group name: from switches)
-> DsM a
-> (a, DsWarnings)
-initDs init_us env module_and_group action
- = action init_us noSrcLoc module_and_group env emptyBag
+initDs init_us genv module_and_group action
+ = action init_us genv noSrcLoc module_and_group emptyBag
thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
-thenDs m1 m2 us loc mod_and_grp env warns
+thenDs m1 m2 us genv loc mod_and_grp warns
= case splitUniqSupply us of { (s1, s2) ->
- case (m1 s1 loc mod_and_grp env warns) of { (result, warns1) ->
- m2 result s2 loc mod_and_grp env warns1}}
+ case (m1 s1 genv loc mod_and_grp warns) of { (result, warns1) ->
+ m2 result s2 genv loc mod_and_grp warns1}}
-andDs combiner m1 m2 us loc mod_and_grp env warns
+andDs combiner m1 m2 us genv loc mod_and_grp warns
= case splitUniqSupply us of { (s1, s2) ->
- case (m1 s1 loc mod_and_grp env warns) of { (result1, warns1) ->
- case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
+ case (m1 s1 genv loc mod_and_grp warns) of { (result1, warns1) ->
+ case (m2 s2 genv loc mod_and_grp warns1) of { (result2, warns2) ->
(combiner result1 result2, warns2) }}}
returnDs :: a -> DsM a
-returnDs result us loc mod_and_grp env warns = (result, warns)
+returnDs result us genv loc mod_and_grp warns = (result, warns)
listDs :: [DsM a] -> DsM [a]
listDs [] = returnDs []
foldlDs k z (x:xs) = k z x `thenDs` \ r ->
foldlDs k r xs
-
mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
mapAndUnzipDs f [] = returnDs ([], [])
it easier to read debugging output.
\begin{code}
-newLocalDs :: FAST_STRING -> Type -> DsM Id
-newLocalDs nm ty us loc mod_and_grp env warns
- = case (getUnique us) of { assigned_uniq ->
- (mkSysLocal nm assigned_uniq ty loc, warns) }
+newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDs ty us genv loc mod_and_grp warns
+ = case uniqFromSupply us of { assigned_uniq ->
+ (mkSysLocal assigned_uniq ty, warns) }
+
+newSysLocalsDs tys = mapDs newSysLocalDs tys
-newSysLocalDs = newLocalDs SLIT("ds")
-newSysLocalsDs tys = mapDs (newLocalDs SLIT("ds")) tys
-newFailLocalDs = newLocalDs SLIT("fail")
+newFailLocalDs ty us genv loc mod_and_grp warns
+ = case uniqFromSupply us of { assigned_uniq ->
+ (mkUserLocal (varOcc SLIT("fail")) assigned_uniq ty, warns) }
+ -- The UserLocal bit just helps make the code a little clearer
getUniqueDs :: DsM Unique
-getUniqueDs us loc mod_and_grp env warns
- = case (getUnique us) of { assigned_uniq ->
+getUniqueDs us genv loc mod_and_grp warns
+ = case (uniqFromSupply us) of { assigned_uniq ->
(assigned_uniq, warns) }
duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local us loc mod_and_grp env warns
- = case (getUnique us) of { assigned_uniq ->
- (mkIdWithNewUniq old_local assigned_uniq, warns) }
+duplicateLocalDs old_local us genv loc mod_and_grp warns
+ = case uniqFromSupply us of { assigned_uniq ->
+ (setIdUnique old_local assigned_uniq, warns) }
cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
-cloneTyVarsDs tyvars us loc mod_and_grp env warns
- = case (getUniques (length tyvars) us) of { uniqs ->
- (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
+cloneTyVarsDs tyvars us genv loc mod_and_grp warns
+ = case uniqsFromSupply (length tyvars) us of { uniqs ->
+ (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
\end{code}
\begin{code}
newTyVarsDs :: [TyVar] -> DsM [TyVar]
-newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
- = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
- (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
+newTyVarsDs tyvar_tmpls us genv loc mod_and_grp warns
+ = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
+ (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
\end{code}
We can also reach out and either set/grab location information from
\begin{code}
uniqSMtoDsM :: UniqSM a -> DsM a
-uniqSMtoDsM u_action us loc mod_and_grp env warns
- = (u_action us, warns)
+uniqSMtoDsM u_action us genv loc mod_and_grp warns
+ = (initUs us u_action, warns)
getSrcLocDs :: DsM SrcLoc
-getSrcLocDs us loc mod_and_grp env warns
+getSrcLocDs us genv loc mod_and_grp warns
= (loc, warns)
putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
- = expr us new_loc mod_and_grp env warns
+putSrcLocDs new_loc expr us genv old_loc mod_and_grp warns
+ = expr us genv new_loc mod_and_grp warns
dsWarn :: WarnMsg -> DsM ()
-dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn)
+dsWarn warn us genv loc mod_and_grp warns = ((), warns `snocBag` warn)
\end{code}
\begin{code}
getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
-getModuleAndGroupDs us loc mod_and_grp env warns
+getModuleAndGroupDs us genv loc mod_and_grp warns
= (mod_and_grp, warns)
\end{code}
\begin{code}
-type DsIdEnv = IdEnv Id
-
-extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
-
-extendEnvDs pairs then_do us loc mod_and_grp old_env warns
- = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
-
-lookupEnvDs :: Id -> DsM Id
-lookupEnvDs id us loc mod_and_grp env warns
- = (case (lookupIdEnv env id) of
- Nothing -> id
- Just xx -> xx,
- warns)
+dsLookupGlobalValue :: Name -> DsM Id
+dsLookupGlobalValue name us genv loc mod_and_grp warns
+ = case maybeWiredInIdName name of
+ Just id -> (id, warns)
+ Nothing -> (lookupWithDefaultUFM genv def name, warns)
+ where
+ def = pprPanic "tcLookupGlobalValue:" (ppr name)
\end{code}
+
%************************************************************************
%* *
%* type synonym EquationInfo and access functions for its pieces *
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsUtils]{Utilities for desugaring}
CanItFail(..), EquationInfo(..), MatchResult(..),
EqnNo, EqnSet,
- combineGRHSMatchResults,
- combineMatchResults,
- dsExprToAtomGivenTy, DsCoreArg,
- mkCoAlgCaseMatchResult,
- mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
- mkCoLetsMatchResult,
- mkCoPrimCaseMatchResult,
- mkFailurePair,
- mkGuardedMatchResult,
- mkSelectorBinds,
- mkTupleExpr,
- mkTupleSelector,
- selectMatchVars,
- showForErr
+ cantFailMatchResult, extractMatchResult,
+ combineMatchResults,
+ adjustMatchResult, adjustMatchResultDs,
+ mkCoLetsMatchResult, mkGuardedMatchResult,
+ mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
+
+ mkErrorAppDs,
+
+ mkSelectorBinds, mkTupleExpr, mkTupleSelector,
+
+ selectMatchVar
) where
#include "HsVersions.h"
import {-# SOURCE #-} Match ( matchSimply )
-import HsSyn ( OutPat(..), Stmt, DoOrListComp )
+import HsSyn ( OutPat(..) )
import TcHsSyn ( TypecheckedPat )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import CoreSyn
import DsMonad
-import CoreUtils ( coreExprType, mkCoreIfThenElse )
-import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
-import Id ( idType, dataConArgTys,
- DataCon, Id, GenId )
-import Literal ( Literal(..) )
-import PrimOp ( PrimOp )
+import CoreUtils ( coreExprType )
+import PrelVals ( iRREFUT_PAT_ERROR_ID )
+import Id ( idType, Id, mkWildId )
+import Const ( Literal(..), Con(..) )
import TyCon ( isNewTyCon, tyConDataCons )
-import Type ( mkRhoTy, mkFunTy,
- isUnpointedType, mkTyConApp, splitAlgTyConApp,
+import DataCon ( DataCon )
+import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
Type
)
-import BasicTypes ( Unused )
-import TysPrim ( voidTy )
-import TysWiredIn ( unitDataCon, tupleCon, stringTy )
-import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet )
-import Unique ( Unique )
+import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon )
+import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
import Outputable
\end{code}
otherwise, make one up.
\begin{code}
-selectMatchVars :: [TypecheckedPat] -> DsM [Id]
-selectMatchVars pats
- = mapDs var_from_pat_maybe pats
- where
- var_from_pat_maybe (VarPat var) = returnDs var
- var_from_pat_maybe (AsPat var pat) = returnDs var
- var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
- var_from_pat_maybe other_pat
- = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
+selectMatchVar :: TypecheckedPat -> DsM Id
+selectMatchVar (VarPat var) = returnDs var
+selectMatchVar (AsPat var pat) = returnDs var
+selectMatchVar (LazyPat pat) = selectMatchVar pat
+selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
\end{code}
data EquationInfo
= EqnInfo
- EqnNo -- The number of the equation
+ EqnNo -- The number of the equation
+
DsMatchContext -- The context info is used when producing warnings
-- about shadowed patterns. It's the context
-- of the *first* thing matched in this group.
-- Should perhaps be a list of them all!
- [TypecheckedPat] -- the patterns for an eqn
+
+ [TypecheckedPat] -- The patterns for an eqn
+
MatchResult -- Encapsulates the guards and bindings
\end{code}
\begin{code}
data MatchResult
= MatchResult
- CanItFail
- Type -- Type of argument expression
-
- (CoreExpr -> CoreExpr)
+ CanItFail -- Tells whether the failure expression is used
+ (CoreExpr -> DsM CoreExpr)
-- Takes a expression to plug in at the
-- failure point(s). The expression should
-- be duplicatable!
orFail CantFail CantFail = CantFail
orFail _ _ = CanFail
+\end{code}
+
+Functions on MatchResults
+
+\begin{code}
+cantFailMatchResult :: CoreExpr -> MatchResult
+cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
+extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
+extractMatchResult (MatchResult CantFail match_fn) fail_expr
+ = match_fn (error "It can't fail!")
-mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
-mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn)
- = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body))
+extractMatchResult (MatchResult CanFail match_fn) fail_expr
+ = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
+ match_fn if_it_fails `thenDs` \ body ->
+ returnDs (Let fail_bind body)
-mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
-mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn)
- = returnDs (MatchResult CanFail
- ty
- (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
- )
+
+combineMatchResults :: MatchResult -> MatchResult -> MatchResult
+combineMatchResults (MatchResult CanFail body_fn1)
+ (MatchResult can_it_fail2 body_fn2)
+ = MatchResult can_it_fail2 body_fn
+ where
+ body_fn fail = body_fn2 fail `thenDs` \ body2 ->
+ mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
+ body_fn1 duplicatable_expr `thenDs` \ body1 ->
+ returnDs (Let fail_bind body1)
+
+combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
+ = match_result1
+
+
+adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
+ = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
+ returnDs (encl_fn body))
+
+adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
+ = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
+ encl_fn body)
+
+
+mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
+mkCoLetsMatchResult binds match_result
+ = adjustMatchResult (mkLets binds) match_result
+
+
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
+mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
+ = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
+ returnDs (mkIfThenElse pred_expr body fail))
mkCoPrimCaseMatchResult :: Id -- Scrutinee
- -> [(Literal, MatchResult)] -- Alternatives
- -> DsM MatchResult
-mkCoPrimCaseMatchResult var alts
- = newSysLocalDs (idType var) `thenDs` \ wild ->
- returnDs (MatchResult CanFail
- ty1
- (mk_case alts wild))
+ -> [(Literal, MatchResult)] -- Alternatives
+ -> MatchResult
+mkCoPrimCaseMatchResult var match_alts
+ = MatchResult CanFail mk_case
where
- ((_,MatchResult _ ty1 _) : _) = alts
+ mk_case fail
+ = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
+ returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
- mk_case alts wild fail_expr
- = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
- where
- final_alts = [ (lit, body_fn fail_expr)
- | (lit, MatchResult _ _ body_fn) <- alts
- ]
+ mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
+ returnDs (Literal lit, [], body)
-mkCoAlgCaseMatchResult :: Id -- Scrutinee
- -> [(DataCon, [Id], MatchResult)] -- Alternatives
- -> DsM MatchResult
+mkCoAlgCaseMatchResult :: Id -- Scrutinee
+ -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
+ -> MatchResult
-mkCoAlgCaseMatchResult var alts
- | isNewTyCon tycon -- newtype case; use a let
+mkCoAlgCaseMatchResult var match_alts
+ | isNewTyCon tycon -- Newtype case; use a let
= ASSERT( newtype_sanity )
- returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
-
- | otherwise -- datatype case
- = -- Find all the constructors in the type which aren't
- -- explicitly mentioned in the alternatives:
- case un_mentioned_constructors of
- [] -> -- All constructors mentioned, so no default needed
- returnDs (MatchResult can_any_alt_fail
- ty1
- (mk_case alts (\ignore -> NoDefault)))
-
- [con] -> -- Just one constructor missing, so add a case for it
- -- We need to build new locals for the args of the constructor,
- -- and figuring out their types is somewhat tiresome.
- let
- arg_tys = dataConArgTys con tycon_arg_tys
- in
- newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
-
- -- Now we are ready to construct the new alternative
- let
- new_alt = (con, arg_ids, MatchResult CanFail ty1 id)
- in
- returnDs (MatchResult CanFail
- ty1
- (mk_case (new_alt:alts) (\ignore -> NoDefault)))
-
- other -> -- Many constructors missing, so use a default case
- newSysLocalDs scrut_ty `thenDs` \ wild ->
- returnDs (MatchResult CanFail
- ty1
- (mk_case alts (\fail_expr -> BindDefault wild fail_expr)))
+ mkCoLetsMatchResult [coercion_bind] match_result
+
+ | otherwise -- Datatype case; use a case
+ = MatchResult fail_flag mk_case
where
-- Common stuff
scrut_ty = idType var
(tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
-- Stuff for newtype
- (con_id, arg_ids, match_result) = head alts
+ (con_id, arg_ids, match_result) = head match_alts
arg_id = head arg_ids
coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) scrut_ty) (Var var))
- newtype_sanity = null (tail alts) && null (tail arg_ids)
+ newtype_sanity = null (tail match_alts) && null (tail arg_ids)
-- Stuff for data types
data_cons = tyConDataCons tycon
- un_mentioned_constructors
- = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
-
- match_results = [match_result | (_,_,match_result) <- alts]
- (MatchResult _ ty1 _ : _) = match_results
- can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ <- match_results]
+ match_results = [match_result | (_,_,match_result) <- match_alts]
- mk_case alts deflt_fn fail_expr
- = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
- where
- final_alts = [ (con, args, body_fn fail_expr)
- | (con, args, MatchResult _ _ body_fn) <- alts
- ]
+ fail_flag | exhaustive_case
+ = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+ | otherwise
+ = CanFail
+ wild_var = mkWildId (idType var)
+ mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
+ returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
-combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
-combineMatchResults (MatchResult CanFail ty1 body_fn1)
- (MatchResult can_it_fail2 ty2 body_fn2)
- = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
- let
- new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
- new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
- in
- returnDs (MatchResult can_it_fail2 ty1 new_body_fn2)
+ mk_alt fail (con, args, MatchResult _ body_fn)
+ = body_fn fail `thenDs` \ body ->
+ returnDs (DataCon con, args, body)
-combineMatchResults match_result1@(MatchResult CantFail ty body_fn1)
- match_result2
- = returnDs match_result1
+ mk_default fail | exhaustive_case = []
+ | otherwise = [(DEFAULT, [], fail)]
+ un_mentioned_constructors
+ = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
+ exhaustive_case = isEmptyUniqSet un_mentioned_constructors
--- The difference in combineGRHSMatchResults is that there is no
--- need to let-bind to avoid code duplication
-combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
-combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1)
- (MatchResult can_it_fail ty2 body_fn2)
- = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)))
-combineGRHSMatchResults match_result1 match_result2
- = -- Delegate to avoid duplication of code
- combineMatchResults match_result1 match_result2
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[dsExprToAtom]{Take an expression and produce an atom}
-%* *
-%************************************************************************
-
-\begin{code}
-dsArgToAtom :: DsCoreArg -- The argument expression
- -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
- -- and delivering an expression E
- -> DsM CoreExpr -- Either E or let x=arg-expr in E
-
-dsArgToAtom (TyArg t) continue_with = continue_with (TyArg t)
-dsArgToAtom (LitArg l) continue_with = continue_with (LitArg l)
-dsArgToAtom (VarArg arg) continue_with = dsExprToAtomGivenTy arg (coreExprType arg) continue_with
-
-dsExprToAtomGivenTy
- :: CoreExpr -- The argument expression
- -> Type -- Type of the argument
- -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
- -- and delivering an expression E
- -> DsM CoreExpr -- Either E or let x=arg-expr in E
-
-dsExprToAtomGivenTy (Var v) arg_ty continue_with = continue_with (VarArg v)
-dsExprToAtomGivenTy (Lit v) arg_ty continue_with = continue_with (LitArg v)
-dsExprToAtomGivenTy arg_expr arg_ty continue_with
- = newSysLocalDs arg_ty `thenDs` \ arg_id ->
- continue_with (VarArg arg_id) `thenDs` \ body ->
- returnDs (
- if isUnpointedType arg_ty
- then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
- else Let (NonRec arg_id arg_expr) body
- )
-
-dsArgsToAtoms :: [DsCoreArg]
- -> ([CoreArg] -> DsM CoreExpr)
- -> DsM CoreExpr
-
-dsArgsToAtoms [] continue_with = continue_with []
-
-dsArgsToAtoms (arg:args) continue_with
- = dsArgToAtom arg $ \ arg_atom ->
- dsArgsToAtoms args $ \ arg_atoms ->
- continue_with (arg_atom:arg_atoms)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type DsCoreArg = GenCoreArg CoreExpr{-NB!-} Unused
-
-mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
-mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
-mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
-
-mkAppDs fun args
- = dsArgsToAtoms args $ \ atoms ->
- returnDs (mkGenApp fun atoms)
-
-mkConDs con args
- = dsArgsToAtoms args $ \ atoms ->
- returnDs (Con con atoms)
-
-mkPrimDs op args
- = dsArgsToAtoms args $ \ atoms ->
- returnDs (Prim op atoms)
-\end{code}
-
-\begin{code}
-showForErr :: Outputable a => a -> String -- Boring but useful
-showForErr thing = showSDoc (ppr thing)
-
mkErrorAppDs :: Id -- The error function
-> Type -- Type to which it should be applied
-> String -- The error message string to pass
= getSrcLocDs `thenDs` \ src_loc ->
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
- msg_lit = NoRepStr (_PK_ full_msg)
in
- returnDs (mkApp (Var err_id) [ty] [LitArg msg_lit])
+ returnDs (mkApps (Var err_id) [Type ty, mkStringLit full_msg])
\end{code}
%************************************************************************
getSrcLocDs `thenDs` \ src_loc ->
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
- msg_lit = NoRepStr (_PK_ full_msg)
in
mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
returnDs ( (val_var, val_expr) :
- (msg_var, Lit msg_lit) :
+ (msg_var, mkStringLit full_msg) :
binds )
| otherwise
= mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
- matchSimply val_expr LetMatch pat tuple_ty local_tuple error_expr `thenDs` \ tuple_expr ->
- newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
+ matchSimply val_expr LetMatch pat local_tuple error_expr `thenDs` \ tuple_expr ->
+ newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
let
- mk_tup_bind binder = (binder, mkTupleSelector binders binder (Var tuple_var))
+ mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
in
returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
where
-- (mk_bind sv bv) generates
-- bv = case sv of { pat -> bv; other -> error-msg }
-- Remember, pat binds bv
- = matchSimply (Var scrut_var) LetMatch pat binder_ty
+ = matchSimply (Var scrut_var) LetMatch pat
(Var bndr_var) error_expr `thenDs` \ rhs_expr ->
returnDs (bndr_var, rhs_expr)
where
binder_ty = idType bndr_var
- error_expr = mkApp (Var iRREFUT_PAT_ERROR_ID) [binder_ty] [VarArg msg_var]
+ error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
- is_simple_pat (TuplePat ps) = all is_triv_pat ps
- is_simple_pat (ConPat _ _ ps) = all is_triv_pat ps
+ is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
+ is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
is_simple_pat (VarPat _) = True
- is_simple_pat (ConOpPat p1 _ p2 _) = is_triv_pat p1 && is_triv_pat p2
- is_simple_pat (RecPat _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
+ is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
is_simple_pat other = False
is_triv_pat (VarPat v) = True
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
-mkTupleExpr [] = Con unitDataCon []
+mkTupleExpr [] = mkConApp unitDataCon []
mkTupleExpr [id] = Var id
-mkTupleExpr ids = mkCon (tupleCon (length ids))
- (map idType ids)
- [ VarArg i | i <- ids ]
+mkTupleExpr ids = mkConApp (tupleCon (length ids))
+ (map (Type . idType) ids ++ [ Var i | i <- ids ])
\end{code}
\begin{code}
mkTupleSelector :: [Id] -- The tuple args
-> Id -- The selected one
+ -> Id -- A variable of the same type as the scrutinee
-> CoreExpr -- Scrutinee
-> CoreExpr
-mkTupleSelector [var] should_be_the_same_var scrut
+mkTupleSelector [var] should_be_the_same_var scrut_var scrut
= ASSERT(var == should_be_the_same_var)
scrut
-mkTupleSelector vars the_var scrut
+mkTupleSelector vars the_var scrut_var scrut
= ASSERT( not (null vars) )
- Case scrut (AlgAlts [(tupleCon (length vars), vars, Var the_var)] NoDefault)
+ Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)]
\end{code}
Now fail.33 is a function, so it can be let-bound.
\begin{code}
-mkFailurePair :: Type -- Result type of the whole case expression
- -> DsM (CoreExpr -> CoreBinding,
- -- Binds the newly-created fail variable
+mkFailurePair :: CoreExpr -- Result type of the whole case expression
+ -> DsM (CoreBind, -- Binds the newly-created fail variable
-- to either the expression or \ _ -> expression
CoreExpr) -- Either the fail variable, or fail variable
-- applied to unit tuple
-mkFailurePair ty
- | isUnpointedType ty
- = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
- newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
- returnDs (\ body ->
- NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
- App (Var fail_fun_var) (VarArg voidId))
+mkFailurePair expr
+ | isUnLiftedType ty
+ = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
+ newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
+ returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
+ App (Var fail_fun_var) (mkConApp unitDataCon []))
| otherwise
= newFailLocalDs ty `thenDs` \ fail_var ->
- returnDs (\ body -> NonRec fail_var body, Var fail_var)
+ returnDs (NonRec fail_var expr, Var fail_var)
+ where
+ ty = coreExprType expr
\end{code}
_interface_ Match 1
_exports_
-Match match matchExport matchSimply;
+Match match matchExport matchSimply matchSinglePat;
_declarations_
-1 match _:_ [Id.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
-1 matchExport _:_ [Id.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
-1 matchSimply _:_ CoreSyn.CoreExpr -> DsMonad.DsMatchKind -> TcHsSyn.TypecheckedPat -> Type.Type -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
+1 match _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
+1 matchExport _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
+1 matchSimply _:_ CoreSyn.CoreExpr -> DsMonad.DsMatchKind -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
+1 matchSinglePat _:_ CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;;
+
--- /dev/null
+__interface Match 1 0 where
+__export Match match matchExport matchSimply matchSinglePat;
+1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
+1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
+1 matchSimply :: CoreSyn.CoreExpr -> DsMonad.DsMatchKind -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
+1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Main_match]{The @match@ function}
\begin{code}
-module Match ( match, matchExport, matchWrapper, matchSimply ) where
+module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsExpr )
-import {-# SOURCE #-} DsBinds ( dsBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
opt_WarnSimplePatterns
)
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch,
- TypecheckedHsBinds, TypecheckedHsExpr )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
import DsHsSyn ( outPatType )
-import Check ( check, ExhaustivePat, WarningPat, BoxedString )
+import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( coreExprType )
import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
-import Id ( idType, dataConFieldLabels,
- dataConArgTys, recordSelectorFieldLabel,
- Id
- )
+import Id ( idType, recordSelectorFieldLabel, Id )
+import DataCon ( dataConFieldLabels, dataConArgTys )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import Name ( Name {--O only-} )
import PrelVals ( pAT_ERROR_ID )
-import Type ( isUnpointedType, splitAlgTyConApp,
+import Type ( isUnLiftedType, splitAlgTyConApp,
Type
)
-import TyVar ( TyVar )
import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
addrPrimTy, wordPrimTy
)
charTy, charDataCon, intTy, intDataCon,
floatTy, floatDataCon, doubleTy, tupleCon,
doubleDataCon, addrTy,
- addrDataCon, wordTy, wordDataCon
+ addrDataCon, wordTy, wordDataCon,
+ mkUnboxedTupleTy, unboxedTupleCon
)
import UniqSet
import Outputable
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
-matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _ _)) : _)
+matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
| incomplete && shadow =
dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
dsIncompleteWarn ctx pats `thenDs` \ () ->
ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats
-
\end{code}
complete_matches (eqn:eqns)
= complete_match eqn `thenDs` \ match_result1 ->
complete_matches eqns `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
+ returnDs (combineMatchResults match_result1 match_result2)
- complete_match (EqnInfo _ _ [] match_result@(MatchResult _ _ _))
- = returnDs match_result
+ complete_match (EqnInfo _ _ pats match_result)
+ = ASSERT( null pats )
+ returnDs match_result
\end{code}
%************************************************************************
match_unmixed_eqn_blks vars (eqn_blk:eqn_blks)
= matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk
match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
+ returnDs (combineMatchResults match_result1 match_result2)
\end{code}
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
-- of new bindings to be added to the front
tidy1 v (VarPat var) match_result
- = returnDs (WildPat (idType var),
- mkCoLetsMatchResult extra_binds match_result)
+ = returnDs (WildPat (idType var), match_result')
where
- extra_binds | v == var = []
- | otherwise = [NonRec var (Var v)]
+ match_result' | v == var = match_result
+ | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
tidy1 v (AsPat var pat) match_result
- = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
+ = tidy1 v pat match_result'
where
- extra_binds | v == var = []
- | otherwise = [NonRec var (Var v)]
+ match_result' | v == var = match_result
+ | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
tidy1 v (WildPat ty) match_result
= returnDs (WildPat ty, match_result)
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (ConOpPat pat1 id pat2 ty) match_result
- = returnDs (ConPat id ty [pat1, pat2], match_result)
-
-tidy1 v (RecPat con_id pat_ty rpats) match_result
- = returnDs (ConPat con_id pat_ty pats, match_result)
+tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result
+ = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result)
where
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
(_, inst_tys, _) = splitAlgTyConApp pat_ty
- con_arg_tys' = dataConArgTys con_id inst_tys
- tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id)
+ con_arg_tys' = dataConArgTys data_con inst_tys
+ tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
where
list_ty = mkListTy ty
list_ConPat
- = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
- (ConPat nilDataCon list_ty [])
+ = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
+ (ConPat nilDataCon list_ty [] [] [])
pats
-tidy1 v (TuplePat pats) match_result
+tidy1 v (TuplePat pats True{-boxed-}) match_result
= returnDs (tuple_ConPat, match_result)
where
arity = length pats
tuple_ConPat
= ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType pats))
+ (mkTupleTy arity (map outPatType pats)) [] []
+ pats
+
+tidy1 v (TuplePat pats False{-unboxed-}) match_result
+ = returnDs (tuple_ConPat, match_result)
+ where
+ arity = length pats
+ tuple_ConPat
+ = ConPat (unboxedTupleCon arity)
+ (mkUnboxedTupleTy arity (map outPatType pats)) [] []
pats
tidy1 v (DictPat dicts methods) match_result
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat []) match_result
+ 0 -> tidy1 v (TuplePat [] True) match_result
1 -> tidy1 v (head dict_and_method_pats) match_result
- _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
+ _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
-- LitPats: the desugarer only sees these at well-known types
tidy1 v pat@(LitPat lit lit_ty) match_result
- | isUnpointedType lit_ty
+ | isUnLiftedType lit_ty
= returnDs (pat, match_result)
| lit_ty == charTy
- = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
+ = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy],
match_result)
| otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
= returnDs (better_pat, match_result)
where
better_pat
- | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
- | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
- | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
- | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
- | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
- | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
+ | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy]
+ | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
+ | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy]
+ | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy]
+ | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
+ | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
-- Convert the literal pattern "" to the constructor pattern [].
- | null_str_lit lit = ConPat nilDataCon lit_ty []
+ | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
| otherwise = pat
returnDs (var:vars, core_expr)
matchWrapper kind [(GRHSMatch
- (GRHSsAndBindsOut [GRHS [] expr _] binds _))] error_string
- = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
- dsExpr expr `thenDs` \ core_expr ->
- returnDs ([], mkCoLetsAny core_binds core_expr)
+ (GRHSsAndBindsOut [GRHS [ExprStmt expr _]] binds _))] error_string
+ = dsExpr expr `thenDs` \ core_expr ->
+ dsLet binds core_expr `thenDs` \ rhs ->
+ returnDs ([], rhs)
\end{old_code}
And all the rest... (general case)
JJQC 30-Nov-1997
\begin{code}
-
matchWrapper kind matches error_string
- = flattenMatches kind 1 matches `thenDs` \ eqns_info@(EqnInfo _ _ arg_pats (MatchResult _ result_ty _) : _) ->
-
- selectMatchVars arg_pats `thenDs` \ new_vars ->
+ = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) ->
+ let
+ EqnInfo _ _ arg_pats _ : _ = eqns_info
+ in
+ mapDs selectMatchVar arg_pats `thenDs` \ new_vars ->
match_fun new_vars eqns_info `thenDs` \ match_result ->
mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
-
extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
returnDs (new_vars, result_expr)
where match_fun = case kind of
matchSimply :: CoreExpr -- Scrutinee
-> DsMatchKind -- Match kind
-> TypecheckedPat -- Pattern it should match
- -> Type -- Type of result
-> CoreExpr -- Return this if it matches
- -> CoreExpr -- Return this if it does
+ -> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
-matchSimply (Var var) kind pat result_ty result_expr fail_expr
+matchSimply scrut kind pat result_expr fail_expr
= getSrcLocDs `thenDs` \ locn ->
let
- ctx = DsMatchContext kind [pat] locn
- eqn_info = EqnInfo 1 ctx [pat] initial_match_result
+ ctx = DsMatchContext kind [pat] locn
+ match_result = cantFailMatchResult result_expr
in
- match_fun [var] [eqn_info] `thenDs` \ match_result ->
- extractMatchResult match_result fail_expr
- where
- initial_match_result = MatchResult CantFail result_ty (\ ignore -> result_expr)
- match_fun = if opt_WarnSimplePatterns
- then matchExport
- else match
+ matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' ->
+ extractMatchResult match_result' fail_expr
-matchSimply scrut_expr kind pat result_ty result_expr msg
- = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var ->
- matchSimply (Var scrut_var) kind pat result_ty result_expr msg `thenDs` \ expr ->
- returnDs (Let (NonRec scrut_var scrut_expr) expr)
+matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
+ -> MatchResult -> DsM MatchResult
-extractMatchResult (MatchResult CantFail _ match_fn) fail_expr
- = returnDs (match_fn (error "It can't fail!"))
+matchSinglePat (Var var) ctx pat match_result
+ = match_fn [var] [EqnInfo 1 ctx [pat] match_result]
+ where
+ match_fn | opt_WarnSimplePatterns = matchExport
+ | otherwise = match
-extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr
- = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
- returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
+matchSinglePat scrut ctx pat match_result
+ = selectMatchVar pat `thenDs` \ var ->
+ matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' ->
+ returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
\end{code}
%************************************************************************
%* flattenMatches : create a list of EquationInfo *
%* *
%************************************************************************
+
\subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
This is actually local to @matchWrapper@.
\begin{code}
flattenMatches
:: DsMatchKind
- -> EqnNo
-> [TypecheckedMatch]
- -> DsM [EquationInfo]
-
-flattenMatches kind n [] = returnDs []
+ -> DsM (Type, [EquationInfo])
-flattenMatches kind n (match : matches)
- = flatten_match [] n match `thenDs` \ eqn_info ->
- flattenMatches kind (n+1) matches `thenDs` \ eqn_infos ->
- returnDs (eqn_info : eqn_infos)
+flattenMatches kind matches
+ = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) ->
+ let
+ result_ty = head result_tys
+ in
+ ASSERT( all (== result_ty) result_tys )
+ returnDs (result_ty, eqn_infos)
where
- flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far
- -> EqnNo
- -> TypecheckedMatch
- -> DsM EquationInfo
+ flatten_match (match, eqn_no) = flatten_match_help [] match eqn_no
+
+ flatten_match_help :: [TypecheckedPat] -- Reversed list of patterns encountered so far
+ -> TypecheckedMatch
+ -> EqnNo
+ -> DsM (Type, EquationInfo)
- flatten_match pats_so_far n (PatMatch pat match)
- = flatten_match (pat:pats_so_far) n match
+ flatten_match_help pats_so_far (PatMatch pat match) n
+ = flatten_match_help (pat:pats_so_far) match n
- flatten_match pats_so_far n (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
- = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
- dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
+ flatten_match_help pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) n
+ = dsGRHSs kind pats grhss `thenDs` \ match_result ->
getSrcLocDs `thenDs` \ locn ->
- returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
- (mkCoLetsMatchResult core_binds match_result))
+ returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats
+ (adjustMatchResultDs (dsLet binds) match_result))
+ -- NB: nested dsLet inside matchResult
where
pats = reverse pats_so_far -- They've accumulated in reverse order
- flatten_match pats_so_far n (SimpleMatch expr)
+ flatten_match_help pats_so_far (SimpleMatch expr) n
= dsExpr expr `thenDs` \ core_expr ->
getSrcLocDs `thenDs` \ locn ->
- returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
- (MatchResult CantFail (coreExprType core_expr)
- (\ ignore -> core_expr)))
-
- -- the matching can't fail, so we won't generate an error message.
+ returnDs (coreExprType core_expr,
+ EqnInfo n (DsMatchContext kind pats locn) pats
+ (cantFailMatchResult core_expr))
where
pats = reverse pats_so_far -- They've accumulated in reverse order
-
\end{code}
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[MatchCon]{Pattern-matching constructors}
import {-# SOURCE #-} Match ( match )
-import HsSyn ( OutPat(..), HsLit, HsExpr )
-import DsHsSyn ( outPatType )
+import HsSyn ( OutPat(..) )
import DsMonad
import DsUtils
-import Id ( GenId{-instances-}, Id )
-import Util ( panic, assertPanic )
+import Id ( Id )
+import CoreSyn
+import Type ( mkTyVarTys )
+import Unique ( Uniquable(..), Unique )
+import UniqFM -- Until equivClassesUniq moves to Util
+import Outputable
\end{code}
We are confronted with the first column of patterns in a set of
-> DsM MatchResult
matchConFamily (var:vars) eqns_info
- = match_cons_used vars eqns_info `thenDs` \ alts ->
- mkCoAlgCaseMatchResult var alts
+ = let
+ -- Sort into equivalence classes by the unique on the constructor
+ -- All the EqnInfos should start with a ConPat
+ eqn_groups = equivClassesByUniq get_uniq eqns_info
+ get_uniq (EqnInfo _ _ (ConPat data_con _ _ _ _ : _) _) = getUnique data_con
+ in
+ -- Now make a case alternative out of each group
+ mapDs (match_con vars) eqn_groups `thenDs` \ alts ->
+
+ returnDs (mkCoAlgCaseMatchResult var alts)
\end{code}
And here is the local function that does all the work. It is
more-or-less the @matchCon@/@matchClause@ functions on page~94 in
Wadler's chapter in SLPJ.
-\begin{code}
-match_cons_used _ [{- no more eqns -}] = returnDs []
-match_cons_used vars eqns_info@(EqnInfo n ctx (ConPat data_con _ arg_pats : ps1) _ : eqns)
- = let
- (eqns_for_this_con, eqns_not_for_this_con) = splitByCon eqns_info
- in
- -- Go ahead and do the recursive call to make the alts
- -- for the other ConPats in this con family...
- match_cons_used vars eqns_not_for_this_con `thenDs` \ rest_of_alts ->
-
- -- Make new vars for the con arguments; avoid new locals where possible
- selectMatchVars arg_pats `thenDs` \ new_vars ->
+\begin{code}
+match_con vars all_eqns@(EqnInfo n ctx (ConPat data_con _ ex_tvs ex_dicts arg_pats : pats1) match_result1 : other_eqns)
+ = -- Make new vars for the con arguments; avoid new locals where possible
+ mapDs selectMatchVar arg_pats `thenDs` \ arg_vars ->
-- Now do the business to make the alt for _this_ ConPat ...
- match (new_vars++vars)
- (map shift_con_pat eqns_for_this_con) `thenDs` \ match_result ->
-
- returnDs (
- (data_con, new_vars, match_result)
- : rest_of_alts
- )
+ match (ex_dicts ++ arg_vars ++ vars)
+ (map shift_con_pat all_eqns) `thenDs` \ match_result ->
+
+ -- Substitute over the result
+ let
+ match_result' | null ex_tvs = match_result
+ | otherwise = adjustMatchResult subst_it match_result
+ in
+ returnDs (data_con, ex_tvs ++ ex_dicts ++ arg_vars, match_result')
where
- splitByCon :: [EquationInfo] -> ([EquationInfo], [EquationInfo])
- splitByCon [] = ([],[])
- splitByCon (info@(EqnInfo _ _ (pat : _) _) : rest)
- = case pat of
- ConPat n _ _ | n == data_con -> (info:rest_yes, rest_no)
- other_pat -> (rest_yes, info:rest_no)
- where
- (rest_yes, rest_no) = splitByCon rest
-
shift_con_pat :: EquationInfo -> EquationInfo
- shift_con_pat (EqnInfo n ctx (ConPat _ _ pats': pats) match_result)
- = EqnInfo n ctx (pats' ++ pats) match_result
- shift_con_pat (EqnInfo n ctx (WildPat _: pats) match_result) -- Will only happen in shadow
- = EqnInfo n ctx ([WildPat (outPatType arg_pat) | arg_pat <- arg_pats] ++ pats) match_result
- shift_con_pat other = panic "matchConFamily:match_cons_used:shift_con_pat"
+ shift_con_pat (EqnInfo n ctx (ConPat _ _ ex_tvs' ex_dicts' arg_pats: pats) match_result)
+ = EqnInfo n ctx (new_pats ++ pats) match_result
+ where
+ new_pats = map VarPat ex_dicts' ++ arg_pats
+
+ -- We 'substitute' by going: (/\ tvs' -> e) tvs
+ subst_it e = foldr subst_one e other_eqns
+ subst_one (EqnInfo _ _ (ConPat _ _ ex_tvs' _ _ : _) _) e = mkTyApps (mkLams ex_tvs' e) ex_tys
+ ex_tys = mkTyVarTys ex_tvs
+
+
+-- Belongs in Util.lhs
+equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
+ -- NB: it's *very* important that if we have the input list [a,b,c],
+ -- where a,b,c all have the same unique, then we get back the list
+ -- [a,b,c]
+ -- not
+ -- [c,b,a]
+ -- Hence the use of foldr, plus the reversed-args tack_on below
+equivClassesByUniq get_uniq xs
+ = eltsUFM (foldr add emptyUFM xs)
+ where
+ add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
+ tack_on old new = new++old
\end{code}
Note on @shift_con_pats@ just above: does what the list comprehension in
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[MatchLit]{Pattern-matching literal patterns}
import {-# SOURCE #-} Match ( match )
import {-# SOURCE #-} DsExpr ( dsExpr )
-import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity,
- Match, HsBinds, DoOrListComp, HsType, ArithSeqInfo )
+import HsSyn ( HsLit(..), OutPat(..), HsExpr(..) )
import TcHsSyn ( TypecheckedHsExpr, TypecheckedPat )
-import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr(..), GenCoreBinding(..) )
+import CoreSyn ( Expr(..), Bind(..) )
import Id ( Id )
import DsMonad
import DsUtils
-import Literal ( mkMachInt_safe, Literal(..) )
+import Const ( mkMachInt, Literal(..) )
import PrimRep ( PrimRep(IntRep) )
import Maybes ( catMaybes )
-import Type ( Type, isUnpointedType )
+import Type ( Type, isUnLiftedType )
import Util ( panic, assertPanic )
\end{code}
match_prims_used vars eqns_info `thenDs` \ prim_alts ->
-- MAKE THE PRIMITIVE CASE
- mkCoPrimCaseMatchResult var prim_alts
+ returnDs (mkCoPrimCaseMatchResult var prim_alts)
where
match_prims_used _ [{-no more eqns-}] = returnDs []
where
mk_core_lit :: Type -> HsLit -> Literal
- mk_core_lit ty (HsIntPrim i) = mkMachInt_safe i
+ mk_core_lit ty (HsIntPrim i) = mkMachInt i
mk_core_lit ty (HsCharPrim c) = MachChar c
mk_core_lit ty (HsStringPrim s) = MachStr s
mk_core_lit ty (HsFloatPrim f) = MachFloat f
mk_core_lit ty (HsDoublePrim d) = MachDouble d
- mk_core_lit ty (HsLitLit s) = ASSERT(isUnpointedType ty)
+ mk_core_lit ty (HsLitLit s) = ASSERT(isUnLiftedType ty)
MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled"
\end{code}
in
dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr ->
match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result ->
- mkGuardedMatchResult pred_expr inner_match_result `thenDs` \ match_result1 ->
-
+ let
+ match_result1 = mkGuardedMatchResult pred_expr inner_match_result
+ in
if (null eqns_not_for_this_lit)
then
returnDs match_result1
else
matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
+ returnDs (combineMatchResults match_result1 match_result2)
\end{code}
For an n+k pattern, we use the various magic expressions we've been given.
dsExpr (HsApp ge (HsVar var)) `thenDs` \ ge_expr ->
dsExpr (HsApp sub (HsVar var)) `thenDs` \ nminusk_expr ->
- mkGuardedMatchResult
- ge_expr
- (mkCoLetsMatchResult [NonRec master_n nminusk_expr] inner_match_result)
- `thenDs` \ match_result1 ->
-
+ let
+ match_result1 = mkGuardedMatchResult ge_expr $
+ mkCoLetsMatchResult [NonRec master_n nminusk_expr] $
+ inner_match_result
+ in
if (null eqns_not_for_this_lit)
then
returnDs match_result1
else
matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
+ returnDs (combineMatchResults match_result1 match_result2)
\end{code}
Given a blob of LitPats/NPats, we want to split them into those
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsLit]{Abstract syntax: source-language literals}
\begin{code}
instance Outputable HsLit where
+ -- Use "show" because it puts in appropriate escapes
ppr (HsChar c) = text (show c)
- ppr (HsCharPrim c) = (<>) (text (show c)) (char '#')
- ppr (HsString s) = text (show s)
- ppr (HsStringPrim s) = (<>) (text (show s)) (char '#')
+ ppr (HsCharPrim c) = text (show c) <> char '#'
+ ppr (HsStringPrim s) = pprFSAsString s <> char '#'
+ ppr (HsString s) = pprFSAsString s
ppr (HsInt i) = integer i
ppr (HsFrac f) = rational f
- ppr (HsFloatPrim f) = (<>) (rational f) (char '#')
- ppr (HsDoublePrim d) = (<>) (rational d) (text "##")
- ppr (HsIntPrim i) = (<>) (integer i) (char '#')
+ ppr (HsFloatPrim f) = rational f <> char '#'
+ ppr (HsDoublePrim d) = rational d <> text "##"
+ ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsLitLit s) = hcat [text "``", ptext s, text "''"]
\end{code}
+++ /dev/null
-d_interface_ HsBinds 1
-_exports_
-HsBinds HsBinds nullBinds;
-_instances_
-_declarations_
-1 data HsBinds f i p ;
-1 nullBinds _:_ _forall_ [f i p] => HsBinds.HsBinds f i p -> PrelBase.Bool ;;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsBinds]{Abstract syntax: top-level bindings and signatures}
import PprCore () -- Instances for Outputable
--others:
-import Id ( Id, GenId )
+import Id ( Id )
import Name ( OccName, NamedThing(..) )
import BasicTypes ( RecFlag(..) )
import Outputable
import Bag
import SrcLoc ( SrcLoc )
-import Type ( GenType )
-import TyVar ( GenTyVar )
+import Var ( GenTyVar )
\end{code}
%************************************************************************
nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
nullMonoBinds other_monobind = False
-andMonoBinds :: [MonoBinds flexi id pat] -> MonoBinds flexi id pat
-andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds
+andMonoBinds :: MonoBinds flexi id pat -> MonoBinds flexi id pat -> MonoBinds flexi id pat
+andMonoBinds EmptyMonoBinds mb = mb
+andMonoBinds mb EmptyMonoBinds = mb
+andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
+
+andMonoBindList :: [MonoBinds flexi id pat] -> MonoBinds flexi id pat
+andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
\end{code}
\begin{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
%************************************************************************
%* *
\begin{code}
module HsCore (
- UfExpr(..), UfAlts(..), UfBinder(..), UfNote(..),
- UfDefault(..), UfBinding(..),
- UfArg(..), UfPrimOp(..)
+ UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
+ UfBinding(..), UfCon(..)
) where
#include "HsVersions.h"
-- friends:
import HsTypes ( HsType, pprParendHsType )
-import Kind ( Kind {- instance Outputable -} )
-- others:
-import Literal ( Literal )
-import Util ( panic )
+import Const ( Literal )
+import Type ( Kind )
import CostCentre
import Outputable
\end{code}
\begin{code}
data UfExpr name
= UfVar name
- | UfLit Literal
- | UfCon name [UfArg name]
- | UfPrim (UfPrimOp name) [UfArg name]
+ | UfType (HsType name)
+ | UfCon (UfCon name) [UfExpr name]
+ | UfTuple name [UfExpr name] -- Type arguments omitted
| UfLam (UfBinder name) (UfExpr name)
- | UfApp (UfExpr name) (UfArg name)
- | UfCase (UfExpr name) (UfAlts name)
+ | UfApp (UfExpr name) (UfExpr name)
+ | UfCase (UfExpr name) name [UfAlt name]
| UfLet (UfBinding name) (UfExpr name)
| UfNote (UfNote name) (UfExpr name)
-data UfPrimOp name
- = UfCCallOp FAST_STRING -- callee
- Bool -- True <=> casm, rather than ccall
- Bool -- True <=> might cause GC
- [HsType name] -- arg types, incl state token
- -- (which will be first)
- (HsType name) -- return type
-
- | UfOtherOp name
-
data UfNote name = UfSCC CostCentre
| UfCoerce (HsType name)
| UfInlineCall
-data UfAlts name
- = UfAlgAlts [(name, [name], UfExpr name)]
- (UfDefault name)
- | UfPrimAlts [(Literal, UfExpr name)]
- (UfDefault name)
+type UfAlt name = (UfCon name, [name], UfExpr name)
-data UfDefault name
- = UfNoDefault
- | UfBindDefault name (UfExpr name)
+data UfCon name = UfDefault
+ | UfDataCon name
+ | UfLitCon Literal
+ | UfLitLitCon FAST_STRING (HsType name)
+ | UfPrimOp name
+ | UfCCallOp FAST_STRING -- callee
+ Bool -- True <=> casm, rather than ccall
+ Bool -- True <=> might cause GC
data UfBinding name
= UfNonRec (UfBinder name)
data UfBinder name
= UfValBinder name (HsType name)
| UfTyBinder name Kind
-
-data UfArg name
- = UfVarArg name
- | UfLitArg Literal
- | UfTyArg (HsType name)
\end{code}
+
%************************************************************************
%* *
\subsection[HsCore-print]{Printing Core unfoldings}
\begin{code}
instance Outputable name => Outputable (UfExpr name) where
ppr (UfVar v) = ppr v
- ppr (UfLit l) = ppr l
+ ppr (UfType ty) = char '@' <+> pprParendHsType ty
ppr (UfCon c as)
- = hsep [text "UfCon", ppr c, ppr as, char ')']
- ppr (UfPrim o as)
- = hsep [text "UfPrim", ppr o, ppr as, char ')']
+ = hsep [text "UfCon", ppr c, ppr as]
+
+ ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
ppr (UfLam b body)
= hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
- ppr (UfApp fun (UfTyArg ty))
- = hsep [ppr fun, char '@', pprParendHsType ty]
+ ppr (UfApp fun arg) = ppr fun <+> ppr arg
- ppr (UfApp fun (UfLitArg lit))
- = hsep [ppr fun, ppr lit]
-
- ppr (UfApp fun (UfVarArg var))
- = hsep [ppr fun, ppr var]
-
- ppr (UfCase scrut alts)
- = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
+ ppr (UfCase scrut bndr alts)
+ = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
+ braces (hsep (punctuate semi (map pp_alt alts)))]
where
- pp_alts (UfAlgAlts alts deflt)
- = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
- where
- pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
- pp_alts (UfPrimAlts alts deflt)
- = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
- where
- pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
-
- pp_deflt UfNoDefault = empty
- pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
+ pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
ppr_arrow = ptext SLIT("->")
ppr (UfNote note body)
= hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
-instance Outputable name => Outputable (UfPrimOp name) where
- ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
- = let
+instance Outputable name => Outputable (UfCon name) where
+ ppr UfDefault = text "DEFAULT"
+ ppr (UfDataCon d) = ppr d
+ ppr (UfPrimOp p) = ppr p
+ ppr (UfCCallOp str is_casm can_gc)
+ = hcat [before, ptext str, after]
+ where
before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
after = if is_casm then text "'' " else space
- in
- hcat [before, ptext str, after,
- brackets (ppr arg_tys), space, ppr result_ty]
-
- ppr (UfOtherOp op)
- = ppr op
-
-instance Outputable name => Outputable (UfArg name) where
- ppr (UfVarArg v) = ppr v
- ppr (UfLitArg l) = ppr l
- ppr (UfTyArg ty) = pprParendHsType ty
instance Outputable name => Outputable (UfBinder name) where
ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsDecls]{Abstract syntax: global declarations}
import HsTypes
import HsCore ( UfExpr )
import BasicTypes ( Fixity, NewOrData(..) )
-import IdInfo ( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo )
+import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo )
import Demand ( Demand )
import CallConv ( CallConv, pprCallConv )
-- others:
-import Name ( getOccName, OccName, NamedThing(..) )
+import Name ( NamedThing )
import Outputable
import SrcLoc ( SrcLoc )
import Util
ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
= pp_tydecl
- (pp_decl_head keyword (pp_context_and_arrow context) tycon tyvars)
+ (pp_decl_head keyword (pprContext context) tycon tyvars)
(pp_condecls condecls)
derivings
where
Nothing -> empty
Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
])
-
-pp_context_and_arrow :: Outputable name => Context name -> SDoc
-pp_context_and_arrow [] = empty
-pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")]
\end{code}
A type for recording what types a datatype should be specialised to.
\begin{code}
data ConDecl name
= ConDecl name -- Constructor name
- (Context name) -- Existential context for this constructor
+
+ [HsTyVar name] -- Existentially quantified type variables
+ (Context name) -- ...and context
+ -- If both are empty then there are no existentials
+
(ConDetails name)
SrcLoc
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
- ppr (ConDecl con cxt con_details loc)
- = pp_context_and_arrow cxt <+> ppr_con_details con con_details
+ ppr (ConDecl con tvs cxt con_details loc)
+ = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details]
ppr_con_details con (InfixCon ty1 ty2)
= hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
ppr methods,
char '}'])]
where
- top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow context,
+ top_matter = hsep [ptext SLIT("class"), pprContext context,
ppr clas, hsep (map (ppr) tyvars)]
ppr_sig sig = ppr sig <> semi
\end{code}
data HsIdInfo name
= HsArity ArityInfo
| HsStrictness (HsStrictnessInfo name)
- | HsUnfold Bool (UfExpr name) -- True <=> INLINE pragma
+ | HsUnfold InlinePragInfo (Maybe (UfExpr name))
| HsUpdate UpdateInfo
- | HsArgUsage ArgUsageInfo
- | HsFBType FBTypeInfo
| HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
+ | HsNoCafRefs
data HsStrictnessInfo name
--- /dev/null
+__interface HsExpr 1 0 where
+__export HsExpr HsExpr pprExpr;
+1 data HsExpr f i p ;
+1 pprExpr :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => HsExpr.HsExpr _f _i _p -> Outputable.SDoc ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsExpr]{Abstract Haskell syntax: expressions}
import HsTypes ( HsType )
-- others:
-import Name ( NamedThing )
-import Id ( Id )
+import Name ( Name, NamedThing(..), isLexSym, occNameString )
import Outputable
import PprType ( pprType, pprParendType )
import Type ( GenType )
-import TyVar ( GenTyVar )
+import Var ( GenTyVar, Id )
+import DataCon ( DataCon )
import SrcLoc ( SrcLoc )
\end{code}
| HsLet (HsBinds flexi id pat) -- let(rec)
(HsExpr flexi id pat)
- | HsDo DoOrListComp
+ | HsDo StmtCtxt
[Stmt flexi id pat] -- "do":one or more stmts
SrcLoc
- | HsDoOut DoOrListComp
+ | HsDoOut StmtCtxt
[Stmt flexi id pat] -- "do":one or more stmts
id -- id for return
id -- id for >>=
-- NB: Unit is ExplicitTuple []
-- for tuples, we can get the types
-- direct from the components
+ Bool -- boxed?
- | HsCon Id -- TRANSLATION; a saturated constructor application
+ | HsCon DataCon -- TRANSLATION; a saturated constructor application
[GenType flexi]
[HsExpr flexi id pat]
-- Record construction
| RecordCon id -- The constructor
- (HsExpr flexi id pat) -- Always (HsVar id) until type checker,
- -- but the latter adds its type args too
(HsRecordBinds flexi id pat)
+ | RecordConOut DataCon
+ (HsExpr flexi id pat) -- Data con Id applied to type args
+ (HsRecordBinds flexi id pat)
+
+
-- Record update
| RecordUpd (HsExpr flexi id pat)
(HsRecordBinds flexi id pat)
=> HsExpr flexi id pat -> SDoc
pprExpr e = pprDeeper (ppr_expr e)
+pprBinds b = pprDeeper (ppr b)
ppr_expr (HsVar v) = ppr v
= hang (pprExpr op) 4 (sep [pp_e1, pp_e2])
pp_infixly v
- = sep [pp_e1, hsep [ppr v, pp_e2]]
+ = sep [pp_e1, hsep [pp_v, pp_e2]]
+ where
+ pp_v | isLexSym (occNameString (getOccName v)) = ppr v
+ | otherwise = char '`' <> ppr v <> char '`'
ppr_expr (NegApp e _)
- = (<>) (char '-') (pprParendExpr e)
+ = char '-' <+> pprParendExpr e
-ppr_expr (HsPar e)
- = parens (ppr_expr e)
+ppr_expr (HsPar e) = parens (ppr_expr e)
ppr_expr (SectionL expr op)
= case op of
-- special case: let ... in let ...
ppr_expr (HsLet binds expr@(HsLet _ _))
- = sep [hang (ptext SLIT("let")) 2 (hsep [ppr binds, ptext SLIT("in")]),
+ = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
pprExpr expr]
ppr_expr (HsLet binds expr)
- = sep [hang (ptext SLIT("let")) 2 (ppr binds),
+ = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
hang (ptext SLIT("in")) 2 (ppr expr)]
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
= hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
ifNotPprForUser ((<>) space (parens (pprType ty))) ]
-ppr_expr (ExplicitTuple exprs)
+ppr_expr (ExplicitTuple exprs True)
= parens (sep (punctuate comma (map ppr_expr exprs)))
+ppr_expr (ExplicitTuple exprs False)
+ = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)")
+
ppr_expr (HsCon con_id tys args)
= ppr con_id <+> sep (map pprParendType tys ++
map pprParendExpr args)
-ppr_expr (RecordCon con_id con rbinds)
+ppr_expr (RecordCon con_id rbinds)
+ = pp_rbinds (ppr con_id) rbinds
+ppr_expr (RecordConOut data_con con rbinds)
= pp_rbinds (ppr con) rbinds
ppr_expr (RecordUpd aexp rbinds)
HsVar _ -> pp_as_was
ExplicitList _ -> pp_as_was
ExplicitListOut _ _ -> pp_as_was
- ExplicitTuple _ -> pp_as_was
+ ExplicitTuple _ _ -> pp_as_was
HsPar _ -> pp_as_was
_ -> parens pp_as_was
%************************************************************************
\begin{code}
-data DoOrListComp = DoStmt | ListComp | Guard
-
+data StmtCtxt -- Context of a Stmt
+ = DoStmt -- Do Statment
+ | ListComp -- List comprehension
+ | CaseAlt -- Guard on a case alternative
+ | PatBindRhs -- Guard on a pattern binding
+ | FunRhs Name -- Guard on a function defn for f
+ | LambdaBody -- Body of a lambda abstraction
+
pprDo DoStmt stmts
= hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
pprDo ListComp stmts
| GuardStmt (HsExpr flexi id pat) -- List comps only
SrcLoc
- | ExprStmt (HsExpr flexi id pat) -- Do stmts only
+ | ExprStmt (HsExpr flexi id pat) -- Do stmts; and guarded things at the end
SrcLoc
| ReturnStmt (HsExpr flexi id pat) -- List comps only, at the end
pprStmt (BindStmt pat expr _)
= hsep [ppr pat, ptext SLIT("<-"), ppr expr]
pprStmt (LetStmt binds)
- = hsep [ptext SLIT("let"), ppr binds]
+ = hsep [ptext SLIT("let"), pprBinds binds]
pprStmt (ExprStmt expr _)
= ppr expr
pprStmt (GuardStmt expr _)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsImpExp]{Abstract syntax: imports, exports, interfaces}
--- /dev/null
+__interface HsMatches 1 0 where
+__export HsMatches Match GRHSsAndBinds pprMatch pprMatches pprGRHSsAndBinds ;
+1 data Match a b c ;
+1 data GRHSsAndBinds a b c ;
+1 pprGRHSsAndBinds :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.GRHSsAndBinds _f _i _p -> Outputable.SDoc ;
+1 pprMatch :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.Match _f _i _p -> Outputable.SDoc ;
+1 pprMatches :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _f _i _p] -> Outputable.SDoc ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
#include "HsVersions.h"
-- Friends
-import HsExpr ( HsExpr, Stmt )
+import HsExpr ( HsExpr, Stmt(..) )
import HsBinds ( HsBinds, nullBinds )
-- Others
import Type ( GenType )
import SrcLoc ( SrcLoc )
-import Util ( panic )
import Outputable
import Name ( NamedThing )
\end{code}
(GenType flexi)
data GRHS flexi id pat
- = GRHS [Stmt flexi id pat] -- guard(ed)...
- (HsExpr flexi id pat) -- ... right-hand side
+ = GRHS [Stmt flexi id pat] -- The RHS is the final ExprStmt
+ -- I considered using a RetunStmt, but
+ -- it printed 'wrong' in error messages
SrcLoc
unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat]
-unguardedRHS rhs loc = [GRHS [] rhs loc]
+unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc]
\end{code}
@getMatchLoc@ takes a @Match@ and returns the
\begin{code}
getMatchLoc :: Match flexi id pat -> SrcLoc
-getMatchLoc (PatMatch _ m) = getMatchLoc m
-getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ _ loc : _) _)) = loc
+getMatchLoc (PatMatch _ m) = getMatchLoc m
+getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
\end{code}
%************************************************************************
= ($$) (vcat (map (pprGRHS is_case) grhss))
(if (nullBinds binds)
then empty
- else vcat [ text "where", nest 4 (ppr binds) ])
+ else vcat [ text "where", nest 4 (pprDeeper (ppr binds)) ])
pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty)
= ($$) (vcat (map (pprGRHS is_case) grhss))
(if (nullBinds binds)
then empty
- else vcat [text "where", nest 4 (ppr binds) ])
+ else vcat [text "where", nest 4 (pprDeeper (ppr binds)) ])
---------------------------------------------
pprGRHS :: (NamedThing id, Outputable id, Outputable pat)
=> Bool -> GRHS flexi id pat -> SDoc
-pprGRHS is_case (GRHS [] expr locn)
- = text (if is_case then "->" else "=") <+> ppr expr
+pprGRHS is_case (GRHS [ExprStmt expr _] locn)
+ = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
-pprGRHS is_case (GRHS guard expr locn)
- = sep [char '|' <+> interpp'SP guard,
- text (if is_case then "->" else "=") <+> ppr expr
+pprGRHS is_case (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards,
+ text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
]
+ where
+ ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards
+ guards = init guarded
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PatSyntax]{Abstract Haskell syntax---patterns}
import BasicTypes ( Fixity )
-- others:
-import Id ( Id, dataConTyCon, GenId )
+import Var ( Id, GenTyVar )
+import DataCon ( DataCon, dataConTyCon )
import Maybes ( maybeToBool )
import Outputable
import TyCon ( maybeTyConSingleCon )
import Type ( GenType )
-import Name ( NamedThing )
\end{code}
Patterns come in distinct before- and after-typechecking flavo(u)rs.
| ListPatIn [InPat name] -- syntactic list
-- must have >= 1 elements
- | TuplePatIn [InPat name] -- tuple
+ | TuplePatIn [InPat name] Bool -- tuple (boxed?)
| RecPatIn name -- record
[(name, InPat name, Bool)] -- True <=> source used punning
| AsPat id -- as pattern
(OutPat flexi id)
- | ConPat Id -- Constructor is always an Id
- (GenType flexi) -- the type of the pattern
- [OutPat flexi id]
-
- | ConOpPat (OutPat flexi id) -- just a special case...
- Id
- (OutPat flexi id)
- (GenType flexi)
| ListPat -- syntactic list
(GenType flexi) -- the type of the elements
[OutPat flexi id]
| TuplePat [OutPat flexi id] -- tuple
+ Bool -- boxed?
-- UnitPat is TuplePat []
- | RecPat Id -- record constructor
+ | ConPat DataCon
(GenType flexi) -- the type of the pattern
+ [GenTyVar flexi] -- Existentially bound type variables
+ [id] -- Ditto dictionaries
+ [OutPat flexi id]
+
+ -- ConOpPats are only used on the input side
+
+ | RecPat DataCon -- record constructor
+ (GenType flexi) -- the type of the pattern
+ [GenTyVar flexi] -- Existentially bound type variables
+ [id] -- Ditto dictionaries
[(Id, OutPat flexi id, Bool)] -- True <=> source used punning
| LitPat -- Used for *non-overloaded* literal patterns:
pprInPat (ListPatIn pats)
= brackets (interpp'SP pats)
-pprInPat (TuplePatIn pats)
+pprInPat (TuplePatIn pats False)
+ = text "(#" <> (interpp'SP pats) <> text "#)"
+pprInPat (TuplePatIn pats True)
= parens (interpp'SP pats)
pprInPat (NPlusKPatIn n k)
= parens (hcat [ppr n, char '+', ppr k])
pprOutPat (AsPat name pat)
= parens (hcat [ppr name, char '@', ppr pat])
-pprOutPat (ConPat name ty [])
+pprOutPat (ConPat name ty [] [] [])
= ppr name
-pprOutPat (ConPat name ty pats)
- = hcat [parens (hcat [ppr name, space, interppSP pats])]
-
-pprOutPat (ConOpPat pat1 op pat2 ty)
- = parens (hcat [ppr pat1, space, ppr op, space, ppr pat2])
+pprOutPat (ConPat name ty tyvars dicts pats)
+ = parens (hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats])
pprOutPat (ListPat ty pats)
= brackets (interpp'SP pats)
-pprOutPat (TuplePat pats)
+pprOutPat (TuplePat pats boxed@True)
= parens (interpp'SP pats)
+pprOutPat (TuplePat pats unboxed@False)
+ = text "(#" <> (interpp'SP pats) <> text "#)"
-pprOutPat (RecPat con ty rpats)
- = hcat [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
+pprOutPat (RecPat con ty tvs dicts rpats)
+ = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
where
pp_rpat (v, _, True) = ppr v
pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p]
failureFreePat (VarPat _) = True
failureFreePat (LazyPat _) = True
failureFreePat (AsPat _ pat) = failureFreePat pat
-failureFreePat (ConPat con tys pats) = only_con con && all failureFreePat pats
-failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1
-failureFreePat (RecPat con _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
+failureFreePat (ConPat con tys _ _ pats) = only_con con && all failureFreePat pats
+failureFreePat (RecPat con _ _ _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
failureFreePat (ListPat _ _) = False
-failureFreePat (TuplePat pats) = all failureFreePat pats
+failureFreePat (TuplePat pats _) = all failureFreePat pats
failureFreePat (DictPat _ _) = True
failureFreePat other_pat = False -- Literals, NPat
patsAreAllCons pat_list = all isConPat pat_list
isConPat (AsPat _ pat) = isConPat pat
-isConPat (ConPat _ _ _) = True
-isConPat (ConOpPat _ _ _ _) = True
+isConPat (ConPat _ _ _ _ _) = True
isConPat (ListPat _ _) = True
-isConPat (TuplePat _) = True
-isConPat (RecPat _ _ _) = True
+isConPat (TuplePat _ _) = True
+isConPat (RecPat _ _ _ _ _) = True
isConPat (DictPat ds ms) = (length ds + length ms) > 1
isConPat other = False
collectPatBinders (NegPatIn pat) = collectPatBinders pat
collectPatBinders (ParPatIn pat) = collectPatBinders pat
collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
+collectPatBinders (TuplePatIn pats _) = concat (map collectPatBinders pats)
collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
%************************************************************************
%* *
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{Haskell abstract syntax definition}
DefaultDecl(..), ForeignDecl(..), ForKind(..),
ExtName(..), isDynamic, FixityDecl(..),
ConDecl(..), ConDetails(..), BangType(..),
- IfaceSig(..), HsIdInfo, SpecDataSig(..),
+ IfaceSig(..), SpecDataSig(..),
hsDeclName
)
import HsExpr
import HsMatches
import HsPat
import HsTypes
-import HsPragmas ( ClassPragmas, ClassOpPragmas,
- DataPragmas, GenPragmas, InstancePragmas )
import HsCore
import BasicTypes ( Fixity, Version, NewOrData, IfaceFlavour, Module )
-- others:
-import FiniteMap ( FiniteMap )
import Outputable
import SrcLoc ( SrcLoc )
import Bag
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsTypes]{Abstract syntax: user-defined types}
, mkHsForAllTy
, getTyVarName, replaceTyVarName
, pprParendHsType
- , pprContext, pprClassAssertion
+ , pprForAll, pprContext, pprClassAssertion
, cmpHsType, cmpHsTypes, cmpContext
) where
#include "HsVersions.h"
+import Type ( Kind )
+import PprType ( {- instance Outputable Kind -} )
import Outputable
-import Kind ( Kind {- instance Outputable -} )
import Util ( thenCmp, cmpList, panic )
-import GlaExts ( Int#, (<#) )
\end{code}
This is the syntax for types as seen in type signatures.
-- doesn't have to be when reading interface files
data HsType name
- = HsPreForAllTy (Context name)
- (HsType name)
-
- -- The renamer turns HsPreForAllTys into HsForAllTys when they
- -- occur in signatures, to make the binding of variables
- -- explicit. This distinction is made visible for
- -- non-COMPILING_GHC code, because you probably want to do the
- -- same thing.
-
- | HsForAllTy [HsTyVar name]
+ = HsForAllTy [HsTyVar name]
(Context name)
(HsType name)
| MonoFunTy (HsType name) -- function type
(HsType name)
- | MonoListTy name -- The list TyCon name
- (HsType name) -- Element type
+ | MonoListTy (HsType name) -- Element type
- | MonoTupleTy name -- The tuple TyCon name
- [HsType name] -- Element types (length gives arity)
+ | MonoTupleTy [HsType name] -- Element types (length gives arity)
+ Bool -- boxed?
-- these next two are only used in unfoldings in interfaces
| MonoDictTy name -- Class
ppr (UserTyVar name) = ppr name
ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
-ppr_forall ctxt_prec [] [] ty
- = ppr_mono_ty ctxt_prec ty
-ppr_forall ctxt_prec tvs ctxt ty
- = maybeParen (ctxt_prec >= pREC_FUN) $
- sep [ptext SLIT("_forall_"), brackets (interppSP tvs),
- pprContext ctxt, ptext SLIT("=>"),
- pprHsType ty]
+pprForAll [] = empty
+pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
pprContext :: (Outputable name) => Context name -> SDoc
pprContext [] = empty
-pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context)))
+pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
pprClassAssertion (clas, tys)
pprHsType ty = ppr_mono_ty pREC_TOP ty
pprParendHsType ty = ppr_mono_ty pREC_CON ty
-ppr_mono_ty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall ctxt_prec [] ctxt ty
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall ctxt_prec tvs ctxt ty
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)
+ = maybeParen (ctxt_prec >= pREC_FUN) $
+ sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
-ppr_mono_ty ctxt_prec (MonoTyVar name) = ppr name
+ppr_mono_ty ctxt_prec (MonoTyVar name)
+ = ppr name
ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
= let p1 = ppr_mono_ty pREC_FUN ty1
maybeParen (ctxt_prec >= pREC_FUN)
(sep [p1, (<>) (ptext SLIT("-> ")) p2])
-ppr_mono_ty ctxt_prec (MonoTupleTy _ tys)
+ppr_mono_ty ctxt_prec (MonoTupleTy tys True)
= parens (sep (punctuate comma (map ppr tys)))
+ppr_mono_ty ctxt_prec (MonoTupleTy tys False)
+ = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)")
-ppr_mono_ty ctxt_prec (MonoListTy _ ty)
+ppr_mono_ty ctxt_prec (MonoListTy ty)
= brackets (ppr_mono_ty pREC_TOP ty)
ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
cmpHsTypes cmp tys1 [] = GT
cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
--- We assume that HsPreForAllTys have been smashed by now.
-# ifdef DEBUG
-cmpHsType _ (HsPreForAllTy _ _) _ = panic "cmpHsType:HsPreForAllTy:1st arg"
-cmpHsType _ _ (HsPreForAllTy _ _) = panic "cmpHsType:HsPreForAllTy:2nd arg"
-# endif
-
cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
= cmpList (cmpHsTyVar cmp) tvs1 tvs2 `thenCmp`
cmpContext cmp c1 c2 `thenCmp`
cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
= cmp n1 n2
-cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2)
- = cmpList (cmpHsType cmp) tys1 tys2
-cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2)
+cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
+ = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
+
+cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
= cmpHsType cmp ty1 ty2
cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
in
if tag1 _LT_ tag2 then LT else GT
where
- tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
- tag (MonoTupleTy _ tys1) = ILIT(2)
- tag (MonoListTy _ ty1) = ILIT(3)
- tag (MonoTyApp tc1 tys1) = ILIT(4)
- tag (MonoFunTy a1 b1) = ILIT(5)
- tag (MonoDictTy c1 tys1) = ILIT(7)
- tag (HsForAllTy _ _ _) = ILIT(8)
- tag (HsPreForAllTy _ _) = ILIT(9)
+ tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
+ tag (MonoTupleTy tys1 _) = ILIT(2)
+ tag (MonoListTy ty1) = ILIT(3)
+ tag (MonoTyApp tc1 tys1) = ILIT(4)
+ tag (MonoFunTy a1 b1) = ILIT(5)
+ tag (MonoDictTy c1 tys1) = ILIT(7)
+ tag (HsForAllTy _ _ _) = ILIT(8)
-------------------
cmpContext cmp a b
intSwitchSet,
switchIsOn,
- maybe_CompilingGhcInternals,
opt_AllStrict,
opt_AllowOverlappingInstances,
+ opt_AllowUndecidableInstances,
opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
opt_AutoSccsOnIndividualCafs,
- opt_CompilingGhcInternals,
opt_D_dump_absC,
opt_D_dump_asm,
opt_D_dump_deriv,
opt_D_dump_ds,
opt_D_dump_flatC,
+ opt_D_dump_inlinings,
opt_D_dump_foreign,
opt_D_dump_occur_anal,
opt_D_dump_rdr,
opt_D_source_stats,
opt_D_verbose_core2core,
opt_D_verbose_stg2stg,
+ opt_DictsStrict,
opt_DoCoreLinting,
opt_DoStgLinting,
opt_DoSemiTagging,
opt_EmitCExternDecls,
opt_EnsureSplittableC,
opt_FoldrBuildOn,
- opt_ForConcurrent,
opt_GlasgowExts,
opt_GranMacros,
opt_HiMap,
opt_IgnoreIfacePragmas,
opt_IrrefutableTuples,
opt_LiberateCaseThreshold,
+ opt_MaxContextReductionDepth,
opt_MultiParamClasses,
opt_NoHiCheck,
opt_NoImplicitPrelude,
+ opt_NoPreInlining,
opt_NumbersStrict,
opt_OmitBlackHoling,
opt_OmitInterfacePragmas,
- opt_PprStyle_All,
+ opt_PprStyle_NoPrags,
opt_PprStyle_Debug,
- opt_PprStyle_User, -- ToDo: rm
opt_PprUserLength,
opt_ProduceC,
opt_ProduceHi,
opt_ProduceS,
opt_ProduceExportCStubs,
opt_ProduceExportHStubs,
- opt_ReportWhyUnfoldingsDisallowed,
- opt_ReturnInRegsThreshold,
opt_ReportCompile,
opt_SccGroup,
opt_SccProfilingOn,
- opt_ShowImportSpecs,
- opt_SigsRequired,
opt_SourceUnchanged,
- opt_SpecialiseAll,
- opt_SpecialiseImports,
- opt_SpecialiseOverloaded,
- opt_SpecialiseTrace,
- opt_SpecialiseUnboxed,
opt_StgDoLetNoEscapes,
+ opt_Parallel,
opt_InterfaceUnfoldThreshold,
opt_UnfoldCasms,
opt_WarnMissingMethods,
opt_WarnDuplicateExports,
opt_WarnHiShadows,
+ opt_WarnMissingSigs,
opt_PruneTyDecls, opt_PruneInstDecls,
opt_D_show_rn_stats
) where
| SimplOkToFloatPrimOps
| SimplAlwaysFloatLetsFromLets
| SimplDoCaseElim
- | SimplReuseCon
| SimplCaseOfCase
| SimplLetToCase
| SimplMayDeleteConjurableIds
-- do unfoldings that *must* be done
-- (to saturate constructors and primitives)
- | ShowSimplifierProgress -- report counts on every interation
-
| MaxSimplifierIterations Int
| SimplNoLetFromCase -- used when turning off floating entirely
| SimplNoLetFromApp -- (for experimentation only) WDP 95/10
| SimplNoLetFromStrictLet
- | SimplDontFoldBackAppend
- -- we fold `foldr (:)' back into flip (++),
- -- but we *don't* want to do it when compiling
- -- List.hs, otherwise
- -- xs ++ ys = foldr (:) ys xs
- -- {- via our loopback -}
- -- xs ++ ys = xs ++ ys
- -- Oops!
- -- So only use this flag inside List.hs
- -- (Sigh, what a HACK, Andy. WDP 96/01)
-
| SimplCaseMerge
- | SimplCaseScrutinee -- This flag tells that the expression being simplified is
- -- the scrutinee of a case expression, so we should
- -- apply the scrutinee discount when considering inlinings.
- -- See SimplVar.lhs
-
- | SimplCloneBinds -- This flag controls whether the simplifier should
- -- always clone binder ids when creating expression
- -- copies. The default is NO, but it needs to be turned on
- -- prior to floating binders outwards.
- -- (see comment inside SimplVar.simplBinder)
+ | SimplPleaseClone
\end{code}
%************************************************************************
\begin{code}
opt_AllStrict = lookUp SLIT("-fall-strict")
opt_AllowOverlappingInstances = lookUp SLIT("-fallow-overlapping-instances")
+opt_AllowUndecidableInstances = lookUp SLIT("-fallow-undecidable-instances")
opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs")
opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs")
opt_AutoSccsOnIndividualCafs = lookUp SLIT("-fauto-sccs-on-individual-cafs")
-opt_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals
-maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals="
opt_D_dump_absC = lookUp SLIT("-ddump-absC")
opt_D_dump_asm = lookUp SLIT("-ddump-asm")
opt_D_dump_deriv = lookUp SLIT("-ddump-deriv")
opt_D_dump_ds = lookUp SLIT("-ddump-ds")
opt_D_dump_flatC = lookUp SLIT("-ddump-flatC")
+opt_D_dump_inlinings = lookUp SLIT("-ddump-inlinings")
opt_D_dump_foreign = lookUp SLIT("-ddump-foreign-stubs")
opt_D_dump_occur_anal = lookUp SLIT("-ddump-occur-anal")
opt_D_dump_rdr = lookUp SLIT("-ddump-rdr")
opt_D_source_stats = lookUp SLIT("-dsource-stats")
opt_D_verbose_core2core = lookUp SLIT("-dverbose-simpl")
opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg")
+opt_DictsStrict = lookUp SLIT("-fdicts-strict")
opt_DoCoreLinting = lookUp SLIT("-dcore-lint")
opt_DoStgLinting = lookUp SLIT("-dstg-lint")
opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction")
opt_EmitCExternDecls = lookUp SLIT("-femit-extern-decls")
opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names")
opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on")
-opt_ForConcurrent = lookUp SLIT("-fconcurrent")
opt_GranMacros = lookUp SLIT("-fgransim")
opt_GlasgowExts = lookUp SLIT("-fglasgow-exts")
opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
opt_HiVersion = lookup_def_int "-fhi-version=" 0 -- what version we're compiling.
opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
+opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
opt_MultiParamClasses = opt_GlasgowExts
-opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude")
opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check")
+opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude")
+opt_NoPreInlining = lookUp SLIT("-fno-pre-inlining")
opt_NumbersStrict = lookUp SLIT("-fnumbers-strict")
opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas")
-opt_PprStyle_All = lookUp SLIT("-dppr-all")
+opt_PprStyle_NoPrags = lookUp SLIT("-dppr-noprags")
opt_PprStyle_Debug = lookUp SLIT("-dppr-debug")
-opt_PprStyle_User = lookUp SLIT("-dppr-user")
opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
opt_ProduceC = lookup_str "-C="
opt_ProduceS = lookup_str "-S="
opt_ProduceExportCStubs = lookup_str "-F="
opt_ProduceExportHStubs = lookup_str "-FH="
opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time
-opt_ReportWhyUnfoldingsDisallowed= lookUp SLIT("-freport-disallowed-unfoldings")
opt_ReportCompile = lookUp SLIT("-freport-compile")
-opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold"
opt_SccProfilingOn = lookUp SLIT("-fscc-profiling")
-opt_ShowImportSpecs = lookUp SLIT("-fshow-import-specs")
-opt_SigsRequired = lookUp SLIT("-fsignatures-required")
opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged")
-opt_SpecialiseAll = lookUp SLIT("-fspecialise-all")
-opt_SpecialiseImports = lookUp SLIT("-fspecialise-imports")
-opt_SpecialiseOverloaded = lookUp SLIT("-fspecialise-overloaded")
-opt_SpecialiseTrace = lookUp SLIT("-ftrace-specialisation")
-opt_SpecialiseUnboxed = lookUp SLIT("-fspecialise-unboxed")
opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape")
+opt_Parallel = lookUp SLIT("-fparallel")
opt_SccGroup = lookup_str "-G="
opt_Verbose = lookUp SLIT("-v")
opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports")
opt_WarnMissingMethods = lookUp SLIT("-fwarn-missing-methods")
opt_WarnDuplicateExports = lookUp SLIT("-fwarn-duplicate-exports")
+opt_WarnMissingSigs = lookUp SLIT("-fwarn-missing-signatures")
opt_PruneTyDecls = not (lookUp SLIT("-fno-prune-tydecls"))
opt_PruneInstDecls = not (lookUp SLIT("-fno-prune-instdecls"))
opt_D_show_rn_stats = lookUp SLIT("-dshow-rn-stats")
# define SIMPL_SW(sw) simpl_sep opts (sw:simpl_sw) core_td stg_td
-- the non-"just match a string" options are at the end...
- "-fshow-simplifier-progress" -> SIMPL_SW(ShowSimplifierProgress)
"-fcode-duplication-ok" -> SIMPL_SW(SimplOkToDupCode)
"-ffloat-lets-exposing-whnf" -> SIMPL_SW(SimplFloatLetsExposingWHNF)
"-ffloat-primops-ok" -> SIMPL_SW(SimplOkToFloatPrimOps)
"-fdo-case-elim" -> SIMPL_SW(SimplDoCaseElim)
"-fdo-lambda-eta-expansion" -> SIMPL_SW(SimplDoLambdaEtaExpansion)
"-fdo-foldr-build" -> SIMPL_SW(SimplDoFoldrBuild)
- "-fdo-not-fold-back-append" -> SIMPL_SW(SimplDontFoldBackAppend)
"-fdo-arity-expand" -> SIMPL_SW(SimplDoArityExpand)
"-fdo-inline-foldr-build" -> SIMPL_SW(SimplDoInlineFoldrBuild)
- "-freuse-con" -> SIMPL_SW(SimplReuseCon)
"-fcase-of-case" -> SIMPL_SW(SimplCaseOfCase)
"-fcase-merge" -> SIMPL_SW(SimplCaseMerge)
"-flet-to-case" -> SIMPL_SW(SimplLetToCase)
"-fno-let-from-case" -> SIMPL_SW(SimplNoLetFromCase)
"-fno-let-from-app" -> SIMPL_SW(SimplNoLetFromApp)
"-fno-let-from-strict-let" -> SIMPL_SW(SimplNoLetFromStrictLet)
- "-fclone-binds" -> SIMPL_SW(SimplCloneBinds)
+ "-fclone-binds" -> SIMPL_SW(SimplPleaseClone)
o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi))
where
tagOf_SimplSwitch SimplOkToFloatPrimOps = ILIT(2)
tagOf_SimplSwitch SimplAlwaysFloatLetsFromLets = ILIT(3)
tagOf_SimplSwitch SimplDoCaseElim = ILIT(4)
-tagOf_SimplSwitch SimplReuseCon = ILIT(5)
tagOf_SimplSwitch SimplCaseOfCase = ILIT(6)
tagOf_SimplSwitch SimplLetToCase = ILIT(7)
tagOf_SimplSwitch SimplMayDeleteConjurableIds = ILIT(9)
tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15)
tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16)
tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19)
-tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20)
tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21)
tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27)
tagOf_SimplSwitch SimplNoLetFromApp = ILIT(28)
tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29)
-tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(30)
tagOf_SimplSwitch SimplCaseMerge = ILIT(31)
-tagOf_SimplSwitch SimplCaseScrutinee = ILIT(32)
-tagOf_SimplSwitch SimplCloneBinds = ILIT(33)
+tagOf_SimplSwitch SimplPleaseClone = ILIT(32)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
-lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCloneBinds)
+lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplPleaseClone)
\end{code}
%************************************************************************
case sw_tbl of { Array bounds_who_needs_'em stuff ->
\ switch ->
case (indexArray# stuff (tagOf_SimplSwitch switch)) of
+#if __GLASGOW_HASKELL__ < 400
Lift v -> v
+#else
+ (# _, v #) -> v
+#endif
}
where
mk_assoc_elem k@(MaxSimplifierIterations lvl) = (IBOX(tagOf_SimplSwitch k), SwInt lvl)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Constants]{Info about this compilation}
-!!!!! THIS CODE MUST AGREE WITH SMinterface.h !!!!!!
-
-*** This SHOULD BE the only module that is CPP'd with "stgdefs.h" stuff.
-
\begin{code}
module Constants (
uNFOLDING_USE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT,
uNFOLDING_KEENESS_FACTOR,
- mAX_SPEC_ALL_PTRS,
- mAX_SPEC_ALL_NONPTRS,
- mAX_SPEC_MIXED_FIELDS,
+ mAX_CONTEXT_REDUCTION_DEPTH,
+ mAX_TUPLE_SIZE,
+
mAX_SPEC_SELECTEE_SIZE,
+ mAX_SPEC_AP_SIZE,
tARGET_MIN_INT, tARGET_MAX_INT,
mIN_UPD_SIZE,
mIN_SIZE_NonUpdHeapObject,
- mIN_SIZE_NonUpdStaticHeapObject,
+
+ sTD_HDR_SIZE,
+ pROF_HDR_SIZE,
+ gRAN_HDR_SIZE,
+ tICKY_HDR_SIZE,
+ aRR_HDR_SIZE,
+
+ sTD_ITBL_SIZE,
+ pROF_ITBL_SIZE,
+ gRAN_ITBL_SIZE,
+ tICKY_ITBL_SIZE,
mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
- sTD_UF_SIZE, cON_UF_SIZE,
- sCC_STD_UF_SIZE, sCC_CON_UF_SIZE,
+ uF_SIZE,
+ sCC_UF_SIZE,
uF_RET,
- uF_SUB,
- uF_SUA,
+ uF_SU,
uF_UPDATEE,
- uF_COST_CENTRE,
+ uF_CCS,
+
+ sEQ_FRAME_SIZE,
mAX_Vanilla_REG,
mAX_Float_REG,
mAX_Double_REG,
mAX_Long_REG,
- mIN_MP_INT_SIZE,
- mP_STRUCT_SIZE,
+ mAX_Real_Vanilla_REG,
+ mAX_Real_Float_REG,
+ mAX_Real_Double_REG,
- oTHER_TAG, iND_TAG, -- semi-tagging stuff
-
- lIVENESS_R1,
- lIVENESS_R2,
- lIVENESS_R3,
- lIVENESS_R4,
- lIVENESS_R5,
- lIVENESS_R6,
- lIVENESS_R7,
- lIVENESS_R8,
+ oTHER_TAG,
mAX_INTLIKE, mIN_INTLIKE,
+ spRelToInt,
+
+ dOUBLE_SIZE,
+ iNT64_SIZE,
+ wORD64_SIZE,
+
+ interfaceFileFormatVersion
- spARelToInt,
- spBRelToInt
) where
-- This magical #include brings in all the everybody-knows-these magic
-- be in trouble.
#include "HsVersions.h"
-#include "../../includes/GhcConstants.h"
+#include "../includes/config.h"
+#include "../includes/MachRegs.h"
+#include "../includes/Constants.h"
import Util
\end{code}
All pretty arbitrary:
+
+\begin{code}
+mAX_TUPLE_SIZE = 37
+mAX_CONTEXT_REDUCTION_DEPTH = 20
+\end{code}
+
\begin{code}
uNFOLDING_USE_THRESHOLD = ( 8 :: Int)
uNFOLDING_CREATION_THRESHOLD = (30 :: Int) -- Discounts can be big
\end{code}
\begin{code}
-mAX_SPEC_ALL_PTRS = (MAX_SPEC_ALL_PTRS :: Int)
-mAX_SPEC_ALL_NONPTRS = (MAX_SPEC_ALL_NONPTRS :: Int)
-mAX_SPEC_MIXED_FIELDS = (MAX_SPEC_OTHER_SIZE :: Int)
+
+-- pre-compiled thunk types
mAX_SPEC_SELECTEE_SIZE = (MAX_SPEC_SELECTEE_SIZE :: Int)
+mAX_SPEC_AP_SIZE = (MAX_SPEC_AP_SIZE :: Int)
--- closure sizes: these do NOT include the header
+-- closure sizes: these do NOT include the header (see below for header sizes)
mIN_UPD_SIZE = (MIN_UPD_SIZE::Int)
mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int)
-mIN_SIZE_NonUpdStaticHeapObject = (0::Int)
-\end{code}
-
-Sizes of gmp objects:
-\begin{code}
-mIN_MP_INT_SIZE = (MIN_MP_INT_SIZE :: Int)
-mP_STRUCT_SIZE = (MP_STRUCT_SIZE :: Int)
\end{code}
\begin{code}
Constants for semi-tagging; the tags associated with the data
constructors will start at 0 and go up.
-\begin{code}
-oTHER_TAG = (INFO_OTHER_TAG :: Integer) -- (-1) unevaluated, probably
-iND_TAG = (INFO_IND_TAG :: Integer) -- (-2) NOT USED, REALLY
-\end{code}
-Stuff for liveness masks:
\begin{code}
-lIVENESS_R1 = (LIVENESS_R1 :: Int)
-lIVENESS_R2 = (LIVENESS_R2 :: Int)
-lIVENESS_R3 = (LIVENESS_R3 :: Int)
-lIVENESS_R4 = (LIVENESS_R4 :: Int)
-lIVENESS_R5 = (LIVENESS_R5 :: Int)
-lIVENESS_R6 = (LIVENESS_R6 :: Int)
-lIVENESS_R7 = (LIVENESS_R7 :: Int)
-lIVENESS_R8 = (LIVENESS_R8 :: Int)
+oTHER_TAG = (INFO_OTHER_TAG :: Integer) -- (-1) unevaluated, probably
\end{code}
\begin{code}
mAX_INTLIKE = MAX_INTLIKE
\end{code}
+A little function that abstracts the stack direction. Note that most
+of the code generator is dependent on the stack direction anyway, so
+changing this on its own spells certain doom. ToDo: remove?
+
\begin{code}
--- THESE ARE DIRECTION SENSITIVE!
-spARelToInt :: Int{-VirtualSpAOffset-} -> Int{-VirtualSpAOffset-} -> Int
-spBRelToInt :: Int{-VirtualSpBOffset-} -> Int{-VirtualSpBOffset-} -> Int
+-- THIS IS DIRECTION SENSITIVE!
+
+-- stack grows down, positive virtual offsets correspond to negative
+-- additions to the stack pointer.
-spARelToInt spA off = spA - off -- equiv to: AREL(spA - off)
-spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off)
+spRelToInt :: Int{-VirtualSpOffset-} -> Int{-VirtualSpOffset-} -> Int
+spRelToInt sp off = sp - off
\end{code}
A section of code-generator-related MAGIC CONSTANTS.
+
\begin{code}
mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary
-- If you change this, you may need to change runtimes/standard/Update.lhc
-- The update frame sizes
-sTD_UF_SIZE = (NOSCC_STD_UF_SIZE::Int)
-cON_UF_SIZE = (NOSCC_CON_UF_SIZE::Int)
+uF_SIZE = (NOSCC_UF_SIZE::Int)
-- Same again, with profiling
-sCC_STD_UF_SIZE = (SCC_STD_UF_SIZE::Int)
-sCC_CON_UF_SIZE = (SCC_CON_UF_SIZE::Int)
+sCC_UF_SIZE = (SCC_UF_SIZE::Int)
-- Offsets in an update frame. They don't change with profiling!
-uF_RET = (UF_RET::Int)
-uF_SUB = (UF_SUB::Int)
-uF_SUA = (UF_SUA::Int)
-uF_UPDATEE = (UF_UPDATEE::Int)
-uF_COST_CENTRE = (UF_COST_CENTRE::Int)
+uF_RET = (UF_RET::Int)
+uF_SU = (UF_SU::Int)
+uF_UPDATEE = (UF_UPDATEE::Int)
+uF_CCS = (UF_CCS::Int)
+\end{code}
+
+\begin{code}
+sEQ_FRAME_SIZE = (SEQ_FRAME_SIZE::Int)
\end{code}
\begin{code}
mAX_Vanilla_REG = (MAX_VANILLA_REG :: Int)
mAX_Float_REG = (MAX_FLOAT_REG :: Int)
mAX_Double_REG = (MAX_DOUBLE_REG :: Int)
-mAX_Long_REG = (MAX_LONG_REG :: Int)
+
+mAX_Real_Vanilla_REG = (MAX_REAL_VANILLA_REG :: Int)
+mAX_Real_Float_REG = (MAX_REAL_FLOAT_REG :: Int)
+mAX_Real_Double_REG = (MAX_REAL_DOUBLE_REG :: Int)
+\end{code}
+
+Closure header sizes.
+
+\begin{code}
+sTD_HDR_SIZE = (STD_HDR_SIZE :: Int)
+pROF_HDR_SIZE = (PROF_HDR_SIZE :: Int)
+gRAN_HDR_SIZE = (GRAN_HDR_SIZE :: Int)
+tICKY_HDR_SIZE = (TICKY_HDR_SIZE :: Int)
+aRR_HDR_SIZE = (ARR_HDR_SIZE :: Int)
+\end{code}
+
+Info Table sizes.
+
+\begin{code}
+sTD_ITBL_SIZE = (STD_ITBL_SIZE :: Int)
+pROF_ITBL_SIZE = (PROF_ITBL_SIZE :: Int)
+gRAN_ITBL_SIZE = (GRAN_ITBL_SIZE :: Int)
+tICKY_ITBL_SIZE = (TICKY_ITBL_SIZE :: Int)
+\end{code}
+
+Size of a double in StgWords.
+
+\begin{code}
+dOUBLE_SIZE = (DOUBLE_SIZE :: Int)
+mAX_Long_REG = (MAX_LONG_REG :: Int)
+wORD64_SIZE = (WORD64_SIZE :: Int)
+iNT64_SIZE = (INT64_SIZE :: Int)
+\end{code}
+
+The version of the interface file format we're
+using:
+
+\begin{code}
+interfaceFileFormatVersion = HscIfaceFileVersion
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[ErrsUtils]{Utilities for error reporting}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
#include "HsVersions.h"
-import IO ( IOMode(..),
- hGetContents, hPutStr, hClose, openFile,
- stdin,stderr, hPutStrLn
- )
+import IO ( IOMode(..), hPutStr, hClose, openFile, stderr )
import HsSyn
-import RdrHsSyn ( RdrName )
import BasicTypes ( NewOrData(..) )
import ReadPrefix ( rdModule )
import Rename ( renameModule )
-import RnMonad ( ExportEnv )
import MkIface -- several functions
import TcModule ( typecheckModule )
-import Desugar ( deSugar, pprDsWarnings )
+import Desugar ( deSugar )
import SimplCore ( core2core )
import CoreToStg ( topCoreBindsToStg )
-import StgSyn ( collectFinalStgBinders, pprStgBindings )
+import StgSyn ( collectFinalStgBinders, pprStgBindingsWithSRTs )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
#if ! OMIT_NATIVE_CODEGEN
import AsmCodeGen ( dumpRealAsm, writeRealAsm )
#endif
-import AbsCSyn ( absCNop, AbstractC )
+import AbsCSyn ( absCNop )
import AbsCUtils ( flattenAbsC )
-import CoreUnfold ( Unfolding )
-import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
-import ErrUtils ( pprBagOfErrors, ghcExit, doIfSet, dumpIfSet )
+import ErrUtils ( ghcExit, doIfSet, dumpIfSet )
import Maybes ( maybeToBool, MaybeErr(..) )
-import StgSyn ( GenStgBinding )
-import TcInstUtil ( InstInfo )
import TyCon ( isDataTyCon )
import Class ( classTyCon )
import UniqSupply ( mkSplitUniqSupply )
import PprAbsC ( dumpRealC, writeRealC )
-import PprCore ( pprCoreBinding )
import FiniteMap ( emptyFM )
import Outputable
import Char ( isSpace )
\begin{code}
main =
- _scc_ "main"
- let
- cmd_line_info = classifyOpts
- in
- doIt cmd_line_info
+ -- _scc_ "main"
+ doIt classifyOpts
\end{code}
\begin{code}
doIt :: ([CoreToDo], [StgToDo]) -> IO ()
-doIt (core_cmds, stg_cmds) =
- doIfSet opt_Verbose
- (hPutStr stderr "Glasgow Haskell Compiler, version" >>
- hPutStr stderr compiler_version >>
- hPutStr stderr ", for Haskell 1.4\n") >>
+doIt (core_cmds, stg_cmds)
+ = doIfSet opt_Verbose
+ (hPutStr stderr "Glasgow Haskell Compiler, version " >>
+ hPutStr stderr compiler_version >>
+ hPutStr stderr ", for Haskell 1.4\n") >>
-- ******* READER
show_pass "Reader" >>
Nothing -> ghcExit 1; -- Type checker failed
Just (all_binds,
- local_tycons, local_classes, inst_info,
+ local_tycons, local_classes, inst_info,
fo_decls,
- ddump_deriv) ->
+ ddump_deriv,
+ global_env,
+ global_ids) ->
-- ******* DESUGARER
- show_pass "DeSugar" >>
+ show_pass "DeSugar" >>
_scc_ "DeSugar"
- deSugar ds_uniqs mod_name all_binds fo_decls >>= \ (desugared, hc_code, h_code, c_code) ->
+ deSugar ds_uniqs global_env mod_name all_binds fo_decls >>= \ (desugared, h_code, c_code) ->
-- ******* CORE-TO-CORE SIMPLIFICATION
local_data_tycons = filter isDataTyCon local_tycons
in
core2core core_cmds mod_name
- sm_uniqs local_data_tycons desugared
+ sm_uniqs desugared
>>=
\ simplified ->
>>=
\ (stg_binds2, cost_centre_info) ->
- dumpIfSet opt_D_dump_stg "STG syntax:" (pprStgBindings stg_binds2) >>
+ dumpIfSet opt_D_dump_stg "STG syntax:"
+ (pprStgBindingsWithSRTs stg_binds2) >>
-- Dump instance decls and type signatures into the interface file
let
- final_ids = collectFinalStgBinders stg_binds2
+ final_ids = collectFinalStgBinders (map fst stg_binds2)
in
_scc_ "Interface"
ifaceDecls if_handle local_tycons local_classes inst_info final_ids simplified >>
flat_abstractC = flattenAbsC fl_uniqs abstractC
in
- dumpIfSet opt_D_dump_absC "Abstract C"
- (dumpRealC abstractC hc_code) >>
-
- dumpIfSet opt_D_dump_flatC "Flat Abstract C"
- (dumpRealC flat_abstractC hc_code) >>
-
show_pass "CodeOutput" >>
_scc_ "CodeOutput"
-- You can have C (c_output) or assembly-language (ncg_output),
(False, False) -> (absCNop, absCNop)
(True, True) -> error "ERROR: Can't do both .hc and .s at the same time"
- c_output_d = dumpRealC flat_absC_c hc_code
- c_output_w = (\ f -> writeRealC f flat_absC_c hc_code)
-
-- C stubs for "foreign export"ed functions.
stub_c_output_d = pprCode CStyle c_code
stub_c_output_w = showSDoc stub_c_output_d
stub_h_output_d = pprCode CStyle h_code
stub_h_output_w = showSDoc stub_h_output_d
+ c_output_d = dumpRealC flat_absC_c
+ c_output_w = (\ f -> writeRealC f flat_absC_c)
+
#if OMIT_NATIVE_CODEGEN
ncg_output_d = error "*** GHC not built with a native-code generator ***"
ncg_output_w = ncg_output_d
dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >>
doOutput opt_ProduceS ncg_output_w >>
- dumpIfSet opt_D_dump_realC "Real C" c_output_d >>
- doOutput opt_ProduceC c_output_w >>
-
dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >>
outputHStub opt_ProduceExportHStubs stub_h_output_w >>
dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >>
outputCStub mod_name opt_ProduceExportCStubs stub_c_output_w >>
+ dumpIfSet opt_D_dump_realC "Real C" c_output_d >>
+ doOutput opt_ProduceC c_output_w >>
+
reportCompile (_UNPK_ mod_name) (showSDoc (ppSourceStats True rdr_module)) >>
ghcExit 0
outputCStub mod_name switch doc_str
= case switch of
Nothing -> return ()
- Just fname -> writeFile fname ("#include \"rtsdefs.h\"\n"++rest)
+ Just fname -> writeFile fname ("#include \"Rts.h\"\n#include \"RtsAPI.h\"\n"++rest)
where
rest = "#include "++show ((_UNPK_ mod_name) ++ "_stub.h") ++ '\n':doc_str
outputHStub switch doc_str
= case switch of
Nothing -> return ()
- Just fname -> writeFile fname ("#include \"rtsdefs.h\"\n"++doc_str)
+ Just fname -> writeFile fname ("#include \"Rts.h\"\n"++doc_str)
ppSourceStats short (HsModule name version exports imports fixities decls src_loc)
= (if short then hcat else vcat)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[MkIface]{Print an interface for a module}
import HsSyn
import RdrHsSyn ( RdrName(..) )
-import RnHsSyn ( RenamedHsModule )
import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..),
+ StrictnessMark(..),
pprModule
)
import RnMonad
import WorkWrap ( getWorkerIdAndCons )
import CmdLineOpts
-import Id ( idType, dataConRawArgTys, dataConFieldLabels,
- idInfo, omitIfaceSigForId,
- dataConStrictMarks, StrictnessMark(..),
- IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet,
- isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
- pprId, getIdSpecialisation,
- Id
+import Id ( Id, idType, idInfo, omitIfaceSigForId,
+ getIdSpecialisation
)
+import Var ( isId )
+import VarSet
+import DataCon ( dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
- arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
+ arityInfo, ppArityInfo,
+ strictnessInfo, ppStrictnessInfo,
+ cafInfo, ppCafInfo,
bottomIsGuaranteed, workerExists,
)
-import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
-import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding,
- okToUnfoldInHiFile
- )
-import FreeVars ( exprFreeVars )
-import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
- OccName, occNameString, nameOccName, nameString, isExported,
- Name {-instance NamedThing-}, Provenance, NamedThing(..)
+import CoreSyn ( CoreExpr, CoreBind, Bind(..) )
+import CoreUtils ( exprSomeFreeVars )
+import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..),
+ Unfolding, okToUnfoldInHiFile )
+import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule,
+ OccName, occNameString, isExported,
+ Name, NamedThing(..)
)
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons
import SpecEnv ( specEnvToList )
import FieldLabel ( fieldLabelName, fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy,
- mkTyVarTys, Type, ThetaType
+ Type, ThetaType
)
-import PprEnv -- not sure how much...
import PprType
import PprCore ( pprIfaceUnfolding )
import Bag ( bagToList, isEmptyBag )
import Maybes ( catMaybes, maybeToBool )
-import FiniteMap ( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap )
-import UniqFM ( UniqFM, lookupUFM, listToUFM )
-import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL )
+import FiniteMap ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap )
+import UniqFM ( lookupUFM, listToUFM )
+import UniqSet ( uniqSetToList )
+import Util ( sortLt, mapAccumL )
import Outputable
\end{code}
-> [TyCon] -> [Class]
-> Bag InstInfo
-> [Id] -- Ids used at code-gen time; they have better pragma info!
- -> [CoreBinding] -- In dependency order, later depend on earlier
+ -> [CoreBind] -- In dependency order, later depend on earlier
-> IO ()
endIface :: Maybe Handle -> IO ()
Nothing -> return Nothing -- not producing any .hi file
Just fn -> do
if_hdl <- openFile fn WriteMode
- hPutStrLn if_hdl ("_interface_ "++ _UNPK_ mod ++ ' ':show (opt_HiVersion :: Int))
+ hPutStr if_hdl ("__interface "++ _UNPK_ mod ++ ' ':show (opt_HiVersion :: Int))
+ hPutStrLn if_hdl " where"
return (Just if_hdl)
endIface Nothing = return ()
ifaceMain Nothing iface_stuff = return ()
ifaceMain (Just if_hdl)
(import_usages, ExportEnv avails fixities, instance_modules)
- =
- ifaceInstanceModules if_hdl instance_modules >>
- ifaceUsages if_hdl import_usages >>
- ifaceExports if_hdl avails >>
- ifaceFixities if_hdl fixities >>
+ = do
+ ifaceImports if_hdl import_usages
+ ifaceInstanceModules if_hdl instance_modules
+ ifaceExports if_hdl avails
+ ifaceFixities if_hdl fixities
return ()
ifaceDecls Nothing tycons classes inst_info final_ids simplified = return ()
| null_decls = return ()
-- You could have a module with just (re-)exports/instances in it
| otherwise
- = ifaceInstances hdl inst_infos >>= \ needed_ids ->
- hPutStr hdl "_declarations_\n" >>
- ifaceClasses hdl classes >>
+ = ifaceClasses hdl classes >>
+ ifaceInstances hdl inst_infos >>= \ needed_ids ->
ifaceTyCons hdl tycons >>
ifaceBinds hdl needed_ids final_ids binds >>
return ()
\end{code}
\begin{code}
-ifaceUsages if_hdl import_usages
- = hPutStr if_hdl "_usages_\n" >>
- hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
+ifaceImports if_hdl import_usages
+ = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
where
upp_uses (m, hif, mv, whats_imported)
- = hsep [pprModule m, pp_hif hif, int mv, ptext SLIT("::"),
+ = ptext SLIT("import ") <>
+ hsep [pprModule m, pp_hif hif, int mv, ptext SLIT("::"),
upp_import_versions whats_imported
] <> semi
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
- = hPutStr if_hdl "_instance_modules_\n" >>
- printForIface if_hdl (hsep (map ptext (sortLt (<) imods))) >>
+ = let sorted = sortLt (<) imods
+ lines = map (\m -> ptext SLIT("__instimport ") <> ptext m <>
+ ptext SLIT(" ;")) sorted
+ in
+ printForIface if_hdl (vcat lines) >>
hPutStr if_hdl "\n"
ifaceExports if_hdl [] = return ()
ifaceExports if_hdl avails
- = hPutStr if_hdl "_exports_\n" >>
- hPutCol if_hdl do_one_module (fmToList export_fm)
+ = hPutCol if_hdl do_one_module (fmToList export_fm)
where
-- Sort them into groups by module
export_fm :: FiniteMap Module [AvailInfo]
-- Print one module's worth of stuff
do_one_module :: (Module, [AvailInfo]) -> SDoc
do_one_module (mod_name, avails@(avail1:_))
- = hsep [pp_hif (ifaceFlavour (availName avail1)),
+ = ptext SLIT("__export ") <>
+ hsep [pp_hif (ifaceFlavour (availName avail1)),
pprModule mod_name,
hsep (map upp_avail (sortLt lt_avail avails))
] <> semi
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities
- = hPutStr if_hdl "_fixities_\n" >>
- hPutCol if_hdl upp_fixity fixities
+ = hPutCol if_hdl upp_fixity fixities
\end{code}
%************************************************************************
\begin{code}
ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns
ifaceInstances if_hdl inst_infos
- | null togo_insts = return emptyIdSet
- | otherwise = hPutStr if_hdl "_instances_\n" >>
- hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
+ | null togo_insts = return emptyVarSet
+ | otherwise = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
return needed_ids
where
togo_insts = filter is_togo_inst (bagToList inst_infos)
- needed_ids = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts]
- is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
+ needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
+ is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
-------
- lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _)
- (InstInfo _ _ _ _ _ dfun_id2 _ _ _)
+ lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
+ (InstInfo _ _ _ _ dfun_id2 _ _ _)
= getOccName dfun_id1 < getOccName dfun_id2
-- The dfuns are assigned names df1, df2, etc, in order of original textual
-- occurrence, and this makes as good a sort order as any
-------
- pp_inst (InstInfo clas tvs tys theta _ dfun_id _ _ _)
+ pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
= let
forall_ty = mkSigmaTy tvs theta (mkDictTy clas tys)
renumbered_ty = nmbrGlobalType forall_ty
-> Maybe (SDoc, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids
ifaceId get_idinfo needed_ids is_rec id rhs
- | not (id `elementOfIdSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
+ | not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
(isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
= Nothing -- Well, that was easy!
ifaceId get_idinfo needed_ids is_rec id rhs
- = Just (hsep [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids)
+ = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
where
- pp_double_semi = ptext SLIT(";;")
idinfo = get_idinfo id
inline_pragma = inlinePragInfo idinfo
ty_pretty = pprType (nmbrGlobalType (idType id))
- sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
+ sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" :: "), ty_pretty]
prag_pretty
| opt_OmitInterfacePragmas = empty
- | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty,
- spec_pretty, pp_double_semi]
+ | otherwise = hsep [ptext SLIT("{-##"),
+ arity_pretty,
+ caf_pretty,
+ strict_pretty,
+ unfold_pretty,
+ spec_pretty,
+ ptext SLIT("##-}")]
------------ Arity --------------
arity_pretty = ppArityInfo (arityInfo idinfo)
+ ------------ Caf Info --------------
+ caf_pretty = ppCafInfo (cafInfo idinfo)
+
------------ Strictness --------------
strict_info = strictnessInfo idinfo
has_worker = workerExists strict_info
strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
wrkr_pretty | not has_worker = empty
- | null con_list = pprId work_id
- | otherwise = pprId work_id <+>
- braces (hsep (map (pprId) con_list))
+ | null con_list = ppr work_id
+ | otherwise = ppr work_id <+>
+ braces (hsep (map ppr con_list))
(work_id, wrapper_cons) = getWorkerIdAndCons id rhs
- con_list = idSetToList wrapper_cons
+ con_list = uniqSetToList wrapper_cons
------------ Unfolding --------------
- unfold_pretty | show_unfold = hsep [ptext unfold_herald, pprIfaceUnfolding rhs]
+ unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
| otherwise = empty
- unfold_herald = case inline_pragma of
- IMustBeINLINEd -> SLIT("_U_")
- IWantToBeINLINEd -> SLIT("_U_")
- other -> SLIT("_u_")
-
show_unfold = not implicit_unfolding && -- Not unnecessary
- unfolding_is_ok -- Not dangerous
+ unfolding_needed -- Not dangerous
+
+ unfolding_needed = case inline_pragma of
+ IMustBeINLINEd -> definitely_ok_to_unfold
+ IWantToBeINLINEd -> definitely_ok_to_unfold
+ NoInlinePragInfo -> rhs_is_small
+ other -> False
implicit_unfolding = has_worker ||
bottomIsGuaranteed strict_info
- unfolding_is_ok
- = case inline_pragma of
- IMustBeINLINEd -> definitely_ok_to_unfold
- IWantToBeINLINEd -> definitely_ok_to_unfold
- IDontWantToBeINLINEd -> False
- IMustNotBeINLINEd -> False
- NoPragmaInfo -> case guidance of
- UnfoldNever -> False -- Too big
- other -> definitely_ok_to_unfold
+ unfold_herald = case inline_pragma of
+ NoInlinePragInfo -> ptext SLIT("__u")
+ other -> ppr inline_pragma
+
+ rhs_is_small = case calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs of
+ UnfoldNever -> False -- Too big
+ other -> definitely_ok_to_unfold -- Small enough
definitely_ok_to_unfold = okToUnfoldInHiFile rhs
- guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs
------------ Specialisations --------------
spec_list = specEnvToList (getIdSpecialisation id)
spec_pretty = hsep (map pp_spec spec_list)
- pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
+ pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
if null tyvars then ptext SLIT("[ ]")
else brackets (interppSP tyvars),
-- The lexer interprets "[]" as a CONID. Sigh.
]
------------ Extra free Ids --------------
- new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets`
+ new_needed_ids = (needed_ids `minusVarSet` unitVarSet id) `unionVarSet`
extra_ids
- extra_ids | opt_OmitInterfacePragmas = emptyIdSet
- | otherwise = worker_ids `unionIdSets`
- unfold_ids `unionIdSets`
+ extra_ids | opt_OmitInterfacePragmas = emptyVarSet
+ | otherwise = worker_ids `unionVarSet`
+ unfold_ids `unionVarSet`
spec_ids
- worker_ids | has_worker = unitIdSet work_id
- | otherwise = emptyIdSet
+ worker_ids | has_worker = unitVarSet work_id
+ | otherwise = emptyVarSet
- spec_ids = foldr add emptyIdSet spec_list
+ spec_ids = foldr add emptyVarSet spec_list
where
- add (_, _, rhs) = unionIdSets (find_fvs rhs)
+ add (_, _, rhs) = unionVarSet (find_fvs rhs)
unfold_ids | show_unfold = find_fvs rhs
- | otherwise = emptyIdSet
+ | otherwise = emptyVarSet
find_fvs expr = free_vars
where
- free_vars = exprFreeVars interesting expr
- interesting id = isLocallyDefined id &&
+ free_vars = exprSomeFreeVars interesting expr
+ interesting id = isId id && isLocallyDefined id &&
not (omitIfaceSigForId id)
\end{code}
ifaceBinds :: Handle
-> IdSet -- These Ids are needed already
-> [Id] -- Ids used at code-gen time; they have better pragma info!
- -> [CoreBinding] -- In dependency order, later depend on earlier
+ -> [CoreBind] -- In dependency order, later depend on earlier
-> IO ()
ifaceBinds hdl needed_ids final_ids binds
pretties = go needed_ids (reverse binds) -- Reverse so that later things will
-- provoke earlier ones to be emitted
- go needed [] = if not (isEmptyIdSet needed) then
+ go needed [] = if not (isEmptyVarSet needed) then
pprTrace "ifaceBinds: free vars:"
- (sep (map ppr (idSetToList needed))) $
+ (sep (map ppr (varSetElems needed))) $
[]
else
[]
= pretties ++ go needed'' binds
where
(needed', pretties) = go_rec needed pairs
- needed'' = needed' `minusIdSet` mkIdSet (map fst pairs)
+ needed'' = needed' `minusVarSet` mkVarSet (map fst pairs)
-- Later ones may spuriously cause earlier ones to be "needed" again
go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
keyword | isNewTyCon tycon = SLIT("newtype")
| otherwise = SLIT("data")
+ tyvars = tyConTyVars tycon
+
ppr_con data_con
| null field_labels
- = hsep [ ppr name,
+ = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
+ hsep [ ppr_ex ex_tyvars ex_theta,
+ ppr name,
hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
]
| otherwise
- = hsep [ ppr name,
+ = hsep [ ppr_ex ex_tyvars ex_theta,
+ ppr name,
braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
]
where
+ (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
field_labels = dataConFieldLabels data_con
- arg_tys = dataConRawArgTys data_con
strict_marks = dataConStrictMarks data_con
name = getName data_con
+ ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
+ ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
+ <+> pprIfaceTheta ex_theta <+> ptext SLIT("=>")
+
ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
ppr_strict_mark NotMarkedStrict = empty
(sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
ppr_decl_context :: ThetaType -> SDoc
-ppr_decl_context [] = empty
-ppr_decl_context theta
- = braces (hsep (punctuate comma (map (ppr_dict) theta)))
- <>
- ptext SLIT(" =>")
- where
- ppr_dict (clas,tys) = ppr clas <+> hsep (map pprParendType tys)
+ppr_decl_context [] = empty
+ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
+
+pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files
+pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
\end{code}
%************************************************************************
ns' = filter (/= name) ns
upp_export [] = empty
-upp_export names = parens (hsep (map (upp_occname . getOccName) names))
+upp_export names = braces (hsep (map (upp_occname . getOccName) names))
upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi]
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
+import SMRep ( fixedItblSize,
+ rET_SMALL, rET_BIG,
+ rET_VEC_SMALL, rET_VEC_BIG
+ )
import Constants ( mIN_UPD_SIZE )
-import CLabel ( CLabel )
+import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd
)
-import HeapOffs ( hpRelToInt )
-import Literal ( Literal(..) )
+import Const ( Literal(..) )
import Maybes ( maybeToBool )
-import OrdList ( OrdList )
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable )
-import StixMacro ( macroCode )
+import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
+import StixMacro ( macroCode, checkCode )
import StixPrim ( primCode, amodeToStix, amodeToStix' )
-import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM )
+import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe, panic )
+import BitSet ( intBS )
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
volrestores = volatileRestores
p2stix = primCode
macro_code = macroCode
- hp_rel = hpRelToInt
-- real code follows... ---------
\end{code}
= genCodeStaticClosure stmt `thenUs` \ code ->
returnUs (StSegment DataSegment : StLabel label : code [])
- gentopcode stmt@(CRetUnVector _ _) = returnUs []
-
- gentopcode stmt@(CFlatRetVector label _)
+ gentopcode stmt@(CRetVector label _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
returnUs (StSegment TextSegment : code [StLabel label])
- gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
+ gentopcode stmt@(CRetDirect uniq absC srt liveness)
+ = gencode absC `thenUs` \ code ->
+ genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
+ returnUs (StSegment TextSegment :
+ itbl (StLabel lbl_info : StLabel lbl_ret : code []))
+ where
+ lbl_info = mkReturnInfoLabel uniq
+ lbl_ret = mkReturnPtLabel uniq
+ closure_type = case liveness of
+ LvSmall _ -> rET_SMALL
+ LvLarge _ -> rET_BIG
+
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
| slow_is_empty
= genCodeInfoTable stmt `thenUs` \ itbl ->
slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
slow_lbl = entryLabelFromCI cl_info
- gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) =
-- ToDo: what if this is empty? ------------------------^^^^
genCodeInfoTable stmt `thenUs` \ itbl ->
gencode slow `thenUs` \ slow_code ->
slow_lbl = entryLabelFromCI cl_info
fast_lbl = fastLabelFromCI cl_info
+ gentopcode stmt@(CSRT lbl closures)
+ = returnUs [ StSegment TextSegment
+ , StLabel lbl
+ , StData DataPtrRep (map StCLbl closures)
+ ]
+
+ gentopcode stmt@(CBitmap lbl mask)
+ = returnUs [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (StInt (toInteger (length mask)) :
+ map (StInt . toInteger . intBS) mask)
+ ]
+
gentopcode absC
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : code [])
\end{code}
-Vector tables are trivial!
-
\begin{code}
{-
genCodeVecTbl
:: AbstractC
-> UniqSM StixTreeList
-}
- genCodeVecTbl (CFlatRetVector label amodes)
- = returnUs (\xs -> vectbl : xs)
+ genCodeVecTbl (CRetVector label amodes srt liveness)
+ = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
+ returnUs (\xs -> vectbl : itbl xs)
where
vectbl = StData PtrRep (reverse (map a2stix amodes))
+ closure_type = case liveness of
+ LvSmall _ -> rET_VEC_SMALL
+ LvLarge _ -> rET_VEC_BIG
\end{code}
-Static closures are not so hard either.
-
\begin{code}
{-
genCodeStaticClosure
table = StData PtrRep (StCLbl info_lbl : body)
info_lbl = infoTableLabelFromCI cl_info
+ -- always at least one padding word: this is the static link field
+ -- for the garbage collector.
body = if closureUpdReqd cl_info then
- take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
+ take (1 + max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
else
- amodes'
+ amodes' ++ [StInt 0]
zeros = StInt 0 : zeros
\begin{code}
- gencode (CInitHdr cl_info reg_rel _ _)
+ gencode (CInitHdr cl_info reg_rel _)
= let
lhs = a2stix (CVal reg_rel PtrRep)
lbl = infoTableLabelFromCI cl_info
\end{code}
+Heap/Stack Checks.
+
+\begin{code}
+
+ gencode (CCheck macro args assts)
+ = gencode assts `thenUs` \assts_stix ->
+ checkCode macro args assts_stix
+
+\end{code}
+
Assignment, the curse of von Neumann, is the center of the code we
produce. In most cases, the type of the assignment is determined
by the type of the destination. However, when the destination can
Note that the new entry convention requires that we load the InfoPtr (R2)
with the address of the info table before jumping to the entry code for Node.
+For a vectored return, we must subtract the size of the info table to
+get at the return vector. This depends on the size of the info table,
+which varies depending on whether we're profiling etc.
+
\begin{code}
gencode (CJump dest)
= returnUs (\xs -> StJump dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table)
- (StInt (toInteger (-n-1))))
+ (StInt (toInteger (-n-fixedItblSize-1))))
gencode (CReturn table (DynamicVectoredReturn am))
= returnUs (\xs -> StJump dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
- dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
+ dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
+ StInt (toInteger (fixedItblSize+1))]
\end{code}
\begin{code}
- gencode (COpStmt results op args liveness_mask vols)
+ gencode (COpStmt results op args vols)
-- ToDo (ADR?): use that liveness mask
| primOpNeedsWrapper op
= let
other | simple_discrim -> mkSimpleSwitches discrim alts deflt
-- Otherwise, we need to do a bit of work.
- other -> getUnique `thenUs` \ u ->
+ other -> getUniqueUs `thenUs` \ u ->
gencode (AbsCStmts
(CAssign (CTemp u pk) discrim)
(CSwitch (CTemp u pk) alts deflt))
\end{code}
-Here, we generate a jump table if there are more than four (integer) alternatives and
-the jump table occupancy is greater than 50%. Otherwise, we generate a binary
-comparison tree. (Perhaps this could be tuned.)
+Here, we generate a jump table if there are more than four (integer)
+alternatives and the jump table occupancy is greater than 50%.
+Otherwise, we generate a binary comparison tree. (Perhaps this could
+be tuned.)
\begin{code}
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
import AsmRegAlloc ( runRegAllocate )
import OrdList ( OrdList )
import PrimOp ( commutableOp, PrimOp(..) )
-import PrimRep ( PrimRep{-instance Eq-} )
import RegAllocInfo ( mkMRegsState, MRegsState )
-import Stix ( StixTree(..), StixReg(..), CodeSegment )
-import UniqSupply ( returnUs, thenUs, mapUs, UniqSM, UniqSupply )
+import Stix ( StixTree(..), StixReg(..) )
+import PrimRep ( isFloatingRep )
+import UniqSupply ( returnUs, thenUs, mapUs, initUs, UniqSM, UniqSupply )
+import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
import Outputable
+
+import GlaExts (trace) --tmp
+#include "nativeGen/NCG.h"
\end{code}
The 96/03 native-code generator has machine-independent and
\begin{code}
writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO ()
writeRealAsm handle absC us
- = _scc_ "writeRealAsm" (printForAsm handle (runNCG absC us))
+ = -- _scc_ "writeRealAsm"
+ printForAsm handle (initUs us (runNCG absC))
dumpRealAsm :: AbstractC -> UniqSupply -> SDoc
-dumpRealAsm = runNCG
+dumpRealAsm absC us = initUs us (runNCG absC)
runNCG absC
= genCodeAbstractC absC `thenUs` \ treelists ->
let
stix = map (map genericOpt) treelists
in
+#if i386_TARGET_ARCH
+ let
+ stix' = map floatFix stix
+ in
+ codeGen stix'
+#else
codeGen stix
+#endif
\end{code}
@codeGen@ is the top-level code-generation function:
\begin{code}
primOpt op args = StPrim op args
\end{code}
+
+-----------------------------------------------------------------------------
+Fix up floating point operations for x86.
+
+The problem is that the code generator can't handle the weird register
+naming scheme for floating point registers on the x86, so we have to
+deal with memory-resident floating point values wherever possible.
+
+We therefore can't stand references to floating-point kinded temporary
+variables, and try to translate them into memory addresses wherever
+possible.
+
+\begin{code}
+floatFix :: [StixTree] -> [StixTree]
+floatFix trees = fltFix emptyUFM trees
+
+fltFix :: UniqFM StixTree -- mapping tmp vars to memory locations
+ -> [StixTree]
+ -> [StixTree]
+fltFix locs [] = []
+
+-- The case we're interested in: loading a temporary from a memory
+-- address. Eliminate the instruction and replace all future references
+-- to the temporary with the memory address.
+fltFix locs ((StAssign rep (StReg (StixTemp uq _)) loc) : trees)
+ | isFloatingRep rep = trace "found one" $ fltFix (addToUFM locs uq loc) trees
+
+fltFix locs ((StAssign rep src dst) : trees)
+ = StAssign rep (fltFix1 locs src) (fltFix1 locs dst) : fltFix locs trees
+
+fltFix locs (tree : trees)
+ = fltFix1 locs tree : fltFix locs trees
+
+
+fltFix1 :: UniqFM StixTree -> StixTree -> StixTree
+fltFix1 locs r@(StReg (StixTemp uq rep))
+ | isFloatingRep rep = case lookupUFM locs uq of
+ Nothing -> panic "fltFix1"
+ Just tree -> trace "substed" $ tree
+
+fltFix1 locs (StIndex rep l r) =
+ StIndex rep (fltFix1 locs l) (fltFix1 locs r)
+
+fltFix1 locs (StInd rep tree) =
+ StInd rep (fltFix1 locs tree)
+
+fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign"
+
+fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree)
+
+fltFix1 locs (StCondJump label tree) =
+ StCondJump label (fltFix1 locs tree)
+
+fltFix1 locs (StPrim op trees) =
+ StPrim op (map (fltFix1 locs) trees)
+
+fltFix1 locs (StCall f conv rep trees) =
+ StCall f conv rep (map (fltFix1 locs) trees)
+
+fltFix1 locs tree = tree
+\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[AsmRegAlloc]{Register allocator}
import MachRegs
import RegAllocInfo
-import AbsCSyn ( MagicId )
-import BitSet ( BitSet )
import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
import Maybes ( maybeToBool )
import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
flattenOrdList, OrdList
)
-import Stix ( StixTree )
import Unique ( mkBuiltinUnique )
import Util ( mapAccumB, panic, trace )
import Outputable
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[MachCode]{Generating machine code}
import Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..), showPrimOp )
+import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getUniqLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..)
mapAccumLUs, UniqSM
)
import Outputable
+import GlaExts (trace) --tmp
\end{code}
Code extractor for an entire stix tree---stix statement level.
returnUs (mkSeqInstrs [LABEL lbl,
ASCII True (_UNPK_ s)],
ImmCLbl lbl)
+ -- the linker can handle simple arithmetic...
+ getData (StIndex rep (StCLbl lbl) (StInt off)) =
+ returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep)))
\end{code}
%************************************************************************
maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
maybeImm (StCLbl l) = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off)) =
+ Just (ImmIndex l (fromInteger (off * sizeOf rep)))
+
maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt
= Just (ImmInt (fromInteger i))
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
- _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop)
+ _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
returnUs code__2
assignFltCode pk dst src
- = getRegister dst `thenUs` \ register1 ->
+ = trace "assignFltCode: dodgy floating point instruction" $
+ getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
--getNewRegNCG (registerRep register2)
-- `thenUs` \ tmp ->
_interface_ MachMisc 1
_exports_
-MachMisc fixedHdrSizeInWords fmtAsmLbl varHdrSizeInWords underscorePrefix;
+MachMisc fixedHdrSize fmtAsmLbl underscorePrefix;
_declarations_
-1 fixedHdrSizeInWords _:_ PrelBase.Int ;;
+1 fixedHdrSize _:_ PrelBase.Int ;;
2 fmtAsmLbl _:_ PrelBase.String -> PrelBase.String ;;
-1 varHdrSizeInWords _:_ SMRep.SMRep -> PrelBase.Int ;;
1 underscorePrefix _:_ PrelBase.Bool ;;
--- /dev/null
+__interface MachMisc 1 0 where
+__export MachMisc fixedHdrSize fmtAsmLbl underscorePrefix;
+1 fixedHdrSize :: PrelBase.Int ;
+2 fmtAsmLbl :: PrelBase.String -> PrelBase.String ;
+1 underscorePrefix :: PrelBase.Bool ;
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[MachMisc]{Description of various machine-specific things}
module MachMisc (
- fixedHdrSizeInWords, varHdrSizeInWords,
- charLikeSize, intLikeSize, mutHS, dataHS, fixedHS, foHS,
sizeOf, primRepToSize,
eXTRA_STK_ARGS_HERE,
volatileSaves, volatileRestores,
- storageMgrInfo, smCAFlist, smOldLim, smOldMutables,
- smStablePtrTable,
-
targetMaxDouble, targetMaxInt, targetMinDouble, targetMinInt,
underscorePrefix,
) where
#include "HsVersions.h"
+--#include "config.h"
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import CLabel ( CLabel )
-import CmdLineOpts ( opt_SccProfilingOn )
-import Literal ( mkMachInt, Literal(..) )
+import Const ( mkMachInt, Literal(..) )
import MachRegs ( stgReg, callerSaves, RegLoc(..),
Imm(..), Reg(..),
MachRegsAddr(..)
)
-import OrdList ( OrdList )
import PrimRep ( PrimRep(..) )
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Stix ( StixTree(..), StixReg(..), sStLitLbl,
- CodeSegment
- )
+import SMRep ( SMRep(..) )
+import Stix ( StixTree(..), StixReg(..), CodeSegment )
import Util ( panic )
import Char ( isDigit )
import GlaExts ( word2Int#, int2Word#, shiftRL#, and#, (/=#) )
\begin{code}
underscorePrefix :: Bool -- leading underscore on assembler labels?
-underscorePrefix
- = IF_ARCH_alpha(False
- ,{-else-} IF_ARCH_i386(
- IF_OS_linuxaout(True
- , IF_OS_freebsd(True
- , IF_OS_cygwin32(True
- , IF_OS_bsdi(True
- , {-otherwise-} False)))
- )
- ,{-else-}IF_ARCH_sparc(
- IF_OS_sunos4(True, {-otherwise-} False)
- ,)))
+#ifdef LEADING_UNDERSCORE
+underscorePrefix = True
+#else
+underscorePrefix = False
+#endif
---------------------------
fmtAsmLbl :: String -> String -- for formatting labels
= IF_ARCH_alpha(0, IF_ARCH_i386(23{-6x4bytes-}, IF_ARCH_sparc(23,???)))
\end{code}
-% ----------------------------------------------------------------
-
-@fixedHdrSizeInWords@ and @varHdrSizeInWords@: these are not dependent
-on target architecture.
-\begin{code}
-fixedHdrSizeInWords :: Int
-
-fixedHdrSizeInWords
- = 1{-info ptr-} + profFHS + parFHS + tickyFHS
- -- obviously, we aren't taking non-sequential too seriously yet
- where
- profFHS = if opt_SccProfilingOn then 1 else 0
- parFHS = {-if PAR or GRAN then 1 else-} 0
- tickyFHS = {-if ticky ... then 1 else-} 0
-
-varHdrSizeInWords :: SMRep -> Int{-in words-}
-
-varHdrSizeInWords sm
- = case sm of
- StaticRep _ _ -> 0
- SpecialisedRep _ _ _ _ -> 0
- GenericRep _ _ _ -> 0
- BigTupleRep _ -> 1
- MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -}
- DataRep _ -> 1
- DynamicRep -> 2
- BlackHoleRep -> 0
- PhantomRep -> panic "MachMisc.varHdrSizeInWords:phantom"
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-Static closure sizes:
-\begin{code}
-charLikeSize, intLikeSize :: Int
-
-charLikeSize = blahLikeSize CharLikeRep
-intLikeSize = blahLikeSize IntLikeRep
-
-blahLikeSize blah
- = fromInteger (sizeOf PtrRep)
- * (fixedHdrSizeInWords + varHdrSizeInWords blahLikeRep + 1)
- where
- blahLikeRep = SpecialisedRep blah 0 1 SMNormalForm
-
---------
-mutHS, dataHS, fixedHS, foHS :: StixTree
-
-mutHS = blah_hs (MuTupleRep 0)
-dataHS = blah_hs (DataRep 0)
-fixedHS = StInt (toInteger fixedHdrSizeInWords)
-
-{- Semi-hack: to avoid introducing ForeignObjRep,
- we hard-code the VHS for ForeignObj here.
--}
-foHS
- = StInt (toInteger words)
- where
- words = fixedHdrSizeInWords + 1{-FOREIGN_VHS-}
-
-blah_hs blah
- = StInt (toInteger words)
- where
- words = fixedHdrSizeInWords + varHdrSizeInWords blah
-\end{code}
-
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Size of a @PrimRep@, in bytes.
\begin{code}
volatileSaves, volatileRestores :: [MagicId] -> [StixTree]
-save_cands = [BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg]
-restore_cands = save_cands ++ [StkStubReg,StdUpdRetVecReg]
+save_cands = [BaseReg,Sp,Su,SpLim,Hp,HpLim]
+restore_cands = save_cands
volatileSaves vols
= map save ((filter callerSaves) (save_cands ++ vols))
\begin{code}
targetMinDouble = MachDouble (-1.7976931348623157e+308)
targetMaxDouble = MachDouble (1.7976931348623157e+308)
-targetMinInt = mkMachInt (-2147483647)
+targetMinInt = mkMachInt (-2147483648)
targetMaxInt = mkMachInt 2147483647
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-Storage manager nonsense. Note that the indices are dependent on
-the definition of the smInfo structure in SMinterface.lh
-
-\begin{code}
-storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
-
-storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
-smCAFlist = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
-smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
-smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
-smStablePtrTable = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
This algorithm for determining the $\log_2$ of exact powers of 2 comes
from GCC. It requires bit manipulation primitives, and we use GHC
extensions. Tough.
primRepToSize DoubleRep = IF_ARCH_alpha( TF, IF_ARCH_i386( DF,IF_ARCH_sparc( DF,)))
primRepToSize ArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
primRepToSize ByteArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize WeakPtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize ForeignObjRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
primRepToSize StablePtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
-primRepToSize ForeignObjRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
\end{code}
%************************************************************************
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[MachRegs]{Machine-specific info about registers}
import CLabel ( CLabel )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
-import Stix ( sStLitLbl, StixTree(..), StixReg(..),
- CodeSegment
- )
+import Stix ( sStLitLbl, StixTree(..), StixReg(..) )
import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
Uniquable(..), Unique
)
-import UniqSupply ( getUnique, returnUs, thenUs, UniqSM )
+import UniqSupply ( getUniqueUs, returnUs, thenUs, UniqSM )
import Outputable
\end{code}
| ImmCLbl CLabel -- AbstractC Label (with baggage)
| ImmLab SDoc -- Simple string label (underscore-able)
| ImmLit SDoc -- Simple string
+ | ImmIndex CLabel Int
IF_ARCH_sparc(
| LO Imm -- Possible restrictions...
| HI Imm
Nothing -> sStLitLbl SLIT("MainRegTable")
nonReg = case x of
- StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
- StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
BaseReg -> sStLitLbl SLIT("MainRegTable")
- -- these Hp&HpLim cases perhaps should
- -- not be here for i386 (???) WDP 96/03
-#ifndef i386_TARGET_ARCH
- -- Yup, Hp&HpLim are not mapped into registers for x86's at the mo, so
- -- fetching Hp off BaseReg is the sensible option, since that's
- -- where gcc generated code stuffs/expects it (RTBL_Hp & RTBL_HpLim).
- -- SOF 97/09
- -- In fact, why use StorageMgrInfo at all?
- Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
- HpLim -> StInd PtrRep (sStLitLbl
- (_PK_ ("StorageMgrInfo+" ++ BYTES_PER_WORD_STR)))
-#endif
- TagReg -> StInd IntRep (StPrim IntSubOp [infoptr,
- StInt (1*BYTES_PER_WORD)])
- where
- r2 = VanillaReg PtrRep ILIT(2)
- infoptr = case (stgReg r2) of
- Always t -> t
- Save _ -> StReg (StixMagicId r2)
+
_ -> StInd (magicIdPrimRep x)
(StPrim IntAddOp [baseLoc,
StInt (toInteger (offset*BYTES_PER_WORD))])
getNewRegNCG :: PrimRep -> UniqSM Reg
getNewRegNCG pk
- = getUnique `thenUs` \ u ->
+ = getUniqueUs `thenUs` \ u ->
returnUs (UnmappedReg u pk)
instance Text Reg where
compare a b = cmpReg a b
instance Uniquable Reg where
- uniqueOf (UnmappedReg u _) = u
- uniqueOf (FixedReg i) = mkPseudoUnique1 IBOX(i)
- uniqueOf (MappedReg i) = mkPseudoUnique2 IBOX(i)
- uniqueOf (MemoryReg i _) = mkPseudoUnique3 i
+ getUnique (UnmappedReg u _) = u
+ getUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
+ getUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
+ getUnique (MemoryReg i _) = mkPseudoUnique3 i
\end{code}
\begin{code}
fReg x = (8 + x)
st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg
-eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
-ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 }
-ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 }
-edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 }
-esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 }
-edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 }
-ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 }
-esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 }
-st0 = realReg (fReg 0)
-st1 = realReg (fReg 1)
-st2 = realReg (fReg 2)
-st3 = realReg (fReg 3)
-st4 = realReg (fReg 4)
-st5 = realReg (fReg 5)
-st6 = realReg (fReg 6)
-st7 = realReg (fReg 7)
+eax = realReg (gReg 0)
+ebx = realReg (gReg 1)
+ecx = realReg (gReg 2)
+edx = realReg (gReg 3)
+esi = realReg (gReg 4)
+edi = realReg (gReg 5)
+ebp = realReg (gReg 6)
+esp = realReg (gReg 7)
+st0 = realReg (fReg 0)
+st1 = realReg (fReg 1)
+st2 = realReg (fReg 2)
+st3 = realReg (fReg 3)
+st4 = realReg (fReg 4)
+st5 = realReg (fReg 5)
+st6 = realReg (fReg 6)
+st7 = realReg (fReg 7)
#endif
\end{code}
\begin{code}
baseRegOffset :: MagicId -> Int
-baseRegOffset StkOReg = OFFSET_StkO
baseRegOffset (VanillaReg _ ILIT(1)) = OFFSET_R1
baseRegOffset (VanillaReg _ ILIT(2)) = OFFSET_R2
baseRegOffset (VanillaReg _ ILIT(3)) = OFFSET_R3
baseRegOffset (VanillaReg _ ILIT(6)) = OFFSET_R6
baseRegOffset (VanillaReg _ ILIT(7)) = OFFSET_R7
baseRegOffset (VanillaReg _ ILIT(8)) = OFFSET_R8
-baseRegOffset (FloatReg ILIT(1)) = OFFSET_Flt1
-baseRegOffset (FloatReg ILIT(2)) = OFFSET_Flt2
-baseRegOffset (FloatReg ILIT(3)) = OFFSET_Flt3
-baseRegOffset (FloatReg ILIT(4)) = OFFSET_Flt4
-baseRegOffset (DoubleReg ILIT(1)) = OFFSET_Dbl1
-baseRegOffset (DoubleReg ILIT(2)) = OFFSET_Dbl2
+baseRegOffset (FloatReg ILIT(1)) = OFFSET_F1
+baseRegOffset (FloatReg ILIT(2)) = OFFSET_F2
+baseRegOffset (FloatReg ILIT(3)) = OFFSET_F3
+baseRegOffset (FloatReg ILIT(4)) = OFFSET_F4
+baseRegOffset (DoubleReg ILIT(1)) = OFFSET_D1
+baseRegOffset (DoubleReg ILIT(2)) = OFFSET_D2
+baseRegOffset Sp = OFFSET_Sp
+baseRegOffset Su = OFFSET_Su
+baseRegOffset SpLim = OFFSET_SpLim
#ifdef OFFSET_Lng1
baseRegOffset (LongReg _ ILIT(1)) = OFFSET_Lng1
#endif
#ifdef OFFSET_Lng2
baseRegOffset (LongReg _ ILIT(2)) = OFFSET_Lng2
#endif
-baseRegOffset TagReg = OFFSET_Tag
-baseRegOffset RetReg = OFFSET_Ret
-baseRegOffset SpA = OFFSET_SpA
-baseRegOffset SuA = OFFSET_SuA
-baseRegOffset SpB = OFFSET_SpB
-baseRegOffset SuB = OFFSET_SuB
baseRegOffset Hp = OFFSET_Hp
baseRegOffset HpLim = OFFSET_HpLim
-baseRegOffset LivenessReg = OFFSET_Liveness
#ifdef DEBUG
baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
-baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
-baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg"
baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre"
baseRegOffset VoidReg = panic "baseRegOffset:VoidReg"
#endif
#ifdef CALLER_SAVES_Base
callerSaves BaseReg = True
#endif
-#ifdef CALLER_SAVES_StkO
-callerSaves StkOReg = True
-#endif
#ifdef CALLER_SAVES_R1
callerSaves (VanillaReg _ ILIT(1)) = True
#endif
#ifdef CALLER_SAVES_R8
callerSaves (VanillaReg _ ILIT(8)) = True
#endif
-#ifdef CALLER_SAVES_FltReg1
+#ifdef CALLER_SAVES_F1
callerSaves (FloatReg ILIT(1)) = True
#endif
-#ifdef CALLER_SAVES_FltReg2
+#ifdef CALLER_SAVES_F2
callerSaves (FloatReg ILIT(2)) = True
#endif
-#ifdef CALLER_SAVES_FltReg3
+#ifdef CALLER_SAVES_F3
callerSaves (FloatReg ILIT(3)) = True
#endif
-#ifdef CALLER_SAVES_FltReg4
+#ifdef CALLER_SAVES_F4
callerSaves (FloatReg ILIT(4)) = True
#endif
-#ifdef CALLER_SAVES_DblReg1
+#ifdef CALLER_SAVES_D1
callerSaves (DoubleReg ILIT(1)) = True
#endif
-#ifdef CALLER_SAVES_DblReg2
+#ifdef CALLER_SAVES_D2
callerSaves (DoubleReg ILIT(2)) = True
#endif
-#ifdef CALLER_SAVES_LngReg1
+#ifdef CALLER_SAVES_L1
callerSaves (LongReg _ ILIT(1)) = True
#endif
-#ifdef CALLER_SAVES_LngReg2
-callerSaves (LongReg _ ILIT(2)) = True
-#endif
-#ifdef CALLER_SAVES_Tag
-callerSaves TagReg = True
-#endif
-#ifdef CALLER_SAVES_Ret
-callerSaves RetReg = True
-#endif
-#ifdef CALLER_SAVES_SpA
-callerSaves SpA = True
+#ifdef CALLER_SAVES_Sp
+callerSaves Sp = True
#endif
-#ifdef CALLER_SAVES_SuA
-callerSaves SuA = True
+#ifdef CALLER_SAVES_Su
+callerSaves Su = True
#endif
-#ifdef CALLER_SAVES_SpB
-callerSaves SpB = True
-#endif
-#ifdef CALLER_SAVES_SuB
-callerSaves SuB = True
+#ifdef CALLER_SAVES_SpLim
+callerSaves SpLim = True
#endif
#ifdef CALLER_SAVES_Hp
callerSaves Hp = True
#ifdef CALLER_SAVES_HpLim
callerSaves HpLim = True
#endif
-#ifdef CALLER_SAVES_Liveness
-callerSaves LivenessReg = True
-#endif
-#ifdef CALLER_SAVES_StdUpdRetVec
-callerSaves StdUpdRetVecReg = True
-#endif
-#ifdef CALLER_SAVES_StkStub
-callerSaves StkStubReg = True
-#endif
callerSaves _ = False
\end{code}
#ifdef REG_Base
magicIdRegMaybe BaseReg = Just (FixedReg ILIT(REG_Base))
#endif
-#ifdef REG_StkO
-magicIdRegMaybe StkOReg = Just (FixedReg ILIT(REG_StkOReg))
-#endif
#ifdef REG_R1
magicIdRegMaybe (VanillaReg _ ILIT(1)) = Just (FixedReg ILIT(REG_R1))
#endif
#ifdef REG_R8
magicIdRegMaybe (VanillaReg _ ILIT(8)) = Just (FixedReg ILIT(REG_R8))
#endif
-#ifdef REG_Flt1
-magicIdRegMaybe (FloatReg ILIT(1)) = Just (FixedReg ILIT(REG_Flt1))
+#ifdef REG_F1
+magicIdRegMaybe (FloatReg ILIT(1)) = Just (FixedReg ILIT(REG_F1))
#endif
-#ifdef REG_Flt2
-magicIdRegMaybe (FloatReg ILIT(2)) = Just (FixedReg ILIT(REG_Flt2))
+#ifdef REG_F2
+magicIdRegMaybe (FloatReg ILIT(2)) = Just (FixedReg ILIT(REG_F2))
#endif
-#ifdef REG_Flt3
-magicIdRegMaybe (FloatReg ILIT(3)) = Just (FixedReg ILIT(REG_Flt3))
+#ifdef REG_F3
+magicIdRegMaybe (FloatReg ILIT(3)) = Just (FixedReg ILIT(REG_F3))
#endif
-#ifdef REG_Flt4
-magicIdRegMaybe (FloatReg ILIT(4)) = Just (FixedReg ILIT(REG_Flt4))
+#ifdef REG_F4
+magicIdRegMaybe (FloatReg ILIT(4)) = Just (FixedReg ILIT(REG_F4))
#endif
-#ifdef REG_Dbl1
-magicIdRegMaybe (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_Dbl1))
+#ifdef REG_D1
+magicIdRegMaybe (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_D1))
#endif
-#ifdef REG_Dbl2
-magicIdRegMaybe (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_Dbl2))
+#ifdef REG_D2
+magicIdRegMaybe (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_D2))
+#endif
+#ifdef REG_Sp
+magicIdRegMaybe Sp = Just (FixedReg ILIT(REG_Sp))
#endif
#ifdef REG_Lng1
magicIdRegMaybe (LongReg _ ILIT(1)) = Just (FixedReg ILIT(REG_Lng1))
#ifdef REG_Lng2
magicIdRegMaybe (LongReg _ ILIT(2)) = Just (FixedReg ILIT(REG_Lng2))
#endif
-#ifdef REG_Tag
-magicIdRegMaybe TagReg = Just (FixedReg ILIT(REG_TagReg))
-#endif
-#ifdef REG_Ret
-magicIdRegMaybe RetReg = Just (FixedReg ILIT(REG_Ret))
-#endif
-#ifdef REG_SpA
-magicIdRegMaybe SpA = Just (FixedReg ILIT(REG_SpA))
+#ifdef REG_Su
+magicIdRegMaybe Su = Just (FixedReg ILIT(REG_Su))
#endif
-#ifdef REG_SuA
-magicIdRegMaybe SuA = Just (FixedReg ILIT(REG_SuA))
-#endif
-#ifdef REG_SpB
-magicIdRegMaybe SpB = Just (FixedReg ILIT(REG_SpB))
-#endif
-#ifdef REG_SuB
-magicIdRegMaybe SuB = Just (FixedReg ILIT(REG_SuB))
+#ifdef REG_SpLim
+magicIdRegMaybe SpLim = Just (FixedReg ILIT(REG_SpLim))
#endif
#ifdef REG_Hp
magicIdRegMaybe Hp = Just (FixedReg ILIT(REG_Hp))
#ifdef REG_HpLim
magicIdRegMaybe HpLim = Just (FixedReg ILIT(REG_HpLim))
#endif
-#ifdef REG_Liveness
-magicIdRegMaybe LivenessReg = Just (FixedReg ILIT(REG_Liveness))
-#endif
-#ifdef REG_StdUpdRetVec
-magicIdRegMaybe StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
-#endif
-#ifdef REG_StkStub
-magicIdRegMaybe StkStubReg = Just (FixedReg ILIT(REG_StkStub))
-#endif
magicIdRegMaybe _ = Nothing
\end{code}
#ifdef REG_Base
freeReg ILIT(REG_Base) = _FALSE_
#endif
-#ifdef REG_StkO
-freeReg ILIT(REG_StkO) = _FALSE_
-#endif
#ifdef REG_R1
freeReg ILIT(REG_R1) = _FALSE_
#endif
#ifdef REG_R8
freeReg ILIT(REG_R8) = _FALSE_
#endif
-#ifdef REG_Flt1
-freeReg ILIT(REG_Flt1) = _FALSE_
+#ifdef REG_F1
+freeReg ILIT(REG_F1) = _FALSE_
#endif
-#ifdef REG_Flt2
-freeReg ILIT(REG_Flt2) = _FALSE_
+#ifdef REG_F2
+freeReg ILIT(REG_F2) = _FALSE_
#endif
-#ifdef REG_Flt3
-freeReg ILIT(REG_Flt3) = _FALSE_
+#ifdef REG_F3
+freeReg ILIT(REG_F3) = _FALSE_
#endif
-#ifdef REG_Flt4
-freeReg ILIT(REG_Flt4) = _FALSE_
+#ifdef REG_F4
+freeReg ILIT(REG_F4) = _FALSE_
#endif
-#ifdef REG_Dbl1
-freeReg ILIT(REG_Dbl1) = _FALSE_
+#ifdef REG_D1
+freeReg ILIT(REG_D1) = _FALSE_
#endif
-#ifdef REG_Dbl2
-freeReg ILIT(REG_Dbl2) = _FALSE_
+#ifdef REG_D2
+freeReg ILIT(REG_D2) = _FALSE_
#endif
-#ifdef REG_Tag
-freeReg ILIT(REG_Tag) = _FALSE_
+#ifdef REG_Sp
+freeReg ILIT(REG_Sp) = _FALSE_
#endif
-#ifdef REG_Ret
-freeReg ILIT(REG_Ret) = _FALSE_
+#ifdef REG_Su
+freeReg ILIT(REG_Su) = _FALSE_
#endif
-#ifdef REG_SpA
-freeReg ILIT(REG_SpA) = _FALSE_
-#endif
-#ifdef REG_SuA
-freeReg ILIT(REG_SuA) = _FALSE_
-#endif
-#ifdef REG_SpB
-freeReg ILIT(REG_SpB) = _FALSE_
-#endif
-#ifdef REG_SuB
-freeReg ILIT(REG_SuB) = _FALSE_
+#ifdef REG_SpLim
+freeReg ILIT(REG_SpLim) = _FALSE_
#endif
#ifdef REG_Hp
freeReg ILIT(REG_Hp) = _FALSE_
#ifdef REG_HpLim
freeReg ILIT(REG_HpLim) = _FALSE_
#endif
-#ifdef REG_Liveness
-freeReg ILIT(REG_Liveness) = _FALSE_
-#endif
-#ifdef REG_StdUpdRetVec
-freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
-#endif
-#ifdef REG_StkStub
-freeReg ILIT(REG_StkStub) = _FALSE_
-#endif
-freeReg _ = _TRUE_
freeReg n
-- we hang onto two double regs for dedicated
-- use; this is not necessary on Alphas and
-- may not be on other non-SPARCs.
-#ifdef REG_Dbl1
- | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
+#ifdef REG_D1
+ | n _EQ_ (ILIT(REG_D1) _ADD_ ILIT(1)) = _FALSE_
#endif
-#ifdef REG_Dbl2
- | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
+#ifdef REG_D2
+ | n _EQ_ (ILIT(REG_D2) _ADD_ ILIT(1)) = _FALSE_
#endif
| otherwise = _TRUE_
\end{code}
#define FAST_REG_NO FAST_INT
-#include "../../includes/config.h"
+#include "../includes/config.h"
#if 0
{-testing only-}
-- HACK: go for the max
#endif
-#include "../../includes/MachRegs.h"
+#include "../includes/MachRegs.h"
+#include "../includes/NativeDefs.h"
#if alpha_TARGET_ARCH
# define BYTES_PER_WORD 8
# define BYTES_PER_WORD_STR "8"
-
-# if osf1_TARGET_OS
-# include "../../includes/alpha-dec-osf1.h"
-# endif
-# if osf3_TARGET_OS
-# include "../../includes/alpha-dec-osf3.h"
-# endif
#endif
#if i386_TARGET_ARCH
# define BYTES_PER_WORD 4
# define BYTES_PER_WORD_STR "4"
-
-# if linuxaout_TARGET_OS
-# include "../../includes/i386-unknown-linuxaout.h"
-# endif
-# if linux_TARGET_OS
-# include "../../includes/i386-unknown-linux.h"
-# endif
-# if freebsd_TARGET_OS
-# include "../../includes/i386-unknown-freebsd.h"
-# endif
-# if netbsd_TARGET_OS
-# include "../../includes/i386-unknown-netbsd.h"
-# endif
-# if bsdi_TARGET_OS
-# include "../../includes/i386-unknown-bsdi.h"
-# endif
-# if cygwin32_TARGET_OS
-# include "../../includes/i386-unknown-cygwin32.h"
-# endif
-# if solaris2_TARGET_OS
-# include "../../includes/i386-unknown-solaris2.h"
-# endif
#endif
#if sparc_TARGET_ARCH
# define BYTES_PER_WORD 4
# define BYTES_PER_WORD_STR "4"
-
-# if sunos4_TARGET_OS
-# include "../../includes/sparc-sun-sunos4.h"
-# endif
-# if solaris2_TARGET_OS
-# include "../../includes/sparc-sun-solaris2.h"
-# endif
#endif
---------------------------------------------
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[PprMach]{Pretty-printing assembly language}
import MachRegs -- may differ per-platform
import MachMisc
-import AbsCSyn ( MagicId )
import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
import CStrings ( charToC )
import Maybes ( maybeToBool )
-import OrdList ( OrdList )
-import Stix ( CodeSegment(..), StixTree )
+import Stix ( CodeSegment(..) )
import Char ( isPrint, isDigit )
import Outputable
\end{code}
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
pprImm (ImmCLbl l) = pprCLabel_asm l
+pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
pprImm (ImmLit s) = s
pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s
--UNUSED: HB -> SLIT("\t.byte\t")
--UNUSED: S -> SLIT("\t.word\t")
L -> SLIT("\t.long\t")
- F -> SLIT("\t.long\t")
+ F -> SLIT("\t.float\t")
DF -> SLIT("\t.double\t")
#endif
#if sparc_TARGET_ARCH
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[RegAllocInfo]{Machine-specific info used for register allocation}
import MachRegs
import MachCode ( InstrList )
-import AbsCSyn ( MagicId )
import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet )
import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} )
import FiniteMap ( addToFM, lookupFM, FiniteMap )
-import OrdList ( mkUnitList, OrdList )
+import OrdList ( mkUnitList )
import PrimRep ( PrimRep(..) )
-import Stix ( StixTree, CodeSegment )
import UniqSet -- quite a bit of it
import Outputable
\end{code}
FISUBR sz asrc -> usage (addrToRegs asrc) [st0]
FTST -> usage [st0] []
FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs
- FUCOMPP -> usage [st0, st1] [] -- allFPRegs
+ FUCOMPP -> usage [st0, st1] [st0, st1] -- allFPRegs
FXCH -> usage [st0, st1] [st0, st1]
FNSTSW -> usage [] [eax]
_ -> noUsage
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
sStLitLbl,
- stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
- stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg,
- stgStdUpdRetVecReg, stgStkStubReg,
- getUniqLabelNCG
+ stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim, stgTagReg,
+ getUniqLabelNCG,
+
+ fixedHS, arrHS
) where
#include "HsVersions.h"
import Ratio ( Rational )
-import AbsCSyn ( node, infoptr, MagicId(..) )
+import AbsCSyn ( node, tagreg, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
import CLabel ( mkAsmTempLabel, CLabel )
import PrimRep ( PrimRep )
import PrimOp ( PrimOp )
import Unique ( Unique )
-import UniqSupply ( returnUs, thenUs, getUnique, UniqSM )
+import SMRep ( fixedHdrSize, arrHdrSize )
+import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
import Outputable
\end{code}
Stix Trees for STG registers:
\begin{code}
-stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA,
- stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg,
- stgStdUpdRetVecReg, stgStkStubReg :: StixTree
+stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
+ :: StixTree
stgBaseReg = StReg (StixMagicId BaseReg)
-stgStkOReg = StReg (StixMagicId StkOReg)
stgNode = StReg (StixMagicId node)
-stgInfoPtr = StReg (StixMagicId infoptr)
-stgTagReg = StReg (StixMagicId TagReg)
-stgRetReg = StReg (StixMagicId RetReg)
-stgSpA = StReg (StixMagicId SpA)
-stgSuA = StReg (StixMagicId SuA)
-stgSpB = StReg (StixMagicId SpB)
-stgSuB = StReg (StixMagicId SuB)
+stgTagReg = StReg (StixMagicId tagreg)
+stgSp = StReg (StixMagicId Sp)
+stgSu = StReg (StixMagicId Su)
+stgSpLim = StReg (StixMagicId SpLim)
stgHp = StReg (StixMagicId Hp)
stgHpLim = StReg (StixMagicId HpLim)
-stgLivenessReg = StReg (StixMagicId LivenessReg)
-stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg)
-stgStkStubReg = StReg (StixMagicId StkStubReg)
getUniqLabelNCG :: UniqSM CLabel
getUniqLabelNCG
- = getUnique `thenUs` \ u ->
+ = getUniqueUs `thenUs` \ u ->
returnUs (mkAsmTempLabel u)
+
+fixedHS = StInt (toInteger fixedHdrSize)
+arrHS = StInt (toInteger arrHdrSize)
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
-module StixInfo ( genCodeInfoTable ) where
+module StixInfo ( genCodeInfoTable, genBitmapInfoTable ) where
#include "HsVersions.h"
-import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo,
- RegRelative, MagicId, CStmtMacro
- )
-import ClosureInfo ( closurePtrsSize, closureSizeWithoutFixedHdr,
- closureNonHdrSize, closureSemiTag, maybeSelectorInfo,
- closureSMRep, closureLabelFromCI,
+import AbsCSyn ( AbstractC(..), Liveness(..) )
+import CLabel ( CLabel )
+import StgSyn ( SRT(..) )
+import ClosureInfo ( closurePtrsSize,
+ closureNonHdrSize, closureSMRep,
infoTableLabelFromCI
)
-import HeapOffs ( hpRelToInt )
-import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..) )
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
- isSpecRep
- )
+import SMRep ( SMRep(..), getSMRepClosureTypeInt )
import Stix -- all of it
-import StixPrim ( amodeToStix )
import UniqSupply ( returnUs, UniqSM )
-import Outputable ( hcat, ptext, int, char )
+import Outputable ( int )
+import BitSet ( intBS )
+
+import Bits
+import Word
\end{code}
Generating code for info tables (arrays of data).
\begin{code}
-static___rtbl = sStLitLbl SLIT("Static___rtbl") -- out here to avoid CAF (sigh)
-const___rtbl = sStLitLbl SLIT("Const___rtbl")
-charlike___rtbl = sStLitLbl SLIT("CharLike___rtbl")
-intlike___rtbl = sStLitLbl SLIT("IntLike___rtbl")
-gen_N___rtbl = sStLitLbl SLIT("Gen_N___rtbl")
-gen_S___rtbl = sStLitLbl SLIT("Gen_S___rtbl")
-gen_U___rtbl = sStLitLbl SLIT("Gen_U___rtbl")
-tuple___rtbl = sStLitLbl SLIT("Tuple___rtbl")
-data___rtbl = sStLitLbl SLIT("Data___rtbl")
-dyn___rtbl = sStLitLbl SLIT("Dyn___rtbl")
-
genCodeInfoTable
:: AbstractC
-> UniqSM StixTreeList
-genCodeInfoTable (CClosureInfoAndCode cl_info _ _ upd cl_descr _)
- = returnUs (\xs -> info : lbl : xs)
+genCodeInfoTable (CClosureInfoAndCode cl_info _ _ srt cl_descr)
+ = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
where
- info = StData PtrRep table
- lbl = StLabel info_lbl
-
- table = case sm_rep of
- StaticRep _ _ -> [
- StInt (toInteger ptrs),
- StInt (toInteger size),
- upd_code,
- static___rtbl,
- tag]
-
- SpecialisedRep ConstantRep _ _ _ -> [
- StCLbl closure_lbl,
- upd_code,
- const___rtbl,
- tag]
-
- SpecialisedRep CharLikeRep _ _ _ -> [
- upd_code,
- charlike___rtbl,
- tag]
-
- SpecialisedRep IntLikeRep _ _ _ -> [
- upd_code,
- intlike___rtbl,
- tag]
-
- SpecialisedRep _ _ _ updatable ->
- let rtbl = hcat (
- if is_selector then
- [ptext SLIT("Select__"),
- int select_word,
- ptext SLIT("_rtbl")]
- else
- [ptext (case updatable of
- SMNormalForm -> SLIT("Spec_N_")
- SMSingleEntry -> SLIT("Spec_S_")
- SMUpdatable -> SLIT("Spec_U_")
- ),
- int size,
- char '_',
- int ptrs,
- ptext SLIT("_rtbl")])
- in
- case updatable of
- SMNormalForm -> [upd_code, StLitLbl rtbl, tag]
- _ -> [StLitLbl rtbl, tag]
-
- GenericRep _ _ updatable ->
- let rtbl = case updatable of
- SMNormalForm -> gen_N___rtbl
- SMSingleEntry -> gen_S___rtbl
- SMUpdatable -> gen_U___rtbl
- in [
- StInt (toInteger ptrs),
- StInt (toInteger size),
- upd_code,
- rtbl,
- tag]
-
- BigTupleRep _ -> [
- tuple___rtbl,
- tag]
- DataRep _ -> [
- data___rtbl,
- tag]
- DynamicRep -> [
- dyn___rtbl,
- tag]
-
- PhantomRep -> [
- upd_code,
- info_unused, -- no rep table
- tag]
-
- info_lbl = infoTableLabelFromCI cl_info
- closure_lbl = closureLabelFromCI cl_info
-
- sm_rep = closureSMRep cl_info
- maybe_selector = maybeSelectorInfo cl_info
- is_selector = maybeToBool maybe_selector
- (Just (_, select_word)) = maybe_selector
-
- tag = StInt (toInteger (closureSemiTag cl_info))
-
- size = if isSpecRep sm_rep
- then closureNonHdrSize cl_info
- else hpRelToInt (closureSizeWithoutFixedHdr cl_info)
- ptrs = closurePtrsSize cl_info
-
- upd_code = amodeToStix upd
-
- info_unused = StInt (-1)
+ info_lbl = infoTableLabelFromCI cl_info
+
+ table = case srt_len of
+ 0 -> rest_of_table
+ _ -> srt_label : rest_of_table
+
+ rest_of_table =
+ [
+ {- par, prof, debug -}
+ StInt (toInteger layout_info)
+ , StInt (toInteger type_info)
+ ]
+
+ type_info :: Word32
+ type_info = (fromInt flags `shiftL` 24) .|.
+ (fromInt closure_type `shiftL` 16) .|.
+ (fromInt srt_len)
+
+ (srt_label,srt_len) =
+ case srt of
+ (lbl, NoSRT) -> (StInt 0, 0)
+ (lbl, SRT off len) ->
+ (StIndex DataPtrRep (StCLbl lbl)
+ (StInt (toInteger off)), len)
+
+ layout_info :: Word32
+ layout_info = (fromInt ptrs `shiftL` 16) .|. fromInt nptrs
+
+ ptrs = closurePtrsSize cl_info
+ nptrs = size - ptrs
+
+ size = closureNonHdrSize cl_info
+
+ closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
+
+ flags = 0 -- for now
+
+
+genBitmapInfoTable
+ :: Liveness
+ -> (CLabel, SRT)
+ -> Int
+ -> Bool -- must include SRT field (i.e. it's a vector)
+ -> UniqSM StixTreeList
+
+genBitmapInfoTable liveness srt closure_type include_srt
+ = returnUs (\xs -> StData PtrRep table : xs)
+
+ where
+ table = if srt_len == 0 && not include_srt then
+ rest_of_table
+ else
+ srt_label : rest_of_table
+
+ rest_of_table =
+ [
+ {- par, prof, debug -}
+ layout_info
+ , StInt (toInteger type_info)
+ ]
+
+ layout_info = case liveness of
+ LvSmall mask -> StInt (toInteger (intBS mask))
+ LvLarge lbl -> StCLbl lbl
+
+ type_info :: Word32
+ type_info = (fromInt flags `shiftL` 24) .|.
+ (fromInt closure_type `shiftL` 16) .|.
+ (fromInt srt_len)
+
+ (srt_label,srt_len) =
+ case srt of
+ (lbl, NoSRT) -> (StInt 0, 0)
+ (lbl, SRT off len) ->
+ (StIndex DataPtrRep (StCLbl lbl)
+ (StInt (toInteger off)), len)
+
+ flags = 0 -- for now
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
-module StixInteger (
- gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare,
- gmpInteger2Int, gmpInteger2Word,
- gmpInt2Integer, gmpString2Integer,
- encodeFloatingKind, decodeFloatingKind
- ) where
+module StixInteger (
+ gmpCompare,
+ gmpInteger2Int,
+ gmpInteger2Word,
+ gmpNegate
+ ) where
#include "HsVersions.h"
import MachMisc
import MachRegs
-import AbsCSyn -- bits and bobs...
+import AbsCSyn hiding (spRel) -- bits and bobs..
+import Const ( Literal(..) )
import CallConv ( cCallConv )
-import Constants ( mIN_MP_INT_SIZE )
-import Literal ( Literal(..) )
import OrdList ( OrdList )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
-import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
-import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim,
- StixTree(..), StixTreeList,
- CodeSegment, StixReg
- )
-import StixMacro ( macroCode, heapCheck )
+import SMRep ( arrHdrSize )
+import Stix ( sStLitLbl, StixTree(..), StixTreeList )
import UniqSupply ( returnUs, thenUs, UniqSM )
-import Util ( panic )
-\end{code}
-
-\begin{code}
-gmpTake1Return1
- :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
- -> FAST_STRING -- function name
- -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
- -- argument (4 parts)
- -> UniqSM StixTreeList
-
-argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
-argument2 = mpStruct 2
-result2 = mpStruct 2
-result3 = mpStruct 3
-result4 = mpStruct 4
-init2 = StCall SLIT("mpz_init") cCallConv VoidRep [result2]
-init3 = StCall SLIT("mpz_init") cCallConv VoidRep [result3]
-init4 = StCall SLIT("mpz_init") cCallConv VoidRep [result4]
-
-gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
- = let
- ar = amodeToStix car
- sr = amodeToStix csr
- dr = amodeToStix cdr
- liveness= amodeToStix clive
- aa = amodeToStix caa
- sa = amodeToStix csa
- da = amodeToStix cda
-
- space = mpSpace 2 1 [sa]
- oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
- safeHp = saveLoc Hp
- save = StAssign PtrRep safeHp oldHp
- (a1,a2,a3) = toStruct argument1 (aa,sa,da)
- mpz_op = StCall rtn cCallConv VoidRep [result2, argument1]
- restore = StAssign PtrRep stgHp safeHp
- (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
- in
- heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk .
- (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
-
-gmpTake2Return1
- :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
- -> FAST_STRING -- function name
- -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
- -- liveness + 2 arguments (3 parts each)
- -> UniqSM StixTreeList
-
-gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
- = let
- ar = amodeToStix car
- sr = amodeToStix csr
- dr = amodeToStix cdr
- liveness= amodeToStix clive
- aa1 = amodeToStix caa1
- sa1 = amodeToStix csa1
- da1 = amodeToStix cda1
- aa2 = amodeToStix caa2
- sa2 = amodeToStix csa2
- da2 = amodeToStix cda2
-
- space = mpSpace 3 1 [sa1, sa2]
- oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
- safeHp = saveLoc Hp
- save = StAssign PtrRep safeHp oldHp
- (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
- mpz_op = StCall rtn cCallConv VoidRep [result3, argument1, argument2]
- restore = StAssign PtrRep stgHp safeHp
- (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
- in
- heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk .
- (\xs -> a1 : a2 : a3 : a4 : a5 : a6
- : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
-
-gmpTake2Return2
- :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
- -- 2 results (3 parts each)
- -> FAST_STRING -- function name
- -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
- -- liveness + 2 arguments (3 parts each)
- -> UniqSM StixTreeList
-
-gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
- rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
- = let
- ar1 = amodeToStix car1
- sr1 = amodeToStix csr1
- dr1 = amodeToStix cdr1
- ar2 = amodeToStix car2
- sr2 = amodeToStix csr2
- dr2 = amodeToStix cdr2
- liveness= amodeToStix clive
- aa1 = amodeToStix caa1
- sa1 = amodeToStix csa1
- da1 = amodeToStix cda1
- aa2 = amodeToStix caa2
- sa2 = amodeToStix csa2
- da2 = amodeToStix cda2
-
- space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2]
- oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
- safeHp = saveLoc Hp
- save = StAssign PtrRep safeHp oldHp
- (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
- mpz_op = StCall rtn cCallConv VoidRep [result3, result4, argument1, argument2]
- restore = StAssign PtrRep stgHp safeHp
- (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
- (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
-
- in
- heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk .
- (\xs -> a1 : a2 : a3 : a4 : a5 : a6
- : save : init3 : init4 : mpz_op
- : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
\end{code}
Although gmpCompare doesn't allocate space, it does temporarily use
\begin{code}
gmpCompare
:: CAddrMode -- result (boolean)
- -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- alloc hp + 2 arguments (3 parts each)
-> UniqSM StixTreeList
-gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
+gmpCompare res args@(caa1,csa1,cda1, caa2,csa2,cda2)
= let
result = amodeToStix res
- hp = amodeToStix chp
+ scratch1 = scratch_space
+ scratch2 = StIndex IntRep scratch_space (StInt (toInteger mpIntSize))
aa1 = amodeToStix caa1
sa1 = amodeToStix csa1
da1 = amodeToStix cda1
sa2 = amodeToStix csa2
da2 = amodeToStix cda2
- argument1 = hp
- argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
- (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
- mpz_cmp = StCall SLIT("mpz_cmp") cCallConv IntRep [argument1, argument2]
+ (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2)
+ mpz_cmp = StCall SLIT("mpz_cmp") cCallConv IntRep [scratch1, scratch2]
r1 = StAssign IntRep result mpz_cmp
in
returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
\end{code}
-See the comment above regarding the heap check (or lack thereof).
-
\begin{code}
gmpInteger2Int
:: CAddrMode -- result
- -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
+ -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
-> UniqSM StixTreeList
-gmpInteger2Int res args@(chp, caa,csa,cda)
+gmpInteger2Int res args@(caa,csa,cda)
= let
result = amodeToStix res
- hp = amodeToStix chp
aa = amodeToStix caa
sa = amodeToStix csa
da = amodeToStix cda
- (a1,a2,a3) = toStruct hp (aa,sa,da)
- mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [hp]
+ (a1,a2,a3) = toStruct scratch_space (aa,sa,da)
+ mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [scratch_space]
r1 = StAssign IntRep result mpz_get_si
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
gmpInteger2Word
:: CAddrMode -- result
- -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
+ -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
-> UniqSM StixTreeList
-gmpInteger2Word res args@(chp, caa,csa,cda)
+gmpInteger2Word res args@(caa,csa,cda)
= let
result = amodeToStix res
- hp = amodeToStix chp
aa = amodeToStix caa
sa = amodeToStix csa
da = amodeToStix cda
- (a1,a2,a3) = toStruct hp (aa,sa,da)
- mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [hp]
+ (a1,a2,a3) = toStruct scratch_space (aa,sa,da)
+ mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [scratch_space]
r1 = StAssign WordRep result mpz_get_ui
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
-arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
-
---------------
-gmpInt2Integer
- :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
- -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
- -> UniqSM StixTreeList
-
-gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
- = getUniqLabelNCG `thenUs` \ zlbl ->
- getUniqLabelNCG `thenUs` \ nlbl ->
- getUniqLabelNCG `thenUs` \ jlbl ->
- let
- ar = amodeToStix car
- sr = amodeToStix csr
- dr = amodeToStix cdr
- hp = amodeToStix chp
- i = amodeToStix n
-
- h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
- size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
- h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
- (StInt (toInteger size))
- cts = StInd IntRep (StIndex IntRep hp dataHS)
- test1 = StPrim IntEqOp [i, StInt 0]
- test2 = StPrim IntLtOp [i, StInt 0]
- cjmp1 = StCondJump zlbl test1
- cjmp2 = StCondJump nlbl test2
- -- positive
- p1 = StAssign IntRep cts i
- p2 = StAssign IntRep sr (StInt 1)
- p3 = StJump (StCLbl jlbl)
- -- negative
- n0 = StLabel nlbl
- n1 = StAssign IntRep cts (StPrim IntNegOp [i])
- n2 = StAssign IntRep sr (StInt (-1))
- n3 = StJump (StCLbl jlbl)
- -- zero
- z0 = StLabel zlbl
- z1 = StAssign IntRep sr (StInt 0)
- -- everybody
- a0 = StLabel jlbl
- a1 = StAssign IntRep ar (StInt 1)
- a2 = StAssign PtrRep dr hp
- in
- returnUs (\xs ->
- case n of
- CLit (MachInt c _) ->
- if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
- else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
- else h1 : h2 : n1 : n2 : a1 : a2 : xs
- _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
- : n0 : n1 : n2 : n3 : z0 : z1
- : a0 : a1 : a2 : xs)
-
-gmpString2Integer
- :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
- -> (CAddrMode, CAddrMode) -- liveness, string
- -> UniqSM StixTreeList
-
-gmpString2Integer res@(car,csr,cdr) (liveness, str)
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let
- ar = amodeToStix car
- sr = amodeToStix csr
- dr = amodeToStix cdr
-
- len = case str of
- (CString s) -> _LENGTH_ s
- (CLit (MachStr s)) -> _LENGTH_ s
- _ -> panic "String2Integer"
- space = len `quot` 8 + 17 + mpIntSize +
- varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
- oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
- safeHp = saveLoc Hp
- save = StAssign PtrRep safeHp oldHp
- result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
- set_str = StCall SLIT("mpz_init_set_str") cCallConv IntRep
- [result, amodeToStix str, StInt 10]
- test = StPrim IntEqOp [set_str, StInt 0]
- cjmp = StCondJump ulbl test
- abort = StCall SLIT("abort") cCallConv VoidRep []
- join = StLabel ulbl
- restore = StAssign PtrRep stgHp safeHp
- (a1,a2,a3) = fromStruct result (ar,sr,dr)
- in
- macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
- `thenUs` \ heap_chk ->
-
- returnUs (heap_chk .
- (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
-
-mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
-
-encodeFloatingKind
- :: PrimRep
- -> CAddrMode -- result
- -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
- -- heap pointer for result, integer argument (3 parts), exponent
- -> UniqSM StixTreeList
-
-encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
- = let
- result = amodeToStix res
- hp = amodeToStix chp
- aa = amodeToStix caa
- sa = amodeToStix csa
- da = amodeToStix cda
- expon = amodeToStix cexpon
-
- pk' = if sizeOf FloatRep == sizeOf DoubleRep
- then DoubleRep
- else pk
- (a1,a2,a3) = toStruct hp (aa,sa,da)
- fn = case pk' of
- FloatRep -> SLIT("__encodeFloat")
- DoubleRep -> SLIT("__encodeDouble")
- _ -> panic "encodeFloatingKind"
- encode = StCall fn cCallConv pk' [hp, expon]
- r1 = StAssign pk' result encode
- in
- returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
-
-decodeFloatingKind
- :: PrimRep
- -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
- -- exponent result, integer result (3 parts)
- -> (CAddrMode, CAddrMode)
- -- heap pointer for exponent, floating argument
+gmpNegate
+ :: (CAddrMode,CAddrMode,CAddrMode) -- result
+ -> (CAddrMode,CAddrMode,CAddrMode) -- argument (3 parts)
-> UniqSM StixTreeList
-decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
+gmpNegate (rca, rcs, rcd) args@(ca, cs, cd)
= let
- exponr = amodeToStix cexponr
- ar = amodeToStix car
- sr = amodeToStix csr
- dr = amodeToStix cdr
- hp = amodeToStix chp
- arg = amodeToStix carg
-
- pk' = if sizeOf FloatRep == sizeOf DoubleRep
- then DoubleRep
- else pk
- setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
- fn = case pk' of
- FloatRep -> SLIT("__decodeFloat")
- DoubleRep -> SLIT("__decodeDouble")
- _ -> panic "decodeFloatingKind"
- decode = StCall fn cCallConv VoidRep [mantissa, hp, arg]
- (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
- a4 = StAssign IntRep exponr (StInd IntRep hp)
+ a = amodeToStix ca
+ s = amodeToStix cs
+ d = amodeToStix cd
+ ra = amodeToStix rca
+ rs = amodeToStix rcs
+ rd = amodeToStix rcd
+ a1 = StAssign IntRep ra a
+ a2 = StAssign IntRep rs (StPrim IntNegOp [s])
+ a3 = StAssign PtrRep rd d
in
- returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
-
-mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
-mpData_mantissa = mpData mantissa
+ returnUs (\xs -> a1 : a2 : a3 : xs)
\end{code}
Support for the Gnu GMP multi-precision package.
mpAlloc base = StInd IntRep base
mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
-
-mpSpace
- :: Int -- gmp structures needed
- -> Int -- number of results
- -> [StixTree] -- sizes to add for estimating result size
- -> StixTree -- total space
-
-mpSpace gmp res sizes
- = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
- where
- sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
- -- what's the magical 17 for?
- fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
- hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
\end{code}
-We don't have a truly portable way of allocating local temporaries, so
-we cheat and use space at the end of the heap. (Thus, negative
-offsets from HpLim are our temporaries.) Note that you must have
-performed a heap check which includes the space needed for these
-temporaries before you use them.
-
\begin{code}
-mpStruct :: Int -> StixTree
-mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
-
toStruct
:: StixTree
-> (StixTree, StixTree, StixTree)
= let
f1 = StAssign IntRep (mpAlloc str) alloc
f2 = StAssign IntRep (mpSize str) size
- f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
+ f3 = StAssign PtrRep (mpData str)
+ (StIndex PtrRep arr (StInt (toInteger arrHdrSize)))
in
(f1, f2, f3)
-fromStruct
- :: StixTree
- -> (StixTree, StixTree, StixTree)
- -> (StixTree, StixTree, StixTree)
-
-fromStruct str (alloc,size,arr)
- = let
- e1 = StAssign IntRep alloc (mpAlloc str)
- e2 = StAssign IntRep size (mpSize str)
- e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
- (StPrim IntNegOp [dataHS]))
- in
- (e1, e2, e3)
+scratch_space = sStLitLbl SLIT("stg_scratch_space")
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
-module StixMacro ( macroCode, heapCheck ) where
+module StixMacro ( macroCode, checkCode ) where
#include "HsVersions.h"
import MachMisc
import MachRegs
-import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
+import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
+ CCheckMacro(..) )
+import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
import CallConv ( cCallConv )
-import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
- sTD_UF_SIZE
- )
import OrdList ( OrdList )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import Stix
import UniqSupply ( returnUs, thenUs, UniqSM )
+import Outputable
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
closure address.
\begin{code}
-mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
-mkIntCLit_3 = mkIntCLit 3
-
macroCode
:: CStmtMacro -- statement macro
-> [CAddrMode] -- args
-> UniqSM StixTreeList
+\end{code}
+
+-----------------------------------------------------------------------------
+Argument satisfaction checks.
-macroCode ARGS_CHK_A_LOAD_NODE args
+\begin{code}
+macroCode ARGS_CHK_LOAD_NODE args
= getUniqLabelNCG `thenUs` \ ulbl ->
let
[words, lbl] = map amodeToStix args
- temp = StIndex PtrRep stgSpA words
- test = StPrim AddrGeOp [stgSuA, temp]
+ temp = StIndex PtrRep stgSp words
+ test = StPrim AddrGeOp [stgSu, temp]
cjmp = StCondJump ulbl test
assign = StAssign PtrRep stgNode lbl
join = StLabel ulbl
in
returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
-macroCode ARGS_CHK_A [words]
+macroCode ARGS_CHK [words]
= getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep stgSpA (amodeToStix words)
- test = StPrim AddrGeOp [stgSuA, temp]
+ let temp = StIndex PtrRep stgSp (amodeToStix words)
+ test = StPrim AddrGeOp [stgSu, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
returnUs (\xs -> cjmp : updatePAP : join : xs)
\end{code}
-Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
-sufficient arguments on the B stack, and perform a tail call to
-@UpdatePAP@ if the arguments are not there. The @_LOAD_NODE@ version
-also loads R1 with an appropriate closure address. Note that the
-directions are swapped relative to the A stack.
+-----------------------------------------------------------------------------
+Updating a CAF
-\begin{code}
-macroCode ARGS_CHK_B_LOAD_NODE args
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let
- [words, lbl] = map amodeToStix args
- temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
- test = StPrim AddrGeOp [stgSpB, temp]
- cjmp = StCondJump ulbl test
- assign = StAssign PtrRep stgNode lbl
- join = StLabel ulbl
- in
- returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
-
-macroCode ARGS_CHK_B [words]
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let
- temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
- test = StPrim AddrGeOp [stgSpB, temp]
- cjmp = StCondJump ulbl test
- join = StLabel ulbl
- in
- returnUs (\xs -> cjmp : updatePAP : join : xs)
-\end{code}
-
-The @HEAP_CHK@ macro checks to see that there are enough words
-available in the heap (before reaching @HpLim@). When a heap check
-fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The
-call wrapper saves all of our volatile registers so that we don't have
-to.
-
-Since there are @HEAP_CHK@s buried at unfortunate places in the
-integer primOps, this is just a wrapper.
-
-\begin{code}
-macroCode HEAP_CHK args
- = let [liveness,words,reenter] = map amodeToStix args
- in
- heapCheck liveness words reenter
-\end{code}
-
-The @STK_CHK@ macro checks for enough space on the stack between @SpA@
-and @SpB@. A stack check can be complicated in the parallel world,
-but for the sequential case, we just need to ensure that we have
-enough space to continue. Not that @_StackOverflow@ doesn't return,
-so we don't have to @callWrapper@ it.
-
-\begin{code}
-macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
- =
-{- Need to check to see if we are compiling with stack checks
- getUniqLabelNCG `thenUs` \ ulbl ->
- let words = StPrim IntNegOp
- [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
- temp = StIndex PtrRep stgSpA words
- test = StPrim AddrGtOp [temp, stgSpB]
- cjmp = StCondJump ulbl test
- join = StLabel ulbl
- in
- returnUs (\xs -> cjmp : stackOverflow : join : xs)
--}
- returnUs id
-\end{code}
-
-@UPD_CAF@ involves changing the info pointer of the closure, adding an
-indirection, and putting the new CAF on a linked list for the storage
-manager.
+@UPD_CAF@ involves changing the info pointer of the closure, and
+adding an indirection.
\begin{code}
macroCode UPD_CAF args
= let
[cafptr,bhptr] = map amodeToStix args
w0 = StInd PtrRep cafptr
- w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
- w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
- a1 = StAssign PtrRep w0 caf_info
- a2 = StAssign PtrRep w1 smCAFlist
- a3 = StAssign PtrRep w2 bhptr
- a4 = StAssign PtrRep smCAFlist cafptr
- in
- returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
-\end{code}
-
-@UPD_IND@ is complicated by the fact that we are supporting the
-Appel-style garbage collector by default. This means some extra work
-if we update an old generation object.
-
-\begin{code}
-macroCode UPD_IND args
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let
- [updptr, heapptr] = map amodeToStix args
- test = StPrim AddrGtOp [updptr, smOldLim]
- cjmp = StCondJump ulbl test
- updRoots = StAssign PtrRep smOldMutables updptr
- join = StLabel ulbl
- upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
- upd1 = StAssign PtrRep (StInd PtrRep
- (StIndex PtrRep updptr (StInt 1))) smOldMutables
- upd2 = StAssign PtrRep (StInd PtrRep
- (StIndex PtrRep updptr (StInt 2))) heapptr
+ w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
+ blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
+ a1 = StAssign PtrRep w0 ind_static_info
+ a2 = StAssign PtrRep w1 bhptr
+ a3 = StAssign PtrRep blocking_queue end_tso_queue
in
- returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
+ returnUs (\xs -> a1 : a2 : a3 : xs)
\end{code}
-@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
+-----------------------------------------------------------------------------
+Blackholing
-\begin{code}
-macroCode UPD_INPLACE_NOPTRS args = returnUs id
-\end{code}
+We do lazy blackholing: no need to overwrite thunks with blackholes
+the minute they're entered, as long as we do it before a context
+switch or garbage collection, that's ok.
-@UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
-the Appel-style garbage collector by default. This means some extra
-work if we update an old generation object.
+Don't blackhole single entry closures, for the following reasons:
+
+ - if the compiler has decided that they won't be entered again,
+ that probably means that nothing has a pointer to it
+ (not necessarily true, but...)
-\begin{code}
-macroCode UPD_INPLACE_PTRS [liveness]
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let cjmp = StCondJump ulbl testOldLim
- testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
- join = StLabel ulbl
- updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
- updUpd1 = StAssign PtrRep (StInd PtrRep
- (StIndex PtrRep stgNode (StInt 1))) smOldMutables
- updUpd2 = StAssign PtrRep (StInd PtrRep
- (StIndex PtrRep stgNode (StInt 2))) hpBack2
- hpBack2 = StIndex PtrRep stgHp (StInt (-2))
- updOldMutables = StAssign PtrRep smOldMutables stgNode
- updUpdReg = StAssign PtrRep stgNode hpBack2
- in
- macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
- `thenUs` \ heap_chk ->
- returnUs (\xs -> (cjmp :
- heap_chk (updUpd0 : updUpd1 : updUpd2 :
- updOldMutables : updUpdReg : join : xs)))
-\end{code}
-
-@UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
-the sequential case, the GC takes care of this). However, we do need
-to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
+ - no need to blackhole for concurrency reasons, because nothing
+ can block on the result of this computation.
\begin{code}
macroCode UPD_BH_UPDATABLE args = returnUs id
-macroCode UPD_BH_SINGLE_ENTRY [arg]
+macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
+{-
= let
update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
in
returnUs (\xs -> update : xs)
+-}
\end{code}
-Push a four word update frame on the stack and slide the Su[AB]
-registers to the current Sp[AB] locations.
+-----------------------------------------------------------------------------
+Update frames
+
+Push a four word update frame on the stack and slide the Su registers
+to the current Sp location.
\begin{code}
-macroCode PUSH_STD_UPD_FRAME args
+macroCode PUSH_UPD_FRAME args
= let
- [bhptr, aWords, bWords] = map amodeToStix args
+ [bhptr, _{-0-}] = map amodeToStix args
frame n = StInd PtrRep
- (StIndex PtrRep stgSpB (StPrim IntAddOp
- [bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
+ (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
- a1 = StAssign PtrRep (frame uF_RET) stgRetReg
- a2 = StAssign PtrRep (frame uF_SUB) stgSuB
- a3 = StAssign PtrRep (frame uF_SUA) stgSuA
+ a1 = StAssign PtrRep (frame uF_RET) upd_frame_info
+ a3 = StAssign PtrRep (frame uF_SU) stgSu
a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
- updSuB = StAssign PtrRep
- stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
- [bWords, StInt (toInteger sTD_UF_SIZE)]))
- updSuA = StAssign PtrRep
- stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
+ updSu = StAssign PtrRep stgSu
+ (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
in
- returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
+ returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
\end{code}
-Pop a standard update frame.
-
-\begin{code}
-macroCode POP_STD_UPD_FRAME args
- = let
- frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
-
- grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
- grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
- grabSuA = StAssign PtrRep stgSuA (frame uF_SUA)
-
- updSpB = StAssign PtrRep
- stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
- in
- returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
-\end{code}
+-----------------------------------------------------------------------------
+Setting the tag register
This one only applies if we have a machine register devoted to TagReg.
+
\begin{code}
macroCode SET_TAG [tag]
= let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
in
- case stgReg TagReg of
+ case stgReg tagreg of
Always _ -> returnUs id
Save _ -> returnUs (\ xs -> set_tag : xs)
\end{code}
Do the business for a @HEAP_CHK@, having converted the args to Trees
of StixOp.
-\begin{code}
-heapCheck
- :: StixTree -- liveness
- -> StixTree -- words needed
- -> StixTree -- always reenter node? (boolean)
- -> UniqSM StixTreeList
-
-heapCheck liveness words reenter
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let newHp = StIndex PtrRep stgHp words
- assign = StAssign PtrRep stgHp newHp
- test = StPrim AddrLeOp [stgHp, stgHpLim]
- cjmp = StCondJump ulbl test
- arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
- -- ToDo: Overflow? (JSM)
- gc = StCall SLIT("PerformGC_wrapper") cCallConv VoidRep [arg]
- join = StLabel ulbl
- in
- returnUs (\xs -> assign : cjmp : gc : join : xs)
-\end{code}
-
+-----------------------------------------------------------------------------
Let's make sure that these CAFs are lifted out, shall we?
\begin{code}
-- Some common labels
-bh_info, caf_info, ind_info :: StixTree
+bh_info, ind_static_info, ind_info :: StixTree
-bh_info = sStLitLbl SLIT("BH_SINGLE_info")
-caf_info = sStLitLbl SLIT("Caf_info")
-ind_info = sStLitLbl SLIT("Ind_info")
+bh_info = sStLitLbl SLIT("BLACKHOLE_info")
+ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
+ind_info = sStLitLbl SLIT("IND_info")
+upd_frame_info = sStLitLbl SLIT("Upd_frame_entry")
+end_tso_queue = sStLitLbl SLIT("END_TSO_QUEUE_closure")
-- Some common call trees
updatePAP, stackOverflow :: StixTree
-updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
+updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP"))
stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
\end{code}
+
+-----------------------------------------------------------------------------
+Heap/Stack checks
+
+\begin{code}
+checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
+checkCode macro args assts
+ = getUniqLabelNCG `thenUs` \ ulbl_fail ->
+ getUniqLabelNCG `thenUs` \ ulbl_pass ->
+
+ let args_stix = map amodeToStix args
+ newHp wds = StIndex PtrRep stgHp wds
+ assign_hp wds = StAssign PtrRep stgHp (newHp wds)
+ test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
+ cjmp_hp = StCondJump ulbl_pass test_hp
+
+ newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
+ test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
+ test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
+ cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
+ cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
+
+ assign_ret r ret = StAssign CodePtrRep r ret
+
+ fail = StLabel ulbl_fail
+ join = StLabel ulbl_pass
+ in
+
+ returnUs (
+ case macro of
+ HP_CHK_NP ->
+ let [words,ptrs] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_enter ptrs : join : xs))
+
+ STK_CHK_NP ->
+ let [words,ptrs] = args_stix
+ in (\xs -> cjmp_sp_pass words :
+ assts (gc_enter ptrs : join : xs))
+
+ HP_STK_CHK_NP ->
+ let [sp_words,hp_words,ptrs] = args_stix
+ in (\xs -> cjmp_sp_fail sp_words :
+ assign_hp hp_words : cjmp_hp :
+ fail :
+ assts (gc_enter ptrs : join : xs))
+
+ HP_CHK ->
+ let [words,ret,r,ptrs] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (assign_ret r ret : gc_chk ptrs : join : xs))
+
+ STK_CHK ->
+ let [words,ret,r,ptrs] = args_stix
+ in (\xs -> cjmp_sp_pass words :
+ assts (assign_ret r ret : gc_chk ptrs : join : xs))
+
+ HP_STK_CHK ->
+ let [sp_words,hp_words,ret,r,ptrs] = args_stix
+ in (\xs -> cjmp_sp_fail sp_words :
+ assign_hp hp_words : cjmp_hp :
+ fail :
+ assts (assign_ret r ret : gc_chk ptrs : join : xs))
+
+ HP_CHK_NOREGS ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_noregs : join : xs))
+
+ HP_CHK_UNPT_R1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_unpt_r1 : join : xs))
+
+ HP_CHK_UNBX_R1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_unbx_r1 : join : xs))
+
+ HP_CHK_F1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_f1 : join : xs))
+
+ HP_CHK_D1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_d1 : join : xs))
+
+ HP_CHK_UT_ALT ->
+ error "unimplemented check"
+
+ HP_CHK_GEN ->
+ error "unimplemented check"
+ )
+
+-- Various canned heap-check routines
+
+gc_chk (StInt n) = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
+gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
+gc_noregs = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
+gc_unpt_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
+gc_unbx_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
+gc_f1 = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
+gc_d1 = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))
+
+\end{code}
--- /dev/null
+__interface StixPrim 1 0 where
+__export StixPrim amodeToStix;
+1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixTree ;
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
#include "HsVersions.h"
-import Char ( ord )
import MachMisc
import MachRegs
+import Stix
+import StixInteger
-import AbsCSyn
+import AbsCSyn hiding ( spRel )
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
+import SMRep ( fixedHdrSize )
+import Const ( Literal(..) )
import CallConv ( cCallConv )
-import Constants ( spARelToInt, spBRelToInt )
-import CostCentre ( noCostCentreAttached )
-import HeapOffs ( hpRelToInt, subOff )
-import Literal ( Literal(..) )
-import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
- getPrimOpResultInfo, PrimOpResultInfo(..)
- )
+import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..), isFloatingRep )
-import OrdList ( OrdList )
-import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
-import Stix
-import StixMacro ( heapCheck )
-import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, UniqSM )
+import Constants ( mIN_INTLIKE )
import Outputable
+import Char ( ord )
\end{code}
The main honcho here is primCode, which handles the guts of COpStmts.
\begin{code}
-arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
-imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
-
primCode
:: [CAddrMode] -- results
-> PrimOp -- op
Usually, this compiles to an assignment, but when the left-hand side
is empty, we just perform the call and ignore the result.
-ToDo ADR: modify this to handle ForeignObjs.
-
btw Why not let programmer use casm to provide assembly code instead
of C code? ADR
\begin{code}
-- NB: ordering of clauses somewhere driven by
-- the desire to getting sane patt-matching behavior
-
-primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerQuotRemOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerDivModOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
- = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
- = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
+primCode res@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da]
+ = gmpNegate (ar,sr,dr) (aa,sa,da)
\end{code}
-Since we are using the heap for intermediate @MP_INT@ structs, integer
-comparison {\em does} require a heap check in the native code
-implementation.
-
\begin{code}
-primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
- = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
-
-primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
- = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
+primCode [res] IntegerCmpOp args@[aa1,sa1,da1, aa2,sa2,da2]
+ = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2)
-primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
- = gmpInt2Integer (ar,sr,dr) (hp, n)
+primCode [res] Integer2IntOp arg@[aa,sa,da]
+ = gmpInteger2Int res (aa,sa,da)
-primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
- = gmpString2Integer (ar,sr,dr) (liveness,str)
-
-primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
- = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
-
-primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
- = gmpInteger2Int res (hp, aa,sa,da)
-
-primCode [res] Integer2WordOp arg@[hp, aa,sa,da]
- = gmpInteger2Word res (hp, aa,sa,da)
-
-primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
- = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
-
-primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
- = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
+primCode [res] Integer2WordOp arg@[aa,sa,da]
+ = gmpInteger2Word res (aa,sa,da)
primCode [res] Int2AddrOp [arg]
= simpleCoercion AddrRep res arg
= simpleCoercion IntRep res arg
\end{code}
-The @ErrorIO@ primitive is actually a bit weird...assign a new value
-to the root closure, and jump to the @ErrorIO_innards@.
-
-\begin{code}
-primCode [] ErrorIOPrimOp [rhs]
- = let
- changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
- in
- returnUs (\xs -> changeTop : errorIO : xs)
-\end{code}
-
-@newArray#@ ops allocate heap space.
-
\begin{code}
-primCode [res] NewArrayOp args
- = let
- [liveness, n, initial] = map amodeToStix args
- result = amodeToStix res
- space = StPrim IntAddOp [n, mutHS]
- loc = StIndex PtrRep stgHp
- (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrRep result loc
- initialise = StCall SLIT("newArrZh_init") cCallConv VoidRep [result, n, initial]
- in
- heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk . (\xs -> assign : initialise : xs))
-
-primCode [res] (NewByteArrayOp pk) args
- = let
- [liveness, count] = map amodeToStix args
- result = amodeToStix res
- n = StPrim IntMulOp [count, StInt (sizeOf pk)]
- slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
- words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
- space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
- loc = StIndex PtrRep stgHp
- (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrRep result loc
- init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
- init2 = StAssign IntRep
- (StInd IntRep
- (StIndex IntRep loc
- (StInt (toInteger fixedHdrSizeInWords))))
- (StPrim IntAddOp [words,
- StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
- in
- heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
-
primCode [res] SameMutableArrayOp args
= let
compare = StPrim AddrEqOp (map amodeToStix args)
rhs' = amodeToStix rhs
header = StInd PtrRep lhs'
assign = StAssign PtrRep lhs' rhs'
- freeze = StAssign PtrRep header imMutArrayOfPtrs_info
+ freeze = StAssign PtrRep header mutArrPtrsFrozen_info
in
returnUs (\xs -> assign : freeze : xs)
lhs' = amodeToStix lhs
obj' = amodeToStix obj
ix' = amodeToStix ix
- base = StIndex IntRep obj' mutHS
+ base = StIndex IntRep obj' arrHS
assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
in
returnUs (\xs -> assign : xs)
obj' = amodeToStix obj
ix' = amodeToStix ix
v' = amodeToStix v
- base = StIndex IntRep obj' mutHS
+ base = StIndex IntRep obj' arrHS
assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
in
returnUs (\xs -> assign : xs)
lhs' = amodeToStix lhs
obj' = amodeToStix obj
ix' = amodeToStix ix
- base = StIndex IntRep obj' dataHS
+ base = StIndex IntRep obj' arrHS
assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
in
returnUs (\xs -> assign : xs)
lhs' = amodeToStix lhs
obj' = amodeToStix obj
ix' = amodeToStix ix
- obj'' = StIndex PtrRep obj' foHS
+ obj'' = StIndex PtrRep obj' fixedHS
assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
in
returnUs (\xs -> assign : xs)
obj' = amodeToStix obj
ix' = amodeToStix ix
v' = amodeToStix v
- base = StIndex IntRep obj' dataHS
+ base = StIndex IntRep obj' arrHS
assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
in
returnUs (\xs -> assign : xs)
\end{code}
-Stable pointer operations.
-
-First the easy one.
-\begin{code}
-
-primCode [lhs] DeRefStablePtrOp [sp]
- = let
- lhs' = amodeToStix lhs
- pk = getAmodeRep lhs
- sp' = amodeToStix sp
- call = StCall SLIT("deRefStablePointer") cCallConv pk [sp', smStablePtrTable]
- assign = StAssign pk lhs' call
- in
- returnUs (\xs -> assign : xs)
-\end{code}
-
-Now the hard one. For comparison, here's the code from StgMacros:
-
-\begin{verbatim}
-#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- EXTDATA(MK_INFO_LBL(StablePointerTable)); \
- EXTDATA(UnusedSP); \
- StgStablePtr newSP; \
- \
- if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
- I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
- \
- /* any strictly increasing expression will do here */ \
- I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
- \
- I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
- P_ SPTable; \
- \
- HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
- CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
- \
- SPTable = Hp + 1 - (_FHS + NewSize); \
- SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
- SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
- StorageMgrInfo.StablePointerTable = SPTable; \
- } \
- \
- newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
- SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
- stablePtr = newSP; \
-} while (0)
-\end{verbatim}
-
-ToDo ADR: finish this. (Boy, this is hard work!)
-
-Notes for ADR:
- trMumbles are now just StMumbles.
- StInt 1 is how to write ``1''
- temporaries are allocated at the end of the heap (see notes in StixInteger)
- Good luck!
-
- --JSM
-
-\begin{pseudocode}
-primCode [lhs] MakeStablePtrOp args
- = let
- -- some useful abbreviations (I'm sure these must exist already)
- add = trPrim . IntAddOp
- sub = trPrim . IntSubOp
- one = trInt [1]
- dec x = trAssign IntRep [x, sub [x, one]]
- inc x = trAssign IntRep [x, add [x, one]]
-
- -- tedious hardwiring in of closure layout offsets (from SMClosures)
- dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
- spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
- spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
- spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
- spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
- spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
-
- -- tedious hardwiring in of stack manipulation macros (from SMClosures)
- spt_FULL c lbl =
- trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
- spt_EMPTY c lbl =
- trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
- spt_PUSH c f = [
- trAssign PtrRep [spt_FREE c (spt_TOP c), f],
- inc (spt_TOP c),
- spt_POP c x = [
- dec (spt_TOP c),
- trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
- ]
-
- -- now to get down to business
- lhs' = amodeCode lhs
- [liveness, unstable] = map amodeCode args
-
- spt = smStablePtrTable
-
- newSPT = -- a temporary (don't know how to allocate it)
- newSP = -- another temporary
-
- allocNewTable = -- some sort fo heap allocation needed
- copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
-
- enlarge =
- allocNewTable ++ [
- copyOldTable,
- trAssign PtrRep [spt, newSPT]
- allocate = [
- spt_POP spt newSP,
- trAssign PtrRep [spt_SPTR spt newSP, unstable],
- trAssign StablePtrRep [lhs', newSP]
- ]
-
- in
- getUniqLabelCTS `thenCTS` \ oklbl ->
- returnCodes sty md
- (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
-\end{pseudocode}
-
\begin{code}
-primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
-
-primCode [lhs] SeqOp [a]
- = let
- {-
- The evaluation of seq#'s argument is done by `seqseqseq',
- here we just set up the call to it (identical to how
- DerefStablePtr does things.)
- -}
- lhs' = amodeToStix lhs
- a' = amodeToStix a
- pk = getAmodeRep lhs -- an IntRep
- call = StCall SLIT("SeqZhCode") cCallConv pk [a']
- assign = StAssign pk lhs' call
- in
--- trace "SeqOp" $
- returnUs (\xs -> assign : xs)
-
-primCode lhs (CCallOp (Left fn) is_asm may_gc cconv arg_tys result_ty) rhs
+--primCode lhs (CCallOp fn is_asm may_gc) rhs
+primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
| may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
| otherwise
let base = amodeToStix' x
in
case getAmodeRep x of
- ArrayRep -> StIndex PtrRep base mutHS
- ByteArrayRep -> StIndex IntRep base dataHS
- ForeignObjRep -> StIndex PtrRep base foHS
- {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
+ ArrayRep -> StIndex PtrRep base arrHS
+ ByteArrayRep -> StIndex IntRep base arrHS
+ ForeignObjRep -> StIndex PtrRep base fixedHS
_ -> base
\end{code}
= let
lhs' = map amodeToStix lhs
rhs' = map amodeToStix' rhs
+ pk = getAmodeRep (head lhs)
in
- returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
+ returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
\end{code}
\begin{code}
\begin{code}
simplePrim
- :: [StixTree]
+ :: PrimRep -- Rep of first destination
+ -> [StixTree] -- Destinations
-> PrimOp
-> [StixTree]
-> StixTree
Now look for something more conventional.
\begin{code}
-simplePrim [lhs] op rest
- = StAssign pk lhs (StPrim op rest)
- where
- pk = if isCompareOp op then
- IntRep
- else
- case getPrimOpResultInfo op of
- ReturnsPrim pk -> pk
- _ -> simplePrim_error op
-
-simplePrim as op bs = simplePrim_error op
+simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
+simplePrim pk as op bs = simplePrim_error op
simplePrim_error op
- = error ("ERROR: primitive operation `"++showPrimOp op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
+ = error ("ERROR: primitive operation `"++show op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
\end{code}
%---------------------------------------------------------------------
amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
-amodeToStix (CAddr (SpARel spA off))
- = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
-
-amodeToStix (CAddr (SpBRel spB off))
- = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
+amodeToStix (CAddr (SpRel off))
+ = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
-amodeToStix (CAddr (HpRel hp off))
- = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
+amodeToStix (CAddr (HpRel off))
+ = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
amodeToStix (CAddr (NodeRel off))
- = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
+ = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
amodeToStix (CReg magic) = StReg (StixMagicId magic)
amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
amodeToStix (CLbl lbl _) = StCLbl lbl
-amodeToStix (CUnVecLbl dir _) = StCLbl dir
amodeToStix (CTableEntry base off pk)
= StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
amodeToStix (CCharLike (CLit (MachChar c)))
- = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
+ = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
where
off = charLikeSize * ord c
amodeToStix (CCharLike x)
- = StPrim IntAddOp [charLike, off]
+ = StIndex PtrRep charLike off
where
- off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
+ off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))]
amodeToStix (CIntLike (CLit (MachInt i _)))
- = StPrim IntAddOp [intLikePtr, StInt off]
+ = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
where
- off = toInteger intLikeSize * toInteger i
+ off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
amodeToStix (CIntLike x)
- = StPrim IntAddOp [intLikePtr, off]
- where
- off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
+ = panic "CIntLike"
-- A CString is just a (CLit . MachStr)
amodeToStix (CString s) = StString s
-- A CLitLit is just a (CLit . MachLitLit)
amodeToStix (CLitLit s _) = StLitLit s
- -- COffsets are in words, not bytes!
-amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
-
amodeToStix (CMacroExpr _ macro [arg])
= case macro of
- INFO_PTR -> StInd PtrRep (amodeToStix arg)
ENTRY_CODE -> amodeToStix arg
- INFO_TAG -> tag
- EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
- where
- tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
- -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
-
-amodeToStix (CCostCentre cc print_as_string)
- = if noCostCentreAttached cc
- then StComment SLIT("") -- sigh
- else panic "amodeToStix:CCostCentre"
+ ARG_TAG -> amodeToStix arg -- just an integer no. of words
+ GET_TAG -> StPrim SrlOp
+ [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
+ StInt 1]),
+ StInt 16]
+
+-- XXX!!!
+-- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
+-- which we've had to hand-code here.
\end{code}
Sizes of the CharLike and IntLike closures that are arranged as arrays
intLikePtr :: StixTree
-intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
+intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
-- The CHARLIKE base
charLike :: StixTree
-charLike = sStLitLbl SLIT("CHARLIKE_closures")
+charLike = sStLitLbl SLIT("CHARLIKE_closure")
-- Trees for the ErrorIOPrimOp
topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
+
+mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
+
+charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
+intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
\end{code}
gconnty : ttype;
gconnline : long; >;
- /* constr with a prefixed context C => ... */
- constrcxt : < gconcxt : list;
+ /* constr with a existential prefixed context C => ... */
+ constrex : < gcontvs : list; /* tyvars */
+ gconcxt : list; /* theta */
gconcon : constr; >;
field : < gfieldn : list;
--- /dev/null
+/*-----------------------------------------------------------------------------
+ ctype.c for Haskell
+
+ (c) Simon Marlow 1993
+-----------------------------------------------------------------------------*/
+
+#include "ctypes.h"
+
+const unsigned char char_types[] =
+ {
+ 0, /* \000 */
+ 0, /* \001 */
+ 0, /* \002 */
+ 0, /* \003 */
+ 0, /* \004 */
+ 0, /* \005 */
+ 0, /* \006 */
+ 0, /* \007 */
+ 0, /* \010 */
+ C_Any | C_Space, /* \t */
+ C_Any | C_Space, /* \n */
+ C_Any | C_Space, /* \v */
+ C_Any | C_Space, /* \f */
+ 0, /* \015 */
+ 0, /* \016 */
+ 0, /* \017 */
+ 0, /* \020 */
+ 0, /* \021 */
+ 0, /* \022 */
+ 0, /* \023 */
+ 0, /* \024 */
+ 0, /* \025 */
+ 0, /* \026 */
+ 0, /* \027 */
+ 0, /* \030 */
+ 0, /* \031 */
+ 0, /* \032 */
+ 0, /* \033 */
+ 0, /* \034 */
+ 0, /* \035 */
+ 0, /* \036 */
+ 0, /* \037 */
+ C_Any | C_Space, /* */
+ C_Any | C_Symbol, /* ! */
+ C_Any, /* " */
+ C_Any | C_Symbol, /* # */
+ C_Any | C_Symbol, /* $ */
+ C_Any | C_Symbol, /* % */
+ C_Any | C_Symbol, /* & */
+ C_Any | C_Ident, /* ' */
+ C_Any, /* ( */
+ C_Any, /* ) */
+ C_Any | C_Symbol, /* * */
+ C_Any | C_Symbol, /* + */
+ C_Any, /* , */
+ C_Any | C_Symbol, /* - */
+ C_Any | C_Symbol, /* . */
+ C_Any | C_Symbol, /* / */
+ C_Any | C_Ident | C_Digit, /* 0 */
+ C_Any | C_Ident | C_Digit, /* 1 */
+ C_Any | C_Ident | C_Digit, /* 2 */
+ C_Any | C_Ident | C_Digit, /* 3 */
+ C_Any | C_Ident | C_Digit, /* 4 */
+ C_Any | C_Ident | C_Digit, /* 5 */
+ C_Any | C_Ident | C_Digit, /* 6 */
+ C_Any | C_Ident | C_Digit, /* 7 */
+ C_Any | C_Ident | C_Digit, /* 8 */
+ C_Any | C_Ident | C_Digit, /* 9 */
+ C_Any | C_Symbol, /* : */
+ C_Any, /* ; */
+ C_Any | C_Symbol, /* < */
+ C_Any | C_Symbol, /* = */
+ C_Any | C_Symbol, /* > */
+ C_Any | C_Symbol, /* ? */
+ C_Any | C_Symbol, /* @ */
+ C_Any | C_Ident | C_Upper, /* A */
+ C_Any | C_Ident | C_Upper, /* B */
+ C_Any | C_Ident | C_Upper, /* C */
+ C_Any | C_Ident | C_Upper, /* D */
+ C_Any | C_Ident | C_Upper, /* E */
+ C_Any | C_Ident | C_Upper, /* F */
+ C_Any | C_Ident | C_Upper, /* G */
+ C_Any | C_Ident | C_Upper, /* H */
+ C_Any | C_Ident | C_Upper, /* I */
+ C_Any | C_Ident | C_Upper, /* J */
+ C_Any | C_Ident | C_Upper, /* K */
+ C_Any | C_Ident | C_Upper, /* L */
+ C_Any | C_Ident | C_Upper, /* M */
+ C_Any | C_Ident | C_Upper, /* N */
+ C_Any | C_Ident | C_Upper, /* O */
+ C_Any | C_Ident | C_Upper, /* P */
+ C_Any | C_Ident | C_Upper, /* Q */
+ C_Any | C_Ident | C_Upper, /* R */
+ C_Any | C_Ident | C_Upper, /* S */
+ C_Any | C_Ident | C_Upper, /* T */
+ C_Any | C_Ident | C_Upper, /* U */
+ C_Any | C_Ident | C_Upper, /* V */
+ C_Any | C_Ident | C_Upper, /* W */
+ C_Any | C_Ident | C_Upper, /* X */
+ C_Any | C_Ident | C_Upper, /* Y */
+ C_Any | C_Ident | C_Upper, /* Z */
+ C_Any, /* [ */
+ C_Any | C_Symbol, /* \ */
+ C_Any, /* ] */
+ C_Any | C_Symbol, /* ^ */
+ C_Any | C_Ident, /* _ */
+ C_Any, /* ` */
+ C_Any | C_Ident, /* a */
+ C_Any | C_Ident, /* b */
+ C_Any | C_Ident, /* c */
+ C_Any | C_Ident, /* d */
+ C_Any | C_Ident, /* e */
+ C_Any | C_Ident, /* f */
+ C_Any | C_Ident, /* g */
+ C_Any | C_Ident, /* h */
+ C_Any | C_Ident, /* i */
+ C_Any | C_Ident, /* j */
+ C_Any | C_Ident, /* k */
+ C_Any | C_Ident, /* l */
+ C_Any | C_Ident, /* m */
+ C_Any | C_Ident, /* n */
+ C_Any | C_Ident, /* o */
+ C_Any | C_Ident, /* p */
+ C_Any | C_Ident, /* q */
+ C_Any | C_Ident, /* r */
+ C_Any | C_Ident, /* s */
+ C_Any | C_Ident, /* t */
+ C_Any | C_Ident, /* u */
+ C_Any | C_Ident, /* v */
+ C_Any | C_Ident, /* w */
+ C_Any | C_Ident, /* x */
+ C_Any | C_Ident, /* y */
+ C_Any | C_Ident, /* z */
+ C_Any, /* { */
+ C_Any | C_Symbol, /* | */
+ C_Any, /* } */
+ C_Any | C_Symbol, /* ~ */
+ 0, /* \177 */
+ 0, /* \200 */
+ 0, /* \201 */
+ 0, /* \202 */
+ 0, /* \203 */
+ 0, /* \204 */
+ 0, /* \205 */
+ 0, /* \206 */
+ 0, /* \207 */
+ 0, /* \210 */
+ 0, /* \211 */
+ 0, /* \212 */
+ 0, /* \213 */
+ 0, /* \214 */
+ 0, /* \215 */
+ 0, /* \216 */
+ 0, /* \217 */
+ 0, /* \220 */
+ 0, /* \221 */
+ 0, /* \222 */
+ 0, /* \223 */
+ 0, /* \224 */
+ 0, /* \225 */
+ 0, /* \226 */
+ 0, /* \227 */
+ 0, /* \230 */
+ 0, /* \231 */
+ 0, /* \232 */
+ 0, /* \233 */
+ 0, /* \234 */
+ 0, /* \235 */
+ 0, /* \236 */
+ 0, /* \237 */
+ C_Space, /* */
+ C_Any | C_Symbol, /* ¡ */
+ C_Any | C_Symbol, /* ¢ */
+ C_Any | C_Symbol, /* £ */
+ C_Any | C_Symbol, /* ¤ */
+ C_Any | C_Symbol, /* ¥ */
+ C_Any | C_Symbol, /* ¦ */
+ C_Any | C_Symbol, /* § */
+ C_Any | C_Symbol, /* ¨ */
+ C_Any | C_Symbol, /* © */
+ C_Any | C_Symbol, /* ª */
+ C_Any | C_Symbol, /* « */
+ C_Any | C_Symbol, /* ¬ */
+ C_Any | C_Symbol, /* */
+ C_Any | C_Symbol, /* ® */
+ C_Any | C_Symbol, /* ¯ */
+ C_Any | C_Symbol, /* ° */
+ C_Any | C_Symbol, /* ± */
+ C_Any | C_Symbol, /* ² */
+ C_Any | C_Symbol, /* ³ */
+ C_Any | C_Symbol, /* ´ */
+ C_Any | C_Symbol, /* µ */
+ C_Any | C_Symbol, /* ¶ */
+ C_Any | C_Symbol, /* · */
+ C_Any | C_Symbol, /* ¸ */
+ C_Any | C_Symbol, /* ¹ */
+ C_Any | C_Symbol, /* º */
+ C_Any | C_Symbol, /* » */
+ C_Any | C_Symbol, /* ¼ */
+ C_Any | C_Symbol, /* ½ */
+ C_Any | C_Symbol, /* ¾ */
+ C_Any | C_Symbol, /* ¿ */
+ C_Any | C_Ident | C_Upper, /* À */
+ C_Any | C_Ident | C_Upper, /* Á */
+ C_Any | C_Ident | C_Upper, /* Â */
+ C_Any | C_Ident | C_Upper, /* Ã */
+ C_Any | C_Ident | C_Upper, /* Ä */
+ C_Any | C_Ident | C_Upper, /* Å */
+ C_Any | C_Ident | C_Upper, /* Æ */
+ C_Any | C_Ident | C_Upper, /* Ç */
+ C_Any | C_Ident | C_Upper, /* È */
+ C_Any | C_Ident | C_Upper, /* É */
+ C_Any | C_Ident | C_Upper, /* Ê */
+ C_Any | C_Ident | C_Upper, /* Ë */
+ C_Any | C_Ident | C_Upper, /* Ì */
+ C_Any | C_Ident | C_Upper, /* Í */
+ C_Any | C_Ident | C_Upper, /* Î */
+ C_Any | C_Ident | C_Upper, /* Ï */
+ C_Any | C_Ident | C_Upper, /* Ð */
+ C_Any | C_Ident | C_Upper, /* Ñ */
+ C_Any | C_Ident | C_Upper, /* Ò */
+ C_Any | C_Ident | C_Upper, /* Ó */
+ C_Any | C_Ident | C_Upper, /* Ô */
+ C_Any | C_Ident | C_Upper, /* Õ */
+ C_Any | C_Ident | C_Upper, /* Ö */
+ C_Any | C_Symbol, /* × */
+ C_Any | C_Ident | C_Upper, /* Ø */
+ C_Any | C_Ident | C_Upper, /* Ù */
+ C_Any | C_Ident | C_Upper, /* Ú */
+ C_Any | C_Ident | C_Upper, /* Û */
+ C_Any | C_Ident | C_Upper, /* Ü */
+ C_Any | C_Ident | C_Upper, /* Ý */
+ C_Any | C_Ident | C_Upper, /* Þ */
+ C_Any | C_Ident, /* ß */
+ C_Any | C_Ident, /* à */
+ C_Any | C_Ident, /* á */
+ C_Any | C_Ident, /* â */
+ C_Any | C_Ident, /* ã */
+ C_Any | C_Ident, /* ä */
+ C_Any | C_Ident, /* å */
+ C_Any | C_Ident, /* æ */
+ C_Any | C_Ident, /* ç */
+ C_Any | C_Ident, /* è */
+ C_Any | C_Ident, /* é */
+ C_Any | C_Ident, /* ê */
+ C_Any | C_Ident, /* ë */
+ C_Any | C_Ident, /* ì */
+ C_Any | C_Ident, /* í */
+ C_Any | C_Ident, /* î */
+ C_Any | C_Ident, /* ï */
+ C_Any | C_Ident, /* ð */
+ C_Any | C_Ident, /* ñ */
+ C_Any | C_Ident, /* ò */
+ C_Any | C_Ident, /* ó */
+ C_Any | C_Ident, /* ô */
+ C_Any | C_Ident, /* õ */
+ C_Any | C_Ident, /* ö */
+ C_Any | C_Symbol, /* ÷ */
+ C_Any | C_Ident, /* ø */
+ C_Any | C_Ident, /* ù */
+ C_Any | C_Ident, /* ú */
+ C_Any | C_Ident, /* û */
+ C_Any | C_Ident, /* ü */
+ C_Any | C_Ident, /* ý */
+ C_Any | C_Ident, /* þ */
+ C_Any | C_Ident, /* ÿ */
+ };
--- /dev/null
+/*-----------------------------------------------------------------------------
+ ctypes.h for Haskell
+
+ (c) Simon Marlow 1993
+-----------------------------------------------------------------------------*/
+
+#define C_Ident 1
+#define C_Symbol 1<<1
+#define C_Any 1<<2
+#define C_Space 1<<3
+#define C_Upper 1<<4
+#define C_Digit 1<<5
+
+#define _IsType(c,flags) (char_types[(int)(c)] & flags)
+
+#define IsSpace(c) (_IsType(c,C_Space))
+#define IsIdent(c) (_IsType(c,C_Ident))
+#define IsAny(c) (_IsType(c,C_Any))
+#define IsSymbol(c) (_IsType(c,C_Symbol))
+#define IsUpper(c) (_IsType(c,C_Upper))
+#define IsDigit(c) (_IsType(c,C_Digit))
+
+extern const unsigned char char_types[];
for various bits of the RTS. They are linked
in instead of the defaults.
*/
-#include <stdio.h>
-/* Included so as to bring the right prototypes into scope */
+#if __GLASGOW_HASKELL__ >= 400
+#include "Rts.h"
+#else
#include "rtsdefs.h"
-
-#define W_ unsigned long int
-#define I_ long int
+#endif
#if __GLASGOW_HASKELL__ >= 303
+
void
ErrorHdrHook (long fd)
{
char msg[]="\n";
write(fd,msg,1);
}
-#else
-void
-ErrorHdrHook (FILE *where)
-{
- fprintf(where, "\n"); /* no "Fail: " */
-}
-#endif
-
-void
-OutOfHeapHook (W_ request_size, W_ heap_size) /* both in bytes */
-{
- fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
- request_size,
- heap_size);
-}
-
-void
-StackOverflowHook (I_ stack_size) /* in bytes */
-{
- fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
-}
-#if __GLASGOW_HASKELL__ >= 303
void
PatErrorHdrHook (long fd)
{
#endif
}
-#else
+#else /* pre-3.03 GHC with old IO system */
+
+void
+ErrorHdrHook (FILE *where)
+{
+ fprintf(where, "\n"); /* no "Fail: " */
+}
+
void
PatErrorHdrHook (FILE *where)
{
{
fprintf(where, "\n"); /* not "Trace Off" */
}
+
+#endif
+
+#if __GLASGOW_HASKELL__ >= 400
+void
+OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
+ /* both in bytes */
+{
+ fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
+ request_size,
+ heap_size);
+}
+
+void
+StackOverflowHook (unsigned long stack_size) /* in bytes */
+{
+ fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
+}
+
+#else /* GHC < 4.00 */
+
+void
+OutOfHeapHook (W_ request_size, W_ heap_size) /* both in bytes */
+{
+ fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
+ request_size,
+ heap_size);
+}
+
+void
+StackOverflowHook (I_ stack_size) /* in bytes */
+{
+ fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
+}
+
#endif
<Code,GlaExt>"hiding" { RETURN(HIDING); }
<Code,GlaExt>"qualified" { RETURN(QUALIFIED); }
+<Code,GlaExt>"forall" { RETURN(FORALL); }
+
<Code,GlaExt>"_scc_" { RETURN(SCC); }
<GlaExt>"_ccall_" { RETURN(CCALL); }
<GlaExt>"_ccall_GC_" { RETURN(CCALL_GC); }
<GlaExt>"_casm_" { RETURN(CASM); }
<GlaExt>"_casm_GC_" { RETURN(CASM_GC); }
+<GlaExt>"(#" { RETURN(OUNBOXPAREN); }
+<GlaExt>"#)" { RETURN(CUNBOXPAREN); }
<GlaExt>"foreign" { RETURN(FOREIGN); }
<GlaExt>"export" { RETURN(EXPORT); }
<GlaExt>"label" { RETURN(LABEL); }
<GlaExt>"_stdcall" { RETURN(STDCALL); }
<GlaExt>"_ccall" { RETURN(C_CALL); }
<GlaExt>"_pascal" { RETURN(PASCAL); }
-<GlaExt>"_fastcall" { RETURN(FASTCALL); }
+<GlaExt>"stdcall" { RETURN(STDCALL); }
+<GlaExt>"ccall" { RETURN(C_CALL); }
+<GlaExt>"pascal" { RETURN(PASCAL); }
<GlaExt>"dynamic" { RETURN(DYNAMIC); }
%{
<Code,GlaExt>"`" { RETURN(BQUOTE); }
<Code,GlaExt>"_" { RETURN(WILDCARD); }
+<Code,GlaExt>"." { RETURN(DOT); }
<Code,GlaExt>".." { RETURN(DOTDOT); }
<Code,GlaExt,UserPragma>"::" { RETURN(DCOLON); }
<Code,GlaExt,UserPragma>"=" { RETURN(EQUAL); }
%token OCURLY CCURLY VCCURLY
%token COMMA SEMI OBRACK CBRACK
%token WILDCARD BQUOTE OPAREN CPAREN
+%token OUNBOXPAREN CUNBOXPAREN
/**********************************************************************
%token SCC
%token CCALL CCALL_GC CASM CASM_GC
+
+%token DOT FORALL
%token EXPORT UNSAFE STDCALL C_CALL LABEL
%token PASCAL FASTCALL FOREIGN DYNAMIC
dorest stmts stmt
rbinds rbinds1 rpats rpats1 list_exps list_rest
qvarsk qvars_list
- constrs constr1 fields
- types atypes batypes
+ constrs constr1 fields conargatypes
+ tautypes atypes
types_and_maybe_ids
pats simple_context simple_context_list
export_list enames
maybefixes fixes fix ops
dtyclses dtycls_list
gdrhs gdpat valrhs
- lampats cexps gd
+ lampats cexps gd texps
+ tyvars1 constr_context forall
%type <umaybe> maybeexports impspec deriving
ext_name
%type <uliteral> lit_constant
-%type <utree> exp oexp dexp kexp fexp aexp rbind texps
+%type <utree> exp oexp dexp kexp fexp aexp rbind
expL oexpL kexpL expLno oexpLno dexpLno kexpLno
vallhs funlhs qual leftexp
pat cpat bpat apat apatc conpat rpat
VARID CONID VARSYM CONSYM
var con varop conop op
vark varid varsym varsym_nominus
- tycon modid ccallid
+ tycon modid ccallid tyvar
+ varid_noforall
%type <uqid> QVARID QCONID QVARSYM QCONSYM
qvarid qconid qvarsym qconsym
%type <upbinding> valrhs1 altrest
-%type <uttype> ctype sigtype sigarrowtype type atype bigatype btype
- bbtype batype bxtype wierd_atype
- simple_con_app simple_con_app1 tyvar contype inst_type
+%type <uttype> polytype
+ conargatype conapptype
+ tautype
+ apptype
+ atype polyatype
+ simple_con_app simple_con_app1 inst_type
%type <uconstr> constr constr_after_context field
| decl { $$ = $1; }
;
-typed : typekey simple_con_app EQUAL type { $$ = mknbind($2,$4,startlineno); }
+typed : typekey simple_con_app EQUAL tautype { $$ = mknbind($2,$4,startlineno); }
;
| DERIVING dtyclses { $$ = mkjust($2); }
;
-classd : classkey btype DARROW simple_con_app1 cbody
+classd : classkey apptype DARROW simple_con_app1 cbody
/* Context can now be more than simple_context */
{ $$ = mkcbind(type2context($2),$4,$5,startlineno); }
- | classkey btype cbody
- /* We have to say btype rather than simple_con_app1, else
+ | classkey apptype cbody
+ /* We have to say apptype rather than simple_con_app1, else
we get reduce/reduce errs */
{ check_class_decl_head($2);
$$ = mkcbind(Lnil,$2,$3,startlineno); }
instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); }
;
-/* Compare ctype */
-inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */
- $$ = mkcontext(type2context($1),$3); }
- | btype { is_context_format( $1, 0 ); /* Check the instance head */
+/* Compare polytype */
+/* [July 98: first production was tautype DARROW tautype, but I can't see why.] */
+inst_type : apptype DARROW apptype { is_context_format( $3, 0 ); /* Check the instance head */
+ $$ = mkforall(Lnil,type2context($1),$3); }
+ | apptype { is_context_format( $1, 0 ); /* Check the instance head */
$$ = $1; }
;
| WHERE vocurly instdefs vccurly { $$ = $3; }
;
-defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); }
+defaultd: defaultkey OPAREN tautypes CPAREN { $$ = mkdbind($3,startlineno); }
| defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
;
/* FFI primitive declarations - GHC/Hugs specific */
-foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON sigtype { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); }
- | foreignkey EXPORT callconv ext_name qvarid DCOLON sigtype { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); }
+foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON tautype { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); }
+ | foreignkey EXPORT callconv ext_name qvarid DCOLON tautype { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); }
;
- | foreignkey LABEL ext_name qvarid DCOLON sigtype { $$ = mkfobind($4,$6,$3,0,-1,FOREIGN_LABEL,startlineno); }
+ | foreignkey LABEL ext_name qvarid DCOLON tautype { $$ = mkfobind($4,$6,$3,0,-1,FOREIGN_LABEL,startlineno); }
;
callconv: STDCALL { $$ = CALLCONV_STDCALL; }
to real mischief (ugly, but likely to work).
*/
-decl : qvarsk DCOLON sigtype
+decl : qvarsk DCOLON polytype
{ $$ = mksbind($1,$3,startlineno);
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
;
type_and_maybe_id :
- type { $$ = mkvspec_ty_and_id($1,mknothing()); }
- | type EQUAL qvark { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
+ tautype { $$ = mkvspec_ty_and_id($1,mknothing()); }
+ | tautype EQUAL qvark { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
/**********************************************************************
* *
**********************************************************************/
-/* "DCOLON context => type" vs "DCOLON type" is a problem,
+/* "DCOLON context => tautype" vs "DCOLON tautype" is a problem,
because you can't distinguish between
foo :: (Baz a, Baz a)
bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
- with one token of lookahead. The HACK is to have "DCOLON ttype"
- [tuple type] in the first case, then check that it has the right
+ with one token of lookahead. The HACK is to have "DCOLON apptype"
+ in the first case, then check that it has the right
form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
context. Blaach!
*/
-/* A sigtype is a rank 2 type; it can have for-alls as function args:
- f :: All a => (All b => ...) -> Int
-*/
-sigtype : btype DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
- | sigarrowtype
- ;
+/* --------------------------- */
-sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); }
- | btype RARROW sigarrowtype { $$ = mktfun($1,$3); }
- | btype
- ;
+polyatype : atype
+ ;
-/* A "big" atype can be a forall-type in brackets. */
-bigatype: OPAREN btype DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
- ;
+polytype : FORALL tyvars1 DOT
+ apptype DARROW tautype { $$ = mkforall($2, type2context($4), $6); }
+ | FORALL tyvars1 DOT tautype { $$ = mkforall($2, Lnil, $4); }
+ | apptype DARROW tautype { $$ = mkforall(Lnil, type2context($1), $3); }
+ | tautype
+ ;
- /* 1 S/R conflict at DARROW -> shift */
-ctype : btype DARROW type { $$ = mkcontext(type2context($1),$3); }
- | type
- ;
+/* --------------------------- */
+/* tautype is just a monomorphic type.
+ But it may have nested for-alls if we're in a rank-2 type */
- /* 1 S/R conflict at RARROW -> shift */
-type : btype RARROW type { $$ = mktfun($1,$3); }
- | btype { $$ = $1; }
+tautype : apptype RARROW tautype { $$ = mktfun($1,$3); }
+ | apptype { $$ = $1; }
;
-btype : btype atype { $$ = mktapp($1,$2); }
+tautypes : tautype { $$ = lsing($1); }
+ | tautypes COMMA tautype { $$ = lapp($1,$3); }
+ ;
+
+/* --------------------------- */
+/* apptype: type application */
+
+apptype : apptype atype { $$ = mktapp($1,$2); }
| atype { $$ = $1; }
;
-atype : gtycon { $$ = mktname($1); }
- | tyvar { $$ = $1; }
- | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
- | OBRACK type CBRACK { $$ = mktllist($2); }
- | OPAREN type CPAREN { $$ = $2; }
- ;
+/* --------------------------- */
+/* atype: an atomic or bracketed type: T, x, [ty], tuple ty */
+
+atypes : atype { $$ = lsing($1); }
+ | atype atypes { $$ = mklcons($1,$2); }
+ ;
+
+atype : gtycon { $$ = mktname($1); }
+ | tyvar { $$ = mknamedtvar($1); }
+
+ | OPAREN tautype COMMA
+ tautypes CPAREN { $$ = mkttuple(mklcons($2,$4)); }
+
+ | OUNBOXPAREN tautype COMMA
+ tautypes CUNBOXPAREN { $$ = mktutuple(mklcons($2,$4)); }
+ | OBRACK tautype CBRACK { $$ = mktllist($2); }
+ | OPAREN polytype CPAREN { $$ = $2; }
+ ;
+
+/* --------------------------- */
gtycon : qtycon
| OPAREN RARROW CPAREN { $$ = creategid(ARROWGID); }
| OBRACK CBRACK { $$ = creategid(NILGID); }
| OPAREN commas CPAREN { $$ = creategid($2); }
;
-atypes : atype { $$ = lsing($1); }
- | atypes atype { $$ = lapp($1,$2); }
- ;
-
-types : type { $$ = lsing($1); }
- | types COMMA type { $$ = lapp($1,$3); }
- ;
-
commas : COMMA { $$ = 1; }
| commas COMMA { $$ = $1 + 1; }
;
| simple_con_app1 { $$ = $1; }
;
-simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),$2); }
- | simple_con_app tyvar { $$ = mktapp($1, $2); }
+simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),mknamedtvar($2)); }
+ | simple_con_app tyvar { $$ = mktapp($1, mknamedtvar($2)); }
;
simple_context : OPAREN simple_context_list CPAREN { $$ = $2; }
| constrs VBAR constr { $$ = lapp($1,$3); }
;
-constr : constr_after_context
- | btype DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
+constr : forall constr_context DARROW constr_after_context { $$ = mkconstrex ( $1, $2, $4 ); }
+ | forall constr_after_context { $$ = mkconstrex ( $1, Lnil, $2 ); }
+ ;
+
+forall : { $$ = Lnil }
+ | FORALL tyvars1 DOT { $$ = $2; }
+ ;
+
+constr_context
+ : conapptype conargatype { $$ = type2context( mktapp($1,$2) ); }
+ | conargatype { $$ = type2context( $1 ); }
;
constr_after_context :
*/
/* Con !Int (Tree a) */
- contype { qid tyc; list tys;
+ conapptype { qid tyc; list tys;
splittyconapp($1, &tyc, &tys);
$$ = mkconstrpre(tyc,tys,hsplineno); }
-/* !Int `Con` Tree a */
- | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
-
/* (::) (Tree a) Int */
- | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
+ | OPAREN qconsym CPAREN conargatypes { $$ = mkconstrpre($2,$4,hsplineno); }
+
+/* !Int `Con` Tree a */
+ | conargatype qconop conargatype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
/* Con { op1 :: Int } */
| qtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
/* 1 S/R conflict on OCURLY -> shift */
-/* contype has to reduce to a btype unless there are !'s, so that
- we don't get reduce/reduce conflicts with the second production of constr.
- But as soon as we see a ! we must switch to using bxtype. */
-
-contype : btype { $$ = $1; }
- | bxtype { $$ = $1; }
- ;
-
-/* S !Int Bool; at least one ! */
-bxtype : btype wierd_atype { $$ = mktapp($1, $2); }
- | bxtype batype { $$ = mktapp($1, $2); }
- ;
-
-bbtype : btype { $$ = $1; }
- | wierd_atype { $$ = $1; }
- ;
-
-batype : atype { $$ = $1; }
- | wierd_atype { $$ = $1; }
- ;
+conapptype : gtycon { $$ = mktname($1); }
+ | conapptype conargatype { $$ = mktapp($1, $2); }
+ ;
-/* A wierd atype is one that isn't a regular atype;
- it starts with a "!", or with a forall. */
-wierd_atype : BANG bigatype { $$ = mktbang( $2 ); }
- | BANG atype { $$ = mktbang( $2 ); }
- | bigatype
+conargatype : polyatype { $$ = $1; }
+ | BANG polyatype { $$ = mktbang( $2 ); }
;
-batypes : { $$ = Lnil; }
- | batypes batype { $$ = lapp($1,$2); }
- ;
-
+conargatypes : { $$ = Lnil; }
+ | conargatype conargatypes { $$ = mklcons($1,$2); }
+ ;
fields : field { $$ = lsing($1); }
| fields COMMA field { $$ = lapp($1,$3); }
;
-field : qvars_list DCOLON ctype { $$ = mkfield($1,$3); }
- | qvars_list DCOLON BANG atype { $$ = mkfield($1,mktbang($4)); }
- | qvars_list DCOLON BANG bigatype { $$ = mkfield($1,mktbang($4)); }
+field : qvars_list DCOLON polytype { $$ = mkfield($1,$3); }
+ | qvars_list DCOLON BANG polyatype { $$ = mkfield($1,mktbang($4)); }
;
-constr1 : gtycon atype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
+constr1 : gtycon conargatype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
;
* *
**********************************************************************/
-exp : oexp DCOLON ctype { $$ = mkrestr($1,$3); }
+exp : oexp DCOLON polytype { $$ = mkrestr($1,$3); }
| oexp
;
We need to factor out a leading let expression so we can set
pat_check=FALSE when parsing (non let) expressions inside stmts and quals
*/
-expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
+expLno : oexpLno DCOLON polytype { $$ = mkrestr($1,$3); }
| oexpLno
;
oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| kexpLno
;
-expL : oexpL DCOLON ctype { $$ = mkrestr($1,$3); }
+expL : oexpL DCOLON polytype { $$ = mkrestr($1,$3); }
| oexpL
;
oexpL : oexpL qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
| qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
| OBRACK list_exps CBRACK { $$ = mkllist($2); }
- | OPAREN exp COMMA texps CPAREN { if (ttree($4) == tuple)
- $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
- else
- $$ = mktuple(ldub($2, $4)); }
+ | OPAREN exp COMMA texps CPAREN { $$ = mktuple(mklcons($2,$4)); }
+ /* unboxed tuples */
+ | OUNBOXPAREN exp COMMA texps CUNBOXPAREN
+ { $$ = mkutuple(mklcons($2,$4)); }
/* only in expressions ... */
| aexp OCURLY rbinds1 CCURLY { $$ = mkrupdate($1,$3); }
rbind : qvar { $$ = mkrbind($1,mknothing()); }
| qvar EQUAL exp { $$ = mkrbind($1,mkjust($3)); }
- ;
+;
-texps : exp { $$ = mkpar($1); } /* mkpar: so we don't flatten last element in tuple */
- | exp COMMA texps
- { if (ttree($3) == tuple)
- $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
- else if (ttree($3) == par)
- $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
- else
- hsperror("hsparser:texps: panic");
- }
+texps : exp { $$ = lsing($1); }
+ | exp COMMA texps { $$ = mklcons($1, $3) }
/* right recursion? WDP */
;
| WILDCARD { $$ = mkwildp(); }
| OPAREN pat CPAREN { $$ = mkpar($2); }
| OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
+ | OUNBOXPAREN pat COMMA pats CUNBOXPAREN { $$ = mkutuple(mklcons($2,$4)); }
| OBRACK pats CBRACK { $$ = mkllist($2); }
| LAZY apat { $$ = mklazyp($2); }
;
| WILDCARD { $$ = mkwildp(); setstartlineno(); }
| oparenkey pat CPAREN { $$ = mkpar($2); }
| oparenkey pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
+ | ounboxparenkey pat COMMA pats CUNBOXPAREN
+ { $$ = mkutuple(mklcons($2,$4)); }
| obrackkey pats CBRACK { $$ = mkllist($2); }
| lazykey apat { $$ = mklazyp($2); }
;
oparenkey: OPAREN { setstartlineno(); }
;
+ounboxparenkey: OUNBOXPAREN { setstartlineno(); }
+ ;
+
obrackkey: OBRACK { setstartlineno(); }
;
varsym_nominus : VARSYM
| PLUS { $$ = install_literal("+"); }
| BANG { $$ = install_literal("!"); }
+ | DOT { $$ = install_literal("."); }
;
/* AS HIDING QUALIFIED are valid varids */
-varid : VARID
+varid : varid_noforall
+ | FORALL { $$ = install_literal("forall"); }
+ ;
+
+varid_noforall
+ : VARID
| AS { $$ = install_literal("as"); }
| HIDING { $$ = install_literal("hiding"); }
| QUALIFIED { $$ = install_literal("qualified"); }
+/* The rest of these guys are used by the FFI decls, a ghc (and hugs) extension. */
+ | EXPORT { $$ = install_literal("export"); }
+ | UNSAFE { $$ = install_literal("unsafe"); }
+ | DYNAMIC { $$ = install_literal("dynamic"); }
+ | LABEL { $$ = install_literal("label"); }
+ | C_CALL { $$ = install_literal("ccall"); }
+ | STDCALL { $$ = install_literal("stdcall"); }
+ | PASCAL { $$ = install_literal("pascal"); }
;
-
ccallid : VARID
| CONID
;
-tyvar : varid { $$ = mknamedtvar(mknoqual($1)); }
- ;
tycon : CONID
;
modid : CONID
;
-/*
-tyvar_list: tyvar { $$ = lsing($1); }
- | tyvar_list COMMA tyvar { $$ = lapp($1,$3); }
+/* ---------------------------------------------- */
+tyvar : varid_noforall { $$ = $1; }
+ ;
+
+/* tyvars1: At least one tyvar */
+tyvars1 : tyvar { $$ = lsing($1); }
+ | tyvar tyvars1 { $$ = mklcons($1,$2); }
;
-*/
/**********************************************************************
* *
pqid(gtypeid(t));
break;
case namedtvar : PUTTAG('y');
- pqid(gnamedtvar(t));
+ pstr(gnamedtvar(t));
break;
case tllist : PUTTAG(':');
pttype(gtlist(t));
case tbang : PUTTAG('!');
pttype(gtbang(t));
break;
- case context : PUTTAG('3');
- plist(pttype,gtcontextl(t));
- pttype(gtcontextt(t));
+ case forall : PUTTAG('3');
+ plist(pstr, gtforalltv(t));
+ plist(pttype,gtforallctxt(t));
+ pttype(gtforallt(t));
break;
default : error("bad pttype");
}
}
break;
+ case utuple:
+ {
+ list tup;
+ for (tup = gutuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
+ expORpat(wanted, lhd(tup));
+ }
+ }
+ break;
+
case llist:
{
list l;
grestrt : ttype; >;
tuple : < gtuplelist : list; >;
+ utuple : < gutuplelist : list; >;
llist : < gllist : list; >;
eenum : < gefrom : tree;
gestep : maybe;
import U_qid
%}}
type ttype;
- tname : < gtypeid : qid; >;
- namedtvar : < gnamedtvar : qid; >;
+ tname : < gtypeid : qid; >; /* tycon */
+ namedtvar : < gnamedtvar : stringId; >; /* tvar */
tllist : < gtlist : ttype; >;
ttuple : < gttuple : list; >;
+ tutuple : < gtutuple : list; >;
tfun : < gtin : ttype;
gtout : ttype; >;
tapp : < gtapp : ttype;
gtarg : ttype; >;
tbang : < gtbang : ttype; >;
- context : < gtcontextl : list;
- gtcontextt : ttype; >;
+ forall : < gtforalltv : list; /* tyvars */
+ gtforallctxt : list; /* theta */
+ gtforallt : ttype; >;
end;
case tfun:
hsperror ("type2context: arrow (->) constructor found in a context");
- case context:
- hsperror ("type2context: unexpected context-thing found in a context");
-
default:
hsperror ("type2context: totally unexpected input");
}
case tfun:
hsperror ("is_context_format: arrow (->) constructor found in a context");
-
- case context:
- hsperror ("is_context_format: unexpected context-thing found in a context");
-
default:
hsperror ("is_context_format: totally unexpected input");
}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge}
\begin{code}
module PrelInfo (
- -- finite maps for built-in things (for the renamer and typechecker):
- builtinNames, derivingOccurrences,
- BuiltinNames,
+ builtinNames, -- Names of things whose *unique* must be known, but
+ -- that is all. If something is in here, you know that
+ -- if it's used at all then it's Name will be just as
+ -- it is here, unique and all. Includes all the
+ -- wiredd-in names.
+
+ thinAirIdNames, -- Names of non-wired-in Ids that may be used out of
+ setThinAirIds, -- thin air in any compilation. If they are not wired in
+ thinAirModules, -- we must be sure to import them from some Prelude
+ -- interface file even if they are not overtly
+ -- mentioned. Subset of builtinNames.
+ noRepIntegerIds,
+ noRepStrIds,
+
+ derivingOccurrences, -- For a given class C, this tells what other
+ -- things are needed as a result of a
+ -- deriving(C) clause
+
+
+ -- Here are the thin-air Ids themselves
+ int2IntegerId, addr2IntegerId,
+ integerMinusOneId, integerZeroId, integerPlusOneId, integerPlusTwoId,
+ packStringForCId, unpackCStringId, unpackCString2Id,
+ unpackCStringAppendId, unpackCStringFoldrId,
+ foldrId,
+
+ -- Random other things
+ main_NAME, ioTyCon_NAME,
+ deRefStablePtr_NAME, makeStablePtr_NAME,
+ bindIO_NAME,
maybeCharLikeCon, maybeIntLikeCon,
+ needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys,
+ isNoDictClass, isNumericClass, isStandardClass, isCcallishClass,
+ isCreturnableClass, numericTyKeys,
+ -- RdrNames for lots of things, mainly used in derivings
eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
enumFromThen_RDR, enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR,
numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
- monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR,
- ioDataCon_RDR, ioOkDataCon_RDR,
+ monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
+ ioDataCon_RDR
- main_NAME, allClass_NAME, ioTyCon_NAME, ioOkDataCon_NAME,
-
- needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, isNoDictClass,
- isNumericClass, isStandardClass, isCcallishClass, isCreturnableClass
) where
#include "HsVersions.h"
-import IdUtils ( primOpName )
-- friends:
import PrelMods -- Prelude module names
import PrelVals -- VALUES
+import MkId ( mkPrimitiveId )
import PrimOp ( PrimOp(..), allThePrimOps )
+import DataCon ( DataCon )
import PrimRep ( PrimRep(..) )
import TysPrim -- TYPES
import TysWiredIn
-- others:
import RdrHsSyn ( RdrName(..), varQual, tcQual, qual )
import BasicTypes ( IfaceFlavour )
-import Id ( GenId, Id )
+import Var ( varUnique, Id )
import Name ( Name, OccName(..), Provenance(..),
getName, mkGlobalName, modAndOcc
)
import Class ( Class, classKey )
-import TyCon ( tyConDataCons, mkFunTyCon, TyCon )
-import Type
+import TyCon ( tyConDataCons, TyCon )
+import Type ( funTyCon )
import Bag
import Unique -- *Key stuff
-import UniqFM ( UniqFM, listToUFM )
-import Util ( isIn )
+import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM )
+import Util ( isIn, panic )
+
+import IOExts
\end{code}
%************************************************************************
@Classes@, the other to look up values.
\begin{code}
-type BuiltinNames = Bag Name
-
-builtinNames :: BuiltinNames
+builtinNames :: Bag Name
builtinNames
- = -- Wired in TyCons
- unionManyBags (map getTyConNames wired_in_tycons) `unionBags`
+ = unionManyBags
+ [ -- Wired in TyCons
+ unionManyBags (map getTyConNames wired_in_tycons)
+
+ -- Wired in Ids
+ , listToBag (map getName wired_in_ids)
- -- Wired in Ids
- listToBag (map getName wired_in_ids) `unionBags`
+ -- PrimOps
+ , listToBag (map (getName . mkPrimitiveId) allThePrimOps)
- -- PrimOps
- listToBag (map (getName.primOpName) allThePrimOps) `unionBags`
+ -- Thin-air ids
+ , listToBag thinAirIdNames
- -- Other names with magic keys
- listToBag knownKeyNames
+ -- Other names with magic keys
+ , listToBag knownKeyNames
+ ]
\end{code}
\begin{code}
getTyConNames :: TyCon -> Bag Name
getTyConNames tycon
- = getName tycon `consBag` listToBag (map getName (tyConDataCons tycon))
+ = getName tycon `consBag`
+ listToBag (map getName (tyConDataCons tycon))
-- Synonyms return empty list of constructors
\end{code}
-
We let a lot of "non-standard" values be visible, so that we can make
sense of them in interface pragmas. It's cool, though they all have
"non-standard" names, so they won't get past the parser in user code.
+
%************************************************************************
%* *
\subsection{Wired in TyCons}
%* *
%************************************************************************
-
\begin{code}
-wired_in_tycons = [mkFunTyCon] ++
+wired_in_tycons = [funTyCon] ++
prim_tycons ++
tuple_tycons ++
+ unboxed_tuple_tycons ++
data_tycons
prim_tycons
, intPrimTyCon
, int64PrimTyCon
, foreignObjPrimTyCon
+ , weakPrimTyCon
, mutableArrayPrimTyCon
, mutableByteArrayPrimTyCon
- , synchVarPrimTyCon
+ , mVarPrimTyCon
+ , mutVarPrimTyCon
, realWorldTyCon
, stablePtrPrimTyCon
, statePrimTyCon
+ , threadIdPrimTyCon
, wordPrimTyCon
, word64PrimTyCon
]
tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ]
-
+unboxed_tuple_tycons = [unboxedTupleTyCon i | i <- [1..37] ]
data_tycons
- = [ listTyCon
- , addrTyCon
+ = [ addrTyCon
, boolTyCon
, charTyCon
, doubleTyCon
, floatTyCon
- , foreignObjTyCon
, intTyCon
, int8TyCon
, int16TyCon
, int32TyCon
, int64TyCon
, integerTyCon
- , liftTyCon
- , return2GMPsTyCon
- , returnIntAndGMPTyCon
- , stTyCon
- , stRetTyCon
- , stablePtrTyCon
- , stateAndAddrPrimTyCon
- , stateAndArrayPrimTyCon
- , stateAndByteArrayPrimTyCon
- , stateAndCharPrimTyCon
- , stateAndDoublePrimTyCon
- , stateAndFloatPrimTyCon
- , stateAndForeignObjPrimTyCon
- , stateAndIntPrimTyCon
- , stateAndMutableArrayPrimTyCon
- , stateAndMutableByteArrayPrimTyCon
- , stateAndPtrPrimTyCon
- , stateAndStablePtrPrimTyCon
- , stateAndSynchVarPrimTyCon
- , stateAndWordPrimTyCon
+ , listTyCon
, voidTyCon
, wordTyCon
, word8TyCon
]
\end{code}
+
%************************************************************************
%* *
\subsection{Wired in Ids}
%* *
%************************************************************************
-The WiredIn Ids ...
-ToDo: Some of these should be moved to id_keys_infos!
-
\begin{code}
wired_in_ids
- = [ aBSENT_ERROR_ID
- , augmentId
- , buildId
+ = [ -- These error-y things are wired in because we don't yet have
+ -- a way to express in an inteface file that the result type variable
+ -- is 'open'; that is can be unified with an unboxed type
+ aBSENT_ERROR_ID
, eRROR_ID
- , foldlId
- , foldrId
, iRREFUT_PAT_ERROR_ID
- , integerMinusOneId
- , integerPlusOneId
- , integerPlusTwoId
- , integerZeroId
, nON_EXHAUSTIVE_GUARDS_ERROR_ID
, nO_METHOD_BINDING_ERROR_ID
, pAR_ERROR_ID
, pAT_ERROR_ID
- , packStringForCId
, rEC_CON_ERROR_ID
, rEC_UPD_ERROR_ID
+
+ -- These two can't be defined in Haskell
, realWorldPrimId
--- , tRACE_ID
- , unpackCString2Id
- , unpackCStringAppendId
- , unpackCStringFoldrId
- , unpackCStringId
, unsafeCoerceId
- , voidId
-
--- , copyableId
--- , forkId
--- , noFollowId
--- , parAtAbsId
--- , parAtForNowId
--- , parAtId
--- , parAtRelId
--- , parGlobalId
--- , parId
--- , parLocalId
--- , seqId
]
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Thin air entities}
+%* *
+%************************************************************************
+
+These are Ids that we need to reference in various parts of the
+system, and we'd like to pull them out of thin air rather than pass
+them around. We'd also like to have all the IdInfo available for each
+one: i.e. everything that gets pulled out of the interface file.
+
+The solution is to generate this map of global Ids after the
+typechecker, and assign it to a global variable. Any subsequent
+pass may refer to the map to pull Ids out. Any invalid
+(i.e. pre-typechecker) access to the map will result in a panic.
+
+\begin{code}
+thinAirIdNames
+ = map mkKnownKeyGlobal
+ [
+ -- Needed for converting literals to Integers (used in tidyCoreExpr)
+ (varQual (pREL_BASE, SLIT("int2Integer")), int2IntegerIdKey)
+ , (varQual (pREL_BASE, SLIT("addr2Integer")), addr2IntegerIdKey)
+
+ -- OK, this is Will's idea: we should have magic values for Integers 0,
+ -- +1, +2, and -1 (go ahead, fire me):
+ , (varQual (pREL_BASE, SLIT("integer_0")), integerZeroIdKey)
+ , (varQual (pREL_BASE, SLIT("integer_1")), integerPlusOneIdKey)
+ , (varQual (pREL_BASE, SLIT("integer_2")), integerPlusTwoIdKey)
+ , (varQual (pREL_BASE, SLIT("integer_m1")), integerMinusOneIdKey)
+
+
+ -- String literals
+ , (varQual (pREL_PACK, SLIT("packCString#")), packCStringIdKey)
+ , (varQual (pREL_PACK, SLIT("unpackCString#")), unpackCStringIdKey)
+ , (varQual (pREL_PACK, SLIT("unpackNBytes#")), unpackCString2IdKey)
+ , (varQual (pREL_PACK, SLIT("unpackAppendCString#")), unpackCStringAppendIdKey)
+ , (varQual (pREL_PACK, SLIT("unpackFoldrCString#")), unpackCStringFoldrIdKey)
+
+ -- Folds; introduced by desugaring list comprehensions
+ , (varQual (pREL_BASE, SLIT("foldr")), foldrIdKey)
+ ]
+
+thinAirModules = [pREL_PACK] -- See notes with RnIfaces.findAndReadIface
+
+noRepIntegerIds = [integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId,
+ int2IntegerId, addr2IntegerId]
+
+noRepStrIds = [unpackCString2Id, unpackCStringId]
+
+int2IntegerId = lookupThinAirId int2IntegerIdKey
+addr2IntegerId = lookupThinAirId addr2IntegerIdKey
+
+integerMinusOneId = lookupThinAirId integerMinusOneIdKey
+integerZeroId = lookupThinAirId integerZeroIdKey
+integerPlusOneId = lookupThinAirId integerPlusOneIdKey
+integerPlusTwoId = lookupThinAirId integerPlusTwoIdKey
+
+packStringForCId = lookupThinAirId packCStringIdKey
+unpackCStringId = lookupThinAirId unpackCStringIdKey
+unpackCString2Id = lookupThinAirId unpackCString2IdKey
+unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey
+unpackCStringFoldrId = lookupThinAirId unpackCStringFoldrIdKey
+
+foldrId = lookupThinAirId foldrIdKey
+\end{code}
+
+
+\begin{code}
+\end{code}
+
+\begin{code}
+thinAirIdMapRef :: IORef (UniqFM Id)
+thinAirIdMapRef = unsafePerformIO (newIORef (panic "thinAirIdMap: still empty"))
+
+setThinAirIds :: [Id] -> IO ()
+setThinAirIds thin_air_ids
+ = writeIORef thinAirIdMapRef the_map
+ where
+ the_map = listToUFM [(varUnique id, id) | id <- thin_air_ids]
+
+thinAirIdMap :: UniqFM Id
+thinAirIdMap = unsafePerformIO (readIORef thinAirIdMapRef)
+ -- Read it just once, the first time someone tugs on thinAirIdMap
+
+lookupThinAirId :: Unique -> Id
+lookupThinAirId uniq = lookupWithDefaultUFM thinAirIdMap
+ (panic "lookupThinAirId: no mapping") uniq
\end{code}
mkKnownKeyGlobal (Qual mod occ hif, uniq)
= mkGlobalName uniq mod occ NoProvenance
-allClass_NAME = mkKnownKeyGlobal (allClass_RDR, allClassKey)
-ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey)
-ioOkDataCon_NAME = mkKnownKeyGlobal (ioOkDataCon_RDR, ioOkDataConKey)
-main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
+ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey)
+main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
+
+ -- Operations needed when compiling FFI decls
+bindIO_NAME = mkKnownKeyGlobal (bindIO_RDR, bindIOIdKey)
+deRefStablePtr_NAME = mkKnownKeyGlobal (deRefStablePtr_RDR, deRefStablePtrIdKey)
+makeStablePtr_NAME = mkKnownKeyGlobal (makeStablePtr_RDR, makeStablePtrIdKey)
knownKeyNames :: [Name]
knownKeyNames
- = [main_NAME, allClass_NAME, ioTyCon_NAME, ioOkDataCon_NAME]
+ = [main_NAME, ioTyCon_NAME]
++
map mkKnownKeyGlobal
[
-- Type constructors (synonyms especially)
- (orderingTyCon_RDR, orderingTyConKey)
- , (rationalTyCon_RDR, rationalTyConKey)
- , (ratioDataCon_RDR, ratioDataConKey)
- , (ratioTyCon_RDR, ratioTyConKey)
- , (byteArrayTyCon_RDR, byteArrayTyConKey)
+ (orderingTyCon_RDR, orderingTyConKey)
+ , (rationalTyCon_RDR, rationalTyConKey)
+ , (ratioDataCon_RDR, ratioDataConKey)
+ , (ratioTyCon_RDR, ratioTyConKey)
+ , (byteArrayTyCon_RDR, byteArrayTyConKey)
, (mutableByteArrayTyCon_RDR, mutableByteArrayTyConKey)
-
+ , (foreignObjTyCon_RDR, foreignObjTyConKey)
+ , (stablePtrTyCon_RDR, stablePtrTyConKey)
-- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey)
-- classes in "Class.standardClassKeys" (quite a few)
, (eqClass_RDR, eqClassKey) -- mentioned, derivable
, (ordClass_RDR, ordClassKey) -- derivable
- , (evalClass_RDR, evalClassKey) -- mentioned
, (boundedClass_RDR, boundedClassKey) -- derivable
, (numClass_RDR, numClassKey) -- mentioned, numeric
, (enumClass_RDR, enumClassKey) -- derivable
, (returnM_RDR, returnMClassOpKey)
, (zeroM_RDR, zeroClassOpKey)
, (fromRational_RDR, fromRationalClassOpKey)
+
+ , (deRefStablePtr_RDR, deRefStablePtrIdKey)
+ , (makeStablePtr_RDR, makeStablePtrIdKey)
+ , (bindIO_RDR, bindIOIdKey)
+
+ , (map_RDR, mapIdKey)
+ , (append_RDR, appendIdKey)
+
+ -- List operations
+ , (concat_RDR, concatIdKey)
+ , (filter_RDR, filterIdKey)
+ , (zip_RDR, zipIdKey)
-- Others
, (otherwiseId_RDR, otherwiseIdKey)
ToDo: make it do the ``like'' part properly (as in 0.26 and before).
\begin{code}
-maybeCharLikeCon, maybeIntLikeCon :: Id -> Bool
-maybeCharLikeCon con = uniqueOf con == charDataConKey
-maybeIntLikeCon con = uniqueOf con == intDataConKey
+maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
+maybeCharLikeCon con = getUnique con == charDataConKey
+maybeIntLikeCon con = getUnique con == intDataConKey
\end{code}
%************************************************************************
to write them all down in one place.
\begin{code}
-prelude_primop op = qual (modAndOcc (primOpName op))
+prelude_primop op = qual (modAndOcc (mkPrimitiveId op))
+
+main_RDR = varQual (mAIN, SLIT("main"))
+otherwiseId_RDR = varQual (pREL_BASE, SLIT("otherwise"))
intTyCon_RDR = qual (modAndOcc intTyCon)
-ioTyCon_RDR = tcQual (pREL_IO_BASE, SLIT("IO"))
-ioDataCon_RDR = varQual (pREL_IO_BASE, SLIT("IO"))
-ioOkDataCon_RDR = varQual (pREL_IO_BASE, SLIT("IOok"))
+ioTyCon_RDR = tcQual (pREL_IO_BASE, SLIT("IO"))
+ioDataCon_RDR = varQual (pREL_IO_BASE, SLIT("IO"))
+bindIO_RDR = varQual (pREL_IO_BASE, SLIT("bindIO"))
+
orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering"))
rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational"))
ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio"))
byteArrayTyCon_RDR = tcQual (pREL_ARR, SLIT("ByteArray"))
mutableByteArrayTyCon_RDR = tcQual (pREL_ARR, SLIT("MutableByteArray"))
-allClass_RDR = tcQual (pREL_GHC, SLIT("All"))
+foreignObjTyCon_RDR = tcQual (pREL_IO_BASE, SLIT("ForeignObj"))
+stablePtrTyCon_RDR = tcQual (pREL_FOREIGN, SLIT("StablePtr"))
+deRefStablePtr_RDR = varQual (pREL_FOREIGN, SLIT("deRefStablePtr"))
+makeStablePtr_RDR = varQual (pREL_FOREIGN, SLIT("makeStablePtr"))
+
eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq"))
ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord"))
-evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval"))
boundedClass_RDR = tcQual (pREL_BASE, SLIT("Bounded"))
numClass_RDR = tcQual (pREL_BASE, SLIT("Num"))
enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum"))
enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen"))
enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo"))
-thenM_RDR = varQual (pREL_BASE, SLIT(">>="))
-returnM_RDR = varQual (pREL_BASE, SLIT("return"))
-zeroM_RDR = varQual (pREL_BASE, SLIT("zero"))
-fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational"))
+thenM_RDR = varQual (pREL_BASE, SLIT(">>="))
+returnM_RDR = varQual (pREL_BASE, SLIT("return"))
+zeroM_RDR = varQual (pREL_BASE, SLIT("zero"))
+fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational"))
negate_RDR = varQual (pREL_BASE, SLIT("negate"))
eq_RDR = varQual (pREL_BASE, SLIT("=="))
ne_RDR = varQual (pREL_BASE, SLIT("/="))
compose_RDR = varQual (pREL_BASE, SLIT("."))
append_RDR = varQual (pREL_BASE, SLIT("++"))
map_RDR = varQual (pREL_BASE, SLIT("map"))
+concat_RDR = varQual (mONAD, SLIT("concat"))
+filter_RDR = varQual (mONAD, SLIT("filter"))
+zip_RDR = varQual (pREL_LIST, SLIT("zip"))
showList___RDR = varQual (pREL_BASE, SLIT("showList__"))
showsPrec_RDR = varQual (pREL_BASE, SLIT("showsPrec"))
error_RDR = varQual (pREL_ERR, SLIT("error"))
assert_RDR = varQual (pREL_GHC, SLIT("assert"))
-assertErr_RDR = varQual (pREL_ERR, SLIT("assertError"))
+assertErr_RDR = varQual (pREL_ERR, SLIT("assertError"))
eqH_Char_RDR = prelude_primop CharEqOp
ltH_Char_RDR = prelude_primop CharLtOp
geH_RDR = prelude_primop IntGeOp
leH_RDR = prelude_primop IntLeOp
minusH_RDR = prelude_primop IntSubOp
-
-main_RDR = varQual (mAIN, SLIT("main"))
-
-otherwiseId_RDR = varQual (pREL_BASE, SLIT("otherwise"))
\end{code}
%************************************************************************
-- EQ (from Ordering) is needed to force in the constructors
-- as well as the type constructor.
, (enumClassKey, [intTyCon_RDR, map_RDR])
- , (evalClassKey, [intTyCon_RDR])
, (boundedClassKey, [intTyCon_RDR])
, (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
showParen_RDR, showSpace_RDR, showList___RDR])
isNoDictClass clas = classKey clas `is_elem` noDictClassKeys
is_elem = isIn "is_X_Class"
-numericClassKeys
- = [ numClassKey
- , realClassKey
- , integralClassKey
- , fractionalClassKey
- , floatingClassKey
- , realFracClassKey
- , realFloatClassKey
- ]
-
-needsDataDeclCtxtClassKeys -- see comments in TcDeriv
- = [ readClassKey
- ]
-
-cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
+numericClassKeys =
+ [ numClassKey
+ , realClassKey
+ , integralClassKey
+ , fractionalClassKey
+ , floatingClassKey
+ , realFracClassKey
+ , realFloatClassKey
+ ]
+
+ -- the strictness analyser needs to know about numeric types
+ -- (see SaAbsInt.lhs)
+numericTyKeys =
+ [ addrTyConKey
+ , wordTyConKey
+ , intTyConKey
+ , integerTyConKey
+ , doubleTyConKey
+ , floatTyConKey
+ ]
+
+needsDataDeclCtxtClassKeys = -- see comments in TcDeriv
+ [ readClassKey
+ ]
+
+cCallishClassKeys =
+ [ cCallableClassKey
+ , cReturnableClassKey
+ ]
-- Renamer always imports these data decls replete with constructors
-- so that desugarer can always see the constructor. Ugh!
-cCallishTyKeys = [ addrTyConKey, wordTyConKey, byteArrayTyConKey,
- mutableByteArrayTyConKey, foreignObjTyConKey ]
+cCallishTyKeys =
+ [ addrTyConKey
+ , wordTyConKey
+ , byteArrayTyConKey
+ , mutableByteArrayTyConKey
+ , foreignObjTyConKey
+ , stablePtrTyConKey
+ ]
standardClassKeys
= derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
noDictClassKeys -- These classes are used only for type annotations;
-- they are not implemented by dictionaries, ever.
= cCallishClassKeys
- -- I used to think that class Eval belonged in here, but
- -- we really want functions with type (Eval a => ...) and that
- -- means that we really want to pass a placeholder for an Eval
- -- dictionary. The unit tuple is what we'll get if we leave things
- -- alone, and that'll do for now. Could arrange to drop that parameter
- -- in the end.
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PrelMods]{Definitions of prelude modules}
pREL_GHC, pRELUDE, mONAD, rATIO, iX, mAIN, pREL_MAIN, pREL_ERR,
pREL_BASE, pREL_NUM, pREL_LIST, pREL_TUP, pREL_ADDR, pREL_READ,
pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR, pREL_FOREIGN,
- pREL_CCALL,
iNT, wORD
) where
pREL_ST = SLIT("PrelST")
pREL_ARR = SLIT("PrelArr")
pREL_FOREIGN = SLIT("PrelForeign")
-pREL_CCALL = SLIT("PrelCCall")
pREL_ADDR = SLIT("PrelAddr")
pREL_ERR = SLIT("PrelErr")
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PrelVals]{Prelude values the compiler ``knows about''}
import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
-import Id ( Id, mkVanillaId, mkTemplateLocals )
-import SpecEnv ( SpecEnv, emptySpecEnv )
+import Id ( Id, mkVanillaId, setIdInfo, mkTemplateLocals )
-- friends:
import PrelMods
import IdInfo -- quite a bit
import Name ( mkWiredInIdName, Module )
import Type
-import TyVar ( openAlphaTyVar, openAlphaTyVars, alphaTyVar, betaTyVar, TyVar )
+import Var ( TyVar )
import Unique -- lots of *Keys
-import Util ( panic )
+
+import IOExts
\end{code}
-\begin{code}
--- only used herein:
+%************************************************************************
+%* *
+\subsection{Un-definable}
+%* *
+%************************************************************************
-mk_inline_unfolding expr = setUnfoldingInfo (mkUnfolding expr) $
- setInlinePragInfo IWantToBeINLINEd noIdInfo
+These two can't be defined in Haskell.
-exactArityInfo n = exactArity n `setArityInfo` noIdInfo
-pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
+unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
+just gets expanded into a type coercion wherever it occurs. Hence we
+add it as a built-in Id with an unfolding here.
-pcMiscPrelId key mod occ ty info
- = let
- name = mkWiredInIdName key mod occ imp
- imp = mkVanillaId name ty info -- the usual case...
- in
- imp
- -- We lie and say the thing is imported; otherwise, we get into
- -- a mess with dependency analysis; e.g., core2stg may heave in
- -- random calls to GHCbase.unpackPS__. If GHCbase is the module
- -- being compiled, then it's just a matter of luck if the definition
- -- will be in "the right place" to be in scope.
+The type variables we use here are "open" type variables: this means
+they can unify with both unlifted and lifted types. Hence we provide
+another gun with which to shoot yourself in the foot.
+
+\begin{code}
+unsafeCoerceId
+ = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty
+ (mk_inline_unfolding template)
+ where
+ (alphaTyVar:betaTyVar:_) = openAlphaTyVars
+ alphaTy = mkTyVarTy alphaTyVar
+ betaTy = mkTyVarTy betaTyVar
+ ty = mkForAllTys [alphaTyVar,betaTyVar] (mkFunTy alphaTy betaTy)
+ [x] = mkTemplateLocals [alphaTy]
+ template = mkLams [alphaTyVar,betaTyVar,x] $
+ Note (Coerce betaTy alphaTy) (Var x)
+\end{code}
+
+
+@realWorld#@ used to be a magic literal, \tr{void#}. If things get
+nasty as-is, change it back to a literal (@Literal@).
+
+\begin{code}
+realWorldPrimId
+ = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
+ realWorldStatePrimTy
+ noCafIdInfo
\end{code}
+
%************************************************************************
%* *
\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
@absentErr@ is a thing we put in for ``absent'' arguments. They jolly
well shouldn't be yanked on, but if one is, then you will get a
-friendly message from @absentErr@ (rather a totally random crash).
+friendly message from @absentErr@ (rather than a totally random
+crash).
@parError@ is a special version of @error@ which the compiler does
not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
- bottoming_info = mkBottomStrictnessInfo `setStrictnessInfo` noIdInfo
+ bottoming_info = mkBottomStrictnessInfo `setStrictnessInfo` noCafIdInfo
-- these "bottom" out, no matter what their arguments
eRROR_ID
pAR_ERROR_ID
= pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo
openAlphaTy = mkTyVarTy openAlphaTyVar
-- returns, so the return type is irrelevant.
\end{code}
-unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
-just gets expanded into a type coercion wherever it occurs. Hence we
-add it as a built-in Id with an unfolding here.
-
-\begin{code}
-unsafeCoerceId
- = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty
- (mk_inline_unfolding template)
- where
- (alphaTyVar:betaTyVar:_) = openAlphaTyVars
- alphaTy = mkTyVarTy alphaTyVar
- betaTy = mkTyVarTy betaTyVar
- ty = mkForAllTys [alphaTyVar,betaTyVar] (mkFunTy alphaTy betaTy)
- [x] = mkTemplateLocals [alphaTy]
- template = mkLam [alphaTyVar,betaTyVar] [x] $
- Note (Coerce betaTy alphaTy) (Var x)
-
-\end{code}
-
-We want \tr{GHCbase.trace} to be wired in
-because we don't want the strictness analyser to get ahold of it,
-decide that the second argument is strict, evaluate that first (!!),
-and make a jolly old mess.
-\begin{code}
-tRACE_ID
- = pcMiscPrelId traceIdKey pREL_IO_BASE SLIT("trace") traceTy
- (pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy `setSpecInfo` noIdInfo)
- where
- traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
-\end{code}
%************************************************************************
%* *
-\subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals}
+\subsection{Utilities}
%* *
%************************************************************************
-\begin{code}
-packStringForCId
- = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pREL_PACK SLIT("packCString#")
- (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
-
---------------------------------------------------------------------
-
-unpackCStringId
- = pcMiscPrelId unpackCStringIdKey pREL_PACK SLIT("unpackCString#")
- (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
--- Andy says:
--- (FunTy addrPrimTy{-a char *-} stringTy) (exactArityInfo 1)
--- but I don't like wired-in IdInfos (WDP)
-
-unpackCString2Id -- for cases when a string has a NUL in it
- = pcMiscPrelId unpackCString2IdKey pREL_PACK SLIT("unpackNBytes#")
- (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
- noIdInfo
-
---------------------------------------------------------------------
-unpackCStringAppendId
- = pcMiscPrelId unpackCStringAppendIdKey pREL_PACK SLIT("unpackAppendCString#")
- (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
- (exactArityInfo 2)
-
-unpackCStringFoldrId
- = pcMiscPrelId unpackCStringFoldrIdKey pREL_PACK SLIT("unpackFoldrCString#")
- (mkSigmaTy [alphaTyVar] []
- (mkFunTys [addrPrimTy{-a "char *" pointer-},
- mkFunTys [charTy, alphaTy] alphaTy,
- alphaTy]
- alphaTy))
- (exactArityInfo 3)
-\end{code}
-
-OK, this is Will's idea: we should have magic values for Integers 0,
-+1, +2, and -1 (go ahead, fire me):
+Note IMustBeINLINEd below. These things have the same status as
+constructor functions, i.e. they will *always* be inlined, wherever
+they occur.
\begin{code}
-integerZeroId
- = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo
-integerPlusOneId
- = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo
-integerPlusTwoId
- = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo
-integerMinusOneId
- = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)}
-%* *
-%************************************************************************
-
-\begin{code}
-{- OUT:
---------------------------------------------------------------------
--- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
--- dangerousEval
-{-
- OLDER:
- seq = /\ a b -> \ x y -> case x of { _ -> y }
-
- OLD:
- seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
-
- NEW (95/05):
- seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
-
--}
-
-seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [alphaTy, betaTy] betaTy))
- (mk_inline_unfolding seq_template)
- where
- [x, y, z]
- = mkTemplateLocals [
- {-x-} alphaTy,
- {-y-} betaTy,
- {-z-} intPrimTy
- ]
-
- seq_template
- = mkLam [alphaTyVar, betaTyVar] [x, y] (
- Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
- (BindDefault z (Var y))))
-
---------------------------------------------------------------------
--- parId :: "par", also used w/ GRIP, etc.
-{-
- OLDER:
-
- par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y }
-
- OLD:
-
- par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
-
- NEW (95/05):
-
- par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
-
--}
-parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [alphaTy, betaTy] betaTy))
- (mk_inline_unfolding par_template)
- where
- [x, y, z]
- = mkTemplateLocals [
- {-x-} alphaTy,
- {-y-} betaTy,
- {-z-} intPrimTy
- ]
-
- par_template
- = mkLam [alphaTyVar, betaTyVar] [x, y] (
- Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
- (BindDefault z (Var y))))
-
--- forkId :: "fork", for *required* concurrent threads
-{-
- _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
--}
-forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [alphaTy, betaTy] betaTy))
- (mk_inline_unfolding fork_template)
- where
- [x, y, z]
- = mkTemplateLocals [
- {-x-} alphaTy,
- {-y-} betaTy,
- {-z-} intPrimTy
- ]
-
- fork_template
- = mkLam [alphaTyVar, betaTyVar] [x, y] (
- Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
- (BindDefault z (Var y))))
--}
-\end{code}
-
-GranSim ones:
-\begin{code}
-{- OUT:
-parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (mk_inline_unfolding parLocal_template)
- where
- -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
- [w, g, s, p, x, y, z]
- = mkTemplateLocals [
- {-w-} intPrimTy,
- {-g-} intPrimTy,
- {-s-} intPrimTy,
- {-p-} intPrimTy,
- {-x-} alphaTy,
- {-y-} betaTy,
- {-z-} intPrimTy
- ]
-
- parLocal_template
- = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
- Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
- (BindDefault z (Var y))))
-
-parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (mk_inline_unfolding parGlobal_template)
- where
- -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
- [w, g, s, p, x, y, z]
- = mkTemplateLocals [
- {-w-} intPrimTy,
- {-g-} intPrimTy,
- {-s-} intPrimTy,
- {-p-} intPrimTy,
- {-x-} alphaTy,
- {-y-} betaTy,
- {-z-} intPrimTy
- ]
-
- parGlobal_template
- = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
- Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
- (BindDefault z (Var y))))
-
-
-parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
- alphaTy, betaTy, gammaTy] gammaTy))
- (mk_inline_unfolding parAt_template)
- where
- -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
- [w, g, s, p, v, x, y, z]
- = mkTemplateLocals [
- {-w-} intPrimTy,
- {-g-} intPrimTy,
- {-s-} intPrimTy,
- {-p-} intPrimTy,
- {-v-} alphaTy,
- {-x-} betaTy,
- {-y-} gammaTy,
- {-z-} intPrimTy
- ]
-
- parAt_template
- = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
- Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
- (BindDefault z (Var y))))
-
-parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (mk_inline_unfolding parAtAbs_template)
- where
- -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
- [w, g, s, p, v, x, y, z]
- = mkTemplateLocals [
- {-w-} intPrimTy,
- {-g-} intPrimTy,
- {-s-} intPrimTy,
- {-p-} intPrimTy,
- {-v-} intPrimTy,
- {-x-} alphaTy,
- {-y-} betaTy,
- {-z-} intPrimTy
- ]
-
- parAtAbs_template
- = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
- Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
- (BindDefault z (Var y))))
-
-parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (mk_inline_unfolding parAtRel_template)
- where
- -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
- [w, g, s, p, v, x, y, z]
- = mkTemplateLocals [
- {-w-} intPrimTy,
- {-g-} intPrimTy,
- {-s-} intPrimTy,
- {-p-} intPrimTy,
- {-v-} intPrimTy,
- {-x-} alphaTy,
- {-y-} betaTy,
- {-z-} intPrimTy
- ]
-
- parAtRel_template
- = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
- Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
- (BindDefault z (Var y))))
-
-parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
- (mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
- alphaTy, betaTy, gammaTy] gammaTy))
- (mk_inline_unfolding parAtForNow_template)
- where
- -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
- [w, g, s, p, v, x, y, z]
- = mkTemplateLocals [
- {-w-} intPrimTy,
- {-g-} intPrimTy,
- {-s-} intPrimTy,
- {-p-} intPrimTy,
- {-v-} alphaTy,
- {-x-} betaTy,
- {-y-} gammaTy,
- {-z-} intPrimTy
- ]
-
- parAtForNow_template
- = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
- Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
- PrimAlts
- [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
- (BindDefault z (Var y))))
-
--- copyable and noFollow are currently merely hooks: they are translated into
--- calls to the macros COPYABLE and NOFOLLOW -- HWL
-
-copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
- (mkSigmaTy [alphaTyVar] []
- alphaTy)
- (mk_inline_unfolding copyable_template)
- where
- -- Annotations: x: closure that's tagged to by copyable
- [x, z]
- = mkTemplateLocals [
- {-x-} alphaTy,
- {-z-} alphaTy
- ]
-
- copyable_template
- = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
-
-noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
- (mkSigmaTy [alphaTyVar] []
- alphaTy)
- (mk_inline_unfolding noFollow_template)
- where
- -- Annotations: x: closure that's tagged to not follow
- [x, z]
- = mkTemplateLocals [
- {-x-} alphaTy,
- {-z-} alphaTy
- ]
-
- noFollow_template
- = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
--}
-\end{code}
-
-@realWorld#@ used to be a magic literal, \tr{void#}. If things get
-nasty as-is, change it back to a literal (@Literal@).
-\begin{code}
-realWorldPrimId
- = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
- realWorldStatePrimTy
- noIdInfo
-\end{code}
-
-\begin{code}
-voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
-%* *
-%************************************************************************
-
-\begin{code}
-buildId
- = pcMiscPrelId buildIdKey pREL_ERR SLIT("build") buildTy
- noIdInfo
- {- LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey)
- `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
- `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
- `setSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
- -}
- -- cheating, but since _build never actually exists ...
- where
- -- The type of this strange object is:
- -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
-
- buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
- where
- build_ty = mkSigmaTy [betaTyVar] []
- (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
-\end{code}
-
-@mkBuild@ is sugar for building a build!
-
-@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
-@ty@ is the type of the list.
-@tv@ is always a new type variable.
-@c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
- c :: a -> b -> b
- n :: b
- v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
--- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
-@e@ is the object right inside the @build@
+mk_inline_unfolding expr = setUnfoldingInfo (mkUnfolding expr) $
+ setInlinePragInfo IMustBeINLINEd noIdInfo
-\begin{code}
-mkBuild :: Type
- -> TyVar
- -> Id
- -> Id
- -> Id
- -> CoreExpr -- template
- -> CoreExpr -- template
-
-mkBuild ty tv c n g expr
- = Let (NonRec g (mkLam [tv] [c,n] expr))
- (App (mkTyApp (Var buildId) [ty]) (VarArg g))
-\end{code}
+exactArityInfo n = exactArity n `setArityInfo` noIdInfo
-\begin{code}
-augmentId
- = pcMiscPrelId augmentIdKey pREL_ERR SLIT("augment") augmentTy
- noIdInfo
- {- LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey)
- `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
- `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
- -}
- -- cheating, but since _augment never actually exists ...
- where
- -- The type of this strange object is:
- -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
+pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
- augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
- where
- aug_ty = mkSigmaTy [betaTyVar] []
- (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
-\end{code}
+pcMiscPrelId key mod occ ty info
+ = let
+ name = mkWiredInIdName key mod occ imp
+ imp = mkVanillaId name ty `setIdInfo` info -- the usual case...
+ in
+ imp
+ -- We lie and say the thing is imported; otherwise, we get into
+ -- a mess with dependency analysis; e.g., core2stg may heave in
+ -- random calls to GHCbase.unpackPS__. If GHCbase is the module
+ -- being compiled, then it's just a matter of luck if the definition
+ -- will be in "the right place" to be in scope.
-\begin{code}
-foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
- foldrTy idInfo
- where
- foldrTy =
- mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
-
- idInfo = noIdInfo
- {- LATER: mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False `setStrictnessInfo`
- exactArity 3 `setArityInfo`
- mkUpdateInfo [2,2,1] `setUpdateInfo`
- pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy `setSpecInfo`
- noIdInfo
- -}
-
-foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
- foldlTy idInfo
- where
- foldlTy =
- mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
-
- idInfo = noIdInfo
- {- LATER: `addUnfoldInfo` mkMagicUnfolding foldlIdKey)
- `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
- `addArityInfo` exactArity 3)
- `addUpdateInfo` mkUpdateInfo [2,2,1])
- `setSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
- -}
-
--- A bit of magic goes no here. We translate appendId into ++,
--- you have to be carefull when you actually compile append:
--- xs ++ ys = augment (\ c n -> foldr c n xs) ys
--- {- unfold augment -}
--- = foldr (:) ys xs
--- {- fold foldr to append -}
--- = ys `appendId` xs
--- = ys ++ xs -- ugg!
--- *BUT* you want (++) and not _append in your interfaces.
---
--- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
--- the prelude.
---
-{- OLD: doesn't apply with 1.3
-appendId
- = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
- where
- appendTy =
- (mkSigmaTy [alphaTyVar] []
- (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
- idInfo = (((noIdInfo
- `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
- `addArityInfo` exactArity 2)
- `addUpdateInfo` mkUpdateInfo [1,2])
--}
+-- very useful...
+noCafIdInfo = NoCafRefs `setCafInfo` noIdInfo
\end{code}
-%************************************************************************
-%* *
-\subsection[PrelUtils-specialisations]{Specialisations for builtin values}
-%* *
-%************************************************************************
-
-The specialisations which exist for the builtin values must be recorded in
-their IdInfos.
-
-NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
- TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
-
-HACK: We currently use the same unique for the specialised Ids.
-
-The list @specing_types@ determines the types for which specialised
-versions are created. Note: This should correspond with the
-types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
-
-ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
-
-\begin{code}
-pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> IdSpecEnv
-pcGenerateSpecs key id info ty
- = emptySpecEnv
-
-{- LATER:
-
-pc_gen_specs True key id info ty
-
-pc_gen_specs is_id key id info ty
- = mkSpecEnv spec_infos
- where
- spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
- spec_id = if is_id
- then mkSpecId key {- HACK WARNING: same unique! -}
- id spec_tys spec_ty info
- else panic "SpecData:SpecInfo:SpecId"
- in
- SpecInfo spec_tys (length ctxts) spec_id
- | spec_tys <- specialisations ]
-
- (tyvars, ctxts, _) = splitSigmaTy ty
- no_tyvars = length tyvars
-
- specialisations = if no_tyvars == 0
- then []
- else tail (cross_product no_tyvars specing_types)
-
- -- N.B. tail removes fully polymorphic specialisation
-
-cross_product 0 tys = []
-cross_product 1 tys = map (:[]) tys
-cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
-
-
-specing_types = [Nothing,
- Just charPrimTy,
- Just doublePrimTy,
- Just intPrimTy ]
--}
-\end{code}
+++ /dev/null
-_interface_ PrimOp 1
-_exports_
-PrimOp PrimOp;
-_declarations_
-1 data PrimOp;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PrimOp]{Primitive operations (machine-level)}
module PrimOp (
PrimOp(..), allThePrimOps,
tagOf_PrimOp, -- ToDo: rm
- primOp_str, -- sigh
- primOpType, isCompareOp,
- commutableOp,
+ primOpType,
+ primOpUniq, primOpStr,
- PrimOpResultInfo(..),
- getPrimOpResultInfo,
+ commutableOp,
- primOpCanTriggerGC, primOpNeedsWrapper,
+ primOpOutOfLine, primOpNeedsWrapper,
primOpOkForSpeculation, primOpIsCheap,
- fragilePrimOp,
- HeapRequirement(..), primOpHeapReq,
- StackRequirement(..), primOpStackRequired,
+ primOpHasSideEffects,
- -- export for the Native Code Generator
- primOpInfo, -- needed for primOpNameInfo
- PrimOpInfo(..),
+ getPrimOpResultInfo, PrimOpResultInfo(..),
- pprPrimOp, showPrimOp
+ pprPrimOp
) where
#include "HsVersions.h"
import TysWiredIn
import CStrings ( identToC )
+import Var ( TyVar )
import CallConv ( CallConv, pprCallConv )
-import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
-import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
-import Outputable
import PprType ( pprParendType )
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import TyCon ( TyCon{-instances-} )
-import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyConApp, typePrimRep,
- splitAlgTyConApp, Type
+import TyCon ( TyCon )
+import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys,
+ mkTyConApp, typePrimRep,
+ splitAlgTyConApp, Type, isUnboxedTupleType,
+ splitAlgTyConApp_maybe
)
-import TyVar --( alphaTyVar, betaTyVar, gammaTyVar )
-import Unique ( Unique{-instance Eq-} )
-import Util ( panic#, assoc, panic{-ToDo:rm-} )
-
+import Unique ( Unique, mkPrimOpIdUnique )
+import Outputable
+import Util ( assoc )
import GlaExts ( Int(..), Int#, (==#) )
\end{code}
| OrdOp | ChrOp
-- Int#-related ops:
- -- IntAbsOp unused?? ADR
+ -- IntAbsOp unused?? ADR
| IntAddOp | IntSubOp | IntMulOp | IntQuotOp
| IntRemOp | IntNegOp | IntAbsOp
| ISllOp | ISraOp | ISrlOp -- shift {left,right} {arithmetic,logical}
-- Integer (and related...) ops:
-- slightly weird -- to match GMP package.
- | IntegerAddOp | IntegerSubOp | IntegerMulOp
+ | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerGcdOp
| IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp
| IntegerCmpOp
| Integer2IntOp | Integer2WordOp
| Int2IntegerOp | Word2IntegerOp
- | Addr2IntegerOp -- "Addr" is *always* a literal string
+ | Addr2IntegerOp
-- casting to/from Integer and 64-bit (un)signed quantities.
| IntegerToInt64Op | Int64ToIntegerOp
| IntegerToWord64Op | Word64ToIntegerOp
| WriteByteArrayOp PrimRep
| IndexByteArrayOp PrimRep
| IndexOffAddrOp PrimRep
+ | WriteOffAddrOp PrimRep
-- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
-- This is just a cheesy encoding of a bunch of ops.
-- Note that ForeignObjRep is not included -- the only way of
-- creating a ForeignObj is with a ccall or casm.
| IndexOffForeignObjOp PrimRep
- | WriteOffAddrOp PrimRep
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
| SizeofByteArrayOp | SizeofMutableByteArrayOp
- | NewSynchVarOp -- for MVars and IVars
+ -- Mutable variables
+ | NewMutVarOp
+ | ReadMutVarOp
+ | WriteMutVarOp
+ | SameMutVarOp
+
+ -- for MVars
+ | NewMVarOp
+ | TakeMVarOp
+ | PutMVarOp
| SameMVarOp
- | TakeMVarOp | PutMVarOp
- | ReadIVarOp | WriteIVarOp
- | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)
- | WriteForeignObjOp -- modifying foreign objects [obscuro factor: 200]
- | MakeStablePtrOp | DeRefStablePtrOp
+ -- exceptions
+ | CatchOp
+ | RaiseOp
+
+ | MakeForeignObjOp
+ | WriteForeignObjOp
+
+ | MkWeakOp
+ | DeRefWeakOp
+
+ | MakeStablePtrOp
+ | DeRefStablePtrOp
+ | EqStablePtrOp
\end{code}
A special ``trap-door'' to use in making calls direct to C functions:
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
CallConv -- calling convention to use.
- [Type] -- Unboxed arguments; the state-token
- -- argument will have been put *first*
- Type -- Return type; one of the "StateAnd<blah>#" types
-- (... to be continued ... )
\end{code}
\begin{code}
-- (... continued from above ... )
- -- one to support "errorIO" (and, thereby, "error")
- | ErrorIOPrimOp
-
-- Operation to test two closure addresses for equality (yes really!)
-- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT!
| ReallyUnsafePtrEqualityOp
- -- three for parallel stuff
+ -- parallel stuff
| SeqOp
| ParOp
- | ForkOp
- -- three for concurrency
+ -- concurrency
+ | ForkOp
+ | KillThreadOp
| DelayOp
| WaitReadOp
| WaitWriteOp
| ParAtForNowOp -- specifies initial destination of global par
| CopyableOp -- marks copyable code
| NoFollowOp -- marks non-followup expression
-
\end{code}
-Deriving Ix is what we really want! ToDo
-(Chk around before deleting...)
+Used for the Ord instance
+
\begin{code}
-tagOf_PrimOp CharGtOp = (ILIT(1) :: FAST_INT)
+tagOf_PrimOp CharGtOp = (ILIT( 1) :: FAST_INT)
tagOf_PrimOp CharGeOp = ILIT( 2)
tagOf_PrimOp CharEqOp = ILIT( 3)
tagOf_PrimOp CharNeOp = ILIT( 4)
tagOf_PrimOp FloatCoshOp = ILIT( 78)
tagOf_PrimOp FloatTanhOp = ILIT( 79)
tagOf_PrimOp FloatPowerOp = ILIT( 80)
+
tagOf_PrimOp DoubleAddOp = ILIT( 81)
tagOf_PrimOp DoubleSubOp = ILIT( 82)
tagOf_PrimOp DoubleMulOp = ILIT( 83)
tagOf_PrimOp DoubleCoshOp = ILIT(100)
tagOf_PrimOp DoubleTanhOp = ILIT(101)
tagOf_PrimOp DoublePowerOp = ILIT(102)
+
tagOf_PrimOp IntegerAddOp = ILIT(103)
tagOf_PrimOp IntegerSubOp = ILIT(104)
tagOf_PrimOp IntegerMulOp = ILIT(105)
-tagOf_PrimOp IntegerQuotRemOp = ILIT(106)
-tagOf_PrimOp IntegerDivModOp = ILIT(107)
-tagOf_PrimOp IntegerNegOp = ILIT(108)
-tagOf_PrimOp IntegerCmpOp = ILIT(109)
-tagOf_PrimOp Integer2IntOp = ILIT(110)
-tagOf_PrimOp Integer2WordOp = ILIT(111)
-tagOf_PrimOp Int2IntegerOp = ILIT(112)
-tagOf_PrimOp Word2IntegerOp = ILIT(113)
-tagOf_PrimOp Addr2IntegerOp = ILIT(114)
-tagOf_PrimOp IntegerToInt64Op = ILIT(115)
-tagOf_PrimOp Int64ToIntegerOp = ILIT(116)
-tagOf_PrimOp IntegerToWord64Op = ILIT(117)
-tagOf_PrimOp Word64ToIntegerOp = ILIT(118)
-tagOf_PrimOp FloatEncodeOp = ILIT(119)
-tagOf_PrimOp FloatDecodeOp = ILIT(120)
-tagOf_PrimOp DoubleEncodeOp = ILIT(121)
-tagOf_PrimOp DoubleDecodeOp = ILIT(122)
-tagOf_PrimOp NewArrayOp = ILIT(123)
-tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(124)
-tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(125)
-tagOf_PrimOp (NewByteArrayOp WordRep) = ILIT(126)
-tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(127)
-tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(128)
-tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(129)
-tagOf_PrimOp (NewByteArrayOp StablePtrRep) = ILIT(130)
-tagOf_PrimOp SameMutableArrayOp = ILIT(131)
-tagOf_PrimOp SameMutableByteArrayOp = ILIT(132)
-tagOf_PrimOp ReadArrayOp = ILIT(133)
-tagOf_PrimOp WriteArrayOp = ILIT(134)
-tagOf_PrimOp IndexArrayOp = ILIT(135)
-tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(136)
-tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(137)
-tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(138)
-tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(139)
-tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(140)
-tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(141)
-tagOf_PrimOp (ReadByteArrayOp StablePtrRep) = ILIT(142)
-tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(143)
-tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(144)
-tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(145)
-tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(146)
-tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(147)
-tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(148)
-tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(149)
-tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(150)
-tagOf_PrimOp (WriteByteArrayOp StablePtrRep) = ILIT(151)
-tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(152)
-tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(153)
-tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(154)
-tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(155)
-tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(156)
-tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(157)
-tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(158)
-tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(159)
-tagOf_PrimOp (IndexByteArrayOp StablePtrRep) = ILIT(160)
-tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(161)
-tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(162)
-tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(163)
-tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(164)
-tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(165)
-tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(166)
-tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(167)
-tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(168)
-tagOf_PrimOp (IndexOffAddrOp StablePtrRep) = ILIT(169)
-tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(170)
-tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(171)
-tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(172)
-tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(173)
-tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(174)
-tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(175)
-tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(176)
-tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(177)
-tagOf_PrimOp (IndexOffForeignObjOp StablePtrRep) = ILIT(178)
-tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(179)
-tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(180)
-tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(181)
-tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(182)
-tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(183)
-tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(184)
-tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(185)
-tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(186)
-tagOf_PrimOp (WriteOffAddrOp StablePtrRep) = ILIT(187)
-tagOf_PrimOp (WriteOffAddrOp ForeignObjRep) = ILIT(188)
-tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(189)
-tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(190)
-tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(191)
-tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(192)
-tagOf_PrimOp SizeofByteArrayOp = ILIT(193)
-tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(194)
-tagOf_PrimOp NewSynchVarOp = ILIT(195)
-tagOf_PrimOp TakeMVarOp = ILIT(196)
-tagOf_PrimOp PutMVarOp = ILIT(197)
-tagOf_PrimOp ReadIVarOp = ILIT(198)
-tagOf_PrimOp WriteIVarOp = ILIT(199)
+tagOf_PrimOp IntegerGcdOp = ILIT(106)
+tagOf_PrimOp IntegerQuotRemOp = ILIT(107)
+tagOf_PrimOp IntegerDivModOp = ILIT(108)
+tagOf_PrimOp IntegerNegOp = ILIT(109)
+tagOf_PrimOp IntegerCmpOp = ILIT(110)
+tagOf_PrimOp Integer2IntOp = ILIT(111)
+tagOf_PrimOp Integer2WordOp = ILIT(112)
+tagOf_PrimOp Int2IntegerOp = ILIT(113)
+tagOf_PrimOp Word2IntegerOp = ILIT(114)
+tagOf_PrimOp Addr2IntegerOp = ILIT(115)
+tagOf_PrimOp IntegerToInt64Op = ILIT(116)
+tagOf_PrimOp Int64ToIntegerOp = ILIT(117)
+tagOf_PrimOp IntegerToWord64Op = ILIT(118)
+tagOf_PrimOp Word64ToIntegerOp = ILIT(119)
+
+tagOf_PrimOp FloatEncodeOp = ILIT(120)
+tagOf_PrimOp FloatDecodeOp = ILIT(121)
+tagOf_PrimOp DoubleEncodeOp = ILIT(122)
+tagOf_PrimOp DoubleDecodeOp = ILIT(123)
+
+tagOf_PrimOp NewArrayOp = ILIT(124)
+tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(125)
+tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(126)
+tagOf_PrimOp (NewByteArrayOp WordRep) = ILIT(127)
+tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(128)
+tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(129)
+tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(130)
+tagOf_PrimOp (NewByteArrayOp StablePtrRep) = ILIT(131)
+tagOf_PrimOp SameMutableArrayOp = ILIT(132)
+tagOf_PrimOp SameMutableByteArrayOp = ILIT(133)
+tagOf_PrimOp ReadArrayOp = ILIT(134)
+tagOf_PrimOp WriteArrayOp = ILIT(135)
+tagOf_PrimOp IndexArrayOp = ILIT(136)
+
+tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(137)
+tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(138)
+tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(139)
+tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(140)
+tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(141)
+tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(142)
+tagOf_PrimOp (ReadByteArrayOp StablePtrRep) = ILIT(143)
+tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(144)
+tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(145)
+
+tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(146)
+tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(147)
+tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(148)
+tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(149)
+tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(150)
+tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(151)
+tagOf_PrimOp (WriteByteArrayOp StablePtrRep) = ILIT(152)
+tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(153)
+tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(154)
+
+tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(155)
+tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(156)
+tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(157)
+tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(158)
+tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(159)
+tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(160)
+tagOf_PrimOp (IndexByteArrayOp StablePtrRep) = ILIT(161)
+tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(162)
+tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(163)
+
+tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(164)
+tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(165)
+tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(166)
+tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(167)
+tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(168)
+tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(169)
+tagOf_PrimOp (IndexOffAddrOp StablePtrRep) = ILIT(170)
+tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(171)
+tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(172)
+tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(173)
+tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(174)
+tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(175)
+tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(176)
+tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(177)
+tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(178)
+tagOf_PrimOp (IndexOffForeignObjOp StablePtrRep) = ILIT(179)
+tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(180)
+tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(181)
+
+tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(182)
+tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(183)
+tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(184)
+tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(185)
+tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(186)
+tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(187)
+tagOf_PrimOp (WriteOffAddrOp StablePtrRep) = ILIT(188)
+tagOf_PrimOp (WriteOffAddrOp ForeignObjRep) = ILIT(189)
+tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(190)
+tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(191)
+
+tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(192)
+tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(193)
+tagOf_PrimOp SizeofByteArrayOp = ILIT(194)
+tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(195)
+tagOf_PrimOp NewMVarOp = ILIT(196)
+tagOf_PrimOp TakeMVarOp = ILIT(197)
+tagOf_PrimOp PutMVarOp = ILIT(198)
+tagOf_PrimOp SameMVarOp = ILIT(199)
tagOf_PrimOp MakeForeignObjOp = ILIT(200)
tagOf_PrimOp WriteForeignObjOp = ILIT(201)
-tagOf_PrimOp MakeStablePtrOp = ILIT(202)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(203)
-tagOf_PrimOp (CCallOp _ _ _ _ _ _) = ILIT(204)
-tagOf_PrimOp ErrorIOPrimOp = ILIT(205)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(206)
-tagOf_PrimOp SeqOp = ILIT(207)
-tagOf_PrimOp ParOp = ILIT(208)
-tagOf_PrimOp ForkOp = ILIT(209)
-tagOf_PrimOp DelayOp = ILIT(210)
-tagOf_PrimOp WaitReadOp = ILIT(211)
-tagOf_PrimOp WaitWriteOp = ILIT(212)
-tagOf_PrimOp ParGlobalOp = ILIT(213)
-tagOf_PrimOp ParLocalOp = ILIT(214)
-tagOf_PrimOp ParAtOp = ILIT(215)
-tagOf_PrimOp ParAtAbsOp = ILIT(216)
-tagOf_PrimOp ParAtRelOp = ILIT(217)
-tagOf_PrimOp ParAtForNowOp = ILIT(218)
-tagOf_PrimOp CopyableOp = ILIT(219)
-tagOf_PrimOp NoFollowOp = ILIT(220)
-tagOf_PrimOp SameMVarOp = ILIT(221)
-
-tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
+tagOf_PrimOp MkWeakOp = ILIT(202)
+tagOf_PrimOp DeRefWeakOp = ILIT(203)
+tagOf_PrimOp MakeStablePtrOp = ILIT(204)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(205)
+tagOf_PrimOp EqStablePtrOp = ILIT(206)
+tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(207)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(208)
+tagOf_PrimOp SeqOp = ILIT(209)
+tagOf_PrimOp ParOp = ILIT(210)
+tagOf_PrimOp ForkOp = ILIT(211)
+tagOf_PrimOp KillThreadOp = ILIT(212)
+tagOf_PrimOp DelayOp = ILIT(213)
+tagOf_PrimOp WaitReadOp = ILIT(214)
+tagOf_PrimOp WaitWriteOp = ILIT(215)
+tagOf_PrimOp ParGlobalOp = ILIT(216)
+tagOf_PrimOp ParLocalOp = ILIT(217)
+tagOf_PrimOp ParAtOp = ILIT(218)
+tagOf_PrimOp ParAtAbsOp = ILIT(219)
+tagOf_PrimOp ParAtRelOp = ILIT(220)
+tagOf_PrimOp ParAtForNowOp = ILIT(221)
+tagOf_PrimOp CopyableOp = ILIT(222)
+tagOf_PrimOp NoFollowOp = ILIT(223)
+tagOf_PrimOp NewMutVarOp = ILIT(224)
+tagOf_PrimOp ReadMutVarOp = ILIT(225)
+tagOf_PrimOp WriteMutVarOp = ILIT(226)
+tagOf_PrimOp SameMutVarOp = ILIT(227)
+tagOf_PrimOp CatchOp = ILIT(228)
+tagOf_PrimOp RaiseOp = ILIT(229)
+
+tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
+--panic# "tagOf_PrimOp: pattern-match"
instance Eq PrimOp where
- op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2
+ op1 == op2 = tagOf_PrimOp op1 _EQ_ tagOf_PrimOp op2
+
+instance Ord PrimOp where
+ op1 < op2 = tagOf_PrimOp op1 _LT_ tagOf_PrimOp op2
+ op1 <= op2 = tagOf_PrimOp op1 _LE_ tagOf_PrimOp op2
+ op1 >= op2 = tagOf_PrimOp op1 _GE_ tagOf_PrimOp op2
+ op1 > op2 = tagOf_PrimOp op1 _GT_ tagOf_PrimOp op2
+ op1 `compare` op2 | op1 < op2 = LT
+ | op1 == op2 = EQ
+ | otherwise = GT
+
+instance Outputable PrimOp where
+ ppr op = pprPrimOp op
+
+instance Show PrimOp where
+ showsPrec p op = showsPrecSDoc p (pprPrimOp op)
\end{code}
An @Enum@-derived list would be better; meanwhile... (ToDo)
IntegerAddOp,
IntegerSubOp,
IntegerMulOp,
+ IntegerGcdOp,
IntegerQuotRemOp,
IntegerDivModOp,
IntegerNegOp,
IndexByteArrayOp StablePtrRep,
IndexByteArrayOp Int64Rep,
IndexByteArrayOp Word64Rep,
- IndexOffAddrOp CharRep,
- IndexOffAddrOp IntRep,
- IndexOffAddrOp WordRep,
- IndexOffAddrOp AddrRep,
- IndexOffAddrOp FloatRep,
- IndexOffAddrOp DoubleRep,
- IndexOffAddrOp StablePtrRep,
- IndexOffAddrOp Int64Rep,
- IndexOffAddrOp Word64Rep,
IndexOffForeignObjOp CharRep,
IndexOffForeignObjOp AddrRep,
IndexOffForeignObjOp IntRep,
IndexOffForeignObjOp StablePtrRep,
IndexOffForeignObjOp Int64Rep,
IndexOffForeignObjOp Word64Rep,
+ IndexOffAddrOp CharRep,
+ IndexOffAddrOp IntRep,
+ IndexOffAddrOp WordRep,
+ IndexOffAddrOp AddrRep,
+ IndexOffAddrOp FloatRep,
+ IndexOffAddrOp DoubleRep,
+ IndexOffAddrOp StablePtrRep,
+ IndexOffAddrOp Int64Rep,
+ IndexOffAddrOp Word64Rep,
WriteOffAddrOp CharRep,
WriteOffAddrOp IntRep,
WriteOffAddrOp WordRep,
WriteOffAddrOp AddrRep,
WriteOffAddrOp FloatRep,
WriteOffAddrOp DoubleRep,
- WriteOffAddrOp StablePtrRep,
WriteOffAddrOp ForeignObjRep,
+ WriteOffAddrOp StablePtrRep,
WriteOffAddrOp Int64Rep,
WriteOffAddrOp Word64Rep,
UnsafeFreezeArrayOp,
UnsafeFreezeByteArrayOp,
SizeofByteArrayOp,
SizeofMutableByteArrayOp,
- NewSynchVarOp,
- SameMVarOp,
- ReadArrayOp,
+ NewMutVarOp,
+ ReadMutVarOp,
+ WriteMutVarOp,
+ SameMutVarOp,
+ CatchOp,
+ RaiseOp,
+ NewMVarOp,
TakeMVarOp,
PutMVarOp,
- ReadIVarOp,
- WriteIVarOp,
+ SameMVarOp,
MakeForeignObjOp,
WriteForeignObjOp,
+ MkWeakOp,
+ DeRefWeakOp,
MakeStablePtrOp,
DeRefStablePtrOp,
+ EqStablePtrOp,
ReallyUnsafePtrEqualityOp,
- ErrorIOPrimOp,
ParGlobalOp,
ParLocalOp,
ParAtOp,
SeqOp,
ParOp,
ForkOp,
+ KillThreadOp,
DelayOp,
WaitReadOp,
WaitWriteOp
Type
| Compare FAST_STRING -- string :: T -> T -> Bool
Type
- | Coercing FAST_STRING -- string :: T1 -> T2
- Type
- Type
- | PrimResult FAST_STRING
- [TyVar] [Type] TyCon PrimRep [Type]
- -- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]"
- -- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm)
- -- D# is a primitive type constructor.
- -- (the kind is the same info as D#, in another convenient form)
-
- | AlgResult FAST_STRING
- [TyVar] [Type] TyCon [Type]
- -- "AlgResult tvs [t1,..,tn] T [s1,..,sm]"
- -- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm)
-
--- ToDo: Specialised calls to PrimOps are prohibited but may be desirable
+ | GenPrimOp FAST_STRING -- string :: \/a1..an . T1 -> .. -> Tk -> T
+ [TyVar]
+ [Type]
+ Type
\end{code}
Utility bits:
= [intPrimTy, intPrimTy, byteArrayPrimTy, -- Integer
intPrimTy]
-integerMonadic name = AlgResult name [] one_Integer_ty integerTyCon []
+unboxedPair = mkUnboxedTupleTy 2
+unboxedTriple = mkUnboxedTupleTy 3
+unboxedQuadruple = mkUnboxedTupleTy 4
+unboxedSexTuple = mkUnboxedTupleTy 6
-integerDyadic name = AlgResult name [] two_Integer_tys integerTyCon []
+integerMonadic name = GenPrimOp name [] one_Integer_ty
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
-integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon []
+integerDyadic name = GenPrimOp name [] two_Integer_tys
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
-integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntRep []
+integerDyadic2Results name = GenPrimOp name [] two_Integer_tys
+ (unboxedSexTuple [intPrimTy, intPrimTy, byteArrayPrimTy,
+ intPrimTy, intPrimTy, byteArrayPrimTy])
+
+integerCompare name = GenPrimOp name [] two_Integer_tys intPrimTy
\end{code}
+%************************************************************************
+%* *
+\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
+%* *
+%************************************************************************
+
@primOpInfo@ gives all essential information (from which everything
else, notably a type, can be constructed) for each @PrimOp@.
There's plenty of this stuff!
-%************************************************************************
-%* *
-\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
-%* *
-%************************************************************************
-
\begin{code}
primOpInfo CharGtOp = Compare SLIT("gtChar#") charPrimTy
primOpInfo CharGeOp = Compare SLIT("geChar#") charPrimTy
%************************************************************************
\begin{code}
-primOpInfo OrdOp = Coercing SLIT("ord#") charPrimTy intPrimTy
-primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy
+primOpInfo OrdOp = GenPrimOp SLIT("ord#") [] [charPrimTy] intPrimTy
+primOpInfo ChrOp = GenPrimOp SLIT("chr#") [] [intPrimTy] charPrimTy
\end{code}
%************************************************************************
primOpInfo NotOp = Monadic SLIT("not#") wordPrimTy
primOpInfo SllOp
- = PrimResult SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
+ = GenPrimOp SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTy
primOpInfo SrlOp
- = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
+ = GenPrimOp SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTy
primOpInfo ISllOp
- = PrimResult SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
+ = GenPrimOp SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTy
primOpInfo ISraOp
- = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
+ = GenPrimOp SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTy
primOpInfo ISrlOp
- = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
+ = GenPrimOp SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTy
-primOpInfo Int2WordOp = Coercing SLIT("int2Word#") intPrimTy wordPrimTy
-primOpInfo Word2IntOp = Coercing SLIT("word2Int#") wordPrimTy intPrimTy
+primOpInfo Int2WordOp = GenPrimOp SLIT("int2Word#") [] [intPrimTy] wordPrimTy
+primOpInfo Word2IntOp = GenPrimOp SLIT("word2Int#") [] [wordPrimTy] intPrimTy
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-primOpInfo Int2AddrOp = Coercing SLIT("int2Addr#") intPrimTy addrPrimTy
-primOpInfo Addr2IntOp = Coercing SLIT("addr2Int#") addrPrimTy intPrimTy
+primOpInfo Int2AddrOp = GenPrimOp SLIT("int2Addr#") [] [intPrimTy] addrPrimTy
+primOpInfo Addr2IntOp = GenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy
\end{code}
primOpInfo FloatDivOp = Dyadic SLIT("divideFloat#") floatPrimTy
primOpInfo FloatNegOp = Monadic SLIT("negateFloat#") floatPrimTy
-primOpInfo Float2IntOp = Coercing SLIT("float2Int#") floatPrimTy intPrimTy
-primOpInfo Int2FloatOp = Coercing SLIT("int2Float#") intPrimTy floatPrimTy
+primOpInfo Float2IntOp = GenPrimOp SLIT("float2Int#") [] [floatPrimTy] intPrimTy
+primOpInfo Int2FloatOp = GenPrimOp SLIT("int2Float#") [] [intPrimTy] floatPrimTy
primOpInfo FloatExpOp = Monadic SLIT("expFloat#") floatPrimTy
primOpInfo FloatLogOp = Monadic SLIT("logFloat#") floatPrimTy
primOpInfo DoubleDivOp = Dyadic SLIT("/##") doublePrimTy
primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy
-primOpInfo Double2IntOp = Coercing SLIT("double2Int#") doublePrimTy intPrimTy
-primOpInfo Int2DoubleOp = Coercing SLIT("int2Double#") intPrimTy doublePrimTy
+primOpInfo Double2IntOp = GenPrimOp SLIT("double2Int#") [] [doublePrimTy] intPrimTy
+primOpInfo Int2DoubleOp = GenPrimOp SLIT("int2Double#") [] [intPrimTy] doublePrimTy
-primOpInfo Double2FloatOp = Coercing SLIT("double2Float#") doublePrimTy floatPrimTy
-primOpInfo Float2DoubleOp = Coercing SLIT("float2Double#") floatPrimTy doublePrimTy
+primOpInfo Double2FloatOp = GenPrimOp SLIT("double2Float#") [] [doublePrimTy] floatPrimTy
+primOpInfo Float2DoubleOp = GenPrimOp SLIT("float2Double#") [] [floatPrimTy] doublePrimTy
primOpInfo DoubleExpOp = Monadic SLIT("expDouble#") doublePrimTy
primOpInfo DoubleLogOp = Monadic SLIT("logDouble#") doublePrimTy
primOpInfo IntegerAddOp = integerDyadic SLIT("plusInteger#")
primOpInfo IntegerSubOp = integerDyadic SLIT("minusInteger#")
primOpInfo IntegerMulOp = integerDyadic SLIT("timesInteger#")
+primOpInfo IntegerGcdOp = integerDyadic SLIT("gcdInteger#")
primOpInfo IntegerCmpOp = integerCompare SLIT("cmpInteger#")
primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#")
primOpInfo Integer2IntOp
- = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntRep []
+ = GenPrimOp SLIT("integer2Int#") [] one_Integer_ty intPrimTy
primOpInfo Integer2WordOp
- = PrimResult SLIT("integer2Word#") [] one_Integer_ty wordPrimTyCon IntRep []
+ = GenPrimOp SLIT("integer2Word#") [] one_Integer_ty wordPrimTy
primOpInfo Int2IntegerOp
- = AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon []
+ = GenPrimOp SLIT("int2Integer#") [] [intPrimTy]
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo Word2IntegerOp
- = AlgResult SLIT("word2Integer#") [] [wordPrimTy] integerTyCon []
+ = GenPrimOp SLIT("word2Integer#") [] [wordPrimTy]
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo Addr2IntegerOp
- = AlgResult SLIT("addr2Integer#") [] [addrPrimTy] integerTyCon []
+ = GenPrimOp SLIT("addr2Integer#") [] [addrPrimTy]
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo IntegerToInt64Op
- = PrimResult SLIT("integerToInt64#") [] one_Integer_ty int64PrimTyCon Int64Rep []
+ = GenPrimOp SLIT("integerToInt64#") [] one_Integer_ty int64PrimTy
primOpInfo Int64ToIntegerOp
- = AlgResult SLIT("int64ToInteger#") [] [int64PrimTy] integerTyCon []
+ = GenPrimOp SLIT("int64ToInteger#") [] [int64PrimTy]
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo Word64ToIntegerOp
- = AlgResult SLIT("word64ToInteger#") [] [word64PrimTy] integerTyCon []
+ = GenPrimOp SLIT("word64ToInteger#") [] [word64PrimTy]
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo IntegerToWord64Op
- = PrimResult SLIT("integerToWord64#") [] one_Integer_ty word64PrimTyCon Word64Rep []
+ = GenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy
\end{code}
Encoding and decoding of floating-point numbers is sorta
\begin{code}
primOpInfo FloatEncodeOp
- = PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys
- floatPrimTyCon FloatRep []
+ = GenPrimOp SLIT("encodeFloat#") [] an_Integer_and_Int_tys floatPrimTy
primOpInfo DoubleEncodeOp
- = PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys
- doublePrimTyCon DoubleRep []
+ = GenPrimOp SLIT("encodeDouble#") [] an_Integer_and_Int_tys doublePrimTy
primOpInfo FloatDecodeOp
- = AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon []
-
+ = GenPrimOp SLIT("decodeFloat#") [] [floatPrimTy]
+ (unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo DoubleDecodeOp
- = AlgResult SLIT("decodeDouble#") [] [doublePrimTy] returnIntAndGMPTyCon []
+ = GenPrimOp SLIT("decodeDouble#") [] [doublePrimTy]
+ (unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy])
\end{code}
%************************************************************************
\begin{code}
primOpInfo NewArrayOp
= let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
+ state = mkStatePrimTy s
} in
- AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s]
- stateAndMutableArrayPrimTyCon [s, elt]
+ GenPrimOp SLIT("newArray#") [s_tv, elt_tv]
+ [intPrimTy, elt, state]
+ (unboxedPair [state, mkMutableArrayPrimTy s elt])
primOpInfo (NewByteArrayOp kind)
= let
s = alphaTy; s_tv = alphaTyVar
- (str, _, prim_tycon) = getPrimRepInfo kind
-
- op_str = _PK_ ("new" ++ str ++ "Array#")
+ op_str = _PK_ ("new" ++ primRepString kind ++ "Array#")
+ state = mkStatePrimTy s
in
- AlgResult op_str [s_tv]
- [intPrimTy, mkStatePrimTy s]
- stateAndMutableByteArrayPrimTyCon [s]
+ GenPrimOp op_str [s_tv]
+ [intPrimTy, state]
+ (unboxedPair [state, mkMutableByteArrayPrimTy s])
---------------------------------------------------------------------------
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
mut_arr_ty = mkMutableArrayPrimTy s elt
} in
- AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
- boolTyCon []
+ GenPrimOp SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
+ boolTy
primOpInfo SameMutableByteArrayOp
= let {
s = alphaTy; s_tv = alphaTyVar;
mut_arr_ty = mkMutableByteArrayPrimTy s
} in
- AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
- boolTyCon []
+ GenPrimOp SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
+ boolTy
---------------------------------------------------------------------------
-- Primitive arrays of Haskell pointers:
primOpInfo ReadArrayOp
= let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
+ state = mkStatePrimTy s
} in
- AlgResult SLIT("readArray#") [s_tv, elt_tv]
- [mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s]
- stateAndPtrPrimTyCon [s, elt]
+ GenPrimOp SLIT("readArray#") [s_tv, elt_tv]
+ [mkMutableArrayPrimTy s elt, intPrimTy, state]
+ (unboxedPair [state, elt])
primOpInfo WriteArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
- PrimResult SLIT("writeArray#") [s_tv, elt_tv]
+ GenPrimOp SLIT("writeArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
- statePrimTyCon VoidRep [s]
+ (mkStatePrimTy s)
primOpInfo IndexArrayOp
= let { elt = alphaTy; elt_tv = alphaTyVar } in
- AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
- liftTyCon [elt]
+ GenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
+ (unboxedPair [realWorldStatePrimTy, elt])
---------------------------------------------------------------------------
-- Primitive arrays full of unboxed bytes:
= let
s = alphaTy; s_tv = alphaTyVar
- (str, _, prim_tycon) = getPrimRepInfo kind
-
- op_str = _PK_ ("read" ++ str ++ "Array#")
- relevant_tycon = (assoc "primOpInfo{ReadByteArrayOp}" tbl kind)
+ op_str = _PK_ ("read" ++ primRepString kind ++ "Array#")
+ relevant_type = assoc "primOpInfo{ReadByteArrayOp}" tbl kind
+ state = mkStatePrimTy s
- (tycon_args, tvs)
- | kind == StablePtrRep = ([s, betaTy], [s_tv, betaTyVar])
- | otherwise = ([s], [s_tv])
+ tvs
+ | kind == StablePtrRep = [s_tv, betaTyVar]
+ | otherwise = [s_tv]
in
- AlgResult op_str tvs
- [mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
- relevant_tycon tycon_args
+ GenPrimOp op_str tvs
+ [mkMutableByteArrayPrimTy s, intPrimTy, state]
+ (unboxedPair [state, relevant_type])
where
- tbl = [ (CharRep, stateAndCharPrimTyCon),
- (IntRep, stateAndIntPrimTyCon),
- (WordRep, stateAndWordPrimTyCon),
- (AddrRep, stateAndAddrPrimTyCon),
- (FloatRep, stateAndFloatPrimTyCon),
- (StablePtrRep, stateAndStablePtrPrimTyCon),
- (DoubleRep, stateAndDoublePrimTyCon) ]
+ tbl = [ (CharRep, charPrimTy),
+ (IntRep, intPrimTy),
+ (WordRep, wordPrimTy),
+ (AddrRep, addrPrimTy),
+ (FloatRep, floatPrimTy),
+ (StablePtrRep, mkStablePtrPrimTy betaTy),
+ (DoubleRep, doublePrimTy) ]
-- How come there's no Word byte arrays? ADR
primOpInfo (WriteByteArrayOp kind)
= let
s = alphaTy; s_tv = alphaTyVar
-
- (str, prim_ty, _) = getPrimRepInfo kind
- op_str = _PK_ ("write" ++ str ++ "Array#")
+ op_str = _PK_ ("write" ++ primRepString kind ++ "Array#")
+ prim_ty = mkTyConApp (primRepTyCon kind) []
(the_prim_ty, tvs)
| kind == StablePtrRep = (mkStablePtrPrimTy betaTy, [s_tv, betaTyVar])
| otherwise = (prim_ty, [s_tv])
in
- -- NB: *Prim*Result --
- PrimResult op_str tvs
+ GenPrimOp op_str tvs
[mkMutableByteArrayPrimTy s, intPrimTy, the_prim_ty, mkStatePrimTy s]
- statePrimTyCon VoidRep [s]
+ (mkStatePrimTy s)
primOpInfo (IndexByteArrayOp kind)
= let
- (str, _, prim_tycon) = getPrimRepInfo kind
- op_str = _PK_ ("index" ++ str ++ "Array#")
+ op_str = _PK_ ("index" ++ primRepString kind ++ "Array#")
(prim_tycon_args, tvs)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([],[])
in
- -- NB: *Prim*Result --
- PrimResult op_str tvs [byteArrayPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
+ GenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy]
+ (mkTyConApp (primRepTyCon kind) prim_tycon_args)
-primOpInfo (IndexOffAddrOp kind)
+primOpInfo (IndexOffForeignObjOp kind)
= let
- (str, _, prim_tycon) = getPrimRepInfo kind
- op_str = _PK_ ("index" ++ str ++ "OffAddr#")
+ op_str = _PK_ ("index" ++ primRepString kind ++ "OffForeignObj#")
(prim_tycon_args, tvs)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([], [])
in
- PrimResult op_str tvs [addrPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
+ GenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy]
+ (mkTyConApp (primRepTyCon kind) prim_tycon_args)
-primOpInfo (IndexOffForeignObjOp kind)
+primOpInfo (IndexOffAddrOp kind)
= let
- (str, _, prim_tycon) = getPrimRepInfo kind
- op_str = _PK_ ("index" ++ str ++ "OffForeignObj#")
+ op_str = _PK_ ("index" ++ primRepString kind ++ "OffAddr#")
(prim_tycon_args, tvs)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([], [])
in
- PrimResult op_str tvs [foreignObjPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
+ GenPrimOp op_str tvs [addrPrimTy, intPrimTy]
+ (mkTyConApp (primRepTyCon kind) prim_tycon_args)
primOpInfo (WriteOffAddrOp kind)
= let
- s = betaTy; s_tv = betaTyVar
-
- (str, prim_ty, _) = getPrimRepInfo kind
- op_str = _PK_ ("write" ++ str ++ "OffAddr#")
-
- tvs
- | kind == StablePtrRep = [s_tv,alphaTyVar]
- | otherwise = [s_tv]
+ s = alphaTy; s_tv = alphaTyVar
+ op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#")
+ prim_ty = mkTyConApp (primRepTyCon kind) []
in
- -- NB: *Prim*Result --
- PrimResult op_str tvs
+ GenPrimOp op_str [s_tv]
[addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s]
- statePrimTyCon VoidRep [s]
+ (mkStatePrimTy s)
---------------------------------------------------------------------------
primOpInfo UnsafeFreezeArrayOp
= let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
+ state = mkStatePrimTy s
} in
- AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
- [mkMutableArrayPrimTy s elt, mkStatePrimTy s]
- stateAndArrayPrimTyCon [s, elt]
+ GenPrimOp SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
+ [mkMutableArrayPrimTy s elt, state]
+ (unboxedPair [state, mkArrayPrimTy elt])
primOpInfo UnsafeFreezeByteArrayOp
- = let { s = alphaTy; s_tv = alphaTyVar } in
- AlgResult SLIT("unsafeFreezeByteArray#") [s_tv]
- [mkMutableByteArrayPrimTy s, mkStatePrimTy s]
- stateAndByteArrayPrimTyCon [s]
+ = let {
+ s = alphaTy; s_tv = alphaTyVar;
+ state = mkStatePrimTy s
+ } in
+ GenPrimOp SLIT("unsafeFreezeByteArray#") [s_tv]
+ [mkMutableByteArrayPrimTy s, state]
+ (unboxedPair [state, byteArrayPrimTy])
+
---------------------------------------------------------------------------
primOpInfo SizeofByteArrayOp
- = PrimResult
+ = GenPrimOp
SLIT("sizeofByteArray#") []
[byteArrayPrimTy]
- intPrimTyCon IntRep []
+ intPrimTy
primOpInfo SizeofMutableByteArrayOp
= let { s = alphaTy; s_tv = alphaTyVar } in
- PrimResult
+ GenPrimOp
SLIT("sizeofMutableByteArray#") [s_tv]
[mkMutableByteArrayPrimTy s]
- intPrimTyCon IntRep []
-
+ intPrimTy
\end{code}
+
%************************************************************************
%* *
-\subsubsection[PrimOp-SynchVars]{PrimOpInfo for synchronizing Variables}
+\subsubsection[PrimOp-MutVars]{PrimOpInfo for mutable variable ops}
%* *
%************************************************************************
\begin{code}
-primOpInfo NewSynchVarOp
+primOpInfo NewMutVarOp
= let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
+ state = mkStatePrimTy s
} in
- AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s]
- stateAndSynchVarPrimTyCon [s, elt]
+ GenPrimOp SLIT("newMutVar#") [s_tv, elt_tv]
+ [elt, state]
+ (unboxedPair [state, mkMutVarPrimTy s elt])
-primOpInfo SameMVarOp
+primOpInfo ReadMutVarOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- mvar_ty = mkSynchVarPrimTy s elt
+ state = mkStatePrimTy s
} in
- AlgResult SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty]
- boolTyCon []
+ GenPrimOp SLIT("readMutVar#") [s_tv, elt_tv]
+ [mkMutVarPrimTy s elt, state]
+ (unboxedPair [state, elt])
-primOpInfo TakeMVarOp
+
+primOpInfo WriteMutVarOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
- AlgResult SLIT("takeMVar#") [s_tv, elt_tv]
- [mkSynchVarPrimTy s elt, mkStatePrimTy s]
- stateAndPtrPrimTyCon [s, elt]
+ GenPrimOp SLIT("writeMutVar#") [s_tv, elt_tv]
+ [mkMutVarPrimTy s elt, elt, mkStatePrimTy s]
+ (mkStatePrimTy s)
-primOpInfo PutMVarOp
+primOpInfo SameMutVarOp
= let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
+ mut_var_ty = mkMutVarPrimTy s elt
} in
- AlgResult SLIT("putMVar#") [s_tv, elt_tv]
- [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
- statePrimTyCon [s]
+ GenPrimOp SLIT("sameMutVar#") [s_tv, elt_tv] [mut_var_ty, mut_var_ty]
+ boolTy
+\end{code}
-primOpInfo ReadIVarOp
- = let {
+%************************************************************************
+%* *
+\subsubsection[PrimOp-Exceptions]{PrimOpInfo for exceptions}
+%* *
+%************************************************************************
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch :: a -> (b -> a) -> a
+
+\begin{code}
+primOpInfo CatchOp
+ = let
+ a = alphaTy; a_tv = alphaTyVar;
+ b = betaTy; b_tv = betaTyVar;
+ in
+ GenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a
+
+primOpInfo RaiseOp
+ = let
+ a = alphaTy; a_tv = alphaTyVar;
+ b = betaTy; b_tv = betaTyVar;
+ in
+ GenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[PrimOp-MVars]{PrimOpInfo for synchronizing Variables}
+%* *
+%************************************************************************
+
+\begin{code}
+primOpInfo NewMVarOp
+ = let
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- } in
- AlgResult SLIT("readIVar#") [s_tv, elt_tv]
- [mkSynchVarPrimTy s elt, mkStatePrimTy s]
- stateAndPtrPrimTyCon [s, elt]
+ state = mkStatePrimTy s
+ in
+ GenPrimOp SLIT("newMVar#") [s_tv, elt_tv] [state]
+ (unboxedPair [state, mkMVarPrimTy s elt])
-primOpInfo WriteIVarOp
- = let {
+primOpInfo TakeMVarOp
+ = let
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- } in
- AlgResult SLIT("writeIVar#") [s_tv, elt_tv]
- [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
- statePrimTyCon [s]
+ state = mkStatePrimTy s
+ in
+ GenPrimOp SLIT("takeMVar#") [s_tv, elt_tv]
+ [mkMVarPrimTy s elt, state]
+ (unboxedPair [state, elt])
+primOpInfo PutMVarOp
+ = let
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ in
+ GenPrimOp SLIT("putMVar#") [s_tv, elt_tv]
+ [mkMVarPrimTy s elt, elt, mkStatePrimTy s]
+ (mkStatePrimTy s)
+
+primOpInfo SameMVarOp
+ = let
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ mvar_ty = mkMVarPrimTy s elt
+ in
+ GenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy
\end{code}
%************************************************************************
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- PrimResult SLIT("delay#") [s_tv]
- [intPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidRep [s]
+ GenPrimOp SLIT("delay#") [s_tv]
+ [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
primOpInfo WaitReadOp
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- PrimResult SLIT("waitRead#") [s_tv]
- [intPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidRep [s]
+ GenPrimOp SLIT("waitRead#") [s_tv]
+ [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
primOpInfo WaitWriteOp
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- PrimResult SLIT("waitWrite#") [s_tv]
- [intPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidRep [s]
+ GenPrimOp SLIT("waitWrite#") [s_tv]
+ [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-ForeignObj]{PrimOpInfo for Foreign Objects}
+\subsubsection[PrimOp-Concurrency]{Concurrency Primitives}
%* *
%************************************************************************
-Not everything should/can be in the Haskell heap. As an example, in an
-image processing application written in Haskell, you really would like
-to avoid heaving huge images between different space or generations of
-a garbage collector. Instead use @ForeignObj@ (formerly known as @MallocPtr@),
-which refer to some externally allocated structure/value. Using @ForeignObj@,
-just a reference to an image is present in the heap, the image could then
-be stored outside the Haskell heap, i.e., as a malloc'ed structure or in
-a completely separate address space alltogether.
+\begin{code}
+-- fork# :: a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
+primOpInfo ForkOp
+ = GenPrimOp SLIT("fork#") [alphaTyVar]
+ [alphaTy, realWorldStatePrimTy]
+ (unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
+
+-- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld
+primOpInfo KillThreadOp
+ = GenPrimOp SLIT("killThread#") []
+ [threadIdPrimTy, realWorldStatePrimTy]
+ realWorldStatePrimTy
+\end{code}
-When a @ForeignObj@ becomes garbage, a user-defined finalisation routine
-associated with the object is invoked (currently, each ForeignObj has a
-direct reference to its finaliser). -- SOF
+************************************************************************
+%* *
+\subsubsection[PrimOps-Foreign]{PrimOpInfo for Foreign Objects}
+%* *
+%************************************************************************
-A @ForeignObj@ is created by the @makeForeignObj#@ primitive:
+\begin{code}
+primOpInfo MakeForeignObjOp
+ = GenPrimOp SLIT("makeForeignObj#") []
+ [addrPrimTy, realWorldStatePrimTy]
+ (unboxedPair [realWorldStatePrimTy, foreignObjPrimTy])
-\begin{pseudocode}
-makeForeignObj# :: Addr# -- foreign object
- -> Addr# -- ptr to its finaliser routine
- -> StateAndForeignObj# _RealWorld# ForeignObj#
-\end{pseudocode}
+primOpInfo WriteForeignObjOp
+ = let {
+ s = alphaTy; s_tv = alphaTyVar
+ } in
+ GenPrimOp SLIT("writeForeignObj#") [s_tv]
+ [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
+\end{code}
+************************************************************************
+%* *
+\subsubsection[PrimOps-Weak]{PrimOpInfo for Weak Pointers}
+%* *
+%************************************************************************
+
+A @Weak@ Pointer is created by the @mkWeak#@ primitive:
+
+ mkWeak# :: k -> v -> f -> State# RealWorld
+ -> (# State# RealWorld, Weak# v #)
+
+In practice, you'll use the higher-level
+
+ data Weak v = Weak# v
+ mkWeak :: k -> v -> IO () -> IO (Weak v)
\begin{code}
-primOpInfo MakeForeignObjOp
- = AlgResult SLIT("makeForeignObj#") []
- [addrPrimTy, addrPrimTy, realWorldStatePrimTy]
- stateAndForeignObjPrimTyCon [realWorldTy]
+primOpInfo MkWeakOp
+ = GenPrimOp SLIT("mkWeak#") [alphaTyVar, betaTyVar, gammaTyVar]
+ [alphaTy, betaTy, gammaTy, realWorldStatePrimTy]
+ (unboxedPair [realWorldStatePrimTy, mkWeakPrimTy betaTy])
\end{code}
-[Experimental--SOF]
-In addition, another @ForeignObj@ primitive is provided for destructively modifying
-the external object wrapped up inside a @ForeignObj@. This primitive is used
-when a mixed programming interface of implicit and explicit de-allocation is used,
-e.g., if @ForeignObj@s are used to implement @Handle@s, then @Handle@s can be
-released either explicitly (through @hClose@) or implicitly (via a finaliser).
-When releasing/closing the @Handle@ explicitly, care must be taken to avoid having
-the finaliser for the embedded @ForeignObj@ attempt the same thing later.
-We deal with this situation, by allowing the programmer to destructively modify
-the data field of the @ForeignObj@ to hold a special value the finaliser recognises,
-and does not attempt to free (e.g., filling the data slot with \tr{NULL}).
+The following operation dereferences a weak pointer. The weak pointer
+may have been finalised, so the operation returns a result code which
+must be inspected before looking at the dereferenced value.
-\begin{pseudocode}
-writeForeignObj# :: ForeignObj# -- foreign object
- -> Addr# -- new data value
- -> StateAndForeignObj# _RealWorld# ForeignObj#
-\end{pseudocode}
+ deRefWeak# :: Weak# v -> State# RealWorld ->
+ (# State# RealWorld, v, Int# #)
+
+Only look at v if the Int# returned is /= 0 !!
+
+The higher-level op is
+
+ deRefWeak :: Weak v -> IO (Maybe v)
\begin{code}
-primOpInfo WriteForeignObjOp
- = let {
- s = alphaTy; s_tv = alphaTyVar
- } in
- PrimResult SLIT("writeForeignObj#") [s_tv]
- [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidRep [s]
+primOpInfo DeRefWeakOp
+ = GenPrimOp SLIT("deRefWeak#") [alphaTyVar]
+ [mkWeakPrimTy alphaTy, realWorldStatePrimTy]
+ (unboxedTriple [realWorldStatePrimTy, intPrimTy, alphaTy])
\end{code}
%************************************************************************
state-interface document).
\begin{verbatim}
-makeStablePtr# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
+makeStablePtr# :: a -> State# _RealWorld -> (# State# _RealWorld, a #)
freeStablePtr# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
-deRefStablePtr# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
+deRefStablePtr# :: StablePtr# a -> State# _RealWorld -> (# State# _RealWorld, a #)
+eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#
\end{verbatim}
It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@
\begin{code}
primOpInfo MakeStablePtrOp
- = AlgResult SLIT("makeStablePtr#") [alphaTyVar]
+ = GenPrimOp SLIT("makeStablePtr#") [alphaTyVar]
[alphaTy, realWorldStatePrimTy]
- stateAndStablePtrPrimTyCon [realWorldTy, alphaTy]
+ (unboxedPair [realWorldStatePrimTy,
+ mkTyConApp stablePtrPrimTyCon [alphaTy]])
primOpInfo DeRefStablePtrOp
- = AlgResult SLIT("deRefStablePtr#") [alphaTyVar]
+ = GenPrimOp SLIT("deRefStablePtr#") [alphaTyVar]
[mkStablePtrPrimTy alphaTy, realWorldStatePrimTy]
- stateAndPtrPrimTyCon [realWorldTy, alphaTy]
+ (unboxedPair [realWorldStatePrimTy, alphaTy])
+
+primOpInfo EqStablePtrOp
+ = GenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar]
+ [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy betaTy]
+ intPrimTy
\end{code}
%************************************************************************
\begin{code}
primOpInfo ReallyUnsafePtrEqualityOp
- = PrimResult SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
- [alphaTy, alphaTy] intPrimTyCon IntRep []
+ = GenPrimOp SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
+ [alphaTy, alphaTy] intPrimTy
\end{code}
%************************************************************************
\begin{code}
primOpInfo SeqOp -- seq# :: a -> Int#
- = PrimResult SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
+ = GenPrimOp SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTy
primOpInfo ParOp -- par# :: a -> Int#
- = PrimResult SLIT("par#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
-
-primOpInfo ForkOp -- fork# :: a -> Int#
- = PrimResult SLIT("fork#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
-
+ = GenPrimOp SLIT("par#") [alphaTyVar] [alphaTy] intPrimTy
\end{code}
\begin{code}
-- Same structure as _seq_ i.e. returns Int#
primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = PrimResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
+ = GenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = PrimResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
+ = GenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
- = PrimResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep [] -- liftTyCon [gammaTy]
+ = GenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = PrimResult SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
+ = GenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = PrimResult SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
+ = GenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
- = PrimResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep [] -- liftTyCon [gammaTy]
+ = GenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
primOpInfo CopyableOp -- copyable# :: a -> a
- = PrimResult SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy]
+ = GenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy
primOpInfo NoFollowOp -- noFollow# :: a -> a
- = PrimResult SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy]
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-errorIO]{PrimOpInfo for @errorIO#@}
-%* *
-%************************************************************************
-
-\begin{code}
--- errorIO# :: (State# RealWorld# -> a) -> State# RealWorld#
-primOpInfo ErrorIOPrimOp
- = PrimResult SLIT("errorIO#") [alphaTyVar]
- [mkFunTy realWorldStatePrimTy alphaTy]
- statePrimTyCon VoidRep [realWorldTy]
+ = GenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+primOpInfo (CCallOp _ _ _ _)
+ = GenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy
+
+{-
primOpInfo (CCallOp _ _ _ _ arg_tys result_ty)
- = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
+ = GenPrimOp SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
(result_tycon, tys_applied, _) = splitAlgTyConApp result_ty
-
+-}
#ifdef DEBUG
primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))
#endif
\end{code}
-%************************************************************************
-%* *
-\subsection[PrimOp-utils]{Utilities for @PrimitiveOps@}
-%* *
-%************************************************************************
-
-The primitive-array-creation @PrimOps@ and {\em most} of those to do
-with @Integers@ can trigger GC. Here we describe the heap requirements
-of the various @PrimOps@. For most, no heap is required. For a few,
-a fixed amount of heap is required, and the needs of the @PrimOp@ can
-be combined with the rest of the heap usage in the basic block. For an
-unfortunate few, some unknown amount of heap is required (these are the
-ops which can trigger GC).
+Some PrimOps need to be called out-of-line because they either need to
+perform a heap check or they block.
\begin{code}
-data HeapRequirement
- = NoHeapRequired
- | FixedHeapRequired HeapOffset
- | VariableHeapRequired
-
-primOpHeapReq :: PrimOp -> HeapRequirement
-
-primOpHeapReq NewArrayOp = VariableHeapRequired
-primOpHeapReq (NewByteArrayOp _)= VariableHeapRequired
-
-primOpHeapReq IntegerAddOp = VariableHeapRequired
-primOpHeapReq IntegerSubOp = VariableHeapRequired
-primOpHeapReq IntegerMulOp = VariableHeapRequired
-primOpHeapReq IntegerQuotRemOp = VariableHeapRequired
-primOpHeapReq IntegerDivModOp = VariableHeapRequired
-primOpHeapReq IntegerNegOp = VariableHeapRequired
-primOpHeapReq Int2IntegerOp = FixedHeapRequired
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE))
-primOpHeapReq Word2IntegerOp = FixedHeapRequired
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE))
-primOpHeapReq Addr2IntegerOp = VariableHeapRequired
-primOpHeapReq IntegerToInt64Op = FixedHeapRequired
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE))
-primOpHeapReq Word64ToIntegerOp = FixedHeapRequired
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE))
-primOpHeapReq Int64ToIntegerOp = FixedHeapRequired
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE))
-primOpHeapReq IntegerToWord64Op = FixedHeapRequired
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE))
-primOpHeapReq FloatDecodeOp = FixedHeapRequired
- (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE)))
-primOpHeapReq DoubleDecodeOp = FixedHeapRequired
- (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
- (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
- (intOff mIN_MP_INT_SIZE)))
-
-{-
- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
- or if it returns a ForeignObj.
-
- Hmm..the allocation for makeForeignObj# is known (and fixed), so
- why do we need to be so indeterminate about it? --SOF
--}
-primOpHeapReq (CCallOp _ _ mayGC@True _ _ _) = VariableHeapRequired
-primOpHeapReq (CCallOp _ _ mayGC@False _ _ _) = NoHeapRequired
-
-primOpHeapReq MakeForeignObjOp = VariableHeapRequired
-primOpHeapReq WriteForeignObjOp = NoHeapRequired
-
--- this occasionally has to expand the Stable Pointer table
-primOpHeapReq MakeStablePtrOp = VariableHeapRequired
-
--- These four only need heap space with the native code generator
--- ToDo!: parameterize, so we know if native code generation is taking place(JSM)
-
-primOpHeapReq IntegerCmpOp = FixedHeapRequired (intOff (2 * mP_STRUCT_SIZE))
-primOpHeapReq Integer2IntOp = FixedHeapRequired (intOff mP_STRUCT_SIZE)
-primOpHeapReq Integer2WordOp = FixedHeapRequired (intOff mP_STRUCT_SIZE)
-primOpHeapReq FloatEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE)
-primOpHeapReq DoubleEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE)
-
--- a NewSynchVarOp creates a three-word mutuple in the heap.
-primOpHeapReq NewSynchVarOp = FixedHeapRequired
- (addOff (totHdrSize (MuTupleRep 3)) (intOff 3))
-
--- Sparking ops no longer allocate any heap; however, _fork_ may
--- require a context switch to clear space in the required thread
--- pool, and that requires liveness information.
-
-primOpHeapReq ParOp = NoHeapRequired
-primOpHeapReq ForkOp = VariableHeapRequired
-
--- A SeqOp requires unknown space to evaluate its argument
-primOpHeapReq SeqOp = VariableHeapRequired
-
--- GranSim sparks are stgMalloced i.e. no heap required
-primOpHeapReq ParGlobalOp = NoHeapRequired
-primOpHeapReq ParLocalOp = NoHeapRequired
-primOpHeapReq ParAtOp = NoHeapRequired
-primOpHeapReq ParAtAbsOp = NoHeapRequired
-primOpHeapReq ParAtRelOp = NoHeapRequired
-primOpHeapReq ParAtForNowOp = NoHeapRequired
--- CopyableOp and NoFolowOp don't require heap; don't rely on default
-primOpHeapReq CopyableOp = NoHeapRequired
-primOpHeapReq NoFollowOp = NoHeapRequired
-
-primOpHeapReq other_op = NoHeapRequired
-\end{code}
-
-The amount of stack required by primops.
-
-\begin{code}
-data StackRequirement
- = NoStackRequired
- | FixedStackRequired Int {-AStack-} Int {-BStack-}
- | VariableStackRequired
-
-primOpStackRequired SeqOp = FixedStackRequired 0 {-AStack-} 2 {-BStack-}
-primOpStackRequired _ = VariableStackRequired
--- ToDo: be more specific for certain primops (currently only used for seq)
-\end{code}
-
-Primops which can trigger GC have to be called carefully.
-In particular, their arguments are guaranteed to be in registers,
-and a liveness mask tells which regs are live.
-
-\begin{code}
-primOpCanTriggerGC op
+primOpOutOfLine op
= case op of
- TakeMVarOp -> True
- ReadIVarOp -> True
- DelayOp -> True
- WaitReadOp -> True
- WaitWriteOp -> True
- _ ->
- case primOpHeapReq op of
- VariableHeapRequired -> True
- _ -> False
+ TakeMVarOp -> True
+ PutMVarOp -> True
+ DelayOp -> True
+ WaitReadOp -> True
+ WaitWriteOp -> True
+ CatchOp -> True
+ RaiseOp -> True
+ NewArrayOp -> True
+ NewByteArrayOp _ -> True
+ IntegerAddOp -> True
+ IntegerSubOp -> True
+ IntegerMulOp -> True
+ IntegerGcdOp -> True
+ IntegerQuotRemOp -> True
+ IntegerDivModOp -> True
+ Int2IntegerOp -> True
+ Word2IntegerOp -> True
+ Addr2IntegerOp -> True
+ Word64ToIntegerOp -> True
+ Int64ToIntegerOp -> True
+ FloatDecodeOp -> True
+ DoubleDecodeOp -> True
+ MkWeakOp -> True
+ DeRefWeakOp -> True
+ MakeForeignObjOp -> True
+ MakeStablePtrOp -> True
+ NewMutVarOp -> True
+ NewMVarOp -> True
+ ForkOp -> True
+ KillThreadOp -> True
+ CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_
+ _ -> False
\end{code}
Sometimes we may choose to execute a PrimOp even though it isn't
See also @primOpIsCheap@ (below).
-There should be no worries about side effects; that's all taken care
-of by data dependencies.
+PrimOps that have side effects also should not be executed speculatively
+or by data dependencies.
\begin{code}
primOpOkForSpeculation :: PrimOp -> Bool
+primOpOkForSpeculation op
+ = not (primOpCanFail op || primOpHasSideEffects op || primOpOutOfLine op)
+\end{code}
+
+@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
+WARNING), we just borrow some other predicates for a
+what-should-be-good-enough test. "Cheap" means willing to call it more
+than once. Evaluation order is unaffected.
+\begin{code}
+primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op)
+\end{code}
+
+\begin{code}
+primOpCanFail :: PrimOp -> Bool
-- Int.
-primOpOkForSpeculation IntQuotOp = False -- Divide by zero
-primOpOkForSpeculation IntRemOp = False -- Divide by zero
+primOpCanFail IntQuotOp = True -- Divide by zero
+primOpCanFail IntRemOp = True -- Divide by zero
-- Integer
-primOpOkForSpeculation IntegerQuotRemOp = False -- Divide by zero
-primOpOkForSpeculation IntegerDivModOp = False -- Divide by zero
+primOpCanFail IntegerQuotRemOp = True -- Divide by zero
+primOpCanFail IntegerDivModOp = True -- Divide by zero
-- Float. ToDo: tan? tanh?
-primOpOkForSpeculation FloatDivOp = False -- Divide by zero
-primOpOkForSpeculation FloatLogOp = False -- Log of zero
-primOpOkForSpeculation FloatAsinOp = False -- Arg out of domain
-primOpOkForSpeculation FloatAcosOp = False -- Arg out of domain
+primOpCanFail FloatDivOp = True -- Divide by zero
+primOpCanFail FloatLogOp = True -- Log of zero
+primOpCanFail FloatAsinOp = True -- Arg out of domain
+primOpCanFail FloatAcosOp = True -- Arg out of domain
-- Double. ToDo: tan? tanh?
-primOpOkForSpeculation DoubleDivOp = False -- Divide by zero
-primOpOkForSpeculation DoubleLogOp = False -- Log of zero
-primOpOkForSpeculation DoubleAsinOp = False -- Arg out of domain
-primOpOkForSpeculation DoubleAcosOp = False -- Arg out of domain
-
--- CCall
-primOpOkForSpeculation (CCallOp _ _ _ _ _ _) = False -- Could be expensive!
-
--- errorIO#
-primOpOkForSpeculation ErrorIOPrimOp = False -- Could be disastrous!
-
--- parallel
-primOpOkForSpeculation ParOp = False -- Could be expensive!
-primOpOkForSpeculation ForkOp = False -- Likewise
-primOpOkForSpeculation SeqOp = False -- Likewise
-
-primOpOkForSpeculation ParGlobalOp = False -- Could be expensive!
-primOpOkForSpeculation ParLocalOp = False -- Could be expensive!
-primOpOkForSpeculation ParAtOp = False -- Could be expensive!
-primOpOkForSpeculation ParAtAbsOp = False -- Could be expensive!
-primOpOkForSpeculation ParAtRelOp = False -- Could be expensive!
-primOpOkForSpeculation ParAtForNowOp = False -- Could be expensive!
-primOpOkForSpeculation CopyableOp = False -- only tags closure
-primOpOkForSpeculation NoFollowOp = False -- only tags closure
+primOpCanFail DoubleDivOp = True -- Divide by zero
+primOpCanFail DoubleLogOp = True -- Log of zero
+primOpCanFail DoubleAsinOp = True -- Arg out of domain
+primOpCanFail DoubleAcosOp = True -- Arg out of domain
-- The default is "yes it's ok for speculation"
-primOpOkForSpeculation other_op = True
-\end{code}
-
-@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
-WARNING), we just borrow some other predicates for a
-what-should-be-good-enough test.
-\begin{code}
-primOpIsCheap op
- = primOpOkForSpeculation op && not (primOpCanTriggerGC op)
+primOpCanFail other_op = True
\end{code}
And some primops have side-effects and so, for example, must not be
duplicated.
\begin{code}
-fragilePrimOp :: PrimOp -> Bool
-
-fragilePrimOp ParOp = True
-fragilePrimOp ForkOp = True
-fragilePrimOp SeqOp = True
-fragilePrimOp MakeForeignObjOp = True -- SOF
-fragilePrimOp WriteForeignObjOp = True -- SOF
-fragilePrimOp MakeStablePtrOp = True
-fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR
-
-fragilePrimOp ParGlobalOp = True
-fragilePrimOp ParLocalOp = True
-fragilePrimOp ParAtOp = True
-fragilePrimOp ParAtAbsOp = True
-fragilePrimOp ParAtRelOp = True
-fragilePrimOp ParAtForNowOp = True
-fragilePrimOp CopyableOp = True -- Possibly not. ASP
-fragilePrimOp NoFollowOp = True -- Possibly not. ASP
-
-fragilePrimOp other = False
+primOpHasSideEffects :: PrimOp -> Bool
+
+primOpHasSideEffects TakeMVarOp = True
+primOpHasSideEffects DelayOp = True
+primOpHasSideEffects WaitReadOp = True
+primOpHasSideEffects WaitWriteOp = True
+
+primOpHasSideEffects ParOp = True
+primOpHasSideEffects ForkOp = True
+primOpHasSideEffects KillThreadOp = True
+primOpHasSideEffects SeqOp = True
+
+primOpHasSideEffects MakeForeignObjOp = True
+primOpHasSideEffects WriteForeignObjOp = True
+primOpHasSideEffects MkWeakOp = True
+primOpHasSideEffects DeRefWeakOp = True
+primOpHasSideEffects MakeStablePtrOp = True
+primOpHasSideEffects EqStablePtrOp = True -- SOF
+primOpHasSideEffects DeRefStablePtrOp = True -- ??? JSM & ADR
+
+primOpHasSideEffects ParGlobalOp = True
+primOpHasSideEffects ParLocalOp = True
+primOpHasSideEffects ParAtOp = True
+primOpHasSideEffects ParAtAbsOp = True
+primOpHasSideEffects ParAtRelOp = True
+primOpHasSideEffects ParAtForNowOp = True
+primOpHasSideEffects CopyableOp = True -- Possibly not. ASP
+primOpHasSideEffects NoFollowOp = True -- Possibly not. ASP
+
+-- CCall
+primOpHasSideEffects (CCallOp _ _ _ _) = True
+
+primOpHasSideEffects other = False
\end{code}
-Primitive operations that perform calls need wrappers to save any live variables
-that are stored in caller-saves registers
+Inline primitive operations that perform calls need wrappers to save
+any live variables that are stored in caller-saves registers.
\begin{code}
primOpNeedsWrapper :: PrimOp -> Bool
-primOpNeedsWrapper (CCallOp _ _ _ _ _ _) = True
-
-primOpNeedsWrapper NewArrayOp = True -- ToDo: for nativeGen only!(JSM)
-primOpNeedsWrapper (NewByteArrayOp _) = True
-
-primOpNeedsWrapper IntegerAddOp = True
-primOpNeedsWrapper IntegerSubOp = True
-primOpNeedsWrapper IntegerMulOp = True
-primOpNeedsWrapper IntegerQuotRemOp = True
-primOpNeedsWrapper IntegerDivModOp = True
-primOpNeedsWrapper IntegerNegOp = True
-primOpNeedsWrapper IntegerCmpOp = True
-primOpNeedsWrapper Integer2IntOp = True
-primOpNeedsWrapper Integer2WordOp = True
-primOpNeedsWrapper Int2IntegerOp = True
-primOpNeedsWrapper Word2IntegerOp = True
-primOpNeedsWrapper Addr2IntegerOp = True
-primOpNeedsWrapper IntegerToInt64Op = True
-primOpNeedsWrapper IntegerToWord64Op = True
-primOpNeedsWrapper Word64ToIntegerOp = True
-primOpNeedsWrapper Int64ToIntegerOp = True
+primOpNeedsWrapper (CCallOp _ _ _ _) = True
+
+primOpNeedsWrapper Integer2IntOp = True
+primOpNeedsWrapper Integer2WordOp = True
+primOpNeedsWrapper IntegerCmpOp = True
primOpNeedsWrapper FloatExpOp = True
primOpNeedsWrapper FloatLogOp = True
primOpNeedsWrapper FloatCoshOp = True
primOpNeedsWrapper FloatTanhOp = True
primOpNeedsWrapper FloatPowerOp = True
-primOpNeedsWrapper FloatEncodeOp = True
-primOpNeedsWrapper FloatDecodeOp = True
+primOpNeedsWrapper FloatEncodeOp = True
primOpNeedsWrapper DoubleExpOp = True
primOpNeedsWrapper DoubleLogOp = True
primOpNeedsWrapper DoubleCoshOp = True
primOpNeedsWrapper DoubleTanhOp = True
primOpNeedsWrapper DoublePowerOp = True
-primOpNeedsWrapper DoubleEncodeOp = True
-primOpNeedsWrapper DoubleDecodeOp = True
+primOpNeedsWrapper DoubleEncodeOp = True
-primOpNeedsWrapper MakeForeignObjOp = True
-primOpNeedsWrapper WriteForeignObjOp = True
primOpNeedsWrapper MakeStablePtrOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
-primOpNeedsWrapper TakeMVarOp = True
-primOpNeedsWrapper PutMVarOp = True
-primOpNeedsWrapper ReadIVarOp = True
-
primOpNeedsWrapper DelayOp = True
primOpNeedsWrapper WaitReadOp = True
primOpNeedsWrapper WaitWriteOp = True
\end{code}
\begin{code}
-primOp_str op
+primOpStr op
= case (primOpInfo op) of
Dyadic str _ -> str
Monadic str _ -> str
Compare str _ -> str
- Coercing str _ _ -> str
- PrimResult str _ _ _ _ _ -> str
- AlgResult str _ _ _ _ -> str
+ GenPrimOp str _ _ _ -> str
\end{code}
-@primOpType@ duplicates some work of @primOpId@, but since we
-grab types pretty often...
\begin{code}
-primOpType :: PrimOp -> Type
+primOpUniq :: PrimOp -> Unique
+primOpUniq op = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
+primOpType :: PrimOp -> Type
primOpType op
= case (primOpInfo op) of
Dyadic str ty -> dyadic_fun_ty ty
Monadic str ty -> monadic_fun_ty ty
Compare str ty -> compare_fun_ty ty
- Coercing str ty1 ty2 -> mkFunTy ty1 ty2
- PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp prim_tycon res_tys))
-
- AlgResult str tyvars arg_tys tycon res_tys ->
- mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp tycon res_tys))
+ GenPrimOp str tyvars arg_tys res_ty ->
+ mkForAllTys tyvars (mkFunTys arg_tys res_ty)
\end{code}
\begin{code}
= ReturnsPrim PrimRep
| ReturnsAlg TyCon
--- ToDo: Deal with specialised PrimOps
--- Will need to return specialised tycon and data constructors
+-- Some PrimOps need not return a manifest primitive or algebraic value
+-- (i.e. they might return a polymorphic value). These PrimOps *must*
+-- be out of line, or the code generator won't work.
getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Monadic _ ty -> ReturnsPrim (typePrimRep ty)
Compare _ ty -> ReturnsAlg boolTyCon
- Coercing _ _ ty -> ReturnsPrim (typePrimRep ty)
- PrimResult _ _ _ _ kind _ -> ReturnsPrim kind
- AlgResult _ _ _ tycon _ -> ReturnsAlg tycon
+ GenPrimOp _ _ _ ty ->
+ let rep = typePrimRep ty in
+ case rep of
+ PtrRep -> case splitAlgTyConApp_maybe ty of
+ Nothing -> panic "getPrimOpResultInfo"
+ Just (tc,_,_) -> ReturnsAlg tc
+ other -> ReturnsPrim other
isCompareOp :: PrimOp -> Bool
commutableOp IntNeOp = True
commutableOp IntegerAddOp = True
commutableOp IntegerMulOp = True
+commutableOp IntegerGcdOp = True
commutableOp FloatAddOp = True
commutableOp FloatMulOp = True
commutableOp FloatEqOp = True
Output stuff:
\begin{code}
pprPrimOp :: PrimOp -> SDoc
-showPrimOp :: PrimOp -> String
-
-showPrimOp op = showSDoc (pprPrimOp op)
-pprPrimOp (CCallOp fun is_casm may_gc cconv arg_tys res_ty)
+pprPrimOp (CCallOp fun is_casm may_gc cconv)
= let
callconv = text "{-" <> pprCallConv cconv <> text "-}"
before
- | is_casm && may_gc = "_casm_GC_ ``"
- | is_casm = "_casm_ ``"
- | may_gc = "_ccall_GC_ "
- | otherwise = "_ccall_ "
+ | is_casm && may_gc = "__casm_GC ``"
+ | is_casm = "__casm ``"
+ | may_gc = "__ccall_GC "
+ | otherwise = "__ccall "
after
| is_casm = text "''"
| otherwise = empty
- pp_tys
- = hsep (map pprParendType (res_ty:arg_tys))
-
ppr_fun =
case fun of
Right _ -> ptext SLIT("<dynamic>")
in
hcat [ ifPprDebug callconv
- , text before , ppr_fun , after, space, brackets pp_tys]
+ , text before , ppr_fun , after]
pprPrimOp other_op
= getPprStyle $ \ sty ->
else -- Unqualified is good enough
ptext str
where
- str = primOp_str other_op
-
-
-instance Outputable PrimOp where
- ppr op = pprPrimOp op
+ str = primOpStr other_op
\end{code}
%
-% (c) The GRASP Project, Glasgow University, 1992-1996
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[PrimRep]{Primitive machine-level kinds of things.}
, getPrimRepSizeInBytes
, retPrimRepSize
, showPrimRep
+ , primRepString
, showPrimRepToUser
- , ppPrimRep
- , guessPrimRep
- , decodePrimRep
) where
#include "HsVersions.h"
+import Constants ( dOUBLE_SIZE, iNT64_SIZE, wORD64_SIZE )
import Util
import Outputable
-
--- Oh dear.
--- NOTE: we have to reach out and grab this header file
--- in our current source/build tree, and not the one supplied
--- by whoever's compiling us.
-#include "../../includes/GhcConstants.h"
\end{code}
%************************************************************************
| CostCentreRep -- Pointer to a cost centre
| CharRep -- Machine characters
- | IntRep -- integers (at least 32 bits)
+ | IntRep -- integers (same size as ptr on this arch)
| WordRep -- ditto (but *unsigned*)
| AddrRep -- addresses ("C pointers")
| FloatRep -- floats
| Word64Rep -- guaranteed to be 64 bits (no more, no less.)
| Int64Rep -- guaranteed to be 64 bits (no more, no less.)
- | ForeignObjRep -- This has to be a special kind because ccall
- -- generates special code when passing/returning
- -- one of these. [ADR]
+ | WeakPtrRep
+ | ForeignObjRep
| StablePtrRep -- We could replace this with IntRep but maybe
-- there's some documentation gain from having
-- it special? [ADR]
+ | ThreadIdRep -- Really a pointer to a TSO
+
| ArrayRep -- Primitive array of Haskell pointers
| ByteArrayRep -- Primitive array of bytes (no Haskell pointers)
-- Kinds are used in PrimTyCons, which need both Eq and Ord
\end{code}
+These pretty much correspond to the C types declared in StgTypes.h,
+with the following exceptions:
+
+ - when an Array or ByteArray is passed to C, we again pass a pointer
+ to the contents. The actual type that is passed is StgPtr for
+ ArrayRep, and StgByteArray (probably a char *) for ByteArrayRep.
+
+These hacks are left until the final printing of the C, in
+PprAbsC.lhs.
+
%************************************************************************
%* *
\subsection[PrimRep-predicates]{Follow-ness, sizes, and such---on @PrimitiveKinds@}
isFollowableRep :: PrimRep -> Bool
isFollowableRep PtrRep = True
-isFollowableRep ArrayRep = True
-isFollowableRep ByteArrayRep = True
--- why is a ForeignObj followable? 4/96 SOF
---
--- A: they're followable because these objects
--- should be lugged around by the storage manager
--- (==> registers containing them are live) -- 3/97 SOF
-isFollowableRep ForeignObjRep = True
-
-isFollowableRep StablePtrRep = False
--- StablePtrs aren't followable because they are just indices into a
--- table for which explicit allocation/ deallocation is required.
+isFollowableRep ArrayRep = True -- all heap objects:
+isFollowableRep ByteArrayRep = True -- ''
+isFollowableRep WeakPtrRep = True -- ''
+isFollowableRep ForeignObjRep = True -- ''
+isFollowableRep ThreadIdRep = True -- pointer to a TSO
isFollowableRep other = False
\begin{code}
getPrimRepSize :: PrimRep -> Int
-getPrimRepSize DoubleRep = DOUBLE_SIZE -- "words", of course
-getPrimRepSize Word64Rep = WORD64_SIZE
-getPrimRepSize Int64Rep = INT64_SIZE
+getPrimRepSize DoubleRep = dOUBLE_SIZE -- "words", of course
+getPrimRepSize Word64Rep = wORD64_SIZE
+getPrimRepSize Int64Rep = iNT64_SIZE
--getPrimRepSize FloatRep = 1
--getPrimRepSize CharRep = 1 -- ToDo: count in bytes?
--getPrimRepSize ArrayRep = 1 -- Listed specifically for *documentation*
DoubleRep -> 8
Word64Rep -> 8
Int64Rep -> 8
+ WeakPtrRep -> 4
ForeignObjRep -> 4
StablePtrRep -> 4
ArrayRep -> 4
showPrimRep :: PrimRep -> String
showPrimRepToUser :: PrimRep -> String
--- dumping PrimRep tag for unfoldings
-ppPrimRep :: PrimRep -> SDoc
-
-guessPrimRep :: String -> PrimRep -- a horrible "inverse" function
-decodePrimRep :: Char -> PrimRep -- of equal nature
-
-ppPrimRep k =
- char
- (case k of
- PtrRep -> 'P'
- CodePtrRep -> 'p'
- DataPtrRep -> 'd'
- CostCentreRep -> 'c' -- Pointer to a cost centre
- RetRep -> 'R'
- CharRep -> 'C'
- IntRep -> 'I'
- Int64Rep -> 'i'
- WordRep -> 'W'
- Word64Rep -> 'w'
- AddrRep -> 'A'
- FloatRep -> 'F'
- DoubleRep -> 'D'
- ArrayRep -> 'a'
- ByteArrayRep -> 'b'
- StablePtrRep -> 'S'
- ForeignObjRep -> 'f'
- VoidRep -> 'V'
- _ -> panic "ppPrimRep")
-
-showPrimRep PtrRep = "P_" -- short for StgPtr
-
-showPrimRep CodePtrRep = "P_" -- DEATH to StgFunPtr! (94/02/22 WDP)
- -- but aren't code pointers and function pointers different sizes
- -- on some machines (eg 80x86)? ADR
- -- Are you trying to ruin my life, or what? (WDP)
-
-showPrimRep DataPtrRep = "D_"
-showPrimRep RetRep = "StgRetAddr"
-showPrimRep CostCentreRep = "CostCentre"
-showPrimRep CharRep = "StgChar"
-showPrimRep IntRep = "I_" -- short for StgInt
-showPrimRep WordRep = "W_" -- short for StgWord
-showPrimRep Int64Rep = "LI_" -- short for StgLongInt
-showPrimRep Word64Rep = "LW_" -- short for StgLongWord
-showPrimRep AddrRep = "StgAddr"
-showPrimRep FloatRep = "StgFloat"
-showPrimRep DoubleRep = "StgDouble"
-showPrimRep ArrayRep = "StgArray" -- see comment below
-showPrimRep ByteArrayRep = "StgByteArray"
-showPrimRep StablePtrRep = "StgStablePtr"
-showPrimRep ForeignObjRep = "StgPtr" -- see comment below
-showPrimRep VoidRep = "!!VOID_KIND!!"
-
-showPrimRepToUser pr =
- case pr of
- CharRep -> "StgChar"
- IntRep -> "StgInt"
- WordRep -> "StgWord"
- Int64Rep -> "StgInt64"
- Word64Rep -> "StgWord64"
- AddrRep -> "StgAddr"
- FloatRep -> "StgFloat"
- DoubleRep -> "StgDouble"
- ArrayRep -> "StgArray"
- ByteArrayRep -> "StgByteArray"
- StablePtrRep -> "StgStablePtr"
- ForeignObjRep -> "StgPtr"
- _ -> panic ("showPrimRepToUser: " ++ showPrimRep pr)
-
-
-decodePrimRep ch =
- case ch of
- 'P' -> PtrRep
- 'p' -> CodePtrRep
- 'd' -> DataPtrRep
- 'c' -> CostCentreRep
- 'R' -> RetRep
- 'C' -> CharRep
- 'I' -> IntRep
- 'W' -> WordRep
- 'i' -> Int64Rep
- 'w' -> Word64Rep
- 'A' -> AddrRep
- 'F' -> FloatRep
- 'D' -> DoubleRep
- 'a' -> ArrayRep
- 'b' -> ByteArrayRep
- 'S' -> StablePtrRep
- 'f' -> ForeignObjRep
- 'V' -> VoidRep
- _ -> panic "decodePrimRep"
-
-guessPrimRep "D_" = DataPtrRep
-guessPrimRep "StgRetAddr" = RetRep
-guessPrimRep "StgChar" = CharRep
-guessPrimRep "I_" = IntRep
-guessPrimRep "LI_" = Int64Rep
-guessPrimRep "W_" = WordRep
-guessPrimRep "LW_" = Word64Rep
-guessPrimRep "StgAddr" = AddrRep
-guessPrimRep "StgFloat" = FloatRep
-guessPrimRep "StgDouble" = DoubleRep
-guessPrimRep "StgArray" = ArrayRep
-guessPrimRep "StgByteArray" = ByteArrayRep
-guessPrimRep "StgStablePtr" = StablePtrRep
+
+showPrimRep PtrRep = "P_" -- short for StgPtr
+
+showPrimRep CodePtrRep = "P_" -- DEATH to StgFunPtr! (94/02/22 WDP)
+showPrimRep PtrRep = "P_" -- short for StgPtr
+showPrimRep CodePtrRep = "P_" -- DEATH to StgFunPtr! (94/02/22 WDP)
+showPrimRep DataPtrRep = "D_"
+showPrimRep RetRep = "P_"
+showPrimRep CostCentreRep = "CostCentre"
+showPrimRep CharRep = "C_"
+showPrimRep IntRep = "I_" -- short for StgInt
+showPrimRep WordRep = "W_" -- short for StgWord
+showPrimRep Int64Rep = "LI_" -- short for StgLongInt
+showPrimRep Word64Rep = "LW_" -- short for StgLongWord
+showPrimRep AddrRep = "StgAddr"
+showPrimRep FloatRep = "StgFloat"
+showPrimRep DoubleRep = "StgDouble"
+showPrimRep ArrayRep = "P_" -- see comment below
+showPrimRep ByteArrayRep = "StgByteArray"
+showPrimRep StablePtrRep = "StgStablePtr"
+showPrimRep ThreadIdRep = "StgTSO*"
+showPrimRep WeakPtrRep = "P_"
+showPrimRep ForeignObjRep = "StgAddr"
+showPrimRep VoidRep = "!!VOID_KIND!!"
+
+primRepString CharRep = "Char"
+primRepString IntRep = "Int"
+primRepString WordRep = "Word"
+primRepString Int64Rep = "Int64"
+primRepString Word64Rep = "Word64"
+primRepString AddrRep = "Addr"
+primRepString FloatRep = "Float"
+primRepString DoubleRep = "Double"
+primRepString WeakPtrRep = "Weak"
+primRepString ForeignObjRep = "ForeignObj"
+primRepString StablePtrRep = "StablePtr"
+primRepString other = pprPanic "primRepString" (ppr other)
+
+showPrimRepToUser pr = primRepString pr
\end{code}
-All local C variables of @ArrayRep@ are declared in C as type
-@StgArray@. The coercion to a more precise C type is done just before
-indexing (by the relevant C primitive-op macro).
-
-Nota Bene. There are three types associated with @ForeignObj@ (MallocPtr++):
-\begin{itemize}
-\item
-@StgForeignObjClosure@ is the type of the thing the prim. op @mkForeignObj@ returns.
-{- old comment for MallocPtr
-(This typename is hardwired into @ppr_casm_results@ in
-@PprAbsC.lhs@.)
--}
-
-\item
-@StgForeignObj@ is the type of the thing we give the C world.
-
-\item
-@StgPtr@ is the type of the (pointer to the) heap object which we
-pass around inside the STG machine.
-\end{itemize}
-
-It is really easy to confuse the two. (I'm not sure this choice of
-type names helps.) [ADR]
+Foreign Objects and Arrays are treated specially by the code for
+_ccall_s: we pass a pointer to the contents of the object, not the
+object itself.
+++ /dev/null
-_interface_ TysPrim 1
-_exports_
-TysPrim voidTy;
-_declarations_
--- Not needed by Type.lhs any more
--- 1 voidTy _:_ Type.Type ;;
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[TysPrim]{Wired-in knowledge about primitive types}
types and operations.''
\begin{code}
-module TysPrim where
+module TysPrim(
+ alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+ alphaTy, betaTy, gammaTy, deltaTy,
+ openAlphaTyVar, openAlphaTyVars,
+
+ charPrimTyCon, charPrimTy,
+ intPrimTyCon, intPrimTy,
+ wordPrimTyCon, wordPrimTy,
+ addrPrimTyCon, addrPrimTy,
+ floatPrimTyCon, floatPrimTy,
+ doublePrimTyCon, doublePrimTy,
+
+ statePrimTyCon, mkStatePrimTy,
+ realWorldTyCon, realWorldTy, realWorldStatePrimTy,
+
+ arrayPrimTyCon, mkArrayPrimTy,
+ byteArrayPrimTyCon, byteArrayPrimTy,
+ mutableArrayPrimTyCon, mkMutableArrayPrimTy,
+ mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy,
+ mutVarPrimTyCon, mkMutVarPrimTy,
+
+ mVarPrimTyCon, mkMVarPrimTy,
+ stablePtrPrimTyCon, mkStablePtrPrimTy,
+ weakPrimTyCon, mkWeakPrimTy,
+ foreignObjPrimTyCon, foreignObjPrimTy,
+ threadIdPrimTyCon, threadIdPrimTy,
+
+ int64PrimTyCon, int64PrimTy,
+ word64PrimTyCon, word64PrimTy,
+
+ primRepTyCon,
+
+ pcPrimTyCon
+ ) where
#include "HsVersions.h"
-import Kind ( mkBoxedTypeKind )
+import Var ( TyVar, mkSysTyVar )
import Name ( mkWiredInTyConName )
-import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
-import TyCon ( mkPrimTyCon, mkDataTyCon, TyCon )
-import BasicTypes ( NewOrData(..), RecFlag(..) )
-import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, Type )
-import TyVar ( GenTyVar(..), alphaTyVars )
+import PrimRep ( PrimRep(..), isFollowableRep )
+import TyCon ( mkPrimTyCon, TyCon )
+import Type ( Type,
+ mkTyConApp, mkTyConTy, mkTyVarTys,
+ unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds
+ )
import PrelMods ( pREL_GHC )
+import Outputable
import Unique
\end{code}
\begin{code}
+alphaTyVars :: [TyVar]
+alphaTyVars = [ mkSysTyVar u boxedTypeKind
+ | u <- map mkAlphaTyVarUnique [2..] ]
+
+alphaTyVar, betaTyVar, gammaTyVar :: TyVar
+(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
+
alphaTys = mkTyVarTys alphaTyVars
(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys
+
+ -- openAlphaTyVar is prepared to be instantiated
+ -- to a boxed or unboxed type variable. It's used for the
+ -- result type for "error", so that we can have (error Int# "Help")
+openAlphaTyVar :: TyVar
+openAlphaTyVar = mkSysTyVar (mkAlphaTyVarUnique 1) openTypeKind
+
+openAlphaTyVars :: [TyVar]
+openAlphaTyVars = [ mkSysTyVar u openTypeKind
+ | u <- map mkAlphaTyVarUnique [2..] ]
\end{code}
%************************************************************************
\begin{code}
-- only used herein
pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon
-
-pcPrimTyCon key str arity primrep
+pcPrimTyCon key str arity rep
= the_tycon
where
name = mkWiredInTyConName key pREL_GHC str the_tycon
- the_tycon = mkPrimTyCon name arity primrep
-
+ the_tycon = mkPrimTyCon name kind arity rep
+ kind = mkArrowKinds (take arity (repeat openTypeKind)) result_kind
+ result_kind | isFollowableRep rep = boxedTypeKind -- Represented by a GC-ish ptr
+ | otherwise = unboxedTypeKind -- Represented by a non-ptr
charPrimTy = mkTyConTy charPrimTyCon
charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 CharRep
doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 DoubleRep
\end{code}
-@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need
-to reconstruct various type information. (It's slightly more
-convenient/efficient to make type info from kinds, than kinds [etc.]
-from type info.)
-
-\begin{code}
-getPrimRepInfo ::
- PrimRep -> (String, -- tag string
- Type, TyCon) -- prim type and tycon
-
-getPrimRepInfo CharRep = ("Char", charPrimTy, charPrimTyCon)
-getPrimRepInfo IntRep = ("Int", intPrimTy, intPrimTyCon)
-getPrimRepInfo WordRep = ("Word", wordPrimTy, wordPrimTyCon)
-getPrimRepInfo AddrRep = ("Addr", addrPrimTy, addrPrimTyCon)
-getPrimRepInfo FloatRep = ("Float", floatPrimTy, floatPrimTyCon)
-getPrimRepInfo DoubleRep = ("Double", doublePrimTy, doublePrimTyCon)
-getPrimRepInfo Int64Rep = ("Int64", int64PrimTy, int64PrimTyCon)
-getPrimRepInfo Word64Rep = ("Word64", word64PrimTy, word64PrimTyCon)
-getPrimRepInfo StablePtrRep = ("StablePtr", mkStablePtrPrimTy alphaTy, stablePtrPrimTyCon)
-getPrimRepInfo ForeignObjRep = ("ForeignObj", foreignObjPrimTy, foreignObjPrimTyCon)
-
-\end{code}
%************************************************************************
%* *
\end{code}
@_RealWorld@ is deeply magical. It {\em is primitive}, but it
-{\em is not unboxed}.
+{\em is not unboxed} (hence PtrRep).
We never manipulate values of type RealWorld; it's only used in the type
system, to parameterise State#.
\begin{code}
realWorldTy = mkTyConTy realWorldTyCon
-realWorldTyCon = mk_no_constr_tycon realWorldTyConKey SLIT("RealWorld")
+realWorldTyCon = pcPrimTyCon realWorldTyConKey SLIT("RealWorld") 0 PtrRep
realWorldStatePrimTy = mkStatePrimTy realWorldTy
\end{code}
Note: the ``state-pairing'' types are not truly primitive, so they are
defined in \tr{TysWiredIn.lhs}, not here.
-\begin{code}
--- The Void type is represented as a data type with no constructors
--- It's a built in type (i.e. there's no way to define it in Haskell;
--- the nearest would be
---
--- data Void = -- No constructors!
---
--- ) It's boxed; there is only one value of this
--- type, namely "void", whose semantics is just bottom.
-voidTy = mkTyConTy voidTyCon
-voidTyCon = mk_no_constr_tycon voidTyConKey SLIT("Void")
-\end{code}
-
-\begin{code}
-mk_no_constr_tycon key str
- = the_tycon
- where
- name = mkWiredInTyConName key pREL_GHC str the_tycon
- the_tycon = mkDataTyCon name mkBoxedTypeKind
- [] -- No tyvars
- [] -- No context
- [] -- No constructors; we tell you *nothing* about this guy
- [] -- No derivings
- Nothing -- Not a dictionary
- DataType
- NonRecursive
-\end{code}
%************************************************************************
%* *
%************************************************************************
%* *
+\subsection[TysPrim-mut-var]{The mutable variable type}
+%* *
+%************************************************************************
+
+\begin{code}
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConKey SLIT("MutVar#") 2 PtrRep
+
+mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt]
+\end{code}
+
+%************************************************************************
+%* *
\subsection[TysPrim-synch-var]{The synchronizing variable type}
%* *
%************************************************************************
\begin{code}
-synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2 PtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConKey SLIT("MVar#") 2 PtrRep
-mkSynchVarPrimTy s elt = mkTyConApp synchVarPrimTyCon [s, elt]
+mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
%* *
%************************************************************************
-Foreign objects (formerly ``Malloc'' pointers) provide a mechanism which
-will let Haskell's garbage collector communicate with a {\em simple\/}
-garbage collector in the IO world. We want Haskell to be able to hold
-onto references to objects in the IO world and for Haskell's garbage
-collector to tell the IO world when these references become garbage.
-We are not aiming to provide a mechanism that could
-talk to a sophisticated garbage collector such as that provided by a
-LISP system (with a correspondingly complex interface); in particular,
-we shall ignore the danger of circular structures spread across the
-two systems.
+A Foreign Object is just a boxed, unlifted, Addr#. They're needed
+because finalisers (weak pointers) can't watch Addr#s, they can only
+watch heap-resident objects.
-There are no primitive operations on @ForeignObj#@s (although equality
-could possibly be added?)
+We can't use a lifted Addr# (such as Addr) because race conditions
+could bite us. For example, if the program deconstructed the Addr
+before passing its contents to a ccall, and a weak pointer was
+watching the Addr, the weak pointer might deduce that the Addr was
+dead before it really was.
\begin{code}
foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon
foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 ForeignObjRep
\end{code}
+
+%************************************************************************
+%* *
+\subsection[TysPrim-Weak]{The ``weak pointer'' type}
+%* *
+%************************************************************************
+
+\begin{code}
+weakPrimTyCon = pcPrimTyCon weakPrimTyConKey SLIT("Weak#") 1 WeakPtrRep
+
+mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[TysPrim-thread-ids]{The ``thread id'' type}
+%* *
+%************************************************************************
+
+A thread id is represented by a pointer to the TSO itself, to ensure
+that they are always unique and we can always find the TSO for a given
+thread id. However, this has the unfortunate consequence that a
+ThreadId# for a given thread is treated as a root by the garbage
+collector and can keep TSOs around for too long.
+
+Hence the programmer API for thread manipulation uses a weak pointer
+to the thread id internally.
+
+\begin{code}
+threadIdPrimTy = mkTyConTy threadIdPrimTyCon
+threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConKey SLIT("ThreadId#") 0 ThreadIdRep
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[TysPrim-PrimRep]{Making types from PrimReps}
+%* *
+%************************************************************************
+
+Each of the primitive types from this module is equivalent to a
+PrimRep (see PrimRep.lhs). The following function returns the
+primitive TyCon for a given PrimRep.
+
+\begin{code}
+primRepTyCon CharRep = charPrimTyCon
+primRepTyCon IntRep = intPrimTyCon
+primRepTyCon WordRep = wordPrimTyCon
+primRepTyCon Int64Rep = int64PrimTyCon
+primRepTyCon Word64Rep = word64PrimTyCon
+primRepTyCon AddrRep = addrPrimTyCon
+primRepTyCon FloatRep = floatPrimTyCon
+primRepTyCon DoubleRep = doublePrimTyCon
+primRepTyCon StablePtrRep = stablePtrPrimTyCon
+primRepTyCon ForeignObjRep = foreignObjPrimTyCon
+primRepTyCon WeakPtrRep = weakPrimTyCon
+primRepTyCon other = pprPanic "primRepTyCon" (ppr other)
+\end{code}
_interface_ TysWiredIn 1
_exports_
-TysWiredIn tupleCon ;
+TysWiredIn listTyCon ;
_declarations_
--- Let's try not having this either!
--- 1 tupleTyCon _:_ BasicTypes.Arity -> TyCon.TyCon ;;
-
--- Needed by TyCon.lhs
-1 tupleCon _:_ BasicTypes.Arity -> Id!Id ;;
-
-
+1 listTyCon _:_ TyCon!TyCon ;;
%
-% (c) The GRASP Project, Glasgow University, 1994-1995
+% (c) The GRASP Project, Glasgow University, 1994-1998
%
\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types}
floatTy,
isFloatTy,
floatTyCon,
- getStatePairingConInfo,
+
+ voidTyCon, voidTy,
intDataCon,
intTy,
integerDataCon,
isIntegerTy,
- liftDataCon,
- liftTyCon,
listTyCon,
- foreignObjTyCon,
- mkLiftTy,
mkListTy,
+ nilDataCon,
+
+ -- tuples
mkTupleTy,
tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
- nilDataCon,
- realWorldStateTy,
- return2GMPsTyCon,
- returnIntAndGMPTyCon,
-
- -- ST and STret types
- mkStateTy,
- mkStateTransformerTy,
- mkSTretTy,
- stTyCon,
- stDataCon,
- stRetDataCon,
- stRetTyCon,
-
- -- CCall result types
- stateAndAddrPrimTyCon,
- stateAndArrayPrimTyCon,
- stateAndByteArrayPrimTyCon,
- stateAndCharPrimTyCon,
- stateAndDoublePrimTyCon,
- stateAndFloatPrimTyCon,
- stateAndIntPrimTyCon,
- stateAndInt64PrimTyCon,
- stateAndForeignObjPrimTyCon,
- stateAndMutableArrayPrimTyCon,
- stateAndMutableByteArrayPrimTyCon,
- stateAndPtrPrimTyCon,
- stateAndPtrPrimDataCon,
- stateAndStablePtrPrimTyCon,
- stateAndSynchVarPrimTyCon,
- stateAndWordPrimTyCon,
- stateAndWord64PrimTyCon,
+
+ -- unboxed tuples
+ mkUnboxedTupleTy,
+ unboxedTupleTyCon, unboxedTupleCon,
+ unboxedPairTyCon, unboxedPairDataCon,
+
stateDataCon,
stateTyCon,
+ realWorldStateTy,
stablePtrTyCon,
stringTy,
#include "HsVersions.h"
-import {-# SOURCE #-} MkId ( mkDataCon, mkTupleCon )
-import {-# SOURCE #-} Id ( Id, StrictnessMark(..) )
+import {-# SOURCE #-} MkId( mkDataConId )
-- friends:
import PrelMods
import TysPrim
-- others:
-import Kind ( mkBoxedTypeKind, mkArrowKind )
-import Name ( mkWiredInTyConName, mkWiredInIdName )
-import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
- TyCon, Arity
- )
-import BasicTypes ( Module, NewOrData(..), RecFlag(..) )
+import Constants ( mAX_TUPLE_SIZE )
+import Name ( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr,
+ mkUbxTupNameStr )
+import DataCon ( DataCon, mkDataCon )
+import Var ( TyVar, tyVarKind )
+import TyCon ( TyCon, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
+import BasicTypes ( Module, Arity, NewOrData(..),
+ RecFlag(..), StrictnessMark(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
- mkFunTy, mkFunTys, splitTyConApp_maybe, splitAlgTyConApp_maybe,
- GenType(..), ThetaType, TauType, isUnpointedType )
-import TyVar ( GenTyVar, TyVar, tyVarKind, alphaTyVars, alphaTyVar, betaTyVar )
-import Lex ( mkTupNameStr )
+ mkArrowKinds, boxedTypeKind, unboxedTypeKind,
+ mkFunTy, mkFunTys, isUnLiftedType,
+ splitTyConApp_maybe, splitAlgTyConApp_maybe,
+ GenType(..), ThetaType, TauType )
+import PrimRep ( PrimRep(..) )
import Unique
import CmdLineOpts ( opt_GlasgowExts )
import Util ( assoc, panic )
-
+import Array
alpha_tyvar = [alphaTyVar]
alpha_ty = [alphaTy]
pcRecDataTyCon, pcNonRecDataTyCon, pcNonRecNewTyCon
:: Unique{-TyConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> [Id] -> TyCon
+ -> [TyVar] -> [DataCon] -> TyCon
-pcRecDataTyCon = pc_tycon DataType Recursive
-pcNonRecDataTyCon = pc_tycon DataType NonRecursive
-pcNonRecNewTyCon = pc_tycon NewType NonRecursive
+pcRecDataTyCon = pcTyCon DataType Recursive
+pcNonRecDataTyCon = pcTyCon DataType NonRecursive
+pcNonRecNewTyCon = pcTyCon NewType NonRecursive
-pc_tycon new_or_data is_rec key mod str tyvars cons
+pcTyCon new_or_data is_rec key mod str tyvars cons
= tycon
where
- tycon = mkDataTyCon name tycon_kind
+ tycon = mkAlgTyCon name kind
tyvars
[] -- No context
cons
is_rec
name = mkWiredInTyConName key mod str tycon
- tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
+ kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
pcSynTyCon key mod str kind arity tyvars expansion
= tycon
name = mkWiredInTyConName key mod str tycon
pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> Id
+ -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon
pcDataCon key mod str tyvars context arg_tys tycon
= data_con
where
data_con = mkDataCon name
[ NotMarkedStrict | a <- arg_tys ]
[ {- no labelled fields -} ]
- tyvars context [] [] arg_tys tycon
- name = mkWiredInIdName key mod str data_con
+ tyvars context [] [] arg_tys tycon id
+ name = mkWiredInIdName key mod str id
+ id = mkDataConId data_con
\end{code}
%************************************************************************
\begin{code}
tupleTyCon :: Arity -> TyCon
-tupleTyCon arity
- = tycon
- where
- tycon = mkTupleTyCon uniq name arity
- uniq = mkTupleTyConUnique arity
- name = mkWiredInTyConName uniq mod_name (mkTupNameStr arity) tycon
- mod_name | arity == 0 = pREL_BASE
- | otherwise = pREL_TUP
-
-tupleCon :: Arity -> Id
-tupleCon arity
- = tuple_con
+tupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_tuple i) -- Build one specially
+ | otherwise = tupleTyConArr!i
+
+tupleCon :: Arity -> DataCon
+tupleCon i | i > mAX_TUPLE_SIZE = snd (mk_tuple i) -- Build one specially
+ | otherwise = tupleConArr!i
+
+tupleTyCons :: [TyCon]
+tupleTyCons = elems tupleTyConArr
+
+tupleTyConArr :: Array Int TyCon
+tupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst tuples)
+
+tupleConArr :: Array Int DataCon
+tupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd tuples)
+
+tuples :: [(TyCon,DataCon)]
+tuples = [mk_tuple i | i <- [0..mAX_TUPLE_SIZE]]
+
+mk_tuple :: Int -> (TyCon,DataCon)
+mk_tuple arity = (tycon, tuple_con)
where
- tuple_con = mkTupleCon arity name ty
- uniq = mkTupleDataConUnique arity
- name = mkWiredInIdName uniq mod_name (mkTupNameStr arity) tuple_con
- mod_name | arity == 0 = pREL_BASE
- | otherwise = pREL_TUP
- ty = mkSigmaTy tyvars [] (mkFunTys tyvar_tys (mkTyConApp tycon tyvar_tys))
- tyvars = take arity alphaTyVars
- tyvar_tys = mkTyVarTys tyvars
- tycon = tupleTyCon arity
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con True
+ tc_name = mkWiredInTyConName tc_uniq mod_name name_str tycon
+ tc_kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
+
+ tuple_con = pcDataCon dc_uniq mod_name name_str tyvars [] tyvar_tys tycon
+ tyvars = take arity alphaTyVars
+ tyvar_tys = mkTyVarTys tyvars
+ (mod_name, name_str) = mkTupNameStr arity
+ tc_uniq = mkTupleTyConUnique arity
+ dc_uniq = mkTupleDataConUnique arity
unitTyCon = tupleTyCon 0
pairTyCon = tupleTyCon 2
pairDataCon = tupleCon 2
\end{code}
+%************************************************************************
+%* *
+\subsection[TysWiredIn-ubx-tuples]{Unboxed Tuple Types}
+%* *
+%************************************************************************
+
+\begin{code}
+unboxedTupleTyCon :: Arity -> TyCon
+unboxedTupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_unboxed_tuple i)
+ | otherwise = unboxedTupleTyConArr!i
+
+unboxedTupleCon :: Arity -> DataCon
+unboxedTupleCon i | i > mAX_TUPLE_SIZE = snd (mk_unboxed_tuple i)
+ | otherwise = unboxedTupleConArr!i
+
+unboxedTupleTyConArr :: Array Int TyCon
+unboxedTupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst ubx_tuples)
+
+unboxedTupleConArr :: Array Int DataCon
+unboxedTupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd ubx_tuples)
+
+ubx_tuples :: [(TyCon,DataCon)]
+ubx_tuples = [mk_unboxed_tuple i | i <- [0..mAX_TUPLE_SIZE]]
+
+mk_unboxed_tuple :: Int -> (TyCon,DataCon)
+mk_unboxed_tuple arity = (tycon, tuple_con)
+ where
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con False
+ tc_name = mkWiredInTyConName tc_uniq mod_name name_str tycon
+ tc_kind = mkArrowKinds (map tyVarKind tyvars) unboxedTypeKind
+
+ tuple_con = pcDataCon dc_uniq mod_name name_str tyvars [] tyvar_tys tycon
+ tyvars = take arity openAlphaTyVars
+ tyvar_tys = mkTyVarTys tyvars
+ (mod_name, name_str) = mkUbxTupNameStr arity
+ tc_uniq = mkUbxTupleTyConUnique arity
+ dc_uniq = mkUbxTupleDataConUnique arity
+
+unboxedPairTyCon = unboxedTupleTyCon 2
+unboxedPairDataCon = unboxedTupleCon 2
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
+-- The Void type is represented as a data type with no constructors
+-- It's a built in type (i.e. there's no way to define it in Haskell;
+-- the nearest would be
+--
+-- data Void = -- No constructors!
+--
+-- ) It's boxed; there is only one value of this
+-- type, namely "void", whose semantics is just bottom.
+voidTy = mkTyConTy voidTyCon
+voidTyCon = pcNonRecDataTyCon voidTyConKey pREL_GHC SLIT("Void") [] [{-No data cons-}]
+\end{code}
+
+\begin{code}
charTy = mkTyConTy charTyCon
charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [charDataCon]
isIntTy :: GenType flexi -> Bool
isIntTy ty
= case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> uniqueOf tycon == intTyConKey
+ Just (tycon, [], _) -> getUnique tycon == intTyConKey
_ -> False
inIntRange :: Integer -> Bool -- Tells if an integer lies in the legal range of Ints
int64Ty = mkTyConTy int64TyCon
-int64TyCon = pcNonRecDataTyCon int64TyConKey pREL_CCALL SLIT("Int64") [] [int64DataCon]
-int64DataCon = pcDataCon int64DataConKey pREL_CCALL SLIT("I64#") [] [] [int64PrimTy] int64TyCon
+int64TyCon = pcNonRecDataTyCon int64TyConKey pREL_ADDR SLIT("Int64") [] [int64DataCon]
+int64DataCon = pcDataCon int64DataConKey pREL_ADDR SLIT("I64#") [] [] [int64PrimTy] int64TyCon
\end{code}
\begin{code}
wordTy = mkTyConTy wordTyCon
-wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_FOREIGN SLIT("Word") [] [wordDataCon]
-wordDataCon = pcDataCon wordDataConKey pREL_FOREIGN SLIT("W#") [] [] [wordPrimTy] wordTyCon
+wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_ADDR SLIT("Word") [] [wordDataCon]
+wordDataCon = pcDataCon wordDataConKey pREL_ADDR SLIT("W#") [] [] [wordPrimTy] wordTyCon
word8TyCon = pcNonRecDataTyCon word8TyConKey wORD SLIT("Word8") [] [word8DataCon]
where
word64Ty = mkTyConTy word64TyCon
-word64TyCon = pcNonRecDataTyCon word64TyConKey pREL_CCALL SLIT("Word64") [] [word64DataCon]
-word64DataCon = pcDataCon word64DataConKey pREL_CCALL SLIT("W64#") [] [] [word64PrimTy] word64TyCon
+word64TyCon = pcNonRecDataTyCon word64TyConKey pREL_ADDR SLIT("Word64") [] [word64DataCon]
+word64DataCon = pcDataCon word64DataConKey pREL_ADDR SLIT("W64#") [] [] [word64PrimTy] word64TyCon
\end{code}
\begin{code}
isAddrTy :: GenType flexi -> Bool
isAddrTy ty
= case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> uniqueOf tycon == addrTyConKey
+ Just (tycon, [], _) -> getUnique tycon == addrTyConKey
_ -> False
\end{code}
isFloatTy :: GenType flexi -> Bool
isFloatTy ty
= case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> uniqueOf tycon == floatTyConKey
+ Just (tycon, [], _) -> getUnique tycon == floatTyConKey
_ -> False
\end{code}
isDoubleTy :: GenType flexi -> Bool
isDoubleTy ty
= case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> uniqueOf tycon == doubleTyConKey
+ Just (tycon, [], _) -> getUnique tycon == doubleTyConKey
_ -> False
doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon]
isIntegerTy :: GenType flexi -> Bool
isIntegerTy ty
= case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
+ Just (tycon, [], _) -> getUnique tycon == integerTyConKey
_ -> False
\end{code}
-And the other pairing types:
-\begin{code}
-return2GMPsTyCon = pcNonRecDataTyCon return2GMPsTyConKey
- pREL_NUM SLIT("Return2GMPs") [] [return2GMPsDataCon]
-
-return2GMPsDataCon
- = pcDataCon return2GMPsDataConKey pREL_NUM SLIT("Return2GMPs") [] []
- [intPrimTy, intPrimTy, byteArrayPrimTy,
- intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon
-
-returnIntAndGMPTyCon = pcNonRecDataTyCon returnIntAndGMPTyConKey
- pREL_NUM SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon]
-
-returnIntAndGMPDataCon
- = pcDataCon returnIntAndGMPDataConKey pREL_NUM SLIT("ReturnIntAndGMP") [] []
- [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TysWiredIn-state-pairing]{``State-pairing'' types}
-%* *
-%************************************************************************
-
-These boring types pair a \tr{State#} with another primitive type.
-They are not really primitive, so they are given here, not in
-\tr{TysPrim.lhs}.
-
-We fish one of these \tr{StateAnd<blah>#} things with
-@getStatePairingConInfo@ (given a little way down).
-
-\begin{code}
-stateAndPtrPrimTyCon
- = pcNonRecDataTyCon stateAndPtrPrimTyConKey pREL_ST SLIT("StateAndPtr#")
- alpha_beta_tyvars [stateAndPtrPrimDataCon]
-stateAndPtrPrimDataCon
- = pcDataCon stateAndPtrPrimDataConKey pREL_ST SLIT("StateAndPtr#")
- alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
- stateAndPtrPrimTyCon
-
-stateAndCharPrimTyCon
- = pcNonRecDataTyCon stateAndCharPrimTyConKey pREL_ST SLIT("StateAndChar#")
- alpha_tyvar [stateAndCharPrimDataCon]
-stateAndCharPrimDataCon
- = pcDataCon stateAndCharPrimDataConKey pREL_ST SLIT("StateAndChar#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy]
- stateAndCharPrimTyCon
-
-stateAndIntPrimTyCon
- = pcNonRecDataTyCon stateAndIntPrimTyConKey pREL_ST SLIT("StateAndInt#")
- alpha_tyvar [stateAndIntPrimDataCon]
-stateAndIntPrimDataCon
- = pcDataCon stateAndIntPrimDataConKey pREL_ST SLIT("StateAndInt#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy]
- stateAndIntPrimTyCon
-
-stateAndInt64PrimTyCon
- = pcNonRecDataTyCon stateAndInt64PrimTyConKey pREL_ST SLIT("StateAndInt64#")
- alpha_tyvar [stateAndInt64PrimDataCon]
-stateAndInt64PrimDataCon
- = pcDataCon stateAndInt64PrimDataConKey pREL_ST SLIT("StateAndInt64#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, int64PrimTy]
- stateAndInt64PrimTyCon
-
-stateAndWordPrimTyCon
- = pcNonRecDataTyCon stateAndWordPrimTyConKey pREL_ST SLIT("StateAndWord#")
- alpha_tyvar [stateAndWordPrimDataCon]
-stateAndWordPrimDataCon
- = pcDataCon stateAndWordPrimDataConKey pREL_ST SLIT("StateAndWord#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy]
- stateAndWordPrimTyCon
-
-stateAndWord64PrimTyCon
- = pcNonRecDataTyCon stateAndWord64PrimTyConKey pREL_ST SLIT("StateAndWord64#")
- alpha_tyvar [stateAndWord64PrimDataCon]
-stateAndWord64PrimDataCon
- = pcDataCon stateAndWord64PrimDataConKey pREL_ST SLIT("StateAndWord64#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, word64PrimTy]
- stateAndWord64PrimTyCon
-
-stateAndAddrPrimTyCon
- = pcNonRecDataTyCon stateAndAddrPrimTyConKey pREL_ST SLIT("StateAndAddr#")
- alpha_tyvar [stateAndAddrPrimDataCon]
-stateAndAddrPrimDataCon
- = pcDataCon stateAndAddrPrimDataConKey pREL_ST SLIT("StateAndAddr#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy]
- stateAndAddrPrimTyCon
-
-stateAndStablePtrPrimTyCon
- = pcNonRecDataTyCon stateAndStablePtrPrimTyConKey pREL_FOREIGN SLIT("StateAndStablePtr#")
- alpha_beta_tyvars [stateAndStablePtrPrimDataCon]
-stateAndStablePtrPrimDataCon
- = pcDataCon stateAndStablePtrPrimDataConKey pREL_FOREIGN SLIT("StateAndStablePtr#")
- alpha_beta_tyvars []
- [mkStatePrimTy alphaTy, mkTyConApp stablePtrPrimTyCon [betaTy]]
- stateAndStablePtrPrimTyCon
-
-stateAndForeignObjPrimTyCon
- = pcNonRecDataTyCon stateAndForeignObjPrimTyConKey pREL_IO_BASE SLIT("StateAndForeignObj#")
- alpha_tyvar [stateAndForeignObjPrimDataCon]
-stateAndForeignObjPrimDataCon
- = pcDataCon stateAndForeignObjPrimDataConKey pREL_IO_BASE SLIT("StateAndForeignObj#")
- alpha_tyvar []
- [mkStatePrimTy alphaTy, mkTyConTy foreignObjPrimTyCon]
- stateAndForeignObjPrimTyCon
-
-stateAndFloatPrimTyCon
- = pcNonRecDataTyCon stateAndFloatPrimTyConKey pREL_ST SLIT("StateAndFloat#")
- alpha_tyvar [stateAndFloatPrimDataCon]
-stateAndFloatPrimDataCon
- = pcDataCon stateAndFloatPrimDataConKey pREL_ST SLIT("StateAndFloat#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy]
- stateAndFloatPrimTyCon
-
-stateAndDoublePrimTyCon
- = pcNonRecDataTyCon stateAndDoublePrimTyConKey pREL_ST SLIT("StateAndDouble#")
- alpha_tyvar [stateAndDoublePrimDataCon]
-stateAndDoublePrimDataCon
- = pcDataCon stateAndDoublePrimDataConKey pREL_ST SLIT("StateAndDouble#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy]
- stateAndDoublePrimTyCon
-\end{code}
-
-\begin{code}
-stateAndArrayPrimTyCon
- = pcNonRecDataTyCon stateAndArrayPrimTyConKey pREL_ARR SLIT("StateAndArray#")
- alpha_beta_tyvars [stateAndArrayPrimDataCon]
-stateAndArrayPrimDataCon
- = pcDataCon stateAndArrayPrimDataConKey pREL_ARR SLIT("StateAndArray#")
- alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
- stateAndArrayPrimTyCon
-
-stateAndMutableArrayPrimTyCon
- = pcNonRecDataTyCon stateAndMutableArrayPrimTyConKey pREL_ARR SLIT("StateAndMutableArray#")
- alpha_beta_tyvars [stateAndMutableArrayPrimDataCon]
-stateAndMutableArrayPrimDataCon
- = pcDataCon stateAndMutableArrayPrimDataConKey pREL_ARR SLIT("StateAndMutableArray#")
- alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
- stateAndMutableArrayPrimTyCon
-
-stateAndByteArrayPrimTyCon
- = pcNonRecDataTyCon stateAndByteArrayPrimTyConKey pREL_ARR SLIT("StateAndByteArray#")
- alpha_tyvar [stateAndByteArrayPrimDataCon]
-stateAndByteArrayPrimDataCon
- = pcDataCon stateAndByteArrayPrimDataConKey pREL_ARR SLIT("StateAndByteArray#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
- stateAndByteArrayPrimTyCon
-
-stateAndMutableByteArrayPrimTyCon
- = pcNonRecDataTyCon stateAndMutableByteArrayPrimTyConKey pREL_ARR SLIT("StateAndMutableByteArray#")
- alpha_tyvar [stateAndMutableByteArrayPrimDataCon]
-stateAndMutableByteArrayPrimDataCon
- = pcDataCon stateAndMutableByteArrayPrimDataConKey pREL_ARR SLIT("StateAndMutableByteArray#")
- alpha_tyvar [] [mkStatePrimTy alphaTy, mkTyConApp mutableByteArrayPrimTyCon alpha_ty]
- stateAndMutableByteArrayPrimTyCon
-
-stateAndSynchVarPrimTyCon
- = pcNonRecDataTyCon stateAndSynchVarPrimTyConKey pREL_CONC SLIT("StateAndSynchVar#")
- alpha_beta_tyvars [stateAndSynchVarPrimDataCon]
-stateAndSynchVarPrimDataCon
- = pcDataCon stateAndSynchVarPrimDataConKey pREL_CONC SLIT("StateAndSynchVar#")
- alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
- stateAndSynchVarPrimTyCon
-\end{code}
-
-The ccall-desugaring mechanism uses this function to figure out how to
-rebox the result. It's really a HACK, especially the part about
-how many types to drop from \tr{tys_applied}.
-
-\begin{code}
-getStatePairingConInfo
- :: Type -- primitive type
- -> (Id, -- state pair constructor for prim type
- Type) -- type of state pair
-
-getStatePairingConInfo prim_ty
- = case (splitTyConApp_maybe prim_ty) of
- Nothing -> panic "getStatePairingConInfo:1"
- Just (prim_tycon, tys_applied) ->
- let
- (pair_con, pair_tycon, num_tys) = assoc "getStatePairingConInfo" tbl prim_tycon
- pair_ty = mkTyConApp pair_tycon (realWorldTy : drop num_tys tys_applied)
- in
- (pair_con, pair_ty)
- where
- tbl = [
- (charPrimTyCon, (stateAndCharPrimDataCon, stateAndCharPrimTyCon, 0)),
- (intPrimTyCon, (stateAndIntPrimDataCon, stateAndIntPrimTyCon, 0)),
- (wordPrimTyCon, (stateAndWordPrimDataCon, stateAndWordPrimTyCon, 0)),
- (int64PrimTyCon, (stateAndInt64PrimDataCon, stateAndInt64PrimTyCon, 0)),
- (word64PrimTyCon, (stateAndWord64PrimDataCon, stateAndWord64PrimTyCon, 0)),
- (addrPrimTyCon, (stateAndAddrPrimDataCon, stateAndAddrPrimTyCon, 0)),
- (stablePtrPrimTyCon, (stateAndStablePtrPrimDataCon, stateAndStablePtrPrimTyCon, 0)),
- (foreignObjPrimTyCon, (stateAndForeignObjPrimDataCon, stateAndForeignObjPrimTyCon, 0)),
- (floatPrimTyCon, (stateAndFloatPrimDataCon, stateAndFloatPrimTyCon, 0)),
- (doublePrimTyCon, (stateAndDoublePrimDataCon, stateAndDoublePrimTyCon, 0)),
- (arrayPrimTyCon, (stateAndArrayPrimDataCon, stateAndArrayPrimTyCon, 0)),
- (mutableArrayPrimTyCon, (stateAndMutableArrayPrimDataCon, stateAndMutableArrayPrimTyCon, 1)),
- (byteArrayPrimTyCon, (stateAndByteArrayPrimDataCon, stateAndByteArrayPrimTyCon, 0)),
- (mutableByteArrayPrimTyCon, (stateAndMutableByteArrayPrimDataCon, stateAndMutableByteArrayPrimTyCon, 1)),
- (synchVarPrimTyCon, (stateAndSynchVarPrimDataCon, stateAndSynchVarPrimTyCon, 1))
- -- (PtrPrimTyCon, (stateAndPtrPrimDataCon, stateAndPtrPrimTyCon, 0)),
- ]
-\end{code}
-
%************************************************************************
%* *
\begin{code}
isFFIArgumentTy :: Type -> Bool
isFFIArgumentTy ty =
- (opt_GlasgowExts && isUnpointedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
+ (opt_GlasgowExts && isUnLiftedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
case (splitAlgTyConApp_maybe ty) of
- Just (tycon, _, _) -> (uniqueOf tycon) `elem` primArgTyConKeys
+ Just (tycon, _, _) -> (getUnique tycon) `elem` primArgTyConKeys
_ -> False
-- types that can be passed as arguments to "foreign" functions
-- excludes (mutable) byteArrays.
isFFIExternalTy :: Type -> Bool
isFFIExternalTy ty =
- (opt_GlasgowExts && isUnpointedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
+ (opt_GlasgowExts && isUnLiftedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
case (splitAlgTyConApp_maybe ty) of
Just (tycon, _, _) ->
let
- u_tycon = uniqueOf tycon
+ u_tycon = getUnique tycon
in
(u_tycon `elem` primArgTyConKeys) &&
not (u_tycon `elem` notLegalExternalTyCons)
isFFIResultTy :: Type -> Bool
isFFIResultTy ty =
- not (isUnpointedType ty) &&
+ not (isUnLiftedType ty) &&
case (splitAlgTyConApp_maybe ty) of
Just (tycon, _, _) ->
let
- u_tycon = uniqueOf tycon
+ u_tycon = getUnique tycon
in
- (u_tycon == uniqueOf unitTyCon) ||
+ (u_tycon == getUnique unitTyCon) ||
((u_tycon `elem` primArgTyConKeys) &&
not (u_tycon `elem` notLegalExternalTyCons))
_ -> False
\end{code}
-
-%************************************************************************
-%* *
-\subsection[TysWiredIn-ST]{The basic @_ST@ state-transformer type}
-%* *
-%************************************************************************
-
-The only reason this is wired in is because we have to represent the
-type of runST.
-
-\begin{code}
-mkStateTransformerTy s a = mkTyConApp stTyCon [s, a]
-
-stTyCon = pcNonRecNewTyCon stTyConKey pREL_ST SLIT("ST") alpha_beta_tyvars [stDataCon]
-
-stDataCon = pcDataCon stDataConKey pREL_ST SLIT("ST")
- alpha_beta_tyvars [] [ty] stTyCon
- where
- ty = mkFunTy (mkStatePrimTy alphaTy) (mkSTretTy alphaTy betaTy)
-
-mkSTretTy alpha beta = mkTyConApp stRetTyCon [alpha,beta]
-
-stRetTyCon
- = pcNonRecDataTyCon stRetTyConKey pREL_ST SLIT("STret")
- alpha_beta_tyvars [stRetDataCon]
-stRetDataCon
- = pcDataCon stRetDataConKey pREL_ST SLIT("STret")
- alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
- stRetTyCon
-\end{code}
-
%************************************************************************
%* *
\subsection[TysWiredIn-Bool]{The @Bool@ type}
\begin{code}
boolTy = mkTyConTy boolTyCon
-boolTyCon = pcNonRecDataTyCon boolTyConKey pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon]
+boolTyCon = pcTyCon EnumType NonRecursive boolTyConKey
+ pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon]
falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon
trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon
\begin{code}
mkTupleTy :: Int -> [GenType t] -> GenType t
-
mkTupleTy arity tys = mkTyConApp (tupleTyCon arity) tys
-unitTy = mkTupleTy 0 []
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TysWiredIn-_Lift]{@_Lift@ type: to support array indexing}
-%* *
-%************************************************************************
-
-Again, deeply turgid: \tr{data _Lift a = _Lift a}.
+mkUnboxedTupleTy :: Int -> [GenType t] -> GenType t
+mkUnboxedTupleTy arity tys = mkTyConApp (unboxedTupleTyCon arity) tys
-\begin{code}
-mkLiftTy ty = mkTyConApp liftTyCon [ty]
-
-{-
-mkLiftTy ty
- = mkSigmaTy tvs theta (mkTyConApp liftTyCon [tau])
- where
- (tvs, theta, tau) = splitSigmaTy ty
-
-isLiftTy ty
- = case (splitAlgTyConApp_maybeExpandingDicts tau) of
- Just (tycon, tys, _) -> tycon == liftTyCon
- Nothing -> False
- where
- (tvs, theta, tau) = splitSigmaTy ty
--}
-
-
-alphaLiftTy = mkSigmaTy alpha_tyvar [] (mkTyConApp liftTyCon alpha_ty)
-
-liftTyCon
- = pcNonRecDataTyCon liftTyConKey pREL_BASE SLIT("Lift") alpha_tyvar [liftDataCon]
-
-liftDataCon
- = pcDataCon liftDataConKey pREL_BASE SLIT("Lift")
- alpha_tyvar [] alpha_ty liftTyCon
- where
- bottom = panic "liftDataCon:State# _RealWorld"
+unitTy = mkTupleTy 0 []
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CostCentre]{The @CostCentre@ data type}
\begin{code}
module CostCentre (
CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
- noCostCentre, subsumedCosts,
- useCurrentCostCentre,
- noCostCentreAttached, costsAreSubsumed, isCurrentCostCentre,
- currentOrSubsumedCosts,
- preludeCafsCostCentre, preludeDictsCostCentre,
- overheadCostCentre, dontCareCostCentre,
+ CostCentreStack,
+ noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
+ noCostCentre, noCCAttached,
+ noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
- cafifyCC, dupifyCC,
- isCafCC, isDictCC, isDupdCC,
+ mkSingletonCCS, cafifyCC, dupifyCC,
+ isCafCC, isDictCC, isDupdCC, isEmptyCC, isCafCCS,
isSccCountCostCentre,
sccAbleCostCentre,
ccFromThisModule,
ccMentionsId,
- uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
+ pprCostCentreDecl, pprCostCentreStackDecl,
cmpCostCentre -- used for removing dups in a list
) where
#include "HsVersions.h"
-import Id ( externallyVisibleId, GenId, Id )
+import Var ( externallyVisibleId, GenId, Id )
import CStrings ( identToC, stringToC )
-import Name ( OccName, getOccString, moduleString )
+import Name ( getOccString )
import Outputable
-import Util ( panic, panic#, assertPanic, thenCmp )
+import BasicTypes ( moduleString )
+import Util ( panic, assertPanic, thenCmp )
+\end{code}
+
+A Cost Centre Stack is something that can be attached to a closure.
+This is either:
+
+ - the current cost centre stack (CCCS)
+ - a pre-defined cost centre stack (there are several
+ pre-defined CCSs, see below).
+
+\begin{code}
+data CostCentreStack
+ = NoCCS
+
+ | CurrentCCS -- Pinned on a let(rec)-bound
+ -- thunk/function/constructor, this says that the
+ -- cost centre to be attached to the object, when it
+ -- is allocated, is whatever is in the
+ -- current-cost-centre-stack register.
+
+ | SubsumedCCS -- Cost centre stack for top-level subsumed functions
+ -- (CAFs get an AllCafsCC).
+ -- Its execution costs get subsumed into the caller.
+ -- This guy is *only* ever pinned on static closures,
+ -- and is *never* the cost centre for an SCC construct.
+
+ | OverheadCCS -- We charge costs due to the profiling-system
+ -- doing its work to "overhead".
+ --
+ -- Objects whose CCS is "Overhead"
+ -- have their *allocation* charged to "overhead",
+ -- but have the current CCS put into the object
+ -- itself.
+
+ -- For example, if we transform "f g" to "let
+ -- g' = g in f g'" (so that something about
+ -- profiling works better...), then we charge
+ -- the *allocation* of g' to OverheadCCS, but
+ -- we put the cost-centre of the call to f
+ -- (i.e., current CCS) into the g' object. When
+ -- g' is entered, the CCS of the call
+ -- to f will be set.
+ | DontCareCCS -- We need a CCS to stick in static closures
+ -- (for data), but we *don't* expect them to
+ -- accumulate any costs. But we still need
+ -- the placeholder. This CCS is it.
+
+ | SingletonCCS CostCentre
+ -- This is primarily for CAF cost centres, which
+ -- are attached to top-level thunks right at the
+ -- end of STG processing, before code generation.
+ -- Hence, a CAF cost centre never appears as the
+ -- argument of an _scc_.
+ -- Also, we generate these singleton CCSs statically
+ -- as part of code generation.
+
+ deriving (Eq, Ord) -- needed for Ord on CLabel
\end{code}
+A Cost Centre is the argument of an _scc_ expression.
+
\begin{code}
data CostCentre
= NoCostCentre -- Having this constructor avoids having
IsDupdCC -- see below
IsCafCC -- see below
- | CurrentCC -- Pinned on a let(rec)-bound thunk/function/constructor,
- -- this says that the cost centre to be attached to
- -- the object, when it is allocated, is whatever is in the
- -- current-cost-centre register.
- -- This guy is *never* the cost centre for an SCC construct,
- -- and is only used for *local* (non-top-level) definitions.
-
- | SubsumedCosts -- Cost centre for top-level subsumed functions
- -- (CAFs get an AllCafsCC).
- -- Its execution costs get subsumed into the caller.
- -- This guy is *only* ever pinned on static closures,
- -- and is *never* the cost centre for an SCC construct.
-
| AllCafsCC FAST_STRING -- Ditto for CAFs.
FAST_STRING -- We record module and group names.
-- Again, one "big" CAF cc per module, where all
-- per-individual-DICT cost attribution.
IsDupdCC -- see below
- | OverheadCC -- We charge costs due to the profiling-system
- -- doing its work to "overhead".
- --
- -- Objects whose cost-centre is "Overhead"
- -- have their *allocation* charged to "overhead",
- -- but have the current CC put into the object
- -- itself.
- --
- -- For example, if we transform "f g" to "let
- -- g' = g in f g'" (so that something about
- -- profiling works better...), then we charge
- -- the *allocation* of g' to OverheadCC, but
- -- we put the cost-centre of the call to f
- -- (i.e., current CC) into the g' object. When
- -- g' is entered, the cost-centre of the call
- -- to f will be set.
-
- | PreludeCafsCC -- In compiling the prelude, we do sometimes
- | PreludeDictsCC -- need a CC to blame; i.e., when there's a CAF,
- -- or other costs that really shouldn't be
- -- subsumed/blamed-on-the-caller. These costs
- -- should be *small*. We treat PreludeCafsCC
- -- as if it were shorthand for
- -- (AllCafsCC <PreludeSomething> _). Analogously
- -- for PreludeDictsCC...
- IsDupdCC -- see below/above
-
- | DontCareCC -- We need a cost-centre to stick in static closures
- -- (for data), but we *don't* expect them to
- -- accumulate any costs. But we still need
- -- the placeholder. This CC is it.
-
data CcKind
= UserCC FAST_STRING -- Supplied by user: String is the cc name
| AutoCC Id -- CC -auto-magically inserted for that Id
| ADupdCC -- it is ADupdCC doesn't make it a different
-- CC, just that it a sub-expression which has
-- been moved ("dupd") into a different scope.
+ --
+ -- The point about a dupd SCC is that we don't
+ -- count entries to it, because it's not the
+ -- "original" one.
+ --
-- In the papers, it's called "SCCsub",
-- i.e. SCCsub CC == SCC ADupdCC,
-- but we are trying to avoid confusion between
SIMON: Maybe later...
\begin{code}
-noCostCentre = NoCostCentre
-subsumedCosts = SubsumedCosts
-useCurrentCostCentre = CurrentCC
-overheadCostCentre = OverheadCC
-preludeCafsCostCentre = PreludeCafsCC
-dontCareCostCentre = DontCareCC
-preludeDictsCostCentre is_dupd
- = PreludeDictsCC (if is_dupd then ADupdCC else AnOriginalCC)
-noCostCentreAttached NoCostCentre = True
-noCostCentreAttached _ = False
+noCCS = NoCCS
+subsumedCCS = SubsumedCCS
+currentCCS = CurrentCCS
+overheadCCS = OverheadCCS
+dontCareCCS = DontCareCCS
+
+noCostCentre = NoCostCentre
+\end{code}
+
+Predicates on Cost-Centre Stacks
+
+\begin{code}
+noCCSAttached NoCCS = True
+noCCSAttached _ = False
+
+noCCAttached NoCostCentre = True
+noCCAttached _ = False
+
+isCurrentCCS CurrentCCS = True
+isCurrentCCS _ = False
+
+isSubsumedCCS SubsumedCCS = True
+isSubsumedCCS _ = False
-isCurrentCostCentre CurrentCC = True
-isCurrentCostCentre _ = False
+isCafCCS (SingletonCCS cc) = isCafCC cc
+isCafCCS _ = False
-costsAreSubsumed SubsumedCosts = True
-costsAreSubsumed _ = False
+isDictCCS (SingletonCCS cc) = isDictCC cc
+isDictCCS _ = False
+
+currentOrSubsumedCCS SubsumedCCS = True
+currentOrSubsumedCCS CurrentCCS = True
+currentOrSubsumedCCS _ = False
+\end{code}
-currentOrSubsumedCosts SubsumedCosts = True
-currentOrSubsumedCosts CurrentCC = True
-currentOrSubsumedCosts _ = False
+Building cost centres
+\begin{code}
mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
mkUserCC cc_name module_name group_name
mkAllDictsCC m g is_dupd
= AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
+mkSingletonCCS :: CostCentre -> CostCentreStack
+mkSingletonCCS cc = SingletonCCS cc
+
cafifyCC, dupifyCC :: CostCentre -> CostCentre
cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ???
-cafifyCC cc@(PreludeDictsCC _) = cc -- ditto
cafifyCC (NormalCC kind m g is_dupd is_caf)
= ASSERT(not_a_calf_already is_caf)
NormalCC kind m g is_dupd IsCafCC
where
not_a_calf_already IsCafCC = False
not_a_calf_already _ = True
-cafifyCC cc = panic ("cafifyCC"++(showCostCentre False cc))
+cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
-dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC
dupifyCC (NormalCC kind m g is_dupd is_caf)
= NormalCC kind m g ADupdCC is_caf
-dupifyCC cc = panic ("dupifyCC"++(showCostCentre False cc))
+dupifyCC cc = pprPanic "dupifyCC" (ppr cc)
+
+isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
-isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
+isEmptyCC (NoCostCentre) = True
+isEmptyCC _ = False
isCafCC (AllCafsCC _ _) = True
-isCafCC PreludeCafsCC = True
isCafCC (NormalCC _ _ _ _ IsCafCC) = True
isCafCC _ = False
isDictCC (AllDictsCC _ _ _) = True
-isDictCC (PreludeDictsCC _) = True
isDictCC (NormalCC (DictCC _) _ _ _ _) = True
isDictCC _ = False
isDupdCC (AllDictsCC _ _ ADupdCC) = True
-isDupdCC (PreludeDictsCC ADupdCC) = True
isDupdCC (NormalCC _ _ _ ADupdCC _) = True
isDupdCC _ = False
#if DEBUG
isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
-isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts"
-isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC"
-isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC"
#endif
-isSccCountCostCentre OverheadCC = False
isSccCountCostCentre cc | isCafCC cc = False
| isDupdCC cc = False
| isDictCC cc = True
#if DEBUG
sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
-sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts"
-sccAbleCostCentre CurrentCC = panic "sccAbleCC:CurrentCC"
-sccAbleCostCentre DontCareCC = panic "sccAbleCC:DontCareCC"
#endif
-sccAbleCostCentre OverheadCC = False
sccAbleCostCentre cc | isCafCC cc = False
| otherwise = True
ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name
ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name
ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name
-ccFromThisModule PreludeCafsCC _ = False
-ccFromThisModule (PreludeDictsCC _) _ = False
-ccFromThisModule OverheadCC _ = False
-ccFromThisModule DontCareCC _ = False
- -- shouldn't ask about any others!
\end{code}
\begin{code}
\end{code}
\begin{code}
+instance Eq CostCentre where
+ c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
+
+instance Ord CostCentre where
+ compare = cmpCostCentre
+
cmpCostCentre :: CostCentre -> CostCentre -> Ordering
cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = m1 `compare` m2
cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2
-cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ
-cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ
-cmpCostCentre OverheadCC OverheadCC = EQ
-cmpCostCentre DontCareCC DontCareCC = EQ
cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2)
-- first key is module name, then we use "kinds" (which include
tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT)
tag_CC (AllCafsCC _ _) = ILIT(2)
tag_CC (AllDictsCC _ _ _) = ILIT(3)
- tag_CC PreludeCafsCC = ILIT(4)
- tag_CC (PreludeDictsCC _) = ILIT(5)
- tag_CC OverheadCC = ILIT(6)
- tag_CC DontCareCC = ILIT(7)
-
- -- some BUG avoidance here...
- tag_CC NoCostCentre = panic# "tag_CC:NoCostCentre"
- tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts"
- tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts"
-
cmp_kind (UserCC n1) (UserCC n2) = n1 `compare` n2
cmp_kind (AutoCC i1) (AutoCC i2) = i1 `compare` i2
cmp_caf IsCafCC IsNotCafCC = GT
\end{code}
-\begin{code}
-showCostCentre :: Bool -> CostCentre -> String
-uppCostCentre :: Bool -> CostCentre -> SDoc
-uppCostCentreDecl :: Bool -> CostCentre -> SDoc
-
-{- PprUnfolding is gone now
-showCostCentre PprUnfolding print_as_string cc
- = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
- ASSERT(not (noCostCentreAttached cc))
- ASSERT(not (currentOrSubsumedCosts cc))
- uppShow 80 (upp_cc_uf cc)
--}
-
-showCostCentre print_as_string cc
- = showSDoc (uppCostCentre print_as_string cc)
-
-uppCostCentre print_as_string NoCostCentre
- | print_as_string = text "\"NO_CC\""
- | otherwise = ptext SLIT("NO_CC")
-
-uppCostCentre print_as_string SubsumedCosts
- | print_as_string = text "\"SUBSUMED\""
- | otherwise = ptext SLIT("CC_SUBSUMED")
-
-uppCostCentre print_as_string CurrentCC
- | print_as_string = text "\"CURRENT_CC\""
- | otherwise = ptext SLIT("CCC")
-
-uppCostCentre print_as_string OverheadCC
- | print_as_string = text "\"OVERHEAD\""
- | otherwise = ptext SLIT("CC_OVERHEAD")
-
-uppCostCentre print_as_string cc
- = getPprStyle $ \ sty ->
- let
- prefix_CC = ptext SLIT("CC_")
- basic_thing = do_cc sty cc
- basic_thing_string = stringToC basic_thing
- in
- if print_as_string then
- hcat [char '"', text basic_thing_string, char '"']
+-----------------------------------------------------------------------------
+Printing Cost Centre Stacks.
- else if (friendly_sty sty) then
- text basic_thing
- else
- hcat [prefix_CC, identToC (_PK_ basic_thing)]
- where
- friendly_sty sty = userStyle sty || debugStyle sty -- i.e. probably for human consumption
-
- do_cc sty DontCareCC = "DONT_CARE"
- do_cc sty (AllCafsCC m _) = if print_as_string
- then "CAFs_in_..."
- else "CAFs." ++ _UNPK_ m
- do_cc sty (AllDictsCC m _ d) = do_dupd sty d (
- if print_as_string
- then "DICTs_in_..."
- else "DICTs." ++ _UNPK_ m)
- do_cc sty PreludeCafsCC = if print_as_string
- then "CAFs_in_..."
- else "CAFs"
- do_cc sty (PreludeDictsCC d) = do_dupd sty d (
- if print_as_string
- then "DICTs_in_..."
- else "DICTs")
-
- do_cc sty (NormalCC kind mod_name grp_name is_dupd is_caf)
- = let
- basic_kind = do_kind kind
- module_kind = do_caf is_caf (moduleString mod_name ++ '/':
- basic_kind)
- grp_str = []
- {- TODO: re-instate this once interface file lexer
- handles groups.
- grp_str =
- if (_NULL_ grp_name) then
- []
- else
- '/' : (_UNPK_ grp_name)
- -}
- full_kind = do_caf is_caf
- (moduleString mod_name ++
- grp_str ++ ('/' : basic_kind))
- in
- if (friendly_sty sty) then
- do_dupd sty is_dupd full_kind
- else if codeStyle sty && print_as_string then
- {-
- drop the module name when printing
- out SCC label in CC declaration
- -}
- basic_kind
- else
- module_kind
- where
- do_caf IsCafCC ls = "CAF:" ++ ls
- do_caf _ ls = ls
-
- do_kind (UserCC name) = _UNPK_ name
- do_kind (AutoCC id) = do_id id ++ (if (debugStyle sty) then "/AUTO" else "")
- do_kind (DictCC id) = do_id id ++ (if (debugStyle sty) then "/DICT" else "")
-
- {-
- do_id is only applied in a (not print_as_string) context for local ids,
- hence using the occurrence name is enough.
- -}
- do_id :: Id -> String
- do_id id = getOccString id
-
- ---------------
- do_dupd sty ADupdCC str = if (debugStyle sty) then str ++ "/DUPD" else str
- do_dupd _ _ str = str
-\end{code}
+There are two ways to print a CCS:
+
+ - for debugging output (i.e. -ddump-whatever),
+ - as a C label
-Printing unfoldings is sufficiently weird that we do it separately.
-This should only apply to CostCentres that can be ``set to'' (cf
-@sccAbleCostCentre@). That excludes CAFs and
-`overhead'---which are added at the very end---but includes dictionaries.
-Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
-even if we won't ultimately do a \tr{SET_CCC} from it.
\begin{code}
-{- UNUSED
-upp_cc_uf (PreludeDictsCC d)
- = hsep [ptext SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
-upp_cc_uf (AllDictsCC m g d)
- = hsep [ptext SLIT("_ALL_DICTS_CC_"),
- char '"',ptext m,char '"',
- char '"',ptext g,char '"',
- upp_dupd d]
-
-upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
- = ASSERT(sccAbleCostCentre cc)
- hsep [pp_kind cc_kind,
- char '"', ptext m, char '"',
- char '"', ptext g, char '"',
- upp_dupd is_dupd, pp_caf is_caf]
- where
- pp_kind (UserCC name) = hcat [ptext SLIT("_USER_CC_ "), char '"', ptext name, char '"']
- pp_kind (AutoCC id) = (<>) (ptext SLIT("_AUTO_CC_ ")) (show_id id)
- pp_kind (DictCC id) = (<>) (ptext SLIT("_DICT_CC_ ")) (show_id id)
+instance Outputable CostCentreStack where
+ ppr ccs = case ccs of
+ NoCCS -> ptext SLIT("NO_CCS")
+ CurrentCCS -> ptext SLIT("CCCS")
+ OverheadCCS -> ptext SLIT("CCS_OVERHEAD")
+ DontCareCCS -> ptext SLIT("CCS_DONTZuCARE")
+ SubsumedCCS -> ptext SLIT("CCS_SUBSUMED")
+ SingletonCCS cc ->
+ getPprStyle $ \sty ->
+ if (codeStyle sty)
+ then ptext SLIT("CCS_") <>
+ identToC (_PK_ (costCentreStr cc))
+ else ptext SLIT("CCS.") <> text (costCentreStr cc)
+
+pprCostCentreStackDecl :: CostCentreStack -> SDoc
+
+pprCostCentreStackDecl ccs@(SingletonCCS cc)
+ = let
+ (mod_name, grp_name, is_subsumed, externally_visible) = get_cc_info cc
+ in
+ hcat [ ptext SLIT("CCS_DECLARE"), char '(',
+ ppr ccs, comma, -- better be codeStyle
+ ppCostCentreLbl cc, comma,
+ ptext is_subsumed, comma,
+ if externally_visible
+ then empty
+ else ptext SLIT("static"),
+ text ");"
+ ]
+
+pprCostCentreStackDecl ccs
+ = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
+\end{code}
- show_id id = pprIdInUnfolding {-no_in_scopes-} id
+-----------------------------------------------------------------------------
+Printing Cost Centres.
- pp_caf IsCafCC = ptext SLIT("_CAF_CC_")
- pp_caf IsNotCafCC = ptext SLIT("_N_")
+There are several different ways in which we might want to print a
+cost centre:
-#ifdef DEBUG
-upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre True other))
-#endif
+ - the name of the cost centre, for profiling output (a C string)
+ - the label, i.e. C label for cost centre in .hc file.
+ - the debugging name, for output in -ddump things
+ - the interface name, for printing in _scc_ exprs in iface files.
-pprIdInUnfolding = panic "Whoops"
+The last 3 are derived from costCentreStr below. The first is given
+by costCentreName.
-upp_dupd AnOriginalCC = ptext SLIT("_N_")
-upp_dupd ADupdCC = ptext SLIT("_D_")
--}
+\begin{code}
+instance Outputable CostCentre where
+ ppr cc = getPprStyle $ \ sty ->
+ if codeStyle sty
+ then ppCostCentreLbl cc
+ else
+ if ifaceStyle sty
+ then ppCostCentreIface cc
+ else text (costCentreStr cc)
+
+ppCostCentreLbl cc = ptext SLIT("CC_") <> identToC (_PK_ (costCentreStr cc))
+ppCostCentreIface cc = doubleQuotes (text (costCentreStr cc))
+ppCostCentreName cc = doubleQuotes (text (stringToC (costCentreName cc)))
+
+costCentreStr (NoCostCentre) = "NO_CC"
+costCentreStr (AllCafsCC m _) = "CAFs." ++ _UNPK_ m
+costCentreStr (AllDictsCC m _ d) = "DICTs." ++ _UNPK_ m
+costCentreStr (NormalCC kind mod_name grp_name is_dupd is_caf)
+ = case is_caf of { IsCafCC -> "CAF:"; _ -> "" }
+ ++ moduleString mod_name
+ ++ case kind of { UserCC name -> _UNPK_ name;
+ AutoCC id -> getOccString id ++ "/AUTO";
+ DictCC id -> getOccString id ++ "/DICT"
+ }
+ -- ToDo: group name
+ ++ case is_dupd of { ADupdCC -> "/DUPD"; _ -> "" }
+
+-- This is the name to go in the cost centre declaration
+costCentreName (NoCostCentre) = "NO_CC"
+costCentreName (AllCafsCC _ _) = "CAFs_in_..."
+costCentreName (AllDictsCC _ _ _) = "DICTs_in_..."
+costCentreName (NormalCC kind mod_name grp_name is_dupd is_caf)
+ = case is_caf of { IsCafCC -> "CAF:"; _ -> "" }
+ ++ case kind of { UserCC name -> _UNPK_ name;
+ AutoCC id -> getOccString id;
+ DictCC id -> getOccString id
+ }
\end{code}
+Cost Centre Declarations
+
\begin{code}
-uppCostCentreDecl is_local cc
#ifdef DEBUG
- | noCostCentreAttached cc || currentOrSubsumedCosts cc
- = panic "uppCostCentreDecl: no cost centre!"
- | otherwise
+pprCostCentreDecl is_local (NoCostCentre)
+ = panic "pprCostCentreDecl: no cost centre!"
#endif
+pprCostCentreDecl is_local cc
= if is_local then
hcat [
ptext SLIT("CC_DECLARE"),char '(',
- upp_ident, comma,
- uppCostCentre True {-as String!-} cc, comma,
- pp_str mod_name, comma,
- pp_str grp_name, comma,
- text is_subsumed, comma,
- if externally_visible {- || all_toplev_ids_visible -}
- -- all_toplev stuff removed SLPJ Sept 97;
- -- not sure this is right.
+ cc_ident, comma,
+ ppCostCentreName cc, comma,
+ pp_str mod_name, comma,
+ pp_str grp_name, comma,
+ ptext is_subsumed, comma,
+ if externally_visible
then empty
else ptext SLIT("static"),
text ");"]
else
- hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ]
+ hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
where
- upp_ident = uppCostCentre False{-as identifier!-} cc
+ cc_ident = ppCostCentreLbl cc
pp_str s = doubleQuotes (ptext s)
(mod_name, grp_name, is_subsumed, externally_visible)
- = case cc of
+ = get_cc_info cc
+
+
+get_cc_info :: CostCentre ->
+ (FAST_STRING, -- module name
+ FAST_STRING, -- group name
+ FAST_STRING, -- subsumed value
+ Bool) -- externally visible
+
+get_cc_info cc
+ = case cc of
AllCafsCC m g -> (m, g, cc_IS_CAF, True)
AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
-> (m, g, do_caf is_caf,
case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i})
where
- cc_IS_CAF = "CC_IS_CAF"
- cc_IS_DICT = "CC_IS_DICT"
- cc_IS_BORING = "CC_IS_BORING"
+ cc_IS_CAF = SLIT("CC_IS_CAF")
+ cc_IS_DICT = SLIT("CC_IS_DICT")
+ cc_IS_BORING = SLIT("CC_IS_BORING")
do_caf IsCafCC = cc_IS_CAF
do_caf IsNotCafCC = cc_IS_BORING
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SCCfinal]{Modify and collect code generation for final STG program}
import CmdLineOpts ( opt_AutoSccsOnIndividualCafs )
import CostCentre -- lots of things
-import MkId ( mkSysLocal )
-import Id ( idType, emptyIdSet, Id )
-import SrcLoc ( noSrcLoc )
-import Type ( splitSigmaTy, splitFunTy_maybe )
-import UniqSupply ( getUnique, splitUniqSupply, UniqSupply )
+import Const ( Con(..) )
+import Id ( Id, mkSysLocal )
+import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
import Unique ( Unique )
import Util ( removeDups, assertPanic, trace )
import Outputable
\begin{code}
type CollectedCCs = ([CostCentre], -- locally defined ones
- [CostCentre]) -- ones needing "extern" decls
+ [CostCentre], -- ones needing "extern" decls
+ [CostCentreStack]) -- singleton stacks (for CAFs)
stgMassageForProfiling
:: FAST_STRING -> FAST_STRING -- module name, group name
stgMassageForProfiling mod_name grp_name us stg_binds
= let
- ((local_ccs, extern_ccs),
+ ((local_ccs, extern_ccs, cc_stacks),
stg_binds2)
= initMM mod_name us (mapMM do_top_binding stg_binds)
- fixed_ccs
- = if do_auto_sccs_on_cafs
- then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
- else [all_cafs_cc]
+ (fixed_ccs, fixed_cc_stacks)
+ = if opt_AutoSccsOnIndividualCafs
+ then ([],[]) -- don't need "all CAFs" CC
+ -- (for Prelude, we use PreludeCC)
+ else ([all_cafs_cc], [all_cafs_ccs])
local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs)
extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
in
- ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
+ ((fixed_ccs ++ local_ccs_no_dups,
+ extern_ccs_no_dups,
+ fixed_cc_stacks ++ cc_stacks), stg_binds2)
where
- do_auto_sccs_on_cafs = opt_AutoSccsOnIndividualCafs -- only use!
- all_cafs_cc = mkAllCafsCC mod_name grp_name
+ all_cafs_cc = mkAllCafsCC mod_name grp_name
+ all_cafs_ccs = mkSingletonCCS all_cafs_cc
----------
do_top_binding :: StgBinding -> MassageM StgBinding
----------
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
- do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
+ do_top_rhs binder (StgRhsClosure _ bi srt fv u [] (StgSCC cc (StgCon (DataCon con) args _)))
| not (isSccCountCostCentre cc)
-- Trivial _scc_ around nothing but static data
-- Eliminate _scc_ ... and turn into StgRhsCon
- = returnMM (StgRhsCon dontCareCostCentre con args)
+ = returnMM (StgRhsCon dontCareCCS con args)
- do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
- | (noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc)
+{- Can't do this one with cost-centre stacks: --SDM
+ do_top_rhs binder (StgRhsClosure no_cc bi srt fv u [] (StgSCC ty cc expr))
+ | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc)
&& not (isSccCountCostCentre cc)
-- Top level CAF without a cost centre attached
-- Attach and collect cc of trivial _scc_ in body
= collectCC cc `thenMM_`
set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' ->
- returnMM (StgRhsClosure cc bi fv u [] expr')
+ returnMM (StgRhsClosure cc bi srt fv u [] expr')
+-}
- do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body)
- | noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc
+ do_top_rhs binder (StgRhsClosure no_cc bi srt fv u [] body)
+ | noCCSAttached no_cc || currentOrSubsumedCCS no_cc
-- Top level CAF without a cost centre attached
-- Attach CAF cc (collect if individual CAF ccs)
- = let
- (collect, caf_cc)
- = if do_auto_sccs_on_cafs then
- (True, mkAutoCC binder mod_name grp_name IsCafCC)
- else
- (False, all_cafs_cc)
- in
- (if collect then collectCC caf_cc else nopMM) `thenMM_`
- set_prevailing_cc caf_cc (do_expr body) `thenMM` \ body' ->
- returnMM (StgRhsClosure caf_cc bi fv u [] body')
-
- do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
+ = (if opt_AutoSccsOnIndividualCafs
+ then let cc = mkAutoCC binder mod_name grp_name IsCafCC
+ ccs = mkSingletonCCS cc
+ in
+ collectCC cc `thenMM_`
+ collectCCS ccs `thenMM_`
+ returnMM ccs
+ else
+ returnMM all_cafs_ccs) `thenMM` \ caf_ccs ->
+ set_prevailing_cc caf_ccs (do_expr body) `thenMM` \ body' ->
+ returnMM (StgRhsClosure caf_ccs bi srt fv u [] body')
+
+ do_top_rhs binder (StgRhsClosure cc bi srt fv u [] body)
-- Top level CAF with cost centre attached
-- Should this be a CAF cc ??? Does this ever occur ???
- = trace ("SCCfinal: CAF with cc: " ++ showCostCentre False cc) $
- collectCC cc `thenMM_`
- set_prevailing_cc cc (do_expr body) `thenMM` \ body' ->
- returnMM (StgRhsClosure cc bi fv u [] body')
+ = pprPanic "SCCfinal: CAF with cc:" (ppr cc)
- do_top_rhs binder (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
+{- can't do this with cost-centre stacks: --SDM
+ do_top_rhs binder (StgRhsClosure _ bi srt fv u args (StgSCC cc expr))
| not (isSccCountCostCentre cc)
-- Top level function with trivial _scc_ in body
-- Attach and collect cc of trivial _scc_
= collectCC cc `thenMM_`
set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' ->
- returnMM (StgRhsClosure cc bi fv u args expr')
+ returnMM (StgRhsClosure cc bi srt fv u args expr')
+-}
- do_top_rhs binder (StgRhsClosure cc bi fv u args body)
+ do_top_rhs binder (StgRhsClosure no_ccs bi srt fv u args body)
-- Top level function, probably subsumed
- = let
- (cc_closure, cc_body)
- = if noCostCentreAttached cc
- then (subsumedCosts, useCurrentCostCentre)
- else (cc, cc)
- in
- set_prevailing_cc cc_body (do_expr body) `thenMM` \ body' ->
- returnMM (StgRhsClosure cc_closure bi fv u args body')
+ | noCCSAttached no_ccs
+ = set_prevailing_cc currentCCS (do_expr body) `thenMM` \ body' ->
+ returnMM (StgRhsClosure subsumedCCS bi srt fv u args body')
- do_top_rhs binder (StgRhsCon cc con args)
+ | otherwise
+ = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
+
+ do_top_rhs binder (StgRhsCon ccs con args)
-- Top-level (static) data is not counted in heap
- -- profiles; nor do we set CCC from it; so we
+ -- profiles; nor do we set CCCS from it; so we
-- just slam in dontCareCostCentre
- = returnMM (StgRhsCon dontCareCostCentre con args)
+ = returnMM (StgRhsCon dontCareCCS con args)
------
do_expr :: StgExpr -> MassageM StgExpr
- do_expr (StgApp fn args lvs)
- = boxHigherOrderArgs (StgApp fn) args lvs
-
- do_expr (StgCon con args lvs)
- = boxHigherOrderArgs (StgCon con) args lvs
+ do_expr (StgApp fn args)
+ = boxHigherOrderArgs (StgApp fn) args
- do_expr (StgPrim op args lvs)
- = boxHigherOrderArgs (StgPrim op) args lvs
+ do_expr (StgCon con args res_ty)
+ = boxHigherOrderArgs (\args -> StgCon con args res_ty) args
- do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre!
- = collectCC cc `thenMM_`
- set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' ->
- returnMM (StgSCC ty cc expr')
+ do_expr (StgSCC cc expr) -- Ha, we found a cost centre!
+ = collectCC cc `thenMM_`
+ set_prevailing_cc currentCCS (do_expr expr) `thenMM` \ expr' ->
+ returnMM (StgSCC cc expr')
- do_expr (StgCase expr fv1 fv2 uniq alts)
+ do_expr (StgCase expr fv1 fv2 bndr srt alts)
= do_expr expr `thenMM` \ expr' ->
do_alts alts `thenMM` \ alts' ->
- returnMM (StgCase expr' fv1 fv2 uniq alts')
+ returnMM (StgCase expr' fv1 fv2 bndr srt alts')
where
do_alts (StgAlgAlts ty alts def)
= mapMM do_alt alts `thenMM` \ alts' ->
returnMM (l,e')
do_deflt StgNoDefault = returnMM StgNoDefault
- do_deflt (StgBindDefault b is_used e)
+ do_deflt (StgBindDefault e)
= do_expr e `thenMM` \ e' ->
- returnMM (StgBindDefault b is_used e')
+ returnMM (StgBindDefault e')
do_expr (StgLet b e)
= do_binding b `thenMM` \ b' ->
-- We play much the same game as we did in do_top_rhs above;
-- but we don't have to worry about cafs etc.
- do_rhs (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
+{-
+ do_rhs (StgRhsClosure closure_cc bi srt fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
| not (isSccCountCostCentre cc)
= collectCC cc `thenMM_`
returnMM (StgRhsCon cc con args)
+-}
- do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
+{-
+ do_rhs (StgRhsClosure _ bi srt fv u args (StgSCC ty cc expr))
| not (isSccCountCostCentre cc)
= collectCC cc `thenMM_`
set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' ->
- returnMM (StgRhsClosure cc bi fv u args expr')
+ returnMM (StgRhsClosure cc bi srt fv u args expr')
+-}
- do_rhs (StgRhsClosure cc bi fv u args body)
+ do_rhs (StgRhsClosure cc bi srt fv u args body)
= set_prevailing_cc_maybe cc $ \ cc' ->
set_lambda_cc (do_expr body) `thenMM` \ body' ->
- returnMM (StgRhsClosure cc' bi fv u args body')
+ returnMM (StgRhsClosure cc' bi srt fv u args body')
do_rhs (StgRhsCon cc con args)
= set_prevailing_cc_maybe cc $ \ cc' ->
\begin{code}
boxHigherOrderArgs
- :: ([StgArg] -> StgLiveVars -> StgExpr)
+ :: ([StgArg] -> StgExpr)
-- An application lacking its arguments and live-var info
-> [StgArg] -- arguments which we might box
- -> StgLiveVars -- live var info, which we do *not* try
- -- to maintain/update (setStgVarInfo will
- -- do that)
-> MassageM StgExpr
-boxHigherOrderArgs almost_expr args live_vars
- = returnMM (almost_expr args live_vars)
+boxHigherOrderArgs almost_expr args
+ = returnMM (almost_expr args)
{- No boxing for now ... should be moved to desugarer and preserved ...
-- make a trivial let-binding for the top-level function
getUniqueMM `thenMM` \ uniq ->
let
- new_var = mkSysLocal SLIT("ho") uniq var_type noSrcLoc
+ new_var = mkSysLocal uniq var_type
in
returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
else
mk_stg_let cc (new_var, old_var) body
= let
- rhs_body = StgApp (StgVarAtom old_var) [{-args-}] bOGUS_LVs
- rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body
+ rhs_body = StgApp (StgVarAtom old_var) [{-args-}]
+ rhs_closure = StgRhsClosure cc stgArgOcc NoSRT [{-fvs-}] ReEntrant [{-args-}] rhs_body
in
StgLet (StgNonRec new_var rhs_closure) body
where
\begin{code}
type MassageM result
= FAST_STRING -- module name
- -> CostCentre -- prevailing CostCentre
+ -> CostCentreStack -- prevailing CostCentre
-- if none, subsumedCosts at top-level
-- useCurrentCostCentre at nested levels
-> UniqSupply
-> MassageM a
-> (CollectedCCs, a)
-initMM mod_name init_us m = m mod_name noCostCentre init_us ([],[])
+initMM mod_name init_us m = m mod_name noCCS init_us ([],[],[])
thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b
thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
returnMM (b3, r:rs)
getUniqueMM :: MassageM Unique
-getUniqueMM mod scope_cc us ccs = (ccs, getUnique us)
+getUniqueMM mod scope_cc us ccs = (ccs, uniqFromSupply us)
\end{code}
+I'm not sure about all this prevailing CC stuff --SDM
+
\begin{code}
-set_prevailing_cc :: CostCentre -> MassageM a -> MassageM a
+set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a
set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
-- set unconditionally
= action mod cc_to_set_to us ccs
-set_prevailing_cc_maybe :: CostCentre -> (CostCentre -> MassageM a) -> MassageM a
+set_prevailing_cc_maybe :: CostCentreStack -> (CostCentreStack -> MassageM a) -> MassageM a
set_prevailing_cc_maybe cc_to_try action mod scope_cc us ccs
-- set only if a real cost centre
= let
cc_to_use
- = if noCostCentreAttached cc_to_try || currentOrSubsumedCosts cc_to_try
+ = if noCCSAttached cc_to_try
then scope_cc -- carry on as before
else cc_to_try -- use new cost centre
in
set_lambda_cc :: MassageM a -> MassageM a
set_lambda_cc action mod scope_cc us ccs
- -- used when moving inside a lambda;
- -- if we were chugging along as "caf/dict" we change to "ccc"
+ -- used when moving inside a lambda;
+ -- if we were chugging along as "caf/dict" we change to "ccc"
= let
- cc_to_use
+ cc_to_use = currentCCS
+ {-
= if isCafCC scope_cc || isDictCC scope_cc
then useCurrentCostCentre
else scope_cc
+ -}
in
action mod cc_to_use us ccs
-get_prevailing_cc :: MassageM CostCentre
+get_prevailing_cc :: MassageM CostCentreStack
get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)
\end{code}
\begin{code}
collectCC :: CostCentre -> MassageM ()
-collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
- = ASSERT(not (noCostCentreAttached cc))
- ASSERT(not (currentOrSubsumedCosts cc))
+collectCC cc mod_name scope_cc us (local_ccs, extern_ccs, ccss)
+ = ASSERT(not (noCCAttached cc))
if (cc `ccFromThisModule` mod_name) then
- ((cc : local_ccs, extern_ccs), ())
+ ((cc : local_ccs, extern_ccs, ccss), ())
else -- must declare it "extern"
- ((local_ccs, cc : extern_ccs), ())
+ ((local_ccs, cc : extern_ccs, ccss), ())
+
+collectCCS :: CostCentreStack -> MassageM ()
+
+collectCCS ccs mod_name scope_cc us (local_ccs, extern_ccs, ccss)
+ = ASSERT(not (noCCSAttached ccs))
+ ((local_ccs, extern_ccs, ccs : ccss), ())
\end{code}
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Lexical analysis]{Lexical analysis}
+
--------------------------------------------------------
[Jan 98]
There's a known bug in here:
f _:_ _forall_ [a] <<<END OF FILE>>>
--------------------------------------------------------
-
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Lexical analysis]{Lexical analysis}
-
\begin{code}
+{-# OPTIONS -#include "ctypes.h" #-}
+
module Lex (
- isLexCon, isLexVar, isLexId, isLexSym,
- isLexConId, isLexConSym, isLexVarId, isLexVarSym,
- mkTupNameStr, ifaceParseErr,
+ ifaceParseErr,
-- Monad for parser
IfaceToken(..), lexIface, IfM, thenIf, returnIf, getSrcLocIf,
#include "HsVersions.h"
-import Char (isDigit, isAlphanum, isUpper,isLower, isSpace, ord )
+import Char ( ord, isSpace )
import List ( isSuffixOf )
-import {-# SOURCE #-} CostCentre
+import CostCentre -- Pretty much all of it
+import IdInfo ( InlinePragInfo(..) )
+import Name ( mkTupNameStr, mkUbxTupNameStr,
+ isLowerISO, isUpperISO )
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
import Maybes ( MaybeErr(..) )
import ErrUtils ( ErrMsg )
import Outputable
-import Util ( nOfThem, panic )
import FastString
import StringBuffer
import GlaExts
import ST ( runST )
-import PrelRead ( readRational__ ) -- Glasgow non-std
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Lexical categories}
-%* *
-%************************************************************************
-
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report. Normally applied as in e.g. @isCon
-(getLocalName foo)@.
-
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
- isLexVarId, isLexVarSym :: FAST_STRING -> Bool
-
-isLexCon cs = isLexConId cs || isLexConSym cs
-isLexVar cs = isLexVarId cs || isLexVarSym cs
-
-isLexId cs = isLexConId cs || isLexVarId cs
-isLexSym cs = isLexConSym cs || isLexVarSym cs
-
--------------
-
-isLexConId cs
- | _NULL_ cs = False
- | cs == SLIT("[]") = True
- | c == '(' = True -- (), (,), (,,), ...
- | otherwise = isUpper c || isUpperISO c
- where
- c = _HEAD_ cs
-
-isLexVarId cs
- | _NULL_ cs = False
- | otherwise = isLower c || isLowerISO c
- where
- c = _HEAD_ cs
-
-isLexConSym cs
- | _NULL_ cs = False
- | otherwise = c == ':'
- || cs == SLIT("->")
- where
- c = _HEAD_ cs
-
-isLexVarSym cs
- | _NULL_ cs = False
- | otherwise = isSymbolASCII c
- || isSymbolISO c
- where
- c = _HEAD_ cs
-
--------------
-isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
-isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
-isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'#
---0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
---0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
-\end{code}
-
+#if __GLASGOW_HASKELL__ >= 303
+import Bits
+import Word
+#endif
-%************************************************************************
-%* *
-\subsection{Tuple strings -- ugh!}
-%* *
-%************************************************************************
+import Addr
-\begin{code}
-mkTupNameStr 0 = SLIT("()")
-mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary
-mkTupNameStr 3 = _PK_ "(,,)" -- ditto
-mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
-mkTupNameStr n = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
+import PrelRead ( readRational__ ) -- Glasgow non-std
\end{code}
-
-
%************************************************************************
%* *
\subsection{Data types}
%* *
%************************************************************************
-The token data type, fairly un-interesting except from two constructors,
-@ITidinfo@ and @ITtype@, which are used to lazily lex id info (arity,
-strictness, unfolding etc) and types for id decls.
+The token data type, fairly un-interesting except from one
+constructor, @ITidinfo@, which is used to lazily lex id info (arity,
+strictness, unfolding etc).
The Idea/Observation here is that the renamer needs to scan through
all of an interface file before it can continue. But only a fraction
\begin{code}
data IfaceToken
- = ITinterface -- keywords
- | ITusages
- | ITversions
- | ITexports
- | ITinstance_modules
- | ITinstances
- | ITfixities
- | ITdeclarations
- | ITpragmas
- | ITdata
- | ITtype
- | ITnewtype
+ = ITcase -- Haskell keywords
| ITclass
- | ITwhere
- | ITinstance
+ | ITdata
+ | ITdefault
+ | ITderiving
+ | ITdo
+ | ITelse
+ | ITif
+ | ITimport
+ | ITin
+ | ITinfix
| ITinfixl
| ITinfixr
- | ITinfix
+ | ITinstance
+ | ITlet
+ | ITmodule
+ | ITnewtype
+ | ITof
+ | ITthen
+ | ITtype
+ | ITwhere
+ | ITas
+ | ITqualified
+ | IThiding
+
+ | ITinterface -- GHC-extension keywords
+ | ITexport
+ | ITinstimport
| ITforall
- | ITbang -- magic symbols
- | ITvbar
+ | ITletrec
+ | ITcoerce
+ | ITinline
+ | ITccall (Bool,Bool) -- (is_casm, may_gc)
+ | ITdefaultbranch
+ | ITbottom
+ | ITinteger_lit
+ | ITfloat_lit
+ | ITrational_lit
+ | ITaddr_lit
+ | ITlit_lit
+ | ITstring_lit
+ | ITtypeapp
+ | ITarity
+ | ITspecialise
+ | ITnocaf
+ | ITunfold InlinePragInfo
+ | ITstrict [Demand]
+ | ITscc CostCentre
+
+ | ITdotdot -- reserved symbols
| ITdcolon
- | ITcomma
- | ITdarrow
- | ITdotdot
| ITequal
- | ITocurly
- | ITobrack
- | IToparen
+ | ITlam
+ | ITvbar
+ | ITlarrow
| ITrarrow
+ | ITat
+ | ITtilde
+ | ITdarrow
+ | ITminus
+ | ITbang
+
+ | ITbiglam -- GHC-extension symbols
+
+ | ITocurly -- special symbols
| ITccurly
+ | ITobrack
| ITcbrack
+ | IToparen
| ITcparen
+ | IToubxparen
+ | ITcubxparen
| ITsemi
- | ITvarid FAST_STRING
+ | ITcomma
+
+ | ITvarid FAST_STRING -- identifiers
| ITconid FAST_STRING
| ITvarsym FAST_STRING
| ITconsym FAST_STRING
| ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour)
| ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour)
- | ITtysig StringBuffer (Maybe StringBuffer)
- -- lazily return the stream of tokens for
- -- the info attached to an id.
- -- Stuff for reading unfoldings
- | ITarity
- | ITunfold Bool -- True <=> there's an INLINE pragma on this Id
- | ITstrict [Demand] | ITbottom
- | ITspecialise
- | ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof
- | ITcoerce | ITinline | ITatsign
- | ITccall (Bool,Bool) -- (is_casm, may_gc)
- | ITscc CostCentre
- | ITchar Char | ITstring FAST_STRING
- | ITinteger Integer | ITrational Rational
- | ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit
+ | ITpragma StringBuffer
+
+ | ITchar Char
+ | ITstring FAST_STRING
+ | ITinteger Integer
+ | ITrational Rational
+
| ITunknown String -- Used when the lexer can't make sense of it
- | ITeof -- end of file token
+ | ITeof -- end of file token
deriving Text -- debugging
instance Text CostCentre -- cheat!
-- if bufferExhausted buf then
-- []
-- else
--- _trace ("Lexer: "++[C# (currentChar# buf)]) $
+-- trace ("Lexer: '"++[C# (currentChar# buf)]++"'") $
case currentChar# buf of
-- whitespace and comments, ignore.
' '# -> lexIface cont (stepOn buf)
case lookAhead# buf 1# of
'-'# -> lex_comment cont (stepOnBy# buf 2#)
c ->
- if isDigit (C# c)
+ if is_digit c
then lex_num cont (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf))
- else lex_id cont buf
-
--- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake?
--- '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
-
+ else lex_sym cont buf
+
+ '{'# -> -- look for "{-##" special iface pragma
+ case lookAhead# buf 1# of
+ '-'# -> case lookAhead# buf 2# of
+ '#'# -> case lookAhead# buf 3# of
+ '#'# ->
+ let (lexeme, buf')
+ = doDiscard False (stepOnBy# buf 4#) in
+ cont (ITpragma lexeme) buf'
+ _ -> lex_nested_comment (lexIface cont) buf
+ _ -> cont ITocurly (stepOn buf)
+ -- lex_nested_comment (lexIface cont) buf
+ _ -> cont ITocurly (stepOn buf)
+
+ -- special symbols ----------------------------------------------------
'('# ->
case prefixMatch (stepOn buf) "..)" of
Just buf' -> cont ITdotdot (stepOverLexeme buf')
Nothing ->
case lookAhead# buf 1# of
- ','# -> lex_tuple cont Nothing (stepOnBy# buf 2#)
- ')'# -> cont (ITconid SLIT("()")) (stepOnBy# buf 2#)
+ '#'# -> cont IToubxparen (stepOnBy# buf 2#)
_ -> cont IToparen (stepOn buf)
-
- '{'# -> cont ITocurly (stepOn buf)
- '}'# -> cont ITccurly (stepOn buf)
')'# -> cont ITcparen (stepOn buf)
- '['# ->
- case lookAhead# buf 1# of
- ']'# -> cont (ITconid SLIT("[]")) (stepOnBy# buf 2#)
- _ -> cont ITobrack (stepOn buf)
+ '}'# -> cont ITccurly (stepOn buf)
+ '#'# -> case lookAhead# buf 1# of
+ ')'# -> cont ITcubxparen (stepOnBy# buf 2#)
+ _ -> lex_sym cont (incLexeme buf)
+ '['# -> cont ITobrack (stepOn buf)
']'# -> cont ITcbrack (stepOn buf)
','# -> cont ITcomma (stepOn buf)
- ';'# -> cont ITsemi (stepOn buf)
- '\"'# -> case untilEndOfString# (stepOn buf) of
+ ';'# -> cont ITsemi (stepOn buf)
+
+ -- strings/characters -------------------------------------------------
+ '\"'#{-"-} -> case untilEndOfString# (stepOn buf) of
buf' ->
-- the string literal does *not* include the dquotes
case lexemeToFastString buf' of
buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of
[ (ch, rest)] -> cont (ITchar ch) (stepOverLexeme (incLexeme buf'))
+ -- strictness pragma and __scc treated specially.
+ '_'# ->
+ case lookAhead# buf 1# of
+ '_'# -> case lookAhead# buf 2# of
+ 'S'# ->
+ lex_demand cont (stepOnUntil (not . isSpace)
+ (stepOnBy# buf 3#)) -- past __S
+ 's'# ->
+ case prefixMatch (stepOnBy# buf 3#) "cc" of
+ Just buf' -> lex_scc cont
+ (stepOnUntil (not . isSpace)
+ (stepOverLexeme buf'))
+ Nothing -> lex_id cont buf
+ _ -> lex_id cont buf
+ _ -> lex_id cont buf
+
-- ``thingy'' form for casm
'`'# ->
case lookAhead# buf 1# of
- '`'# -> lex_cstring cont (stepOnBy# buf 2#) -- remove the `` and go.
- _ -> lex_id cont (incLexeme buf) -- add ` to lexeme and assume
+ '`'# -> lex_cstring cont (stepOnBy# buf 2#) -- remove the `s and go.
+ _ -> lex_sym cont (incLexeme buf) -- add ` to lexeme and assume
-- scanning an id of some sort.
--- Keywords
- '_'# ->
- case lookAhead# buf 1# of
- 'S'# -> case lookAhead# buf 2# of
- '_'# ->
- lex_demand cont (stepOnUntil (not . isSpace)
- (stepOnBy# buf 3#)) -- past _S_
- 's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of
- Just buf' -> lex_scc cont (stepOnUntil (not . isSpace) (stepOverLexeme buf'))
- Nothing -> lex_keyword cont (stepOnBy# buf 1#) -- drop the '_' and assume
- -- it is a keyword.
- _ -> lex_keyword cont (stepOn buf)
'\NUL'# ->
if bufferExhausted (stepOn buf) then
cont ITeof buf
else
- lex_id cont buf
- c ->
- if isDigit (C# c) then
- lex_num cont (id) (ord# c -# ord# '0'#) (incLexeme buf)
- else
- lex_id cont buf
+ trace "lexIface: misplaced NUL?" $
+ cont (ITunknown "\NUL") (stepOn buf)
+
+ c | is_digit c -> lex_num cont (id) (ord# c -# ord# '0'#) (incLexeme buf)
+ | is_symbol c -> lex_sym cont buf
+ | is_upper c -> lex_con cont buf
+ | is_ident c -> lex_id cont buf
+
-- where
lex_comment cont buf =
-- _trace ("comment: "++[C# (currentChar# buf)]) $
case untilChar# buf '\n'# of {buf' -> lexIface cont (stepOverLexeme buf')}
-------------------
+-------------------------------------------------------------------------------
+
+lex_nested_comment cont buf =
+ case currentChar# buf of
+ '-'# -> case lookAhead# buf 1# of
+ '}'# -> cont (stepOnBy# buf 2#)
+ _ -> lex_nested_comment cont (stepOn buf)
+
+ '{'# -> case lookAhead# buf 1# of
+ '-'# -> lex_nested_comment
+ (lex_nested_comment cont)
+ (stepOnBy# buf 2#)
+ _ -> lex_nested_comment cont (stepOn buf)
+
+ _ -> lex_nested_comment cont (stepOn buf)
+
+-------------------------------------------------------------------------------
+
lex_demand cont buf =
case read_em [] buf of { (ls,buf') -> cont (ITstrict ls) (stepOverLexeme buf')}
where
lex_scc cont buf =
case currentChar# buf of
'"'# ->
- -- YUCK^2
- case prefixMatch (stepOn buf) "NO_CC\"" of
- Just buf' -> cont (ITscc noCostCentre) (stepOverLexeme buf')
- Nothing ->
- case prefixMatch (stepOn buf) "CURRENT_CC\"" of
- Just buf' -> cont (ITscc useCurrentCostCentre) (stepOverLexeme buf')
- Nothing ->
- case prefixMatch (stepOn buf) "OVERHEAD\"" of
- Just buf' -> cont (ITscc overheadCostCentre) (stepOverLexeme buf')
- Nothing ->
- case prefixMatch (stepOn buf) "DONT_CARE\"" of
- Just buf' -> cont (ITscc dontCareCostCentre) (stepOverLexeme buf')
- Nothing ->
- case prefixMatch (stepOn buf) "SUBSUMED\"" of
- Just buf' -> cont (ITscc subsumedCosts) (stepOverLexeme buf')
+ case prefixMatch (stepOn buf) "CAFs." of
+ Just buf' ->
+ case untilChar# (stepOverLexeme buf') '\"'# of
+ buf'' -> cont (ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_)) (stepOn (stepOverLexeme buf''))
+ Nothing ->
+ case prefixMatch (stepOn buf) "DICTs." of
+ Just buf' ->
+ case untilChar# (stepOverLexeme buf') '\"'# of
+ buf'' -> cont (ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True))
+ (stepOn (stepOverLexeme buf''))
Nothing ->
- case prefixMatch (stepOn buf) "CAFs_in_...\"" of
- Just buf' -> cont (ITscc preludeCafsCostCentre) (stepOverLexeme buf')
- Nothing ->
- case prefixMatch (stepOn buf) "CC_CAFs_in_..." of
- Just buf' ->
- case untilChar# (stepOverLexeme buf') '\"'# of
- buf'' -> cont (ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_)) (stepOn (stepOverLexeme buf''))
- Nothing ->
- case prefixMatch (stepOn buf) "DICTs_in_...\"" of
- Just buf' -> cont (ITscc (preludeDictsCostCentre True)) (stepOverLexeme buf')
- Nothing ->
- case prefixMatch (stepOn buf) "CC_DICTs_in_..." of
- Just buf' ->
- case untilChar# (stepOverLexeme buf') '\"'# of
- buf'' -> cont (ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True))
- (stepOn (stepOverLexeme buf''))
- Nothing ->
- let
- match_user_cc buf =
- case untilChar# buf '/'# of
- buf' ->
- let mod_name = lexemeToFastString buf' in
+ let
+ match_user_cc buf =
+ case untilChar# buf '/'# of
+ buf' ->
+ let mod_name = lexemeToFastString buf' in
-- case untilChar# (stepOn (stepOverLexeme buf')) '/'# of
-- buf'' ->
-- let grp_name = lexemeToFastString buf'' in
- case untilChar# (stepOn (stepOverLexeme buf')) '\"'# of
- buf'' ->
- -- The label may contain arbitrary characters, so it
- -- may have been escaped etc., hence we `read' it in to get
- -- rid of these meta-chars in the string and then pack it (again.)
- -- ToDo: do the same for module name (single quotes allowed in m-names).
- -- BTW, the code in this module is totally gruesome..
- let upk_label = _UNPK_ (lexemeToFastString buf'') in
- case reads ('"':upk_label++"\"") of
- ((cc_label,_):_) ->
- let cc_name = _PK_ cc_label in
- (mkUserCC cc_name mod_name _NIL_{-grp_name-},
- stepOn (stepOverLexeme buf''))
- _ ->
- trace ("trouble lexing scc label: " ++ upk_label ++ " , ignoring")
- (mkUserCC _NIL_ mod_name _NIL_{-grp_name-},
- stepOn (stepOverLexeme buf''))
- in
- case prefixMatch (stepOn buf) "CAF:" of
- Just buf' ->
- case match_user_cc (stepOverLexeme buf') of
- (cc, buf'') -> cont (ITscc (cafifyCC cc)) buf''
- Nothing ->
- case match_user_cc (stepOn buf) of
- (cc, buf'') -> cont (ITscc cc) buf''
+ case untilChar# (stepOn (stepOverLexeme buf')) '\"'# of
+ buf'' ->
+ -- The label may contain arbitrary characters, so it
+ -- may have been escaped etc., hence we `read' it in to get
+ -- rid of these meta-chars in the string and then pack it (again.)
+ -- ToDo: do the same for module name (single quotes allowed in m-names).
+ -- BTW, the code in this module is totally gruesome..
+ let upk_label = _UNPK_ (lexemeToFastString buf'') in
+ case reads ('"':upk_label++"\"") of
+ ((cc_label,_):_) ->
+ let cc_name = _PK_ cc_label in
+ (mkUserCC cc_name mod_name _NIL_{-grp_name-},
+ stepOn (stepOverLexeme buf''))
+ _ ->
+ trace ("trouble lexing scc label: " ++ upk_label ++ " , ignoring")
+ (mkUserCC _NIL_ mod_name _NIL_{-grp_name-},
+ stepOn (stepOverLexeme buf''))
+ in
+ case prefixMatch (stepOn buf) "CAF:" of
+ Just buf' ->
+ case match_user_cc (stepOverLexeme buf') of
+ (cc, buf'') -> cont (ITscc (cafifyCC cc)) buf''
+ Nothing ->
+ case match_user_cc (stepOn buf) of
+ (cc, buf'') -> cont (ITscc cc) buf''
c -> cont (ITunknown [C# c]) (stepOn buf)
-----------
-lex_num :: (IfaceToken -> IfM a) ->
- (Int -> Int) -> Int# -> IfM a
+lex_num :: (IfaceToken -> IfM a) -> (Int -> Int) -> Int# -> IfM a
lex_num cont minus acc# buf =
--- _trace ("lex_num: "++[C# (currentChar# buf)]) $
+ --trace ("lex_num: "++[C# (currentChar# buf)]) $
case scanNumLit (I# acc#) buf of
(acc',buf') ->
case currentChar# buf' of
-- this case is not optimised at all, as the
-- presence of floating point numbers in interface
-- files is not that common. (ToDo)
- case expandWhile (isDigit) (incLexeme buf') of
+ case expandWhile# is_digit (incLexeme buf') of
buf2 -> -- points to first non digit char
let l = case currentChar# buf2 of
'e'# -> let buf3 = incLexeme buf2 in
case currentChar# buf3 of
- '-'# -> expandWhile (isDigit) (incLexeme buf3)
- _ -> expandWhile (isDigit) buf3
+ '-'# -> expandWhile# is_digit (incLexeme buf3)
+ _ -> expandWhile# is_digit buf3
_ -> buf2
in let v = readRational__ (lexemeToString l) in
cont (ITrational v) (stepOverLexeme l)
_ -> cont (ITinteger (fromInt (minus acc'))) (stepOverLexeme buf')
-
-
-------------
-lex_keyword cont buf =
--- _trace ("lex_keyword: "++[C# (currentChar# buf)]) $
- case currentChar# buf of
- ':'# -> case lookAhead# buf 1# of
- '_'# -> -- a binding, type (and other id-info) follows,
- -- to make the parser ever so slightly, we push
- --
- lex_decl cont (stepOnBy# buf 2#)
- v# -> cont (ITunknown (['_',':',C# v#])) (stepOnBy# buf 2#)
- _ ->
- case expandWhile (is_kwd_char) buf of
- buf' ->
- let kw = lexemeToFastString buf' in
--- _trace ("kw: "++lexemeToString buf') $
- case lookupUFM ifaceKeywordsFM kw of
- Nothing -> cont (ITunknown (_UNPK_ kw)) -- (minor) sigh
- (stepOverLexeme buf')
- Just xx -> cont xx (stepOverLexeme buf')
-
-lex_decl cont buf =
- case doDiscard False buf of -- spin until ;; is found
- buf' ->
- {- _trace (show (lexemeToString buf')) $ -}
- case currentChar# buf' of
- '\n'# -> -- newline, no id info.
- cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
- (stepOverLexeme buf')
- '\r'# -> -- just to be sure for those Win* boxes..
- cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
- (stepOverLexeme buf')
- '\NUL'# ->
- cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
- (stepOverLexeme buf')
- c -> -- run all over the id info
- case doDiscard False (stepOverLexeme buf') of -- spin until ;; is found (outside a string!)
- buf'' ->
- --_trace ((C# c):show (lexemeToString (decLexeme buf'))) $
- --_trace (show (lexemeToString (decLexeme buf''))) $
- let idinfo =
- if opt_IgnoreIfacePragmas then
- Nothing
- else
- Just (lexemeToBuffer (decLexeme buf''))
- --_trace (show is) $
- in
- cont (ITtysig (lexemeToBuffer (decLexeme buf')) idinfo)
- (stepOverLexeme buf'')
-
--- ToDo: hammer!
-is_kwd_char c@(C# c#) =
- isAlphanum c || -- OLD: c `elem` "_@/\\"
- (case c# of
- '_'# -> True
- '@'# -> True
- '/'# -> True
- '\\'# -> True
- _ -> False)
-
-
-
-----------
lex_cstring cont buf =
case expandUntilMatch buf "\'\'" of
buf' -> cont (ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))))
- (stepOverLexeme buf')
-
------------
-lex_tuple cont module_dot buf =
- go 2 buf
- where
- go n buf =
- case currentChar# buf of
- ','# -> go (n+1) (stepOn buf)
- ')'# -> end_lex_id cont module_dot (ITconid (mkTupNameStr n)) (stepOn buf)
- _ -> cont (ITunknown ("tuple " ++ show n)) buf
-
--- Similarly ' itself is ok inside an identifier, but not at the start
-
--- id_arr is an array of bytes, indexed by characters,
--- containing 0 if the character isn't a valid character from an identifier
--- and 1 if it is. It's just a memo table for is_id_char.
-id_arr :: ByteArray Int
-id_arr =
- runST (
- newCharArray (0,255) >>= \ barr ->
- let
- loop 256# = return ()
- loop i# =
- if isAlphanum (C# (chr# i#)) || is_sym (chr# i#) then
- writeCharArray barr (I# i#) '\1' >>
- loop (i# +# 1#)
- else
- writeCharArray barr (I# i#) '\0' >>
- loop (i# +# 1#)
- in
- loop 0# >>
- unsafeFreezeByteArray barr)
-
-is_id_char (C# c#) =
- let
- ByteArray _ arr# = id_arr
- in
- case ord# (indexCharArray# arr# (ord# c#)) of
- 0# -> False
- 1# -> True
-
---OLD: is_id_char c@(C# c#) = isAlphanum c || is_sym c#
-
-is_sym c# =
- case c# of {
- ':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True;
- '#'# -> True; '$'# -> True; '%'# -> True;
- '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True;
- '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True;
- '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True;
- '-'# -> True; '~'# -> True; '@'# -> True; _ -> False }
-
---isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
-
-
--- mod_arr is an array of bytes, indexed by characters,
--- containing 0 if the character isn't a valid character from a module name,
--- and 1 if it is.
-mod_arr :: ByteArray Int
-mod_arr =
- runST (
- newCharArray (0,255) >>= \ barr ->
- let
- loop 256# = return ()
- loop i# =
- if isAlphanum (C# (chr# i#)) || i# ==# (ord# '_'#) || i# ==# (ord# '\''#) then
- writeCharArray barr (I# i#) '\1' >>
- loop (i# +# 1#)
- else
- writeCharArray barr (I# i#) '\0' >>
- loop (i# +# 1#)
- in
- loop 0# >>
- unsafeFreezeByteArray barr)
-
-
-is_mod_char (C# c#) =
- let
- ByteArray _ arr# = mod_arr
+ (stepOverLexeme buf')
+
+------------------------------------------------------------------------------
+-- Character Classes
+
+is_ident, is_symbol, is_any, is_upper, is_digit :: Char# -> Bool
+
+{-# INLINE is_ctype #-}
+#if __GLASGOW_HASKELL__ >= 303
+is_ctype :: Word8 -> Char# -> Bool
+is_ctype mask = \c ->
+ (indexWord8OffAddr (``char_types'' :: Addr) (ord (C# c)) .&. mask) /= 0
+#else
+is_ctype :: Int -> Char# -> Bool
+is_ctype (I# mask) = \c ->
+ let (A# ctype) = ``char_types'' :: Addr
+ flag_word = int2Word# (ord# (indexCharOffAddr# ctype (ord# c)))
+ in
+ (flag_word `and#` (int2Word# mask)) `neWord#` (int2Word# 0#)
+#endif
+
+is_ident = is_ctype 1
+is_symbol = is_ctype 2
+is_any = is_ctype 4
+is_space = is_ctype 8
+is_upper = is_ctype 16
+is_digit = is_ctype 32
+
+-----------------------------------------------------------------------------
+-- identifiers, symbols etc.
+
+lex_id cont buf =
+ case expandWhile# is_ident buf of { buf1 ->
+ case expandWhile# (eqChar# '#'#) buf1 of { buf' -> -- only if GHC extns on
+ let new_buf = stepOverLexeme buf'
+ lexeme = lexemeToFastString buf'
in
- case ord# (indexCharArray# arr# (ord# c#)) of
- 0# -> False
- 1# -> True
-
---isAlphanum c || c == '_' || c== '\'' --`elem` "_'"
-
-lex_id cont buf =
--- _trace ("lex_id: "++[C# (currentChar# buf)]) $
- case expandWhile (is_mod_char) buf of
- buf' ->
- case currentChar# buf' of
- '.'# -> munch buf' HiFile
- '!'# -> munch buf' HiBootFile
- _ -> lex_id2 cont Nothing buf'
+ case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+ Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
+ cont kwd_token new_buf;
+ Nothing ->
+ case lookupUFM ifaceKeywordsFM lexeme of {
+ Just kwd_token -> --trace ("ifacekeywd: "++_UNPK_(lexeme)) $
+ cont kwd_token new_buf;
+ Nothing -> --trace ("id: "++_UNPK_(lexeme)) $
+ cont (mk_var_token lexeme) new_buf
+ }}}}
+
+lex_sym cont buf =
+ case expandWhile# is_symbol buf of
+ buf' -> case lookupUFM haskellKeySymsFM lexeme of {
+ Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
+ cont kwd_token new_buf ;
+ Nothing -> --trace ("sym: "++unpackFS lexeme) $
+ cont (mk_var_token lexeme) new_buf
+ }
+ where lexeme = lexemeToFastString buf'
+ new_buf = stepOverLexeme buf'
+
+lex_con cont buf =
+ case expandWhile# is_ident buf of { buf1 ->
+ case expandWhile# (eqChar# '#'#) buf1 of { buf' ->
+ case currentChar# buf' of
+ '.'# -> munch HiFile
+ '!'# -> munch HiBootFile
+ _ -> just_a_conid
+
where
- munch buf' hif =
- if not (emptyLexeme buf') then
--- _trace ("lex_id: "++(C# (currentChar# (stepOverLexeme buf'))):show (lexemeToFastString buf')) $
- case lexemeToFastString buf' of
- l@(FastString u# l# ba#) -> lex_id2 cont (Just (FastString u# l# ba#, hif))
- (stepOn (stepOverLexeme buf'))
- else
- lex_id2 cont Nothing buf'
-
-
--- Dealt with the Module.part
-lex_id2 cont module_dot buf =
--- _trace ("lex_id2: "++[C# (currentChar# buf)]) $
+ just_a_conid = --trace ("con: "++unpackFS lexeme) $
+ cont (ITconid lexeme) new_buf
+ lexeme = lexemeToFastString buf'
+ new_buf = stepOverLexeme buf'
+ munch hif = lex_qid cont lexeme hif (stepOn new_buf) just_a_conid
+ }}
+
+lex_qid cont mod hif buf just_a_conid =
case currentChar# buf of
-
'['# -> -- Special case for []
case lookAhead# buf 1# of
- ']'# -> end_lex_id cont module_dot (ITconid SLIT("[]")) (stepOnBy# buf 2#)
- _ -> lex_id3 cont module_dot buf
+ ']'# -> cont (ITqconid (mod,SLIT("[]"),hif)) (stepOnBy# buf 2#)
+ _ -> just_a_conid
- '('# -> -- Special case for (,,,)
+ '('# -> -- Special case for (,,,)
+ -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
case lookAhead# buf 1# of
- ')'# -> end_lex_id cont module_dot (ITconid SLIT("()")) (stepOnBy# buf 2#)
- ','# -> lex_tuple cont module_dot (stepOnBy# buf 2#)
- _ -> lex_id3 cont module_dot buf
- ':'# -> lex_id3 cont module_dot (incLexeme buf)
- '-'# ->
- case module_dot of
- Nothing -> lex_id3 cont module_dot buf
- Just ghc -> -- this should be "GHC" (current home of (->))
- case lookAhead# buf 1# of
- '>'# -> end_lex_id cont module_dot (ITconid SLIT("->"))
- (stepOnBy# buf 2#)
- _ -> lex_id3 cont module_dot buf
- _ -> lex_id3 cont module_dot buf
-
-
-
--- Dealt with [], (), : special cases
-
-lex_id3 cont module_dot buf =
- case expandWhile (is_id_char) buf of
- buf' ->
- case module_dot of
- Just _ ->
- end_lex_id cont module_dot (mk_var_token lexeme) new_buf
- Nothing ->
- case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of
- Just kwd_token -> cont kwd_token new_buf
- Nothing -> cont (mk_var_token lexeme) new_buf
- where
- lexeme = lexemeToFastString buf'
- new_buf = stepOverLexeme buf'
-
-
--- Dealt with [], (), : special cases
-mk_var_token pk_str =
+ '#'# -> case lookAhead# buf 2# of
+ ','# -> lex_ubx_tuple cont mod hif (stepOnBy# buf 3#)
+ just_a_conid
+ _ -> just_a_conid
+ ')'# -> cont (ITqconid (mod,SLIT("()"),hif)) (stepOnBy# buf 2#)
+ ','# -> lex_tuple cont mod hif (stepOnBy# buf 2#) just_a_conid
+ _ -> just_a_conid
+
+ '-'# -> case lookAhead# buf 1# of
+ '>'# -> cont (ITqconid (mod,SLIT("->"),hif)) (stepOnBy# buf 2#)
+ _ -> lex_id3 cont mod hif buf just_a_conid
+ _ -> lex_id3 cont mod hif buf just_a_conid
+
+lex_id3 cont mod hif buf just_a_conid
+ | is_symbol c =
+ case expandWhile# is_symbol buf of { buf' ->
let
- f = _HEAD_ pk_str
+ lexeme = lexemeToFastString buf'
+ new_buf = stepOverLexeme buf'
in
- --
- -- These tests assume a non- ISO-8859-1 impl of isUpper&isLower,
- -- remove the second half of disjunction when using a 1.3 prelude.
- --
- if isUpper f then ITconid pk_str
- else if isLower f then ITvarid pk_str
- else if f == ':' then ITconsym pk_str
- else if isLowerISO f then ITvarid pk_str
- else if isUpperISO f then ITconid pk_str
- else ITvarsym pk_str
-
-end_lex_id cont Nothing token buf = cont token buf
-end_lex_id cont (Just (m,hif)) token buf =
- case token of
- ITconid n -> cont (ITqconid (m,n,hif)) buf
- ITvarid n -> cont (ITqvarid (m,n,hif)) buf
- ITconsym n -> cont (ITqconsym (m,n,hif)) buf
-
- -- Special case for ->
- -- "->" by itself is a special token (ITrarrow),
- -- but M.-> is a ITqconid
- ITvarsym n | n == SLIT("->")
- -> cont (ITqconsym (m,n,hif)) buf
+ case lookupUFM haskellKeySymsFM lexeme of {
+ Just kwd_token -> just_a_conid; -- avoid M.:: etc.
+ Nothing -> cont (mk_qvar_token mod hif lexeme) new_buf
+ }}
+
+ | otherwise =
+ case expandWhile# is_ident buf of { buf1 ->
+ if emptyLexeme buf1
+ then just_a_conid
+ else
+ case expandWhile# (eqChar# '#'#) buf1 of { buf' -> -- only if GHC extns on
+ let
+ lexeme = lexemeToFastString buf'
+ new_buf = stepOverLexeme buf'
+ in
+ case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+ Just kwd_token -> just_a_conid; -- avoid M.where etc.
+ Nothing ->
+ case lookupUFM ifaceKeywordsFM lexeme of { -- only for iface files
+ Just kwd_token -> just_a_conid;
+ Nothing -> cont (mk_qvar_token mod hif lexeme) new_buf
+ }}}}
+ where c = currentChar# buf
+
+mk_var_token pk_str
+ | is_upper f = ITconid pk_str
+ -- _[A-Z] is treated as a constructor in interface files.
+ | f `eqChar#` '_'# && not (_NULL_ tl)
+ && (case _HEAD_ tl of { C# g -> is_upper g }) = ITconid pk_str
+ | is_ident f = ITvarid pk_str
+ | f `eqChar#` ':'# = ITconsym pk_str
+ | otherwise = ITvarsym pk_str
+ where
+ (C# f) = _HEAD_ pk_str
+ tl = _TAIL_ pk_str
+
+mk_qvar_token m hif token =
+ case mk_var_token token of
+ ITconid n -> ITqconid (m,n,hif)
+ ITvarid n -> ITqvarid (m,n,hif)
+ ITconsym n -> ITqconsym (m,n,hif)
+ ITvarsym n -> ITqvarsym (m,n,hif)
+ _ -> ITunknown (show token)
+\end{code}
- ITvarsym n -> cont (ITqvarsym (m,n,hif)) buf
+----------------------------------------------------------------------------
+Horrible stuff for dealing with M.(,,,)
+
+\begin{code}
+lex_tuple cont mod hif buf back_off =
+ go 2 buf
+ where
+ go n buf =
+ case currentChar# buf of
+ ','# -> go (n+1) (stepOn buf)
+ ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n),hif)) (stepOn buf)
+ _ -> back_off
--- ITbang can't happen here I think
--- ITbang -> cont (ITqvarsym (m,SLIT("!"),hif)) buf
+lex_ubx_tuple cont mod hif buf back_off =
+ go 2 buf
+ where
+ go n buf =
+ case currentChar# buf of
+ ','# -> go (n+1) (stepOn buf)
+ '#'# -> case lookAhead# buf 1# of
+ ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n), hif))
+ (stepOnBy# buf 2#)
+ _ -> back_off
+ _ -> back_off
+\end{code}
- _ -> cont (ITunknown (show token)) buf
+-----------------------------------------------------------------------------
+Keyword Lists
-------------
+\begin{code}
ifaceKeywordsFM :: UniqFM IfaceToken
ifaceKeywordsFM = listToUFM $
map (\ (x,y) -> (_PK_ x,y))
- [("/\\_", ITbiglam)
- ,("@_", ITatsign)
- ,("letrec_", ITletrec)
- ,("interface_", ITinterface)
- ,("usages_", ITusages)
- ,("versions_", ITversions)
- ,("exports_", ITexports)
- ,("instance_modules_", ITinstance_modules)
- ,("instances_", ITinstances)
- ,("fixities_", ITfixities)
- ,("declarations_", ITdeclarations)
- ,("pragmas_", ITpragmas)
- ,("forall_", ITforall)
- ,("u_", ITunfold False)
- ,("U_", ITunfold True)
- ,("A_", ITarity)
- ,("P_", ITspecialise)
- ,("coerce_", ITcoerce)
- ,("inline_", ITinline)
- ,("bot_", ITbottom)
- ,("integer_", ITinteger_lit)
- ,("rational_", ITrational_lit)
- ,("addr_", ITaddr_lit)
- ,("float_", ITfloat_lit)
- ,("string_", ITstring_lit)
- ,("litlit_", ITlit_lit)
- ,("ccall_", ITccall (False, False))
- ,("ccall_GC_", ITccall (False, True))
- ,("casm_", ITccall (True, False))
- ,("casm_GC_", ITccall (True, True))
+ [ ("__interface", ITinterface),
+ ("__export", ITexport),
+ ("__instimport", ITinstimport),
+ ("__forall", ITforall),
+ ("__letrec", ITletrec),
+ ("__coerce", ITcoerce),
+ ("__inline", ITinline),
+ ("__DEFAULT", ITdefaultbranch),
+ ("__bot", ITbottom),
+ ("__integer", ITinteger_lit),
+ ("__float", ITfloat_lit),
+ ("__rational", ITrational_lit),
+ ("__addr", ITaddr_lit),
+ ("__litlit", ITlit_lit),
+ ("__string", ITstring_lit),
+ ("__a", ITtypeapp),
+ ("__A", ITarity),
+ ("__P", ITspecialise),
+ ("__C", ITnocaf),
+ ("__u", ITunfold NoInlinePragInfo),
+ ("__U", ITunfold IWantToBeINLINEd),
+ ("__UU", ITunfold IMustBeINLINEd),
+ ("__Unot", ITunfold IMustNotBeINLINEd),
+ ("__Ux", ITunfold IAmALoopBreaker),
+
+ ("__ccall", ITccall (False, False)),
+ ("__ccall_GC", ITccall (False, True)),
+ ("__casm", ITccall (True, False)),
+ ("__casm_GC", ITccall (True, True)),
+
+ ("/\\", ITbiglam)
]
haskellKeywordsFM = listToUFM $
map (\ (x,y) -> (_PK_ x,y))
- [ ("data", ITdata)
- ,("type", ITtype)
- ,("newtype", ITnewtype)
- ,("class", ITclass)
- ,("where", ITwhere)
- ,("instance", ITinstance)
- ,("infixl", ITinfixl)
- ,("infixr", ITinfixr)
- ,("infix", ITinfix)
- ,("case", ITcase)
- ,("case#", ITprim_case)
- ,("of", ITof)
- ,("in", ITin)
- ,("let", ITlet)
-
- ,("->", ITrarrow)
+ [( "case", ITcase ),
+ ( "class", ITclass ),
+ ( "data", ITdata ),
+ ( "default", ITdefault ),
+ ( "deriving", ITderiving ),
+ ( "do", ITdo ),
+ ( "else", ITelse ),
+ ( "if", ITif ),
+ ( "import", ITimport ),
+ ( "in", ITin ),
+ ( "infix", ITinfix ),
+ ( "infixl", ITinfixl ),
+ ( "infixr", ITinfixr ),
+ ( "instance", ITinstance ),
+ ( "let", ITlet ),
+ ( "module", ITmodule ),
+ ( "newtype", ITnewtype ),
+ ( "of", ITof ),
+ ( "then", ITthen ),
+ ( "type", ITtype ),
+ ( "where", ITwhere ),
+ ( "as", ITas ),
+ ( "qualified", ITqualified ),
+ ( "hiding", IThiding )
+ ]
+
+haskellKeySymsFM = listToUFM $
+ map (\ (x,y) -> (_PK_ x,y))
+ [ ("..", ITdotdot)
+ ,("::", ITdcolon)
+ ,("=", ITequal)
,("\\", ITlam)
,("|", ITvbar)
- ,("!", ITbang)
+ ,("<-", ITlarrow)
+ ,("->", ITrarrow)
+ ,("@", ITat)
+ ,("~", ITtilde)
,("=>", ITdarrow)
- ,("=", ITequal)
- ,("::", ITdcolon)
+ ,("-", ITminus)
+ ,("!", ITbang)
]
+\end{code}
+-----------------------------------------------------------------------------
+doDiscard rips along really fast, looking for a '#-}',
+indicating the end of the pragma we're skipping
--- doDiscard rips along really fast, looking for a double semicolon,
--- indicating the end of the pragma we're skipping
+\begin{code}
doDiscard inStr buf =
--- _trace (show (C# (currentChar# buf))) $
case currentChar# buf of
- ';'# ->
- if not inStr then
- case lookAhead# buf 1# of
- ';'# -> incLexeme (incLexeme buf)
- _ -> doDiscard inStr (incLexeme buf)
- else
- doDiscard inStr (incLexeme buf)
+ '#'# | not inStr ->
+ case lookAhead# buf 1# of { '#'# ->
+ case lookAhead# buf 2# of { '-'# ->
+ case lookAhead# buf 3# of { '}'# ->
+ (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#));
+ _ -> doDiscard inStr (incLexeme buf) };
+ _ -> doDiscard inStr (incLexeme buf) };
+ _ -> doDiscard inStr (incLexeme buf) }
'"'# ->
let
odd_slashes buf flg i# =
\end{code}
-begin{code}
-my_span :: (a -> Bool) -> [a] -> ([a],[a])
-my_span p xs = go [] xs
- where
- go so_far (x:xs') | p x = go (x:so_far) xs'
- go so_far xs = (reverse so_far, xs)
-
-my_span' :: (a -> Bool) -> [a] -> ([a],Int,[a])
-my_span' p xs = go [] 0 xs
- where
- go so_far n (x:xs') | p x = go (x:so_far) (n+1) xs'
- go so_far n xs = (reverse so_far,n, xs)
-end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Other utility functions
-%* *
-%************************************************************************
+-----------------------------------------------------------------------------
\begin{code}
type IfM a = StringBuffer -- Input string
ifaceVersionErr hi_vers l toks
= hsep [ppr l, ptext SLIT("Interface file version error;"),
ptext SLIT("Expected"), int opt_HiVersion,
- ptext SLIT(" found "), pp_version]
+ ptext SLIT("found "), pp_version]
where
pp_version =
case hi_vers of
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PrefixSyn]{``Prefix-form'' syntax}
import HsSyn
import RdrHsSyn
-import BasicTypes ( IfaceFlavour )
import Util ( panic )
-import SrcLoc ( SrcLoc )
import Char ( isDigit, ord )
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax}
import PrefixSyn -- and various syntaxen.
import HsSyn
import RdrHsSyn
-import HsPragmas ( noGenPragmas, noClassOpPragmas )
import BasicTypes ( RecFlag(..) )
import SrcLoc ( mkSrcLoc )
RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS
-cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl)
+cvGRHS sf sl (g, e) = GRHS (g ++ [ExprStmt e locn]) locn
+ where
+ locn = mkSrcLoc sf sl
\end{code}
%************************************************************************
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
extractHsTyVars, extractHsCtxtTyVars,
RdrName(..),
- qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
+ qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
+ mkTupConRdrName, mkUbxTupConRdrName,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
- showRdr, rdrNameOcc, rdrNameModule, ieOcc,
+ rdrNameOcc, rdrNameModule, ieOcc,
cmpRdr, prefixRdrName,
mkOpApp, mkClassDecl, isClassDataConRdrName
#include "HsVersions.h"
import HsSyn
-import Lex
import BasicTypes ( Module, IfaceFlavour(..), Unused )
import Name ( pprModule, OccName(..), pprOccName,
- prefixOccName, NamedThing(..) )
+ mkTupNameStr, mkUbxTupNameStr,
+ prefixOccName, NamedThing(..),
+ mkClassTyConStr, mkClassDataConStr )
import Util ( thenCmp )
import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
import List ( nub )
extractHsCtxtTyVars :: Context RdrName -> [RdrName]
extractHsCtxtTyVars ty = nub (extract_ctxt ty [])
-extract_ctxt ctxt acc = foldr extract_ass [] ctxt
+extract_ctxt ctxt acc = foldr extract_ass acc ctxt
where
extract_ass (cls, tys) acc = foldr extract_ty acc tys
-extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy tc ty) acc = extract_ty ty acc
-extract_ty (MonoTupleTy tc tys) acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys
-extract_ty (MonoTyVar tv) acc = insert tv acc
-
- -- In (All a => a -> a) -> Int, there are no free tyvars
- -- We just assume that we quantify over all type variables mentioned in the context.
-extract_ty (HsPreForAllTy ctxt ty) acc = filter (`notElem` locals) (extract_ty ty [])
- ++ acc
- where
- locals = extract_ctxt ctxt []
-
+extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoListTy ty) acc = extract_ty ty acc
+extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
+extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys
+extract_ty (MonoTyVar tv) acc = insert tv acc
extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
(filter (`notElem` locals) $
extract_ctxt ctxt (extract_ty ty []))
where
locals = map getTyVarName tvs
-
insert (Qual _ _ _) acc = acc
insert (Unqual (TCOcc _)) acc = acc
insert other acc = other : acc
(dname, tname) = case cname of
Qual m (TCOcc s) hif -> (Qual m (VarOcc s1) hif, Qual m (TCOcc s1) hif)
where
- s1 = SLIT(":") _APPEND_ s
+ s1 = mkClassTyConStr s
Unqual (TCOcc s) -> (Unqual (VarOcc s1), Unqual (TCOcc s1))
where
- s1 = SLIT(":") _APPEND_ s
+ s1 = mkClassDataConStr s
-- This nasty little function tests for whether a RdrName was
-- constructed by the above process. It's used only for filtering
tcQual (m,n) = Qual m (TCOcc n) HiFile
varQual (m,n) = Qual m (VarOcc n) HiFile
+mkTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor
+ -- Hence VarOcc
+mkTupConRdrName arity = case mkTupNameStr arity of
+ (mod, occ) -> Qual mod (VarOcc occ) HiFile
+
+mkUbxTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor
+ -- Hence VarOcc
+mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of
+ (mod, occ) -> Qual mod (VarOcc occ) HiFile
+
lexTcQual (m,n,hif) = Qual m (TCOcc n) hif
lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
isQual (Unqual _) = False
isQual (Qual _ _ _) = True
+
-- Used for adding a prefix to a RdrName
prefixRdrName :: FAST_STRING -> RdrName -> RdrName
prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
ieOcc :: RdrNameIE -> OccName
ieOcc ie = rdrNameOcc (ieName ie)
-instance Text RdrName where -- debugging
- showsPrec _ rn = showString (showSDoc (ppr rn))
+instance Show RdrName where -- debugging
+ showsPrec p rn = showsPrecSDoc p (ppr rn)
instance Eq RdrName where
a == b = case (a `compare` b) of { EQ -> True; _ -> False }
instance NamedThing RdrName where -- Just so that pretty-printing of expressions works
getOccName = rdrNameOcc
getName = panic "no getName for RdrNames"
-
-showRdr rdr = showSDoc (ppr rdr)
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section{Read parse tree built by Yacc parser}
import PrefixSyn -- and various syntaxen.
import HsSyn
import HsTypes ( HsTyVar(..) )
-import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
+import HsPragmas ( noDataPragmas, noClassPragmas )
import RdrHsSyn
import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
import PrefixToHs
import CallConv
-import CmdLineOpts ( opt_NoImplicitPrelude )
-import FiniteMap ( elemFM, FiniteMap )
-import Name ( OccName(..), Module )
-import Lex ( isLexConId )
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
+import Name ( OccName(..), Module, isLexConId )
import Outputable
import PrelMods ( pRELUDE )
-import Util ( nOfThem )
import FastString ( mkFastCharString )
-import IO ( hPutStr, stderr )
import PrelRead ( readRational__ )
\end{code}
\end{code}
\begin{code}
-wlkTvId = wlkQid TvOcc
wlkTCId = wlkQid TCOcc
wlkVarId = wlkQid VarOcc
wlkDataId = wlkQid VarOcc
| otherwise
= returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
-rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
+
+rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
+rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
+wlkTvId string = returnUgn (Unqual (TvOcc string))
+
cvFlag :: U_long -> Bool
cvFlag 0 = False
cvFlag 1 = True
U_restr restre restrt -> -- expression with type signature
wlkExpr restre `thenUgn` \ expr ->
- wlkHsType restrt `thenUgn` \ ty ->
+ wlkHsSigType restrt `thenUgn` \ ty ->
returnUgn (ExprWithTySig expr ty)
--------------------------------------------------------------
U_tuple tuplelist -> -- explicit tuple
wlkList rdExpr tuplelist `thenUgn` \ exprs ->
- returnUgn (ExplicitTuple exprs)
+ returnUgn (ExplicitTuple exprs True)
+
+ U_utuple tuplelist -> -- explicit tuple
+ wlkList rdExpr tuplelist `thenUgn` \ exprs ->
+ returnUgn (ExplicitTuple exprs False)
U_record con rbinds -> -- record construction
wlkDataId con `thenUgn` \ rcon ->
wlkList rdRbind rbinds `thenUgn` \ recbinds ->
- returnUgn (RecordCon rcon (HsVar rcon) recbinds)
+ returnUgn (RecordCon rcon recbinds)
U_rupdate updexp updbinds -> -- record update
wlkExpr updexp `thenUgn` \ aexp ->
U_tuple tuplelist -> -- explicit tuple
wlkList rdPat tuplelist `thenUgn` \ pats ->
- returnUgn (TuplePatIn pats)
+ returnUgn (TuplePatIn pats True)
+
+ U_utuple tuplelist -> -- explicit tuple
+ wlkList rdPat tuplelist `thenUgn` \ pats ->
+ returnUgn (TuplePatIn pats False)
U_record con rpats -> -- record destruction
wlkDataId con `thenUgn` \ rcon ->
U_nbind nbindid nbindas srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
- wlkMonoType nbindas `thenUgn` \ expansion ->
+ wlkHsType nbindas `thenUgn` \ expansion ->
returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
-- function binding
wlk_sig_thing (U_sbind sbindids sbindid srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdVarId sbindids `thenUgn` \ vars ->
- wlkHsType sbindid `thenUgn` \ poly_ty ->
+ wlkHsSigType sbindid `thenUgn` \ poly_ty ->
returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
-- value specialisation user-pragma
rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
rd_ty_and_id pt
= rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
- wlkHsType vspec_ty `thenUgn` \ ty ->
+ wlkHsSigType vspec_ty `thenUgn` \ ty ->
wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
returnUgn(ty, id_maybe)
-- instance specialisation user-pragma
wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkHsType ispec_ty `thenUgn` \ ty ->
+ wlkHsSigType ispec_ty `thenUgn` \ ty ->
returnUgn (RdrSig (SpecInstSig ty src_loc))
-- value inlining user-pragma
rdHsType :: ParseTree -> UgnM RdrNameHsType
rdMonoType :: ParseTree -> UgnM RdrNameHsType
-rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
-rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
+rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
+rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
+
+wlkHsConstrArgType ttype
+ -- Used for the argument types of contructors
+ -- Only an implicit quantification point if -fglasgow-exts
+ | opt_GlasgowExts = wlkHsSigType ttype
+ | otherwise = wlkHsType ttype
+
+ -- wlkHsSigType is used for type signatures: any place there
+ -- should be *implicit* quantification
+wlkHsSigType ttype
+ = wlkHsType ttype `thenUgn` \ ty ->
+ -- This is an implicit quantification point, so
+ -- make sure it starts with a ForAll
+ case ty of
+ HsForAllTy _ _ _ -> returnUgn ty
+ other -> returnUgn (HsForAllTy [] [] ty)
wlkHsType :: U_ttype -> UgnM RdrNameHsType
-wlkMonoType :: U_ttype -> UgnM RdrNameHsType
-
wlkHsType ttype
= case ttype of
- U_context tcontextl tcontextt -> -- context
- wlkContext tcontextl `thenUgn` \ ctxt ->
- wlkMonoType tcontextt `thenUgn` \ ty ->
- returnUgn (HsPreForAllTy ctxt ty)
-
- other -> -- something else
- wlkMonoType other `thenUgn` \ ty ->
- returnUgn (HsPreForAllTy [{-no context-}] ty)
-
-wlkMonoType ttype
- = case ttype of
- -- Glasgow extension: nested polymorhism
- U_context tcontextl tcontextt -> -- context
- wlkContext tcontextl `thenUgn` \ ctxt ->
- wlkMonoType tcontextt `thenUgn` \ ty ->
- returnUgn (HsPreForAllTy ctxt ty)
+ U_forall u_tyvars u_theta u_ty -> -- context
+ wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkHsType u_ty `thenUgn` \ ty ->
+ returnUgn (HsForAllTy (map UserTyVar tyvars) theta ty)
U_namedtvar tv -> -- type variable
wlkTvId tv `thenUgn` \ tyvar ->
returnUgn (MonoTyVar tycon)
U_tapp t1 t2 ->
- wlkMonoType t1 `thenUgn` \ ty1 ->
- wlkMonoType t2 `thenUgn` \ ty2 ->
+ wlkHsType t1 `thenUgn` \ ty1 ->
+ wlkHsType t2 `thenUgn` \ ty2 ->
returnUgn (MonoTyApp ty1 ty2)
U_tllist tlist -> -- list type
- wlkMonoType tlist `thenUgn` \ ty ->
- returnUgn (MonoListTy dummyRdrTcName ty)
+ wlkHsType tlist `thenUgn` \ ty ->
+ returnUgn (MonoListTy ty)
U_ttuple ttuple ->
wlkList rdMonoType ttuple `thenUgn` \ tys ->
- returnUgn (MonoTupleTy dummyRdrTcName tys)
+ returnUgn (MonoTupleTy tys True)
+
+ U_tutuple ttuple ->
+ wlkList rdMonoType ttuple `thenUgn` \ tys ->
+ returnUgn (MonoTupleTy tys False)
U_tfun tfun targ ->
- wlkMonoType tfun `thenUgn` \ ty1 ->
- wlkMonoType targ `thenUgn` \ ty2 ->
+ wlkHsType tfun `thenUgn` \ ty1 ->
+ wlkHsType targ `thenUgn` \ ty2 ->
returnUgn (MonoFunTy ty1 ty2)
wlkInstType ttype
= case ttype of
- U_context tcontextl tcontextt -> -- context
- wlkContext tcontextl `thenUgn` \ ctxt ->
- wlkConAndTys tcontextt `thenUgn` \ (clas, tys) ->
- returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys))
+ U_forall u_tyvars u_theta inst_head ->
+ wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkConAndTys inst_head `thenUgn` \ (clas, tys) ->
+ returnUgn (HsForAllTy (map UserTyVar tyvars) theta (MonoDictTy clas tys))
other -> -- something else
wlkConAndTys other `thenUgn` \ (clas, tys) ->
- returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys))
+ returnUgn (HsForAllTy [] [] (MonoDictTy clas tys))
\end{code}
\begin{code}
-wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
+wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
wlkConAndTyVars ttype
- = wlkMonoType ttype `thenUgn` \ ty ->
+ = wlkHsType ttype `thenUgn` \ ty ->
let
split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
split (MonoTyVar tycon) args = (tycon,args)
wlkConAndTys ttype
wlkConAndTys ttype
- = wlkMonoType ttype `thenUgn` \ ty ->
+ = wlkHsType ttype `thenUgn` \ ty ->
let
split (MonoTyApp fun ty) tys = split fun (ty : tys)
split (MonoTyVar tycon) tys = (tycon, tys)
wlkConDecl :: U_constr -> UgnM RdrNameConDecl
-wlkConDecl (U_constrcxt ccxt ccdecl)
- = wlkContext ccxt `thenUgn` \ theta ->
- wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
- returnUgn (ConDecl con theta details loc)
+wlkConDecl (U_constrex u_tvs ccxt ccdecl)
+ = wlkList rdTvId u_tvs `thenUgn` \ tyvars ->
+ wlkContext ccxt `thenUgn` \ theta ->
+ wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ _ details loc) ->
+ returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc)
wlkConDecl (U_constrpre ccon ctys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkDataId ccon `thenUgn` \ con ->
wlkList rdBangType ctys `thenUgn` \ tys ->
- returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
+ returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
wlkConDecl (U_constrinf cty1 cop cty2 srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkBangType cty1 `thenUgn` \ ty1 ->
wlkDataId cop `thenUgn` \ op ->
wlkBangType cty2 `thenUgn` \ ty2 ->
- returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
+ returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
wlkConDecl (U_constrnew ccon cty srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkDataId ccon `thenUgn` \ con ->
- wlkMonoType cty `thenUgn` \ ty ->
- returnUgn (ConDecl con [] (NewCon ty) src_loc)
+ wlkHsSigType cty `thenUgn` \ ty ->
+ returnUgn (ConDecl con [] [] (NewCon ty) src_loc)
wlkConDecl (U_constrrec ccon cfields srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkDataId ccon `thenUgn` \ con ->
wlkList rd_field cfields `thenUgn` \ fields_lists ->
- returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
+ returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
where
rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
rd_field pt
wlkBangType :: U_ttype -> UgnM (BangType RdrName)
-wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
+wlkBangType (U_tbang bty) = wlkHsConstrArgType bty `thenUgn` \ ty ->
returnUgn (Banged ty)
-wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
+wlkBangType uty = wlkHsConstrArgType uty `thenUgn` \ ty ->
returnUgn (Unbanged ty)
\end{code}
import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsTypes ( mkHsForAllTy )
import HsCore
-import Literal
-import BasicTypes ( IfaceFlavour(..), Fixity(..), FixityDirection(..), NewOrData(..), Version )
+import Const ( Literal(..), mkMachInt_safe )
+import BasicTypes ( IfaceFlavour(..), Fixity(..), FixityDirection(..),
+ NewOrData(..), Version
+ )
import HsPragmas ( noDataPragmas, noClassPragmas )
-import Kind ( Kind, mkArrowKind, mkBoxedTypeKind, mkTypeKind )
-import IdInfo ( ArgUsageInfo, FBTypeInfo, ArityInfo, exactArity )
-import PrimRep ( decodePrimRep )
+import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind )
+import IdInfo ( ArityInfo, exactArity )
import Lex
import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..),
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) )
+import Name ( OccName(..), isTCOcc, Provenance, Module,
+ mkTupNameStr, mkUbxTupNameStr
+ )
import SrcLoc ( SrcLoc )
import Maybes
import Outputable
+import GlaExts
}
%name parseIface
%lexer { lexIface } { ITeof }
%token
- INTERFACE { ITinterface }
- USAGES_PART { ITusages }
- EXPORTS_PART { ITexports }
- INSTANCE_MODULES_PART { ITinstance_modules }
- INSTANCES_PART { ITinstances }
- FIXITIES_PART { ITfixities }
- DECLARATIONS_PART { ITdeclarations }
- DATA { ITdata }
- TYPE { ITtype }
- NEWTYPE { ITnewtype }
- CLASS { ITclass }
- WHERE { ITwhere }
- INSTANCE { ITinstance }
- INFIXL { ITinfixl }
- INFIXR { ITinfixr }
- INFIX { ITinfix }
- FORALL { ITforall }
- BANG { ITbang }
- VBAR { ITvbar }
- DCOLON { ITdcolon }
- COMMA { ITcomma }
- DARROW { ITdarrow }
- EQUAL { ITequal }
- OCURLY { ITocurly }
- OBRACK { ITobrack }
- OPAREN { IToparen }
- RARROW { ITrarrow }
- CCURLY { ITccurly }
- CBRACK { ITcbrack }
- CPAREN { ITcparen }
- SEMI { ITsemi }
-
- VARID { ITvarid $$ }
- CONID { ITconid $$ }
- VARSYM { ITvarsym $$ }
- CONSYM { ITconsym $$ }
- QVARID { ITqvarid $$ }
- QCONID { ITqconid $$ }
- QVARSYM { ITqvarsym $$ }
- QCONSYM { ITqconsym $$ }
-
- STRICT_PART { ITstrict $$ }
- TYPE_PART { ITtysig _ _ }
- ARITY_PART { ITarity }
- UNFOLD_PART { ITunfold $$ }
- SPECIALISE { ITspecialise }
- BOTTOM { ITbottom }
- LAM { ITlam }
- BIGLAM { ITbiglam }
- CASE { ITcase }
- PRIM_CASE { ITprim_case }
- LET { ITlet }
- LETREC { ITletrec }
- IN { ITin }
- OF { ITof }
- COERCE { ITcoerce }
- ATSIGN { ITatsign }
- CCALL { ITccall $$ }
- SCC { ITscc $$ }
- INLINE_CALL { ITinline }
-
- CHAR { ITchar $$ }
- STRING { ITstring $$ }
- INTEGER { ITinteger $$ }
- RATIONAL { ITrational $$ }
-
- INTEGER_LIT { ITinteger_lit }
- FLOAT_LIT { ITfloat_lit }
- RATIONAL_LIT { ITrational_lit }
- ADDR_LIT { ITaddr_lit }
- LIT_LIT { ITlit_lit }
- STRING_LIT { ITstring_lit }
-
- UNKNOWN { ITunknown $$ }
+ 'case' { ITcase } -- Haskell keywords
+ 'class' { ITclass }
+ 'data' { ITdata }
+ 'default' { ITdefault }
+ 'deriving' { ITderiving }
+ 'do' { ITdo }
+ 'else' { ITelse }
+ 'if' { ITif }
+ 'import' { ITimport }
+ 'in' { ITin }
+ 'infix' { ITinfix }
+ 'infixl' { ITinfixl }
+ 'infixr' { ITinfixr }
+ 'instance' { ITinstance }
+ 'let' { ITlet }
+ 'module' { ITmodule }
+ 'newtype' { ITnewtype }
+ 'of' { ITof }
+ 'then' { ITthen }
+ 'type' { ITtype }
+ 'where' { ITwhere }
+ 'as' { ITas }
+ 'qualified' { ITqualified }
+ 'hiding' { IThiding }
+
+ '__interface' { ITinterface } -- GHC-extension keywords
+ '__export' { ITexport }
+ '__instimport' { ITinstimport }
+ '__forall' { ITforall }
+ '__letrec' { ITletrec }
+ '__coerce' { ITcoerce }
+ '__inline' { ITinline }
+ '__DEFAULT' { ITdefaultbranch }
+ '__bot' { ITbottom }
+ '__integer' { ITinteger_lit }
+ '__float' { ITfloat_lit }
+ '__rational' { ITrational_lit }
+ '__addr' { ITaddr_lit }
+ '__litlit' { ITlit_lit }
+ '__string' { ITstring_lit }
+ '__ccall' { ITccall $$ }
+ '__scc' { ITscc $$ }
+ '__a' { ITtypeapp }
+
+ '__A' { ITarity }
+ '__P' { ITspecialise }
+ '__C' { ITnocaf }
+ '__U' { ITunfold $$ }
+ '__S' { ITstrict $$ }
+
+ '..' { ITdotdot } -- reserved symbols
+ '::' { ITdcolon }
+ '=' { ITequal }
+ '\\' { ITlam }
+ '|' { ITvbar }
+ '<-' { ITlarrow }
+ '->' { ITrarrow }
+ '@' { ITat }
+ '~' { ITtilde }
+ '=>' { ITdarrow }
+ '-' { ITminus }
+ '!' { ITbang }
+
+ '/\\' { ITbiglam } -- GHC-extension symbols
+
+ '{' { ITocurly } -- special symbols
+ '}' { ITccurly }
+ '[' { ITobrack }
+ ']' { ITcbrack }
+ '(' { IToparen }
+ ')' { ITcparen }
+ '(#' { IToubxparen }
+ '#)' { ITcubxparen }
+ ';' { ITsemi }
+ ',' { ITcomma }
+
+ VARID { ITvarid $$ } -- identifiers
+ CONID { ITconid $$ }
+ VARSYM { ITvarsym $$ }
+ CONSYM { ITconsym $$ }
+ QVARID { ITqvarid $$ }
+ QCONID { ITqconid $$ }
+ QVARSYM { ITqvarsym $$ }
+ QCONSYM { ITqconsym $$ }
+
+ PRAGMA { ITpragma $$ }
+
+ CHAR { ITchar $$ }
+ STRING { ITstring $$ }
+ INTEGER { ITinteger $$ }
+ RATIONAL { ITrational $$ }
+
+ UNKNOWN { ITunknown $$ }
%%
-- iface_stuff is the main production.
iface :: { ParsedIface }
-iface : INTERFACE CONID INTEGER checkVersion
- inst_modules_part
- usages_part
- exports_part fixities_part
- instances_part
+iface : '__interface' CONID INTEGER checkVersion 'where'
+ import_part
+ instance_import_part
+ exports_part
+ fixities_part
+ instance_decl_part
decls_part
{ ParsedIface
$2 -- Module name
(fromInteger $3) -- Module version
- $6 -- Usages
- $7 -- Exports
- $5 -- Instance modules
- $8 -- Fixities
- $10 -- Decls
- $9 -- Local instances
- }
+ (reverse $6) -- Usages
+ (reverse $8) -- Exports
+ (reverse $7) -- Instance import modules
+ (reverse $9) -- Fixities
+ (reverse $11) -- Decls
+ (reverse $10) -- Local instances
+ }
+--------------------------------------------------------------------------
-usages_part :: { [ImportVersion OccName] }
-usages_part : USAGES_PART module_stuff_pairs { $2 }
- | { [] }
-
-module_stuff_pairs :: { [ImportVersion OccName] }
-module_stuff_pairs : { [] }
- | module_stuff_pair module_stuff_pairs { $1 : $2 }
-
-module_stuff_pair :: { ImportVersion OccName }
-module_stuff_pair : mod_name opt_bang INTEGER DCOLON whats_imported SEMI
- { ($1, $2, fromInteger $3, $5) }
+import_part :: { [ImportVersion OccName] }
+import_part : { [] }
+ | import_part import_decl { $2 : $1 }
+
+import_decl :: { ImportVersion OccName }
+import_decl : 'import' mod_name opt_bang INTEGER '::' whats_imported ';'
+ { ($2, $3, fromInteger $4, $6) }
whats_imported :: { WhatsImported OccName }
whats_imported : { Everything }
| name_version_pair name_version_pairs { $1 : $2 }
name_version_pair :: { LocalVersion OccName }
-name_version_pair : entity_occ INTEGER { ($1, fromInteger $2)
+name_version_pair : entity_occ INTEGER { ($1, fromInteger $2) }
+
+instance_import_part :: { [Module] }
+instance_import_part : { [] }
+ | instance_import_part '__instimport' mod_name ';'
+ { $3 : $1 }
+
--------------------------------------------------------------------------
- }
exports_part :: { [ExportItem] }
-exports_part : EXPORTS_PART export_items { $2 }
- | { [] }
-
-export_items :: { [ExportItem] }
-export_items : { [] }
- | opt_bang mod_name entities SEMI export_items { ($2,$1,$3) : $5 }
+exports_part : { [] }
+ | exports_part '__export' opt_bang mod_name entities ';'
+ { ($4,$3,$5) : $1 }
opt_bang :: { IfaceFlavour }
opt_bang : { HiFile }
- | BANG { HiBootFile }
+ | '!' { HiBootFile }
entities :: { [RdrAvailInfo] }
entities : { [] }
then AvailTC $1 [$1]
else Avail $1 }
| entity_occ stuff_inside { AvailTC $1 ($1:$2) }
- | entity_occ VBAR stuff_inside { AvailTC $1 $3 }
+ | entity_occ '|' stuff_inside { AvailTC $1 $3 }
stuff_inside :: { [OccName] }
-stuff_inside : OPAREN val_occs CPAREN { $2
+stuff_inside : '{' val_occs '}' { $2 }
+
--------------------------------------------------------------------------
- }
-inst_modules_part :: { [Module] }
-inst_modules_part : { [] }
- | INSTANCE_MODULES_PART mod_list { $2 }
+fixities_part :: { [(OccName,Fixity)] }
+fixities_part : { [] }
+ | fixities_part fixity_decl ';' { $2 : $1 }
-mod_list :: { [Module] }
-mod_list : { [] }
- | mod_name mod_list { $1 : $2
---------------------------------------------------------------------------
- }
+fixity_decl :: { (OccName,Fixity) }
+fixity_decl : 'infixl' mb_fix val_occ { ($3, Fixity $2 InfixL) }
+ | 'infixr' mb_fix val_occ { ($3, Fixity $2 InfixR) }
+ | 'infix' mb_fix val_occ { ($3, Fixity $2 InfixN) }
-fixities_part :: { [(OccName,Fixity)] }
-fixities_part : { [] }
- | FIXITIES_PART fixes { $2 }
+mb_fix :: { Int }
+mb_fix : {-nothing-} { 9 }
+ | INTEGER { (fromInteger $1) }
-fixes :: { [(OccName,Fixity)] }
-fixes : { [] }
- | fix fixes { $1 : $2 }
+-----------------------------------------------------------------------------
+
+csigs :: { [RdrNameSig] }
+csigs : { [] }
+ | 'where' '{' csigs1 '}' { $3 }
+
+csigs1 :: { [RdrNameSig] }
+csigs1 : csig { [$1] }
+ | csig ';' csigs1 { $1 : $3 }
+
+csig :: { RdrNameSig }
+csig : src_loc var_name '::' type { ClassOpSig $2 Nothing $4 $1 }
+ | src_loc var_name '=' '::' type
+ { ClassOpSig $2
+ (Just (error "Un-filled-in default method"))
+ $5 $1 }
-fix :: { (OccName, Fixity) }
-fix : INFIXL INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixL) }
- | INFIXR INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixR) }
- | INFIX INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixN)
--------------------------------------------------------------------------
- }
-decls_part :: { [(Version, RdrNameHsDecl)] }
-decls_part : { [] }
- | DECLARATIONS_PART topdecls { $2 }
+instance_decl_part :: { [RdrNameInstDecl] }
+instance_decl_part : {- empty -} { [] }
+ | instance_decl_part inst_decl { $2 : $1 }
-topdecls :: { [(Version, RdrNameHsDecl)] }
-topdecls : { [] }
- | version topdecl topdecls { ($1,$2) : $3 }
+inst_decl :: { RdrNameInstDecl }
+inst_decl : src_loc 'instance' type '=' var_name ';'
+ { InstDecl $3
+ EmptyMonoBinds {- No bindings -}
+ [] {- No user pragmas -}
+ (Just $5) {- Dfun id -}
+ $1
+ }
-version :: { Version }
-version : INTEGER { fromInteger $1 }
+--------------------------------------------------------------------------
-topdecl :: { RdrNameHsDecl }
-topdecl : src_loc TYPE tc_name tv_bndrs EQUAL type SEMI
+decls_part :: { [(Version, RdrNameHsDecl)] }
+decls_part
+ : {- empty -} { [] }
+ | decls_part version decl ';' { ($2,$3):$1 }
+
+decl :: { RdrNameHsDecl }
+decl : src_loc var_name '::' type maybe_idinfo
+ { SigD (IfaceSig $2 $4 ($5 $2) $1) }
+ | src_loc 'type' tc_name tv_bndrs '=' type
{ TyD (TySynonym $3 $4 $6 $1) }
- | src_loc DATA decl_context tc_name tv_bndrs constrs SEMI
- { TyD (TyData DataType $3 $4 $5 $6 Nothing noDataPragmas $1) }
- | src_loc NEWTYPE decl_context tc_name tv_bndrs newtype_constr SEMI
+ | src_loc 'data' decl_context data_fs tv_bndrs constrs
+ { TyD (TyData DataType $3 (Unqual (TCOcc $4)) $5 $6 Nothing noDataPragmas $1) }
+ | src_loc 'newtype' decl_context tc_name tv_bndrs newtype_constr
{ TyD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) }
- | src_loc CLASS decl_context tc_name tv_bndrs csigs SEMI
- { ClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds noClassPragmas $1) }
- | src_loc var_name TYPE_PART
- {
- case $3 of
- ITtysig sig idinfo_part -> -- Parse type and idinfo lazily
- let info =
- case idinfo_part of
- Nothing -> []
- Just s -> case parseIface s $1 of
- Succeeded (PIdInfo id_info) -> id_info
- other -> pprPanic "IdInfo parse failed"
- (ppr $2)
-
- tp = case parseIface sig $1 of
- Succeeded (PType tp) -> tp
- other -> pprPanic "Id type parse failed"
- (ppr $2)
- in
- SigD (IfaceSig $2 tp info $1) }
+ | src_loc 'class' decl_context tc_name tv_bndrs csigs
+ { ClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds
+ noClassPragmas $1) }
+maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
+maybe_idinfo : {- empty -} { \_ -> [] }
+ | src_loc PRAGMA { \x ->
+ case parseIface $2 $1 of
+ Succeeded (PIdInfo id_info) -> id_info
+ other -> pprPanic "IdInfo parse failed"
+ (ppr x)
+ }
+
+-----------------------------------------------------------------------------
+
+version :: { Version }
+version : INTEGER { fromInteger $1 }
decl_context :: { RdrNameContext }
decl_context : { [] }
- | OCURLY context_list1 CCURLY DARROW { $2 }
-
-
-csigs :: { [RdrNameSig] }
-csigs : { [] }
- | WHERE OCURLY csigs1 CCURLY { $3 }
-
-csigs1 :: { [RdrNameSig] }
-csigs1 : csig { [$1] }
- | csig SEMI csigs1 { $1 : $3 }
+ | '{' context_list1 '}' '=>' { $2 }
-csig :: { RdrNameSig }
-csig : src_loc var_name DCOLON type { ClassOpSig $2 Nothing $4 $1 }
- | src_loc var_name EQUAL DCOLON type { ClassOpSig $2
- (Just (error "Un-filled-in default method"))
- $5 $1 }
----------------------------------------------------------------
-
constrs :: { [RdrNameConDecl] {- empty for handwritten abstract -} }
- : { [] }
- | EQUAL constrs1 { $2 }
+ : { [] }
+ | '=' constrs1 { $2 }
constrs1 :: { [RdrNameConDecl] }
constrs1 : constr { [$1] }
- | constr VBAR constrs1 { $1 : $3 }
+ | constr '|' constrs1 { $1 : $3 }
constr :: { RdrNameConDecl }
-constr : src_loc data_name batypes { ConDecl $2 [] (VanillaCon $3) $1 }
- | src_loc data_name OCURLY fields1 CCURLY { ConDecl $2 [] (RecCon $4) $1 }
+constr : src_loc ex_stuff data_fs batypes { mkConDecl (Unqual (VarOcc $3)) $2 (VanillaCon $4) $1 }
+ | src_loc ex_stuff data_fs '{' fields1 '}' { mkConDecl (Unqual (VarOcc $3)) $2 (RecCon $5) $1 }
+ -- We use "data_fs" so as to include ()
newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} }
newtype_constr : { [] }
- | src_loc EQUAL data_name atype { [ConDecl $3 [] (NewCon $4) $1] }
+ | src_loc '=' ex_stuff data_name atype { [mkConDecl $4 $3 (NewCon $5) $1] }
+
+ex_stuff :: { ([HsTyVar RdrName], RdrNameContext) }
+ex_stuff : { ([],[]) }
+ | '__forall' forall context '=>' { ($2,$3) }
batypes :: { [RdrNameBangType] }
batypes : { [] }
batype :: { RdrNameBangType }
batype : atype { Unbanged $1 }
- | BANG atype { Banged $2 }
+ | '!' atype { Banged $2 }
fields1 :: { [([RdrName], RdrNameBangType)] }
fields1 : field { [$1] }
- | field COMMA fields1 { $1 : $3 }
+ | field ',' fields1 { $1 : $3 }
field :: { ([RdrName], RdrNameBangType) }
-field : var_names1 DCOLON type { ($1, Unbanged $3) }
- | var_names1 DCOLON BANG type { ($1, Banged $4) }
+field : var_names1 '::' type { ($1, Unbanged $3) }
+ | var_names1 '::' '!' type { ($1, Banged $4) }
--------------------------------------------------------------------------
type :: { RdrNameHsType }
-type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
- | btype RARROW type { MonoFunTy $1 $3 }
- | btype { $1 }
+type : '__forall' forall context '=>' type
+ { mkHsForAllTy $2 $3 $5 }
+ | btype '->' type { MonoFunTy $1 $3 }
+ | btype { $1 }
forall :: { [HsTyVar RdrName] }
-forall : OBRACK tv_bndrs CBRACK { $2 }
+forall : '[' tv_bndrs ']' { $2 }
context :: { RdrNameContext }
context : { [] }
- | OCURLY context_list1 CCURLY { $2 }
+ | '{' context_list1 '}' { $2 }
context_list1 :: { RdrNameContext }
context_list1 : class { [$1] }
- | class COMMA context_list1 { $1 : $3 }
+ | class ',' context_list1 { $1 : $3 }
class :: { (RdrName, [RdrNameHsType]) }
-class : tc_name atypes { ($1, $2) }
+class : qtc_name atypes { ($1, $2) }
types2 :: { [RdrNameHsType] {- Two or more -} }
-types2 : type COMMA type { [$1,$3] }
- | type COMMA types2 { $1 : $3 }
+types2 : type ',' type { [$1,$3] }
+ | type ',' types2 { $1 : $3 }
btype :: { RdrNameHsType }
btype : atype { $1 }
| btype atype { MonoTyApp $1 $2 }
atype :: { RdrNameHsType }
-atype : tc_name { MonoTyVar $1 }
+atype : qtc_name { MonoTyVar $1 }
| tv_name { MonoTyVar $1 }
- | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
- | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
- | OCURLY tc_name atypes CCURLY { MonoDictTy $2 $3 }
- | OPAREN type CPAREN { $2 }
+ | '(' ')' { MonoTupleTy [] True }
+ | '(' types2 ')' { MonoTupleTy $2 True{-boxed-} }
+ | '(#' type '#)' { MonoTupleTy [$2] False{-unboxed-} }
+ | '(#' types2 '#)' { MonoTupleTy $2 False{-unboxed-} }
+ | '[' type ']' { MonoListTy $2 }
+ | '{' qtc_name atypes '}' { MonoDictTy $2 $3 }
+ | '(' type ')' { $2 }
atypes :: { [RdrNameHsType] {- Zero or more -} }
atypes : { [] }
mod_name :: { Module }
: CONID { $1 }
-var_occ :: { OccName }
-var_occ : VARID { VarOcc $1 }
- | VARSYM { VarOcc $1 }
- | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
+var_fs :: { FAST_STRING }
+ : VARID { $1 }
+ | VARSYM { $1 }
+ | '-' { SLIT("-") }
+ | '!' { SLIT("!") }
-tc_occ :: { OccName }
-tc_occ : CONID { TCOcc $1 }
- | CONSYM { TCOcc $1 }
- | OPAREN RARROW CPAREN { TCOcc SLIT("->") }
+data_fs :: { FAST_STRING }
+ : CONID { $1 }
+ | CONSYM { $1 }
+ | '->' { SLIT("->") }
+ | '(' ')' { SLIT("()") }
+ | '(' commas ')' { snd (mkTupNameStr $2) }
+ | '[' ']' { SLIT("[]") }
-entity_occ :: { OccName }
-entity_occ : var_occ { $1 }
- | tc_occ { $1 }
- | RARROW { TCOcc SLIT("->") {- Allow un-paren'd arrow -} }
+commas :: { Int }
+ : ',' { 2 }
+ | commas ',' { $1 + 1 }
val_occ :: { OccName }
-val_occ : var_occ { $1 }
- | CONID { VarOcc $1 }
- | CONSYM { VarOcc $1 }
+ : var_fs { VarOcc $1 }
+ | data_fs { VarOcc $1 }
val_occs :: { [OccName] }
: val_occ { [$1] }
| val_occ val_occs { $1 : $2 }
+entity_occ :: { OccName }
+ : var_fs { VarOcc $1 }
+ | data_fs { TCOcc $1 }
var_name :: { RdrName }
-var_name : var_occ { Unqual $1 }
+var_name : var_fs { Unqual (VarOcc $1) }
qvar_name :: { RdrName }
qvar_name : var_name { $1 }
var_names1 : var_name var_names { $1 : $2 }
data_name :: { RdrName }
-data_name : CONID { Unqual (VarOcc $1) }
+ : CONID { Unqual (VarOcc $1) }
| CONSYM { Unqual (VarOcc $1) }
+ | '(' commas ')' { Unqual (VarOcc (snd (mkTupNameStr $2))) }
+ | '[' ']' { Unqual (VarOcc SLIT("[]")) }
qdata_name :: { RdrName }
-qdata_name : data_name { $1 }
+qdata_name : data_name { $1 }
| QCONID { lexVarQual $1 }
| QCONSYM { lexVarQual $1 }
| qdata_name qdata_names { $1 : $2 }
tc_name :: { RdrName }
-tc_name : tc_occ { Unqual $1 }
- | QCONID { lexTcQual $1 }
- | QCONSYM { lexTcQual $1 }
+tc_name : CONID { Unqual (TCOcc $1) }
+ | CONSYM { Unqual (TCOcc $1) }
+ | '(' '->' ')' { Unqual (TCOcc SLIT("->")) }
+ | '(' commas ')' { Unqual (TCOcc (snd (mkTupNameStr $2))) }
+ | '[' ']' { Unqual (TCOcc SLIT("[]")) }
-tc_names1 :: { [RdrName] }
- : tc_name { [$1] }
- | tc_name COMMA tc_names1 { $1 : $3 }
+qtc_name :: { RdrName }
+qtc_name : tc_name { $1 }
+ | QCONID { lexTcQual $1 }
+ | QCONSYM { lexTcQual $1 }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
| VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} }
tv_bndr :: { HsTyVar RdrName }
-tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 }
+tv_bndr : tv_name '::' akind { IfaceTyVar $1 $3 }
| tv_name { UserTyVar $1 }
tv_bndrs :: { [HsTyVar RdrName] }
kind :: { Kind }
: akind { $1 }
- | akind RARROW kind { mkArrowKind $1 $3 }
+ | akind '->' kind { mkArrowKind $1 $3 }
akind :: { Kind }
: VARSYM { if $1 == SLIT("*") then
- mkBoxedTypeKind
+ boxedTypeKind
else if $1 == SLIT("**") then
- mkTypeKind
+ openTypeKind
else panic "ParseInterface: akind"
}
- | OPAREN kind CPAREN { $2 }
---------------------------------------------------------------------------
-
+ | '(' kind ')' { $2 }
-instances_part :: { [RdrNameInstDecl] }
-instances_part : INSTANCES_PART instdecls { $2 }
- | { [] }
-
-instdecls :: { [RdrNameInstDecl] }
-instdecls : { [] }
- | instd instdecls { $1 : $2 }
-
-instd :: { RdrNameInstDecl }
-instd : src_loc INSTANCE type EQUAL var_name SEMI
- { InstDecl $3
- EmptyMonoBinds {- No bindings -}
- [] {- No user pragmas -}
- (Just $5) {- Dfun id -}
- $1
- }
--------------------------------------------------------------------------
id_info :: { [HsIdInfo RdrName] }
-id_info : { [] }
- | id_info_item id_info { $1 : $2 }
+id_info : { [] }
+ | id_info_item id_info { $1 : $2 }
id_info_item :: { HsIdInfo RdrName }
-id_info_item : ARITY_PART arity_info { HsArity $2 }
- | strict_info { HsStrictness $1 }
- | BOTTOM { HsStrictness HsBottom }
- | UNFOLD_PART core_expr { HsUnfold $1 $2 }
- | SPECIALISE spec_tvs
- atypes EQUAL core_expr { HsSpecialise $2 $3 $5 }
+id_info_item : '__A' arity_info { HsArity $2 }
+ | strict_info { HsStrictness $1 }
+ | '__bot' { HsStrictness HsBottom }
+ | '__U' core_expr { HsUnfold $1 (Just $2) }
+ | '__U' { HsUnfold $1 Nothing }
+ | '__P' spec_tvs
+ atypes '=' core_expr { HsSpecialise $2 $3 $5 }
+ | '__C' { HsNoCafRefs }
spec_tvs :: { [HsTyVar RdrName] }
-spec_tvs : OBRACK tv_bndrs CBRACK { $2 }
+spec_tvs : '[' tv_bndrs ']' { $2 }
arity_info :: { ArityInfo }
-arity_info : INTEGER { exactArity (fromInteger $1) }
+arity_info : INTEGER { exactArity (fromInteger $1) }
strict_info :: { HsStrictnessInfo RdrName }
-strict_info : STRICT_PART qvar_name OCURLY qdata_names CCURLY { HsStrictnessInfo $1 (Just ($2,$4)) }
- | STRICT_PART qvar_name { HsStrictnessInfo $1 (Just ($2,[])) }
- | STRICT_PART { HsStrictnessInfo $1 Nothing }
-
-core_expr :: { UfExpr RdrName }
- : LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 }
- | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 }
- | CASE core_expr OF
- OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) }
- | PRIM_CASE core_expr OF
- OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) }
-
- | LET OCURLY core_val_bndr EQUAL core_expr CCURLY
- IN core_expr { UfLet (UfNonRec $3 $5) $8 }
- | LETREC OCURLY rec_binds CCURLY
- IN core_expr { UfLet (UfRec $3) $6 }
-
- | CCALL ccall_string
- OBRACK atype atypes CBRACK core_args { let
- (is_casm, may_gc) = $1
- in
- UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
- $7
- }
-
- | INLINE_CALL core_expr { UfNote UfInlineCall $2 }
- | COERCE atype core_expr { UfNote (UfCoerce $2) $3 }
- | SCC core_expr { UfNote (UfSCC $1) $2 }
- | fexpr { $1 }
+strict_info : '__S' qvar_name '{' qdata_names '}'
+ { HsStrictnessInfo $1 (Just ($2,$4)) }
+ | '__S' qvar_name { HsStrictnessInfo $1 (Just ($2,[])) }
+ | '__S' { HsStrictnessInfo $1 Nothing }
+
+-------------------------------------------------------
+core_expr :: { UfExpr RdrName }
+core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 }
+ | 'case' core_expr 'of' var_name
+ '{' core_alts '}' { UfCase $2 $4 $6 }
+
+ | 'let' '{' core_val_bndr '=' core_expr
+ '}' 'in' core_expr { UfLet (UfNonRec $3 $5) $8 }
+ | '__letrec' '{' rec_binds '}'
+ 'in' core_expr { UfLet (UfRec $3) $6 }
+
+ | con_or_primop '{' core_args '}' { UfCon $1 $3 }
+ | '__litlit' STRING atype { UfCon (UfLitLitCon $2 $3) [] }
+
+ | '__inline' core_expr { UfNote UfInlineCall $2 }
+ | '__coerce' atype core_expr { UfNote (UfCoerce $2) $3 }
+ | '__scc' core_expr { UfNote (UfSCC $1) $2 }
+ | fexpr { $1 }
fexpr :: { UfExpr RdrName }
fexpr : fexpr core_arg { UfApp $1 $2 }
- | fexpr ATSIGN atype { UfApp $1 (UfTyArg $3) }
- | aexpr { $1 }
+ | core_aexpr { $1 }
+
+core_arg :: { UfExpr RdrName }
+ : '__a' atype { UfType $2 }
+ | core_aexpr { $1 }
-aexpr :: { UfExpr RdrName }
-aexpr : qvar_name { UfVar $1 }
- | qdata_name { UfVar $1 }
- | core_lit { UfLit $1 }
- | OPAREN core_expr CPAREN { $2 }
- | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 }
+core_args :: { [UfExpr RdrName] }
+ : { [] }
+ | core_arg core_args { $1 : $2 }
+core_aexpr :: { UfExpr RdrName } -- Atomic expressions
+core_aexpr : qvar_name { UfVar $1 }
+
+ | qdata_name { UfVar $1 }
+ -- This one means that e.g. "True" will parse as
+ -- (UfVar True_Id) rather than (UfCon True_Con []).
+ -- No big deal; it'll be inlined in a jiffy. I tried
+ -- parsing it to (Con con []) directly, but got bitten
+ -- when a real constructor Id showed up in an interface
+ -- file. As usual, a hack bites you in the end.
+ -- If you want to get a UfCon, then use the
+ -- curly-bracket notation (True {}).
+
+ | core_lit { UfCon (UfLitCon $1) [] }
+ | '(' core_expr ')' { $2 }
+ | '(' ')' { UfTuple (mkTupConRdrName 0) [] }
+ | '(' comma_exprs2 ')' { UfTuple (mkTupConRdrName (length $2)) $2 }
+ | '(#' core_expr '#)' { UfTuple (mkUbxTupConRdrName 1) [$2] }
+ | '(#' comma_exprs2 '#)' { UfTuple (mkUbxTupConRdrName (length $2)) $2 }
+
+comma_exprs2 :: { [UfExpr RdrName] } -- Two or more
+comma_exprs2 : core_expr ',' core_expr { [$1,$3] }
+ | core_expr ',' comma_exprs2 { $1 : $3 }
+
+con_or_primop :: { UfCon RdrName }
+con_or_primop : qdata_name { UfDataCon $1 }
+ | qvar_name { UfPrimOp $1 }
+ | '__ccall' ccall_string { let
+ (is_casm, may_gc) = $1
+ in
+ UfCCallOp $2 is_casm may_gc
+ }
rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
: { [] }
- | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
+ | core_val_bndr '=' core_expr ';' rec_binds { ($1,$3) : $5 }
-prim_alts :: { [(Literal,UfExpr RdrName)] }
- : { [] }
- | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 }
+core_alts :: { [UfAlt RdrName] }
+ : core_alt { [$1] }
+ | core_alt ';' core_alts { $1 : $3 }
-alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] }
- : { [] }
- | qdata_name var_names RARROW
- core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
+core_alt :: { UfAlt RdrName }
+core_alt : core_pat '->' core_expr { (fst $1, snd $1, $3) }
-core_default :: { UfDefault RdrName }
- : { UfNoDefault }
- | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 }
+core_pat :: { (UfCon RdrName, [RdrName]) }
+core_pat : core_lit { (UfLitCon $1, []) }
+ | '__litlit' STRING atype { (UfLitLitCon $2 $3, []) }
+ | qdata_name var_names { (UfDataCon $1, $2) }
+ | '(' comma_var_names ')' { (UfDataCon (mkTupConRdrName (length $2)), $2) }
+ | '(#' comma_var_names1 '#)' { (UfDataCon (mkUbxTupConRdrName (length $2)), $2) }
+ | '__DEFAULT' { (UfDefault, []) }
+ | '(' core_pat ')' { $2 }
-core_arg :: { UfArg RdrName }
- : qvar_name { UfVarArg $1 }
- | qdata_name { UfVarArg $1 }
- | core_lit { UfLitArg $1 }
-core_args :: { [UfArg RdrName] }
- : { [] }
- | core_arg core_args { $1 : $2 }
+comma_var_names :: { [RdrName] } -- Zero, or two or more
+comma_var_names : { [] }
+ | var_name ',' comma_var_names1 { $1 : $3 }
-data_args :: { [UfArg RdrName] }
- : { [] }
- | core_arg data_args { $1 : $2 }
- | ATSIGN atype data_args { UfTyArg $2 : $3 }
+comma_var_names1 :: { [RdrName] } -- One or more
+comma_var_names1 : var_name { [$1] }
+ | var_name ',' comma_var_names1 { $1 : $3 }
core_lit :: { Literal }
core_lit : INTEGER { mkMachInt_safe $1 }
| CHAR { MachChar $1 }
| STRING { MachStr $1 }
- | STRING_LIT STRING { NoRepStr $2 }
+ | '__string' STRING { NoRepStr $2 (panic "NoRepStr type") }
| RATIONAL { MachDouble $1 }
- | FLOAT_LIT RATIONAL { MachFloat $2 }
+ | '__float' RATIONAL { MachFloat $2 }
- | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type")
+ | '__integer' INTEGER { NoRepInteger $2 (panic "NoRepInteger type")
-- The type checker will add the types
}
- | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3)
- (panic "NoRepRational type")
- -- The type checker will add the type
+ | '__rational' INTEGER INTEGER { NoRepRational ($2 % $3)
+ (panic "NoRepRational type")
+ -- The type checker will add the type
}
- | ADDR_LIT INTEGER { MachAddr $2 }
- | LIT_LIT prim_rep STRING { MachLitLit $3 (decodePrimRep $2) }
+ | '__addr' INTEGER { MachAddr $2 }
-core_val_bndr :: { UfBinder RdrName }
-core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 }
+core_bndr :: { UfBinder RdrName }
+core_bndr : core_val_bndr { $1 }
+ | core_tv_bndr { $1 }
-core_val_bndrs :: { [UfBinder RdrName] }
-core_val_bndrs : { [] }
- | core_val_bndr core_val_bndrs { $1 : $2 }
+core_bndrs :: { [UfBinder RdrName] }
+core_bndrs : { [] }
+ | core_bndr core_bndrs { $1 : $2 }
-core_tv_bndr :: { UfBinder RdrName }
-core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 }
- | tv_name { UfTyBinder $1 mkBoxedTypeKind }
+core_val_bndr :: { UfBinder RdrName }
+core_val_bndr : var_name '::' atype { UfValBinder $1 $3 }
-core_tv_bndrs :: { [UfBinder RdrName] }
-core_tv_bndrs : { [] }
- | core_tv_bndr core_tv_bndrs { $1 : $2 }
+core_tv_bndr :: { UfBinder RdrName }
+core_tv_bndr : '__a' tv_name '::' akind { UfTyBinder $2 $4 }
+ | '__a' tv_name { UfTyBinder $2 boxedTypeKind }
ccall_string :: { FAST_STRING }
: STRING { $1 }
| VARID { $1 }
| CONID { $1 }
-prim_rep :: { Char }
- : VARID { head (_UNPK_ $1) }
- | CONID { head (_UNPK_ $1) }
-
-------------------------------------------------------------------
src_loc :: { SrcLoc }
| PIdInfo [HsIdInfo RdrName]
| PType RdrNameHsType
+mkConDecl name (ex_tvs, ex_ctxt) details loc = ConDecl name ex_tvs ex_ctxt details loc
}
%
-% (c) The GRASP Project, Glasgow University, 1992-1996
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[Rename]{Renaming and dependency analysis passes}
mkSearchPath, getSlurpedNames, getRnStats
)
import RnEnv ( addImplicitOccsRn, availNames )
-import Name ( Name, PrintUnqualified, Provenance, isLocallyDefined,
- NameSet,
- nameSetToList, minusNameSet,
+import Name ( Name, isLocallyDefined,
NamedThing(..),
- nameModule, pprModule, pprOccName, nameOccName
+ nameModule, pprModule, pprOccName, nameOccName
)
-import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
+import NameSet
import TyCon ( TyCon )
import PrelMods ( mAIN, pREL_MAIN )
-import PrelInfo ( ioTyCon_NAME )
+import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
+import PrelInfo ( ioTyCon_NAME, thinAirIdNames )
import ErrUtils ( pprBagOfErrors, pprBagOfWarnings,
doIfSet, dumpIfSet, ghcExit
)
import UniqSupply ( UniqSupply )
import Util ( equivClasses )
import Maybes ( maybeToBool )
-import List ( partition )
import Outputable
\end{code}
\begin{code}
addImplicits mod_name
- = addImplicitOccsRn (implicit_main ++ default_tys)
+ = addImplicitOccsRn (implicit_main ++ default_tys ++ thinAirIdNames)
where
-- Add occurrences for Int, Double, and (), because they
-- are the types to which ambigious type variables may be defaulted by
- -- the type checker; so they won't every appear explicitly.
+ -- the type checker; so they won't always appear explicitly.
-- [The () one is a GHC extension for defaulting CCall results.]
default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon ]
-- Add occurrences for IO or PrimIO
implicit_main | mod_name == mAIN
|| mod_name == pREL_MAIN = [ioTyCon_NAME]
- | otherwise = []
+ | otherwise = []
\end{code}
--- /dev/null
+__interface RnBinds 1 0 where
+__export RnBinds rnBinds;
+1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnMonad.FreeVars)) -> RnMonad.RnMS _a (_b, RnMonad.FreeVars) ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnBinds]{Renaming and dependency analysis of bindings}
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
isUnboundName, warnUnusedBinds
)
-import CmdLineOpts ( opt_SigsRequired )
+import CmdLineOpts ( opt_WarnMissingSigs )
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( OccName(..), Provenance,
- Name, isExportedName,
- NameSet, emptyNameSet, mkNameSet, unionNameSets,
- minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
- )
+import Name ( OccName(..), Name, isExportedName )
+import NameSet
import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
import Util ( thenCmp, removeDups, panic, panic#, assertPanic )
-import UniqSet ( UniqSet )
import ListSetOps ( minusList )
import Bag ( bagToList )
-import UniqFM ( UniqFM )
import Outputable
\end{code}
not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
type_sig_vars = [n | Sig n _ _ <- goodies]
- sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
+ sigs_required = case top_lev of {TopLevel -> opt_WarnMissingSigs; NotTopLevel -> False}
un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
| otherwise = []
in
else
returnRn []
) `thenRn_`
- mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
+ mapRn (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
returnRn sigs' -- bad ones and all:
-- we need bindings of *some* sort for every name
sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
-missingSigErr var
- = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
+missingSigWarn var
+ = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
methodBindErr mbind
= hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnEnv]{Environment manipulation for the renamer monad}
import HsTypes ( getTyVarName, replaceTyVarName )
import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import RnMonad
-import ErrUtils ( ErrMsg )
import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
occNameFlavour, getSrcLoc, occNameString,
- NameSet, emptyNameSet, addListToNameSet, nameSetToList,
- mkLocalName, mkGlobalName, modAndOcc,
- nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
- pprOccName, isLocalName
+ mkLocalName, mkGlobalName,
+ nameOccName, setNameProvenance, isVarOcc,
+ getNameProvenance, pprOccName, isLocalName,
+ dictNamePrefix
)
+import NameSet
import TyCon ( TyCon )
-import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
+import TysWiredIn ( tupleTyCon, unboxedTupleTyCon,
+ listTyCon, charTyCon )
import FiniteMap
import Unique ( Unique, Uniquable(..), unboundKey )
import UniqFM ( listToUFM, plusUFM_C )
-- Build a new original name, and put it in the cache
let
(us', us1) = splitUniqSupply us
- uniq = getUnique us1
+ uniq = uniqFromSupply us1
name = mkGlobalName uniq mod occ prov
new_cache = addToFM cache key name
in
Nothing -> let
provenance = LocalDef loc (rec_exp_fn new_name)
(us', us1) = splitUniqSupply us
- uniq = getUnique us1
+ uniq = uniqFromSupply us1
new_name = mkGlobalName uniq mod occ provenance
new_cache = addToFM cache key new_name
in
= getModuleRn `thenRn` \ mod_name ->
newInstUniq name `thenRn` \ inst_uniq ->
let
- dfun_occ = VarOcc (_PK_ ("$d" ++ (_UNPK_ name) ++ show inst_uniq))
+ dfun_occ = VarOcc (dictNamePrefix _APPEND_
+ name _APPEND_ _PK_(show inst_uniq))
in
newLocallyDefinedGlobalName mod_name dfun_occ
(\_ -> Exported) src_loc
{-
Dictionary names have the following form
- $d<class><tycon><n>
+ _d<class><tycon><n>
where "n" is a positive number, and "tycon" is the
name of the type constructor for which a "class"
declaration be added to a module.)
-}
-- We're dropping the modids on purpose.
- tycon_nm_str = occNameString tycon_nm
- cl_nm_str = occNameString cl_nm
+ tycon_nm_str = _PK_(map trHash (_UNPK_(occNameString tycon_nm)))
+ cl_nm_str = _PK_(map trHash (_UNPK_(occNameString cl_nm)))
+
+ trHash '#' = '_'
+ trHash c = c
-- give up on any type constructor that starts with a
-- non-alphanumeric char (e.g., [] (,*)
let
n = length rdr_names
(us', us1) = splitUniqSupply us
- uniqs = getUniques n us1
- locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
+ uniqs = uniqsFromSupply n us1
+ locals = [ mkLocalName uniq (rdrNameOcc rdr_name)
| ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
]
in
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
-- during compiler debugging.
mkUnboundName :: RdrName -> Name
-mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
+mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name)
isUnboundName :: Name -> Bool
-isUnboundName name = uniqueOf name == unboundKey
+isUnboundName name = getUnique name == unboundKey
\end{code}
\begin{code}
addImplicitOccsRn :: [Name] -> RnMS s ()
addImplicitOccsRn names = addOccurrenceNames names
-listType_RDR = qual (modAndOcc listType_name)
-tupleType_RDR n = qual (modAndOcc (tupleType_name n))
+charTyCon_name = getName charTyCon
+listTyCon_name = getName listTyCon
-charType_name = getName charTyCon
-listType_name = getName listTyCon
-tupleType_name n = getName (tupleTyCon n)
+tupleTyCon_name True n = getName (tupleTyCon n)
+tupleTyCon_name False n = getName (unboxedTupleTyCon n)
\end{code}
\begin{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnExpr]{Renaming of expressions}
#include "HsVersions.h"
-import {-# SOURCE #-} RnBinds
+import {-# SOURCE #-} RnBinds ( rnBinds )
import {-# SOURCE #-} RnSource ( rnHsSigType )
import HsSyn
ccallableClass_RDR, creturnableClass_RDR,
monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- ioDataCon_RDR, ioOkDataCon_RDR
+ ioDataCon_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
)
-import Name
+import Name ( nameUnique, isLocallyDefined, NamedThing(..) )
+import NameSet
import UniqFM ( isNullUFM )
-import UniqSet ( emptyUniqSet, unionManyUniqSets, UniqSet )
+import UniqSet ( emptyUniqSet, UniqSet )
import Unique ( assertIdKey )
import Util ( removeDups )
import Outputable
returnRn (NPlusKPatIn name' lit)
rnPat (ListPatIn pats)
- = addImplicitOccRn listType_name `thenRn_`
+ = addImplicitOccRn listTyCon_name `thenRn_`
mapRn rnPat pats `thenRn` \ patslist ->
returnRn (ListPatIn patslist)
-rnPat (TuplePatIn pats)
- = addImplicitOccRn (tupleType_name (length pats)) `thenRn_`
+rnPat (TuplePatIn pats boxed)
+ = addImplicitOccRn (tupleTyCon_name boxed (length pats)) `thenRn_`
mapRn rnPat pats `thenRn` \ patslist ->
- returnRn (TuplePatIn patslist)
+ returnRn (TuplePatIn patslist boxed)
rnPat (RecPatIn con rpats)
= lookupOccRn con `thenRn` \ con' ->
rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
- rnGRHS (GRHS guard expr locn)
+ rnGRHS (GRHS guarded locn)
= pushSrcLocRn locn $
- (if not (opt_GlasgowExts || is_standard_guard guard) then
- addWarnRn (nonStdGuardErr guard)
+ (if not (opt_GlasgowExts || is_standard_guard guarded) then
+ addWarnRn (nonStdGuardErr guarded)
else
returnRn ()
) `thenRn_`
- (rnStmts rnExpr guard $ \ guard' ->
- -- This nested thing deals with scope and
- -- the free vars of the guard, and knocking off the
- -- free vars of the rhs that are bound by the guard
-
- rnExpr expr `thenRn` \ (expr', fvse) ->
- returnRn (GRHS guard' expr' locn, fvse))
+ rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
+ returnRn (GRHS guarded' locn, fvs)
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [] = True
- is_standard_guard [GuardStmt _ _] = True
- is_standard_guard other = False
+ is_standard_guard [ExprStmt _ _] = True
+ is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
+ is_standard_guard other = False
\end{code}
%************************************************************************
= lookupImplicitOccRn ccallableClass_RDR `thenRn_`
lookupImplicitOccRn creturnableClass_RDR `thenRn_`
lookupImplicitOccRn ioDataCon_RDR `thenRn_`
- lookupImplicitOccRn ioOkDataCon_RDR `thenRn_`
rnExprs args `thenRn` \ (args', fvs_args) ->
returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
rnExpr (HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
- (rnStmts rnExpr stmts $ \ stmts' ->
- returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
+ rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
+ returnRn (HsDo do_or_lc stmts' src_loc, fvs)
rnExpr (ExplicitList exps)
- = addImplicitOccRn listType_name `thenRn_`
+ = addImplicitOccRn listTyCon_name `thenRn_`
rnExprs exps `thenRn` \ (exps', fvs) ->
returnRn (ExplicitList exps', fvs)
-rnExpr (ExplicitTuple exps)
- = addImplicitOccRn (tupleType_name (length exps)) `thenRn_`
- rnExprs exps `thenRn` \ (exps', fvExps) ->
- returnRn (ExplicitTuple exps', fvExps)
+rnExpr (ExplicitTuple exps boxed)
+ = addImplicitOccRn (tupleTyCon_name boxed (length exps)) `thenRn_`
+ rnExprs exps `thenRn` \ (exps', fvExps) ->
+ returnRn (ExplicitTuple exps' boxed, fvExps)
-rnExpr (RecordCon con_id _ rbinds)
+rnExpr (RecordCon con_id rbinds)
= lookupOccRn con_id `thenRn` \ conname ->
rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
- returnRn (RecordCon conname (error "rnExpr:RecordCon") rbinds', fvRbinds)
+ returnRn (RecordCon conname rbinds', fvRbinds)
rnExpr (RecordUpd expr rbinds)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnStmts :: RnExprTy s
-> [RdrNameStmt]
- -> ([RenamedStmt] -> RnMS s (a, FreeVars))
- -> RnMS s (a, FreeVars)
+ -> RnMS s ([RenamedStmt], FreeVars)
-rnStmts rn_expr [] thing_inside
- = thing_inside []
+rnStmts rn_expr []
+ = returnRn ([], emptyNameSet)
-rnStmts rn_expr (stmt:stmts) thing_inside
+rnStmts rn_expr (stmt:stmts)
= rnStmt rn_expr stmt $ \ stmt' ->
- rnStmts rn_expr stmts $ \ stmts' ->
- thing_inside (stmt' : stmts')
+ rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
+ returnRn (stmt' : stmts', fvs)
-rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
+rnStmt :: RnExprTy s -> RdrNameStmt
+ -> (RenamedStmt -> RnMS s (a, FreeVars))
+ -> RnMS s (a, FreeVars)
-- Because of mutual recursion we have to pass in rnExpr.
rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
\begin{code}
litOccurrence (HsChar _)
- = addImplicitOccRn charType_name
+ = addImplicitOccRn charTyCon_name
litOccurrence (HsCharPrim _)
= addImplicitOccRn (getName charPrimTyCon)
litOccurrence (HsString _)
- = addImplicitOccRn listType_name `thenRn_`
- addImplicitOccRn charType_name
+ = addImplicitOccRn listTyCon_name `thenRn_`
+ addImplicitOccRn charTyCon_name
litOccurrence (HsStringPrim _)
= addImplicitOccRn (getName addrPrimTyCon)
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
#include "HsVersions.h"
+import RnEnv ( listTyCon_name, tupleTyCon_name )
+
import HsSyn
import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas )
-import Id ( GenId, Id )
-import BasicTypes ( Unused, NewOrData, IfaceFlavour )
+import BasicTypes ( Unused )
import Name ( Name )
-import Name ( NameSet, unitNameSet, mkNameSet, minusNameSet, unionNameSets, emptyNameSet )
-import TyVar ( GenTyVar )
-import Unique ( Unique )
+import NameSet
import Util
import Outputable
\end{code}
= get ty
where
get (MonoTyApp ty1 ty2) = get ty1 `unionNameSets` get ty2
- get (MonoListTy tc ty) = unitNameSet tc `unionNameSets` get ty
- get (MonoTupleTy tc tys) = unitNameSet tc `unionNameSets` extractHsTyNames_s tys
+ get (MonoListTy ty) = unitNameSet listTyCon_name
+ `unionNameSets` get ty
+ get (MonoTupleTy tys boxed) = unitNameSet (tupleTyCon_name boxed (length tys))
+ `unionNameSets` extractHsTyNames_s tys
get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
get (MonoDictTy cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
get (MonoTyVar tv) = unitNameSet tv
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnIfaces]{Cacheing and Renaming of Interfaces}
lookupFM, addToFM, addToFM_C, addListToFM,
fmToList
)
-import Name ( Name {-instance NamedThing-}, Provenance, OccName(..),
+import Name ( Name {-instance NamedThing-}, OccName(..),
nameModule, moduleString, pprModule, isLocallyDefined,
- NameSet, emptyNameSet, unionNameSets, nameSetToList,
- minusNameSet, mkNameSet, elemNameSet, nameUnique, addOneToNameSet,
- isWiredInName, maybeWiredInTyConName, maybeWiredInIdName,
- NamedThing(..)
+ isWiredInName, maybeWiredInTyConName,
+ maybeWiredInIdName, nameUnique, NamedThing(..)
)
-import Id ( GenId, Id, idType, dataConTyCon, isAlgCon )
+import NameSet
+import Id ( idType, isDataConId_maybe )
+import DataCon ( dataConTyCon, dataConType )
import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
import Type ( namesOfType )
-import TyVar ( GenTyVar )
+import Var ( Id )
import SrcLoc ( mkSrcLoc, SrcLoc )
import PrelMods ( pREL_GHC )
-import PrelInfo ( cCallishTyKeys )
+import PrelInfo ( cCallishTyKeys, thinAirModules )
import Bag
import Maybes ( MaybeErr(..), maybeToBool )
import ListSetOps ( unionLists )
import IO ( isDoesNotExistError )
import List ( nub )
+
\end{code}
let
munged_inst_ty = case inst_ty of
HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty
- HsPreForAllTy cxt ty -> HsPreForAllTy [] ty
other -> inst_ty
in
-- We find the gates by renaming the instance type with in a
is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
is_data_or_newtype other = False
-
\end{code}
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
get_wired | is_tycon -- ... a type constructor
= get_wired_tycon the_tycon
- | (isAlgCon the_id) -- ... a wired-in data constructor
- = get_wired_tycon (dataConTyCon the_id)
+ | maybeToBool maybe_data_con -- ... a wired-in data constructor
+ = get_wired_tycon (dataConTyCon data_con)
| otherwise -- ... a wired-in non data-constructor
= get_wired_id the_id
maybe_wired_in_id = maybeWiredInIdName name
Just the_tycon = maybe_wired_in_tycon
Just the_id = maybe_wired_in_id
+ maybe_data_con = isDataConId_maybe the_id
+ Just data_con = maybe_data_con
get_wired_id id
where
tycon_name = getName tycon
data_cons = tyConDataCons tycon
- mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
+ mentioned = foldr (unionNameSets . namesOfType . dataConType) emptyNameSet data_cons
\end{code}
getDeclBinders new_name (InstD _) = returnRn NotAvailable
----------------
-getConFieldNames new_name (ConDecl con _ (RecCon fielddecls) src_loc : rest)
+getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest)
= mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
getConFieldNames new_name rest `thenRn` \ ns ->
returnRn (cfs ++ ns)
where
fields = concat (map fst fielddecls)
-getConFieldNames new_name (ConDecl con _ _ src_loc : rest)
+getConFieldNames new_name (ConDecl con _ _ _ src_loc : rest)
= new_name con src_loc `thenRn` \ n ->
getConFieldNames new_name rest `thenRn` \ ns ->
returnRn (n:ns)
-- Just x <=> successfully found and parsed
findAndReadIface doc_str mod_name as_source
= traceRn trace_msg `thenRn_`
- getModuleHiMap `thenRn` \ himap ->
- case (lookupFM himap real_mod_name) of
- Nothing ->
- traceRn (ptext SLIT("...failed")) `thenRn_`
- returnRn Nothing
- Just fpath ->
- readIface fpath
-{-
- getSearchPathRn `thenRn` \ dirs ->
- try dirs
--}
+ -- we keep two maps for interface files,
+ -- one for 'normal' ones, the other for .hi-boot files,
+ -- hence the need to signal which kind we're interested.
+ getModuleHiMap as_source `thenRn` \ himap ->
+ case (lookupFM himap (moduleString mod_name)) of
+ -- Found the file
+ Just fpath -> readIface fpath
+ -- Hack alert! When compiling PrelBase we have to load the
+ -- decls for packCString# and friends; they are 'thin-air' Ids
+ -- (see PrelInfo.lhs). So if we don't find the HiFile we quietly
+ -- look for a .hi-boot file instead, and use that
+ Nothing | thinAirLoop mod_name as_source
+ -> findAndReadIface doc_str mod_name HiBootFile
+ | otherwise
+ -> traceRn (ptext SLIT("...failed")) `thenRn_`
+ returnRn Nothing
where
- real_mod_name =
- case as_source of
- HiBootFile -> 'b':moduleString mod_name
- HiFile -> moduleString mod_name
+ thinAirLoop mod_name HiFile = mod_name `elem` thinAirModules
+ thinAirLoop mod_name hif = False
trace_msg = sep [hsep [ptext SLIT("Reading"),
case as_source of { HiBootFile -> ptext SLIT("[boot]"); other -> empty},
ptext SLIT("interface for"),
ptext mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
-
-{-
- -- For import {-# SOURCE #-} Foo, "as_source" will be True
- -- and we read Foo.hi-boot, not Foo.hi. This is used to break
- -- loops among modules.
- mod_suffix hi = case as_source of
- HiBootFile -> ".hi-boot" -- Ignore `ways' for boot files.
- HiFile -> hi
-
- try [] = traceRn (ptext SLIT("...failed")) `thenRn_`
- returnRn Nothing
-
- try ((dir,hisuf):dirs)
- = readIface file_path `thenRn` \ read_result ->
- case read_result of
- Nothing -> try dirs
- Just iface -> traceRn (ptext SLIT("...done")) `thenRn_`
- returnRn (Just iface)
- where
- file_path = dir ++ '/' : moduleString mod_name ++ (mod_suffix hisuf)
--}
\end{code}
@readIface@ tries just the one file.
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnMonad]{The monad used by the renamer}
import HsSyn
import RdrHsSyn
-import BasicTypes ( Version, NewOrData, pprModule )
+import BasicTypes ( Version, pprModule, IfaceFlavour(..) )
import SrcLoc ( noSrcLoc )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg
)
-import Maybes ( seqMaybe, mapMaybe )
-import Name ( Module, Name, OccName, PrintUnqualified, NameSet, emptyNameSet,
+import Name ( Module, Name, OccName, PrintUnqualified,
isLocallyDefinedName,
modAndOcc, NamedThing(..)
)
+import NameSet
import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, opt_WarnHiShadows )
import PrelInfo ( builtinNames )
import TysWiredIn ( boolTyCon )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
import UniqFM ( UniqFM )
-import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM_C )
+import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM_C, addToFM_C )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
+import Maybes ( seqMaybe, mapMaybe )
import UniqSet
import UniqSupply
import Util
import Outputable
import DirUtils ( getDirectoryContents )
import IO ( hPutStrLn, stderr, isDoesNotExistError )
+import Monad ( foldM )
+import Maybe ( fromMaybe )
+import Constants ( interfaceFileFormatVersion )
infixr 9 `thenRn`, `thenRn_`
\end{code}
-- For getting global names
data GDown = GDown
- ModuleHiMap
+ ModuleHiMap -- for .hi files
+ ModuleHiMap -- for .hi-boot files
(SSTRWRef Ifaces)
-- For renaming source code
type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
-- for interface files.
-type ModuleHiMap = FiniteMap String String
+type ModuleHiMap = FiniteMap String String
-- mapping from module name to the file path of its corresponding
-- interface file.
errs_var <- sstToIO (newMutVarSST (emptyBag,emptyBag))
iface_var <- sstToIO (newMutVarSST (emptyIfaces mod))
occs_var <- sstToIO (newMutVarSST initOccs)
- himap <- mkModuleHiMap dirs
+ (himap, hibmap) <- mkModuleHiMaps dirs
let
rn_down = RnDown loc names_var errs_var occs_var
- g_down = GDown himap iface_var
+ g_down = GDown himap hibmap iface_var
- -- do the buisness
+ -- do the business
res <- sstToIO (do_rn rn_down g_down)
-- grab errors and return
\end{code}
\begin{code}
-mkModuleHiMap :: SearchPath -> IO ModuleHiMap
-mkModuleHiMap dirs = do
- lss <- mapM (uncurry getAllFilesMatching) dirs
- let ls = concat lss
- if opt_WarnHiShadows
- then return (addListToFM_C conflict env ls)
- else return (addListToFM_C (\ old new -> old) env ls)
+mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap)
+mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs
where
env = emptyFM
- conflict old_path new_path
- | old_path /= new_path =
- pprTrace "Warning: " (text "Identically named interface files present on import path, " $$
- text (show old_path) <+> text "shadows" $$
- text (show new_path) $$
- text "on the import path: " <+>
- text (concat (intersperse ":" (map fst dirs))))
- old_path
- | otherwise = old_path -- don't warn about innocous shadowings.
-
-getAllFilesMatching :: FilePath -> String -> IO [(String, FilePath)]
-getAllFilesMatching dir_path suffix = (do
+getAllFilesMatching :: SearchPath
+ -> (ModuleHiMap, ModuleHiMap)
+ -> (FilePath, String)
+ -> IO (ModuleHiMap, ModuleHiMap)
+getAllFilesMatching dirs hims (dir_path, suffix) = ( do
+ -- fpaths entries do not have dir_path prepended
fpaths <- getDirectoryContents dir_path
- -- fpaths entries do not have dir_path prepended
- return (mapMaybe withSuffix fpaths)
+ return (foldl addModules hims fpaths)
) -- soft failure
`catch`
(\ err -> do
else
"' couldn't read, ignoring.")
- return []
+ return hims
)
where
xiffus = reverse dotted_suffix
('.':xs) -> suffix
ls -> '.':ls
- -- filter out files that have the desired suffix
- withSuffix nm = go "" xiffus rev_nm `seqMaybe`
- go "b" "toob-ih." rev_nm
+ hi_boot_version_xiffus =
+ reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus
+ hi_boot_xiffus = "toob-ih." -- .hi-boot reversed.
+
+ addModules his@(hi_env, hib_env) nm = fromMaybe his $
+ map (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm v, hib_env))
+ (go xiffus rev_nm) `seqMaybe`
+
+ map (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm v))
+ (go hi_boot_version_xiffus rev_nm) `seqMaybe`
+
+ map (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm v))
+ (go hi_boot_xiffus rev_nm)
where
rev_nm = reverse nm
- -- the prefix is needed to distinguish between a .hi-boot
- -- file and a normal interface file, i.e., I'm not willing
- -- to guarantee that the presence of the SOURCE pragma
- --
- -- import {-# SOURCE #-} Foo (x)
- -- import Bar
- --
- -- will not cause Foo.hi to somehow be looked at when
- -- slurping in Bar.
- --
- go pre [] xs = Just (pre ++ reverse xs, dir_path ++'/':nm)
- go _ _ [] = Nothing
- go pre (x:xs) (y:ys)
- | x == y = go pre xs ys
+ go [] xs = Just (reverse xs, dir_path ++'/':nm)
+ go _ [] = Nothing
+ go (x:xs) (y:ys)
+ | x == y = go xs ys
| otherwise = Nothing
+
+ addNewOne
+ | opt_WarnHiShadows = conflict
+ | otherwise = stickWithOld
+
+ stickWithOld old new = old
+ overrideNew old new = new
+
+ conflict old_path new_path
+ | old_path /= new_path =
+ pprTrace "Warning: " (text "Identically named interface files present on import path, " $$
+ text (show old_path) <+> text "shadows" $$
+ text (show new_path) $$
+ text "on the import path: " <+>
+ text (concat (intersperse ":" (map fst dirs))))
+ old_path
+ | otherwise = old_path -- don't warn about innocous shadowings.
+
\end{code}
\begin{code}
getIfacesRn :: RnMG Ifaces
-getIfacesRn rn_down (GDown dirs iface_var)
+getIfacesRn rn_down (GDown himap hibmap iface_var)
= readMutVarSST iface_var
setIfacesRn :: Ifaces -> RnMG ()
-setIfacesRn ifaces rn_down (GDown dirs iface_var)
+setIfacesRn ifaces rn_down (GDown himap hibmap iface_var)
= writeMutVarSST iface_var ifaces
-{-
-getSearchPathRn :: RnMG SearchPath
-getSearchPathRn rn_down (GDown dirs iface_var)
- = returnSST dirs
--}
-
-getModuleHiMap :: RnMG ModuleHiMap
-getModuleHiMap rn_down (GDown himap iface_var)
- = returnSST himap
+getModuleHiMap :: IfaceFlavour -> RnMG ModuleHiMap
+getModuleHiMap as_source rn_down (GDown himap hibmap iface_var)
+ = case as_source of
+ HiBootFile -> returnSST hibmap
+ _ -> returnSST himap
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnNames]{Extracting imported and top-level names in scope}
FixityDecl(..),
collectTopBinders
)
-import RdrHsSyn ( RdrNameHsDecl, RdrName(..), RdrNameIE, RdrNameImportDecl,
+import RdrHsSyn ( RdrName(..), RdrNameIE, RdrNameImportDecl,
RdrNameHsModule, RdrNameFixityDecl,
rdrNameOcc, ieOcc
)
import FiniteMap
import PrelMods
-import UniqFM ( UniqFM, addListToUFM_C, lookupUFM )
-import Bag ( Bag, bagToList )
+import UniqFM ( lookupUFM )
+import Bag ( bagToList )
import Maybes ( maybeToBool )
import Name
+import NameSet ( elemNameSet )
import Outputable
import Util ( removeDups )
\end{code}
--- /dev/null
+__interface RnSource 1 0 where
+__export RnSource rnHsSigType;
+1 rnHsSigType :: __forall [_a] => (Outputable.SDoc)
+ -> RdrHsSyn.RdrNameHsType
+ -> RnMonad.RnMS _a RnHsSyn.RenamedHsType ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnDecl, rnHsType, rnHsSigType ) where
+module RnSource ( rnDecl, rnHsSigType ) where
#include "HsVersions.h"
import RdrHsSyn
import RnHsSyn
import HsCore
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
-import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
- newDfunName, checkDupOrQualNames, checkDupNames, lookupGlobalOccRn,
- newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour,
- listType_RDR, tupleType_RDR, addImplicitOccRn
- )
+import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
+ lookupImplicitOccRn, addImplicitOccRn,
+ bindLocalsRn,
+ newDfunName, checkDupOrQualNames, checkDupNames,
+ newLocallyDefinedGlobalName, newImportedGlobalName,
+ ifaceFlavour, listTyCon_name, tupleTyCon_name )
import RnMonad
import Name ( Name, OccName(..), occNameString, prefixOccName,
- ExportFlag(..), Provenance(..), NameSet, mkNameSet,
- elemNameSet, nameOccName, NamedThing(..)
+ ExportFlag(..), Provenance(..),
+ nameOccName, NamedThing(..), isLexCon,
+ mkDefaultMethodName
)
+import NameSet
import BasicTypes ( TopLevelFlag(..) )
-import FiniteMap ( lookupFM )
-import Id ( GenId{-instance NamedThing-} )
-import IdInfo ( FBTypeInfo, ArgUsageInfo )
-import Lex ( isLexCon )
-import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME,
- ioOkDataCon_NAME
+import FiniteMap ( elemFM )
+import PrelInfo ( derivingOccurrences, numClass_RDR,
+ deRefStablePtr_NAME, makeStablePtr_NAME,
+ bindIO_NAME
)
-import Maybes ( maybeToBool )
import Bag ( bagToList )
import Outputable
import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import UniqSet ( UniqSet )
-import UniqFM ( UniqFM, lookupUFM )
+import UniqFM ( lookupUFM )
+import Maybes ( maybeToBool )
import Util
-import List ( partition, nub )
\end{code}
rnDecl `renames' declarations.
rnDecl (SigD (IfaceSig name ty id_infos loc))
= pushSrcLocRn loc $
lookupBndrRn name `thenRn` \ name' ->
- rnHsType ty `thenRn` \ ty' ->
+ rnHsType doc_str ty `thenRn` \ ty' ->
-- Get the pragma info (if any).
getModeRn `thenRn` \ (InterfaceMode _ print_unqual) ->
-- so that (a) we don't die
mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
returnRn (SigD (IfaceSig name' ty' id_infos' loc))
+ where
+ doc_str = text "the interface signature for" <+> quotes (ppr name)
\end{code}
%*********************************************************
= pushSrcLocRn src_loc $
lookupBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- rnContext context `thenRn` \ context' ->
+ rnContext data_doc context `thenRn` \ context' ->
checkDupOrQualNames data_doc con_names `thenRn_`
mapRn rnConDecl condecls `thenRn` \ condecls' ->
rnDerivs derivings `thenRn` \ derivings' ->
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsType ty `thenRn` \ ty' ->
+ rnHsType syn_doc ty `thenRn` \ ty' ->
returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
where
- syn_doc = text "the declaration for type synonym" <+> ppr name
+ syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
\end{code}
%*********************************************************
lookupBndrRn dname `thenRn` \ dname' ->
bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
- rnContext context `thenRn` \ context' ->
+ rnContext cls_doc context `thenRn` \ context' ->
-- Check the signatures
let
rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
= pushSrcLocRn locn $
- lookupBndrRn op `thenRn` \ op_name ->
+ lookupBndrRn op `thenRn` \ op_name ->
rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
-- Make the default-method name
let
- dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
+ dm_occ = mkDefaultMethodName (rdrNameOcc op)
in
getModuleRn `thenRn` \ mod_name ->
getModeRn `thenRn` \ mode ->
where
c_nm = nameOccName (getName cl)
- mkDictPrefix (HsPreForAllTy _ ty) = mkDictPrefix ty
mkDictPrefix (HsForAllTy _ _ ty) = mkDictPrefix ty -- can this
mkDictPrefix _ = (nilOccName, nilOccName)
\begin{code}
rnDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
- mapRn rnHsType tys `thenRn` \ tys' ->
+ mapRn (rnHsType doc_str) tys `thenRn` \ tys' ->
lookupImplicitOccRn numClass_RDR `thenRn_`
returnRn (DefD (DefaultDecl tys' src_loc))
+ where
+ doc_str = text "a `default' declaration"
\end{code}
%*********************************************************
rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
- (if is_import then
- addImplicitOccRn name'
- else
- returnRn name') `thenRn_`
+ (case imp_exp of
+ FoImport _ | not isDyn -> addImplicitOccRn name'
+ FoLabel -> addImplicitOccRn name'
+ FoExport | isDyn ->
+ addImplicitOccRn makeStablePtr_NAME `thenRn_`
+ addImplicitOccRn deRefStablePtr_NAME `thenRn_`
+ addImplicitOccRn bindIO_NAME `thenRn_`
+ returnRn name'
+ _ -> returnRn name') `thenRn_`
rnHsSigType fo_decl_msg ty `thenRn` \ ty' ->
- -- hack: force the constructors of IO to be slurped in,
- -- since we need 'em when desugaring a foreign decl.
- addImplicitOccRn ioOkDataCon_NAME `thenRn_`
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
where
fo_decl_msg = ptext SLIT("a foreign declaration")
- is_import =
- not (isDynamic ext_nm) &&
- case imp_exp of
- FoImport _ -> True
- _ -> False
+ isDyn = isDynamic ext_nm
\end{code}
rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
rnDerivs Nothing -- derivs not specified
- = lookupImplicitOccRn evalClass_RDR `thenRn_`
- returnRn Nothing
+ = returnRn Nothing
rnDerivs (Just ds)
- = lookupImplicitOccRn evalClass_RDR `thenRn_`
- mapRn rn_deriv ds `thenRn` \ derivs ->
+ = mapRn rn_deriv ds `thenRn` \ derivs ->
returnRn (Just derivs)
where
rn_deriv clas
\begin{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
-conDeclName (ConDecl n _ _ l) = (n,l)
+conDeclName (ConDecl n _ _ _ l) = (n,l)
rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
-rnConDecl (ConDecl name cxt details locn)
+rnConDecl (ConDecl name tvs cxt details locn)
= pushSrcLocRn locn $
checkConName name `thenRn_`
lookupBndrRn name `thenRn` \ new_name ->
- rnConDetails name locn details `thenRn` \ new_details ->
- rnContext cxt `thenRn` \ new_context ->
- returnRn (ConDecl new_name new_context new_details locn)
+ bindTyVarsRn doc tvs $ \ new_tyvars ->
+ rnContext doc cxt `thenRn` \ new_context ->
+ rnConDetails doc locn details `thenRn` \ new_details ->
+ returnRn (ConDecl new_name new_tyvars new_context new_details locn)
+ where
+ doc = text "the definition of data constructor" <+> quotes (ppr name)
-rnConDetails con locn (VanillaCon tys)
- = mapRn rnBangTy tys `thenRn` \ new_tys ->
+rnConDetails doc locn (VanillaCon tys)
+ = mapRn (rnBangTy doc) tys `thenRn` \ new_tys ->
returnRn (VanillaCon new_tys)
-rnConDetails con locn (InfixCon ty1 ty2)
- = rnBangTy ty1 `thenRn` \ new_ty1 ->
- rnBangTy ty2 `thenRn` \ new_ty2 ->
+rnConDetails doc locn (InfixCon ty1 ty2)
+ = rnBangTy doc ty1 `thenRn` \ new_ty1 ->
+ rnBangTy doc ty2 `thenRn` \ new_ty2 ->
returnRn (InfixCon new_ty1 new_ty2)
-rnConDetails con locn (NewCon ty)
- = rnHsType ty `thenRn` \ new_ty ->
+rnConDetails doc locn (NewCon ty)
+ = rnHsType doc ty `thenRn` \ new_ty ->
returnRn (NewCon new_ty)
-rnConDetails con locn (RecCon fields)
- = checkDupOrQualNames fld_doc field_names `thenRn_`
- mapRn rnField fields `thenRn` \ new_fields ->
+rnConDetails doc locn (RecCon fields)
+ = checkDupOrQualNames doc field_names `thenRn_`
+ mapRn (rnField doc) fields `thenRn` \ new_fields ->
returnRn (RecCon new_fields)
where
- fld_doc = text "the fields of constructor" <> ppr con
field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
-rnField (names, ty)
+rnField doc (names, ty)
= mapRn lookupBndrRn names `thenRn` \ new_names ->
- rnBangTy ty `thenRn` \ new_ty ->
+ rnBangTy doc ty `thenRn` \ new_ty ->
returnRn (new_names, new_ty)
-rnBangTy (Banged ty)
- = rnHsType ty `thenRn` \ new_ty ->
+rnBangTy doc (Banged ty)
+ = rnHsType doc ty `thenRn` \ new_ty ->
returnRn (Banged new_ty)
-rnBangTy (Unbanged ty)
- = rnHsType ty `thenRn` \ new_ty ->
+rnBangTy doc (Unbanged ty)
+ = rnHsType doc ty `thenRn` \ new_ty ->
returnRn (Unbanged new_ty)
-- This data decl will parse OK
rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
+rnHsSigType doc_str ty = rnHsType (text "the type signature for" <+> doc_str) ty
+
+
+
+
+rnHsType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
+
+rnHsType doc (HsForAllTy [] ctxt ty)
+ -- From source code (no kinds on tyvars)
--- Given the signature C => T we universally quantify over FV(T) \ {in-scope-tyvars}
---
--- We insist that the universally quantified type vars is a superset of FV(C)
--- It follows that FV(T) is a superset of FV(C), so that the context constrains
--- no type variables that don't appear free in the tau-type part.
+ -- Given the signature C => T we universally quantify
+ -- over FV(T) \ {in-scope-tyvars}
+ --
+ -- We insist that the universally quantified type vars is a superset of FV(C)
+ -- It follows that FV(T) is a superset of FV(C), so that the context constrains
+ -- no type variables that don't appear free in the tau-type part.
-rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars)
= getLocalNameEnv `thenRn` \ name_env ->
let
mentioned_tyvars = extractHsTyVars ty
- forall_tyvars = filter (not . in_scope) mentioned_tyvars
- in_scope tv = maybeToBool (lookupFM name_env tv)
+ forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_tyvars
- constrained_tyvars = extractHsCtxtTyVars ctxt
- constrained_and_in_scope = filter in_scope constrained_tyvars
- constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars
+ ctxt_w_ftvs :: [((RdrName,[RdrNameHsType]), [RdrName])]
+ ctxt_w_ftvs = [ (constraint, foldr ((++) . extractHsTyVars) [] tys)
+ | constraint@(_,tys) <- ctxt]
+
+ -- A 'non-poly constraint' is one that does not mention *any*
+ -- of the forall'd type variables
+ non_poly_constraints = filter non_poly ctxt_w_ftvs
+ non_poly (c,ftvs) = not (any (`elem` forall_tyvars) ftvs)
+
+ -- A 'non-mentioned' constraint is one that mentions a
+ -- type variable that does not appear in 'ty'
+ non_mentioned_constraints = filter non_mentioned ctxt_w_ftvs
+ non_mentioned (c,ftvs) = any (not . (`elem` mentioned_tyvars)) ftvs
-- Zap the context if there's a problem, to avoid duplicate error message.
- ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt
+ ctxt' | null non_poly_constraints && null non_mentioned_constraints = ctxt
| otherwise = []
in
- checkRn (null constrained_and_in_scope)
- (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_`
- checkRn (null constrained_and_not_mentioned)
- (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_`
-
- (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
- rnContext ctxt' `thenRn` \ new_ctxt ->
- rnHsType ty `thenRn` \ new_ty ->
- returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
- )
- where
- sig_doc = text "the type signature for" <+> doc_str
-
+ mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints `thenRn_`
+ mapRn (ctxtErr2 doc ty) non_mentioned_constraints `thenRn_`
-rnHsSigType doc_str other_ty = rnHsType other_ty
+ (bindTyVarsRn doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
+ rnContext doc ctxt' `thenRn` \ new_ctxt ->
+ rnHsType doc ty `thenRn` \ new_ty ->
+ returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty))
-rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
-rnHsType (HsForAllTy tvs ctxt ty) -- From an interface file (tyvars may be kinded)
- = rn_poly_help tvs ctxt ty
+rnHsType doc (HsForAllTy tvs ctxt ty)
+ -- tvs are non-empty, hence must be from an interface file
+ -- (tyvars may be kinded)
+ = bindTyVarsRn doc tvs $ \ new_tyvars ->
+ rnContext doc ctxt `thenRn` \ new_ctxt ->
+ rnHsType doc ty `thenRn` \ new_ty ->
+ returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty)
-rnHsType full_ty@(HsPreForAllTy ctxt ty) -- A (context => ty) embedded in a type.
- -- Universally quantify over tyvars in context
- = getLocalNameEnv `thenRn` \ name_env ->
- let
- forall_tyvars = extractHsCtxtTyVars ctxt
- in
- rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
-rnHsType (MonoTyVar tyvar)
+rnHsType doc (MonoTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
returnRn (MonoTyVar tyvar')
-rnHsType (MonoFunTy ty1 ty2)
- = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
+rnHsType doc (MonoFunTy ty1 ty2)
+ = andRn MonoFunTy (rnHsType doc ty1) (rnHsType doc ty2)
-rnHsType (MonoListTy _ ty)
- = lookupImplicitOccRn listType_RDR `thenRn` \ tycon_name ->
- rnHsType ty `thenRn` \ ty' ->
- returnRn (MonoListTy tycon_name ty')
+rnHsType doc (MonoListTy ty)
+ = addImplicitOccRn listTyCon_name `thenRn_`
+ rnHsType doc ty `thenRn` \ ty' ->
+ returnRn (MonoListTy ty')
-rnHsType (MonoTupleTy _ tys)
- = lookupImplicitOccRn (tupleType_RDR (length tys)) `thenRn` \ tycon_name ->
- mapRn rnHsType tys `thenRn` \ tys' ->
- returnRn (MonoTupleTy tycon_name tys')
+rnHsType doc (MonoTupleTy tys boxed)
+ = addImplicitOccRn (tupleTyCon_name boxed (length tys)) `thenRn_`
+ mapRn (rnHsType doc) tys `thenRn` \ tys' ->
+ returnRn (MonoTupleTy tys' boxed)
-rnHsType (MonoTyApp ty1 ty2)
- = rnHsType ty1 `thenRn` \ ty1' ->
- rnHsType ty2 `thenRn` \ ty2' ->
+rnHsType doc (MonoTyApp ty1 ty2)
+ = rnHsType doc ty1 `thenRn` \ ty1' ->
+ rnHsType doc ty2 `thenRn` \ ty2' ->
returnRn (MonoTyApp ty1' ty2')
-rnHsType (MonoDictTy clas tys)
+rnHsType doc (MonoDictTy clas tys)
= lookupOccRn clas `thenRn` \ clas' ->
- mapRn rnHsType tys `thenRn` \ tys' ->
+ mapRn (rnHsType doc) tys `thenRn` \ tys' ->
returnRn (MonoDictTy clas' tys')
-
-rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars
- -> RdrNameContext
- -> RdrNameHsType
- -> RnMS s RenamedHsType
-rn_poly_help tyvars ctxt ty
- = bindTyVarsRn sig_doc tyvars $ \ new_tyvars ->
- rnContext ctxt `thenRn` \ new_ctxt ->
- rnHsType ty `thenRn` \ new_ty ->
- returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
- where
- sig_doc = text "a nested for-all type"
\end{code}
\begin{code}
-rnContext :: RdrNameContext -> RnMS s RenamedContext
+rnContext :: SDoc -> RdrNameContext -> RnMS s RenamedContext
-rnContext ctxt
- = mapRn rn_ctxt ctxt `thenRn` \ result ->
+rnContext doc ctxt
+ = mapRn rn_ctxt ctxt `thenRn` \ theta ->
let
- (_, dup_asserts) = removeDups cmp_assert result
- (alls, theta) = partition (\(c,_) -> c == allClass_NAME) result
+ (_, dup_asserts) = removeDups cmp_assert theta
in
-
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
- -- Check for All constraining a non-type-variable
- mapRn check_All alls `thenRn_`
-
- -- Done. Return a theta omitting all the "All" constraints.
- -- They have done done their work by ensuring that we universally
- -- quantify over their tyvar.
returnRn theta
where
rn_ctxt (clas, tys)
- = -- Mini hack here. If the class is our pseudo-class "All",
- -- then we don't want to record it as an occurrence, otherwise
- -- we try to slurp it in later and it doesn't really exist at all.
- -- Easiest thing is simply not to put it in the occurrence set.
- lookupBndrRn clas `thenRn` \ clas_name ->
- (if clas_name /= allClass_NAME then
- addOccurrenceName clas_name
- else
- returnRn clas_name
- ) `thenRn_`
- mapRn rnHsType tys `thenRn` \ tys' ->
+ = lookupBndrRn clas `thenRn` \ clas_name ->
+ addOccurrenceName clas_name `thenRn_`
+ mapRn (rnHsType doc) tys `thenRn` \ tys' ->
returnRn (clas_name, tys')
-
cmp_assert (c1,tys1) (c2,tys2)
= (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
-
- check_All (c, [MonoTyVar _]) = returnRn () -- OK!
- check_All assertion = addErrRn (wierdAllErr assertion)
\end{code}
= rnStrict strict `thenRn` \ strict' ->
returnRn (HsStrictness strict')
-rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
- returnRn (HsUnfold inline expr')
+rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ expr' ->
+ returnRn (HsUnfold inline (Just expr'))
+rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing)
rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
-rnIdInfo (HsFBType fb) = returnRn (HsFBType fb)
-rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
+rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs)
rnIdInfo (HsSpecialise tyvars tys expr)
= bindTyVarsRn doc tyvars $ \ tyvars' ->
rnCoreExpr expr `thenRn` \ expr' ->
- mapRn rnHsType tys `thenRn` \ tys' ->
+ mapRn (rnHsType doc) tys `thenRn` \ tys' ->
returnRn (HsSpecialise tyvars' tys' expr')
where
doc = text "Specialise in interface pragma"
UfCore expressions.
\begin{code}
+rnCoreExpr (UfType ty)
+ = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
+ returnRn (UfType ty')
+
rnCoreExpr (UfVar v)
= lookupOccRn v `thenRn` \ v' ->
returnRn (UfVar v')
-rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
-
rnCoreExpr (UfCon con args)
- = lookupOccRn con `thenRn` \ con' ->
- mapRn rnCoreArg args `thenRn` \ args' ->
+ = rnUfCon con `thenRn` \ con' ->
+ mapRn rnCoreExpr args `thenRn` \ args' ->
returnRn (UfCon con' args')
-rnCoreExpr (UfPrim prim args)
- = rnCorePrim prim `thenRn` \ prim' ->
- mapRn rnCoreArg args `thenRn` \ args' ->
- returnRn (UfPrim prim' args')
+rnCoreExpr (UfTuple con args)
+ = lookupOccRn con `thenRn` \ con' ->
+ mapRn rnCoreExpr args `thenRn` \ args' ->
+ returnRn (UfTuple con' args')
rnCoreExpr (UfApp fun arg)
= rnCoreExpr fun `thenRn` \ fun' ->
- rnCoreArg arg `thenRn` \ arg' ->
+ rnCoreExpr arg `thenRn` \ arg' ->
returnRn (UfApp fun' arg')
-rnCoreExpr (UfCase scrut alts)
- = rnCoreExpr scrut `thenRn` \ scrut' ->
- rnCoreAlts alts `thenRn` \ alts' ->
- returnRn (UfCase scrut' alts')
+rnCoreExpr (UfCase scrut bndr alts)
+ = rnCoreExpr scrut `thenRn` \ scrut' ->
+ bindLocalsRn "UfCase" [bndr] $ \ [bndr'] ->
+ mapRn rnCoreAlt alts `thenRn` \ alts' ->
+ returnRn (UfCase scrut' bndr' alts')
rnCoreExpr (UfNote note expr)
= rnNote note `thenRn` \ note' ->
\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
- = rnHsType ty `thenRn` \ ty' ->
- bindLocalsRn "unfolding value" [name] $ \ [name'] ->
+ = rnHsType (text str) ty `thenRn` \ ty' ->
+ bindLocalsRn str [name] $ \ [name'] ->
thing_inside (UfValBinder name' ty')
+ where
+ str = "unfolding id"
rnCoreBndr (UfTyBinder name kind) thing_inside
= bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
thing_inside (UfTyBinder name' kind)
rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders
- = mapRn rnHsType tys `thenRn` \ tys' ->
- bindLocalsRn "unfolding value" names $ \ names' ->
+ = mapRn (rnHsType (text str)) tys `thenRn` \ tys' ->
+ bindLocalsRn str names $ \ names' ->
thing_inside (zipWith UfValBinder names' tys')
where
- names = map (\ (UfValBinder name _) -> name) bndrs
- tys = map (\ (UfValBinder _ ty) -> ty) bndrs
-
-rnCoreBndrNamess names thing_inside
- = bindLocalsRn "unfolding value" names $ \ names' ->
- thing_inside names'
+ str = "unfolding id"
+ names = map (\ (UfValBinder name _ ) -> name) bndrs
+ tys = map (\ (UfValBinder _ ty) -> ty) bndrs
\end{code}
\begin{code}
-rnCoreArg (UfVarArg v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVarArg v')
-rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty')
-rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
-
-rnCoreAlts (UfAlgAlts alts deflt)
- = mapRn rn_alt alts `thenRn` \ alts' ->
- rnCoreDefault deflt `thenRn` \ deflt' ->
- returnRn (UfAlgAlts alts' deflt')
- where
- rn_alt (con, bndrs, rhs) = lookupOccRn con `thenRn` \ con' ->
- bindLocalsRn "unfolding alt" bndrs $ \ bndrs' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (con', bndrs', rhs')
-
-rnCoreAlts (UfPrimAlts alts deflt)
- = mapRn rn_alt alts `thenRn` \ alts' ->
- rnCoreDefault deflt `thenRn` \ deflt' ->
- returnRn (UfPrimAlts alts' deflt')
- where
- rn_alt (lit, rhs) = rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (lit, rhs')
+rnCoreAlt (con, bndrs, rhs)
+ = rnUfCon con `thenRn` \ con' ->
+ bindLocalsRn "unfolding alt" bndrs $ \ bndrs' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (con', bndrs', rhs')
-rnCoreDefault UfNoDefault = returnRn UfNoDefault
-rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr] $ \ [bndr'] ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (UfBindDefault bndr' rhs')
rnNote (UfCoerce ty)
- = rnHsType ty `thenRn` \ ty' ->
+ = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' ->
returnRn (UfCoerce ty')
rnNote (UfSCC cc) = returnRn (UfSCC cc)
rnNote UfInlineCall = returnRn UfInlineCall
-rnCorePrim (UfOtherOp op)
- = lookupOccRn op `thenRn` \ op' ->
- returnRn (UfOtherOp op')
-rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
- = mapRn rnHsType arg_tys `thenRn` \ arg_tys' ->
- rnHsType res_ty `thenRn` \ res_ty' ->
- returnRn (UfCCallOp str casm gc arg_tys' res_ty')
+rnUfCon UfDefault
+ = returnRn UfDefault
+
+rnUfCon (UfDataCon con)
+ = lookupOccRn con `thenRn` \ con' ->
+ returnRn (UfDataCon con')
+
+rnUfCon (UfLitCon lit)
+ = returnRn (UfLitCon lit)
+
+rnUfCon (UfLitLitCon lit ty)
+ = rnHsType (text "litlit") ty `thenRn` \ ty' ->
+ returnRn (UfLitLitCon lit ty')
+
+rnUfCon (UfPrimOp op)
+ = lookupOccRn op `thenRn` \ op' ->
+ returnRn (UfPrimOp op')
+
+rnUfCon (UfCCallOp str casm gc)
+ = returnRn (UfCCallOp str casm gc)
\end{code}
%*********************************************************
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
-wierdAllErr assertion
- = ptext SLIT("Mal-formed use of `All':") <+> pprClassAssertion assertion
-
-ctxtErr1 doc tyvars
- = hsep [ptext SLIT("Context constrains in-scope type variable(s)"),
- pprQuotedList tyvars]
- $$
- nest 4 (ptext SLIT("in") <+> doc)
-
-ctxtErr2 doc tyvars ty
- = (ptext SLIT("Context constrains type variable(s)")
- <+> pprQuotedList tyvars)
- $$
- nest 4 (vcat [ptext SLIT("that do not appear in") <+> quotes (ppr ty),
- ptext SLIT("in") <+> doc])
+ctxtErr1 doc tyvars ty (constraint, _)
+ = addErrRn (
+ sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
+ ptext SLIT("does not mention any of"),
+ nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)),
+ nest 4 (ptext SLIT("of the type") <+> quotes (ppr ty))
+ ]
+ $$
+ (ptext SLIT("In") <+> doc)
+ )
+
+ctxtErr2 doc ty (constraint,_)
+ = addErrRn (
+ sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint),
+ nest 4 (ptext SLIT("mentions type variables that do not appear in the type")),
+ nest 4 (quotes (ppr ty))]
+ $$
+ (ptext SLIT("In") <+> doc)
+ )
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
#include "HsVersions.h"
-import CoreSyn ( CoreBinding )
-import Util ( panic{-ToDo:rm-} )
+-- Just a stub for now
+import CoreSyn ( CoreBind )
+import Util ( panic )
--import Util
--import Id ( addIdFBTypeInfo )
\begin{code}
analFBWW
- :: [CoreBinding]
- -> [CoreBinding]
+ :: [CoreBind]
+ -> [CoreBind]
analFBWW = panic "analFBWW (ToDo)"
where
anals :: [InBinding]
anals = newOccurAnalyseBinds top_binds (const False)
- anno = mapAccumL annotateBindingFBWW nullIdEnv anals
+ anno = mapAccumL annotateBindingFBWW emptyVarEnv anals
\end{code}
\begin{code}
(ppr foldr_id)
(foldr_id == foldrId && isCons c) = goodProdFBType
where
- isCons c = case lookupIdEnv env c of
+ isCons c = case lookupVarEnv env c of
Just IsCons -> True
_ -> False
-analExprFBWW (Var v) env = maybeFBtoFB (lookupIdEnv env v)
+analExprFBWW (Var v) env = maybeFBtoFB (lookupVarEnv env v)
analExprFBWW (Lit _) _ = unknownFBType
--
--
analExprFBWW (Con con _ [_,VarArg y]) env
- | con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
+ | con == consDataCon = maybeFBtoFB (lookupVarEnv env y)
--
-- [] is good
--
| con == consDataCon && x == x' && y == y'
= IsCons
analExprFBWW (Lam (id,_) e) env
- = addArgs 1 (analExprFBWW e (delOneFromIdEnv env id))
+ = addArgs 1 (analExprFBWW e (delVarEnv env id))
analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
Just ty -> ty : tys
Nothing -> tys
where
- tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts
+ tys = map (\(con,binders,e) -> analExprFBWW e (delVarEnvList env (map fst binders))) alts
analAltsFBWW (PrimAlts alts deflt) env
= case analDefFBWW deflt env of
Just ty -> ty : tys
analDefFBWW NoDefault env = Nothing
-analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
+analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delVarEnv env (fst v)))
\end{code}
analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
analBind (NonRec (v,bnd) e) env =
case analBindExpr bnd e env of
- ty@(IsFB _) -> addOneToIdEnv env v ty
- ty@(IsCons) -> addOneToIdEnv env v ty
- _ -> delOneFromIdEnv env v -- remember about shadowing!
+ ty@(IsFB _) -> extendVarEnv env v ty
+ ty@(IsCons) -> extendVarEnv env v ty
+ _ -> delVarEnv env v -- remember about shadowing!
analBind (Rec binds) env =
let
first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
(_,args,_) <- [collectBinders e]]
- env' = delManyFromIdEnv env (map (fst.fst) binds)
+ env' = delVarEnvList env (map (fst.fst) binds)
in
- growIdEnvList env' (fixpoint 0 binds env' first_set)
+ extendVarEnvList env' (fixpoint 0 binds env' first_set)
fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
fixpoint n binds env maps =
then maps
else fixpoint (n+1) binds env maps'
where
- env' = growIdEnvList env maps
+ env' = extendVarEnvList env maps
maps' = [ (v,ty) | ((v,bind),e) <- binds,
(ty@(IsFB (FBType cons prod))) <- [analBindExpr bind e env']]
annotateExprFBWW (Con c t a) env = Con c t a
annotateExprFBWW (Prim p t a) env = Prim p t a
annotateExprFBWW (Lam (id,_) e) env
- = Lam id (annotateExprFBWW e (delOneFromIdEnv env id))
+ = Lam id (annotateExprFBWW e (delVarEnv env id))
annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
where
alts' = [ let
binders' = map fst binders
- in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
+ in (con,binders',annotateExprFBWW e (delVarEnvList env binders'))
| (con,binders,e) <- alts ]
deflt' = annotateDefFBWW deflt env
annotateAltsFBWW (PrimAlts alts deflt) env = PrimAlts alts' deflt'
annotateDefFBWW NoDefault env = NoDefault
annotateDefFBWW (BindDefault v e) env
- = BindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
+ = BindDefault (fst v) (annotateExprFBWW e (delVarEnv env (fst v)))
annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
annotateBindingFBWW env bnds = (env',bnds')
NonRec (v,_) e -> NonRec (fixId v) (annotateExprFBWW e env)
Rec bnds -> Rec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
fixId v =
- (case lookupIdEnv env' v of
+ (case lookupVarEnv env' v of
Just (IsFB ty@(FBType xs p))
| not (null xs) -> pprTrace "ADDED to:" (ppr v)
(addIdFBTypeInfo v (mkFBTypeInfo ty))
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
\begin{code}
module BinderInfo (
BinderInfo(..),
- FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!)
- addBinderInfo, orBinderInfo, andBinderInfo,
+ addBinderInfo, orBinderInfo,
- deadOccurrence, argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo,
+ deadOccurrence, funOccurrence, noBinderInfo,
- markMany, markDangerousToDup, markInsideSCC,
+ markLazy, markMany, markInsideLam, markInsideSCC,
getBinderInfoArity,
setBinderInfoArityToZero,
- isOneOcc, isOneFunOcc, isOneSafeFunOcc, isOneSameSCCFunOcc,
- isDeadOcc, isInlinableOcc,
-
- isFun, isDupDanger -- for Simon Marlow deforestation
+ occInfoToInlinePrag
) where
#include "HsVersions.h"
+import IdInfo ( InlinePragInfo(..), OccInfo(..) )
import Util ( panic )
import GlaExts ( Int(..), (+#) )
import Outputable
-
\end{code}
The @BinderInfo@ describes how a variable is used in a given scope.
| OneOcc -- Just one occurrence (or one each in
-- mutually-exclusive case alts).
- !FunOrArg -- How it occurs
-
- !DuplicationDanger
+ !OccInfo
!InsideSCC
-- (because the RHS will be inlined regardless of its size)
-- [again, DupDanger]
-data FunOrArg
- = FunOcc -- An occurrence in a function position
- | ArgOcc -- Other arg occurrence
-
- -- When combining branches of a case, only report FunOcc if
- -- both branches are FunOccs
-
-data DuplicationDanger
- = DupDanger -- Inside a non-linear lambda (that is, a lambda which
- -- is sure to be instantiated only once), or inside
- -- the rhs of an INLINE-pragma'd thing. Either way,
- -- substituting a redex for this occurrence is
- -- dangerous because it might duplicate work.
-
- | NoDupDanger -- It's ok; substitution won't duplicate work.
-
data InsideSCC
= InsideSCC -- Inside an SCC; so be careful when substituting.
| NotInsideSCC -- It's ok.
noBinderInfo = ManyOcc 0 -- A non-committal value
-\end{code}
-
-
+\end{code}
\begin{code}
-isOneOcc :: BinderInfo -> Bool
-isOneOcc (OneOcc _ _ _ _ _) = True
-isOneOcc other_bind = False
-
-isOneFunOcc :: BinderInfo -> Bool
-isOneFunOcc (OneOcc FunOcc _ _ _ _) = True
-isOneFunOcc other_bind = False
-
-isOneSameSCCFunOcc :: BinderInfo -> Bool
-isOneSameSCCFunOcc (OneOcc FunOcc _ NotInsideSCC _ _) = True
-isOneSameSCCFunOcc other_bind = False
-
-isOneSafeFunOcc :: BinderInfo -> Bool -- Completely safe
-isOneSafeFunOcc (OneOcc FunOcc NoDupDanger NotInsideSCC n_alts _) = n_alts <= 1
-isOneSafeFunOcc other = False
-
--- A non-WHNF can be inlined if it doesn't occur inside a lambda,
--- and occurs exactly once or
--- occurs once in each branch of a case and is small
---
--- If the thing is in WHNF, there's no danger of duplicating work,
--- so we can inline if it occurs once, or is small
-isInlinableOcc :: Bool -- True <=> don't worry about dup-danger
- -> Bool -- True <=> don't worry about code size
- -> BinderInfo
- -> Bool -- Inlinable
-isInlinableOcc whnf small (ManyOcc _)
- = whnf && small
-isInlinableOcc whnf small (OneOcc _ dup_danger _ n_alts _)
- = (whnf || (case dup_danger of {NoDupDanger -> True; other -> False}))
- && (small || n_alts <= 1)
-isInlinableOcc _ _ DeadCode = False
-
-isDeadOcc :: BinderInfo -> Bool
-isDeadOcc DeadCode = True
-isDeadOcc other = False
-
-isFun :: FunOrArg -> Bool
-isFun FunOcc = True
-isFun _ = False
-
-isDupDanger :: DuplicationDanger -> Bool
-isDupDanger DupDanger = True
-isDupDanger _ = False
+occInfoToInlinePrag :: BinderInfo -> InlinePragInfo
+occInfoToInlinePrag DeadCode = IAmDead
+occInfoToInlinePrag (OneOcc occ_info NotInsideSCC n_alts _) = ICanSafelyBeINLINEd occ_info (n_alts==1)
+occInfoToInlinePrag other = NoInlinePragInfo
\end{code}
deadOccurrence :: BinderInfo
deadOccurrence = DeadCode
-argOccurrence, funOccurrence :: Int -> BinderInfo
-
-funOccurrence = OneOcc FunOcc NoDupDanger NotInsideSCC 1
-argOccurrence = OneOcc ArgOcc NoDupDanger NotInsideSCC 1
+funOccurrence :: Int -> BinderInfo
+funOccurrence = OneOcc StrictOcc NotInsideSCC 1
-markMany, markDangerousToDup, markInsideSCC :: BinderInfo -> BinderInfo
+markLazy, markMany, markInsideLam, markInsideSCC :: BinderInfo -> BinderInfo
-markMany (OneOcc _ _ _ _ ar) = ManyOcc ar
-markMany (ManyOcc ar) = ManyOcc ar
-markMany DeadCode = panic "markMany"
+markMany (OneOcc _ _ _ ar) = ManyOcc ar
+markMany (ManyOcc ar) = ManyOcc ar
+markMany DeadCode = panic "markMany"
-markDangerousToDup (OneOcc posn _ in_scc n_alts ar)
- = OneOcc posn DupDanger in_scc n_alts ar
-markDangerousToDup other = other
+markInsideLam (OneOcc _ in_scc n_alts ar) = OneOcc InsideLam in_scc n_alts ar
+markInsideLam other = other
-dangerousArgOcc = OneOcc ArgOcc DupDanger NotInsideSCC 1 0
+markInsideSCC (OneOcc dup_danger _ n_alts ar) = OneOcc dup_danger InsideSCC n_alts ar
+markInsideSCC other = other
-markInsideSCC (OneOcc posn dup_danger _ n_alts ar)
- = OneOcc posn dup_danger InsideSCC n_alts ar
-markInsideSCC other = other
+markLazy (OneOcc StrictOcc scc n_alts ar) = OneOcc LazyOcc scc n_alts ar
+markLazy other = other
-addBinderInfo, orBinderInfo
- :: BinderInfo -> BinderInfo -> BinderInfo
+addBinderInfo, orBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
addBinderInfo DeadCode info2 = info2
addBinderInfo info1 DeadCode = info1
addBinderInfo info1 info2
= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
--- (orBinderInfo orig new) is used in two situations:
--- First, when a variable whose occurrence info
--- is currently "orig" is bound to a variable whose occurrence info is "new"
--- eg (\new -> e) orig
--- What we want to do is to *worsen* orig's info to take account of new's
---
--- Second, when combining occurrence info from branches of a case
+-- (orBinderInfo orig new) is used
+-- when combining occurrence info from branches of a case
orBinderInfo DeadCode info2 = info2
orBinderInfo info1 DeadCode = info1
-orBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
- (OneOcc posn2 dup2 scc2 n_alts2 ar_2)
+orBinderInfo (OneOcc dup1 scc1 n_alts1 ar_1)
+ (OneOcc dup2 scc2 n_alts2 ar_2)
= let
- posn = combine_posns posn1 posn2
- scc = combine_sccs scc1 scc2
- dup = combine_dups dup1 dup2
+ scc = or_sccs scc1 scc2
+ dup = or_dups dup1 dup2
alts = n_alts1 + n_alts2
ar = min ar_1 ar_2
in
- OneOcc posn dup scc alts ar
+ OneOcc dup scc alts ar
orBinderInfo info1 info2
= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
--- (andBinderInfo orig new) is used
--- when completing a let-binding
--- let new = ...orig...
--- we compute the way orig occurs in (...orig...), and then use andBinderInfo
--- to worsen this info by the way new occurs in the let body; then we use
--- that to worsen orig's currently recorded occurrence info.
-
-andBinderInfo DeadCode info2 = DeadCode
-andBinderInfo info1 DeadCode = DeadCode
-andBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
- (OneOcc posn2 dup2 scc2 n_alts2 ar_2)
- = let
- posn = combine_posns posn1 posn2
- scc = combine_sccs scc1 scc2
- dup = combine_dups dup1 dup2
- alts = n_alts1 + n_alts2
- in
- OneOcc posn dup scc alts ar_1
-
-andBinderInfo info1 info2 = ManyOcc (getBinderInfoArity info1)
-
+or_dups InsideLam _ = InsideLam
+or_dups _ InsideLam = InsideLam
+or_dups StrictOcc StrictOcc = StrictOcc
+or_dups _ _ = LazyOcc
-combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn
-combine_posns _ _ = ArgOcc
-
-combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo
-combine_dups _ DupDanger = DupDanger
-combine_dups _ _ = NoDupDanger
-
-combine_sccs InsideSCC _ = InsideSCC -- Too paranoid?? ToDo
-combine_sccs _ InsideSCC = InsideSCC
-combine_sccs _ _ = NotInsideSCC
+or_sccs InsideSCC _ = InsideSCC
+or_sccs _ InsideSCC = InsideSCC
+or_sccs _ _ = NotInsideSCC
setBinderInfoArityToZero :: BinderInfo -> BinderInfo
setBinderInfoArityToZero DeadCode = DeadCode
setBinderInfoArityToZero (ManyOcc _) = ManyOcc 0
-setBinderInfoArityToZero (OneOcc fa dd sc i _) = OneOcc fa dd sc i 0
+setBinderInfoArityToZero (OneOcc dd sc i _) = OneOcc dd sc i 0
\end{code}
\begin{code}
getBinderInfoArity (DeadCode) = 0
getBinderInfoArity (ManyOcc i) = i
-getBinderInfoArity (OneOcc _ _ _ _ i) = i
+getBinderInfoArity (OneOcc _ _ _ i) = i
\end{code}
\begin{code}
instance Outputable BinderInfo where
ppr DeadCode = ptext SLIT("Dead")
ppr (ManyOcc ar) = hcat [ ptext SLIT("Many-"), int ar ]
- ppr (OneOcc posn dup_danger in_scc n_alts ar)
- = hcat [ ptext SLIT("One-"), pp_posn posn, char '-', pp_danger dup_danger,
+ ppr (OneOcc dup_danger in_scc n_alts ar)
+ = hcat [ ptext SLIT("One-"), ppr dup_danger,
char '-', pp_scc in_scc, char '-', int n_alts,
char '-', int ar ]
where
- pp_posn FunOcc = ptext SLIT("fun")
- pp_posn ArgOcc = ptext SLIT("arg")
-
- pp_danger DupDanger = ptext SLIT("*dup*")
- pp_danger NoDupDanger = ptext SLIT("nodup")
-
pp_scc InsideSCC = ptext SLIT("*SCC*")
pp_scc NotInsideSCC = ptext SLIT("noscc")
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ConFold]{Constant Folder}
(i1 + i2) only if it results in a valid Float.
\begin{code}
-module ConFold ( completePrim ) where
+module ConFold ( cleverMkPrimApp ) where
#include "HsVersions.h"
import CoreSyn
-import CoreUnfold ( Unfolding )
-import Id ( idType )
-import Literal ( mkMachInt, mkMachWord, Literal(..) )
+import Id ( getIdUnfolding )
+import Const ( mkMachInt, mkMachWord, Literal(..), Con(..) )
import PrimOp ( PrimOp(..) )
-import SimplEnv
import SimplMonad
-import SimplUtils ( newId )
import TysWiredIn ( trueDataCon, falseDataCon )
import Char ( ord, chr )
\end{code}
\begin{code}
-completePrim :: SimplEnv
- -> PrimOp -> [OutArg]
- -> SmplM OutExpr
+cleverMkPrimApp :: PrimOp -> [CoreArg] -> CoreExpr
\end{code}
In the parallel world, we use _seq_ to control the order in which
The second case must never be floated outside of the first!
-\begin{code}
-completePrim env SeqOp [TyArg ty, LitArg lit]
- = returnSmpl (Lit (mkMachInt 1))
+\begin{code}p
+cleverMkPrimApp SeqOp [Type ty, Con (Literal lit) _]
+ = Con (Literal (mkMachInt 1)) []
-completePrim env op@SeqOp args@[TyArg ty, VarArg var]
- | isEvaluated (lookupUnfolding env var) = returnSmpl (Lit (mkMachInt 1)) -- var is eval'd
- | otherwise = returnSmpl (Prim op args) -- var not eval'd
+cleverMkPrimApp SeqOp args@[Type ty, Var var]
+ | isEvaluated (getIdUnfolding var) = Con (Literal (mkMachInt 1)) []) -- var is eval'd
+ | otherwise = Con (PrimOp op) args -- var not eval'd
\end{code}
\begin{code}
-completePrim env op args
+cleverMkPrimApp op args
= case args of
- [LitArg (MachChar char_lit)] -> oneCharLit op char_lit
- [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
+ [Con (Literal (MachChar char_lit)) _] -> oneCharLit op char_lit
+ [Con (Literal (MachInt int_lit signed)) _] -> (if signed then oneIntLit else oneWordLit)
op int_lit
- [LitArg (MachFloat float_lit)] -> oneFloatLit op float_lit
- [LitArg (MachDouble double_lit)] -> oneDoubleLit op double_lit
- [LitArg other_lit] -> oneLit op other_lit
+ [Con (Literal (MachFloat float_lit)) _] -> oneFloatLit op float_lit
+ [Con (Literal (MachDouble double_lit)) _] -> oneDoubleLit op double_lit
+ [Con (Literal other_lit) _] -> oneLit op other_lit
- [LitArg (MachChar char_lit1),
- LitArg (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
+ [Con (Literal (MachChar char_lit1)) _,
+ Con (Literal (MachChar char_lit2)) _] -> twoCharLits op char_lit1 char_lit2
- [LitArg (MachInt int_lit1 True), -- both *signed* literals
- LitArg (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
+ [Con (Literal (MachInt int_lit1 True)) _, -- both *signed* literals
+ Con (Literal (MachInt int_lit2 True)) _] -> twoIntLits op int_lit1 int_lit2
- [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
- LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
+ [Con (Literal (MachInt int_lit1 False)) _, -- both *unsigned* literals
+ Con (Literal (MachInt int_lit2 False)) _] -> twoWordLits op int_lit1 int_lit2
- [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
- LitArg (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
+ [Con (Literal (MachInt int_lit1 False)) _, -- unsigned+signed (shift ops)
+ Con (Literal (MachInt int_lit2 True)) _] -> oneWordOneIntLit op int_lit1 int_lit2
- [LitArg (MachFloat float_lit1),
- LitArg (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
+ [Con (Literal (MachFloat float_lit1)) _,
+ Con (Literal (MachFloat float_lit2)) _] -> twoFloatLits op float_lit1 float_lit2
- [LitArg (MachDouble double_lit1),
- LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
+ [Con (Literal (MachDouble double_lit1)) _,
+ Con (Literal (MachDouble double_lit2)) _] -> twoDoubleLits op double_lit1 double_lit2
- [LitArg lit, VarArg var] -> litVar op lit var
- [VarArg var, LitArg lit] -> litVar op lit var
+ [Con (Literal lit) _, Var var] -> litVar op lit var
+ [Var var, Con (Literal lit) _] -> litVar op lit var
- other -> give_up
+ other -> give_up
where
- give_up = returnSmpl (Prim op args)
+ give_up = Con (PrimOp op) args
- return_char c = returnSmpl (Lit (MachChar c))
- return_int i = returnSmpl (Lit (mkMachInt i))
- return_word i = returnSmpl (Lit (mkMachWord i))
- return_float f = returnSmpl (Lit (MachFloat f))
- return_double d = returnSmpl (Lit (MachDouble d))
- return_lit lit = returnSmpl (Lit lit)
+ return_char c = Con (Literal (MachChar c)) []
+ return_int i = Con (Literal (mkMachInt i)) []
+ return_word i = Con (Literal (mkMachWord i)) []
+ return_float f = Con (Literal (MachFloat f)) []
+ return_double d = Con (Literal (MachDouble d)) []
+ return_lit lit = Con (Literal lit) []
- return_bool True = returnSmpl trueVal
- return_bool False = returnSmpl falseVal
+ return_bool True = trueVal
+ return_bool False = falseVal
return_prim_case var lit val_if_eq val_if_neq
- = newId (idType var) `thenSmpl` \ unused_binder ->
- let
- result
- = Case (Var var)
- (PrimAlts [(lit,val_if_eq)]
- (BindDefault unused_binder val_if_neq))
- in
- returnSmpl result
+ = Case (Var var) var [(Literal lit, [], val_if_eq),
+ (DEFAULT, [], val_if_neq)]
--------- Ints --------------
oneIntLit IntNegOp i = return_int (-i)
litVar other_op lit var = give_up
- checkRange :: Integer -> SmplM OutExpr
+ checkRange :: Integer -> CoreExpr
checkRange val
| (val > fromInt maxInt) || (val < fromInt minInt) =
-- Better tell the user that we've overflowed...
pprTrace "Warning:" (text "Integer overflow in expression: " <>
- ppr ((Prim op args)::CoreExpr)) $
+ ppr ((mkPrimApp op args)::CoreExpr)) $
-- ..not that it stops us from actually folding!
-- ToDo: a SrcLoc would be nice.
return_int val
| otherwise = return_int val
-trueVal = Con trueDataCon []
-falseVal = Con falseDataCon []
+trueVal = Con (DataCon trueDataCon) []
+falseVal = Con (DataCon falseDataCon) []
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
#include "HsVersions.h"
-import AnnCoreSyn
+import CmdLineOpts ( opt_D_verbose_core2core )
import CoreSyn
-
-import FreeVars
-import Id ( emptyIdSet, unionIdSets, unionManyIdSets,
- elementOfIdSet, IdSet, GenId, Id
- )
-import Util ( nOfThem, panic, zipEqual )
+import CoreLint ( beginPass, endPass )
+import FreeVars ( CoreExprWithFVs, freeVars, freeVarsOf )
+import Var ( Id )
+import VarSet
+import Util ( zipEqual )
+import Outputable
\end{code}
Top-level interface function, @floatInwards@. Note that we do not
actually float any bindings downwards from the top-level.
\begin{code}
-floatInwards :: [CoreBinding] -> [CoreBinding]
+floatInwards :: [CoreBind] -> IO [CoreBind]
floatInwards binds
- = map fi_top_bind binds
+ = do {
+ beginPass "Float inwards";
+ let { binds' = map fi_top_bind binds };
+ endPass "Float inwards"
+ opt_D_verbose_core2core {- no specific flag for dumping float-in -}
+ binds'
+ }
+
where
fi_top_bind (NonRec binder rhs)
= NonRec binder (fiExpr [] (freeVars rhs))
Actually we are not doing a proper full laziness (see below), which
was another reason for not floating inwards past a lambda.
-This can easily be fixed.
-The problem is that we float lets outwards,
-but there are a few expressions which are not
-let bound, like case scrutinees and case alternatives.
-After floating inwards the simplifier could decide to inline
-the let and the laziness would be lost, e.g.
+This can easily be fixed. The problem is that we float lets outwards,
+but there are a few expressions which are not let bound, like case
+scrutinees and case alternatives. After floating inwards the
+simplifier could decide to inline the let and the laziness would be
+lost, e.g.
+
\begin{verbatim}
let a = expensive ==> \b -> case expensive of ...
in \ b -> case a of ...
\begin{code}
type FreeVarsSet = IdSet
-type FloatingBinds = [(CoreBinding, FreeVarsSet)]
- -- In dependency order (outermost first)
+type FloatingBinds = [(CoreBind, FreeVarsSet)]
+ -- In reverse dependency order (innermost bindiner first)
-- The FreeVarsSet is the free variables of the binding. In the case
-- of recursive bindings, the set doesn't include the bound
-- variables.
-fiExpr :: FloatingBinds -- binds we're trying to drop
+fiExpr :: FloatingBinds -- Binds we're trying to drop
-- as far "inwards" as possible
- -> CoreExprWithFVs -- input expr
- -> CoreExpr -- result
-
-fiExpr to_drop (_,AnnVar v) = mkCoLets' to_drop (Var v)
+ -> CoreExprWithFVs -- Input expr
+ -> CoreExpr -- Result
-fiExpr to_drop (_,AnnLit k) = mkCoLets' to_drop (Lit k)
+fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
-fiExpr to_drop (_,AnnCon c atoms)
- = mkCoLets' to_drop (Con c atoms)
+fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
+ Type ty
-fiExpr to_drop (_,AnnPrim c atoms)
- = mkCoLets' to_drop (Prim c atoms)
+fiExpr to_drop (_, AnnCon c args)
+ = mkCoLets' drop_here (Con c args')
+ where
+ (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
+ args' = zipWith fiExpr arg_drops args
\end{code}
-Here we are not floating inside lambda (type lambdas are OK):
+Applications: we do float inside applications, mainly because we
+need to get at all the arguments. The next simplifier run will
+pull out any silly ones.
+
\begin{code}
-fiExpr to_drop (_,AnnLam b@(ValBinder binder) body)
- = mkCoLets' to_drop (Lam b (fiExpr [] body))
+fiExpr to_drop (_,AnnApp fun arg)
+ = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
+ where
+ [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint [freeVarsOf fun, freeVarsOf arg] to_drop
+\end{code}
-fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body)
- | whnf body
- -- we do not float into type lambdas if they are followed by
- -- a whnf (actually we check for lambdas and constructors).
- -- The reason is that a let binding will get stuck
- -- in between the type lambda and the whnf and the simplifier
- -- does not know how to pull it back out from a type lambda.
- -- Ex:
- -- let v = ...
- -- in let f = /\t -> \a -> ...
- -- ==>
- -- let f = /\t -> let v = ... in \a -> ...
- -- which is bad as now f is an updatable closure (update PAP)
- -- and has arity 0. This example comes from cichelli.
+We are careful about lambdas:
- = mkCoLets' to_drop (Lam b (fiExpr [] body))
- | otherwise
- = Lam b (fiExpr to_drop body)
- where
- whnf :: CoreExprWithFVs -> Bool
+* We never float inside a value lambda. That risks losing laziness.
+ The float-out pass might rescue us, but then again it might not.
- whnf (_,AnnLit _) = True
- whnf (_,AnnCon _ _) = True
- whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
- whnf (_,AnnNote _ e) = whnf e
- whnf _ = False
-\end{code}
+* We don't float inside type lambdas either. At one time we did, and
+ there is no risk of duplicating work thereby, but we do need to be
+ careful. In particular, here is a bad case (it happened in the
+ cichelli benchmark:
+ let v = ...
+ in let f = /\t -> \a -> ...
+ ==>
+ let f = /\t -> let v = ... in \a -> ...
+ This is bad as now f is an updatable closure (update PAP)
+ and has arity 0.
+
+So the simple thing is never to float inside big lambda either.
+Maybe we'll find cases when that loses something important; if
+so we can modify the decision.
-Applications: we could float inside applications, but it's probably
-not worth it (a purely practical choice, hunch- [not experience-]
-based).
\begin{code}
-fiExpr to_drop (_,AnnApp fun arg)
- | isValArg arg
- = mkCoLets' to_drop (App (fiExpr [] fun) arg)
- | otherwise
- = App (fiExpr to_drop fun) arg
+fiExpr to_drop (_, AnnLam b body)
+ = mkCoLets' to_drop (Lam b (fiExpr [] body))
\end{code}
We don't float lets inwards past an SCC.
-
-ToDo: SCC: {\em should}
+ ToDo: keep info on current cc, and when passing
+ one, if it is not the same, annotate all lets in binds with current
+ cc, change current cc to the new one and float binds into expr.
\begin{code}
fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
= -- Wimp out for now
- -- ToDo: keep info on current cc, and when passing
- -- one, if it is not the same, annotate all lets in binds with current
- -- cc, change current cc to the new one and float binds into expr.
mkCoLets' to_drop (Note note (fiExpr [] expr))
fiExpr to_drop (_, AnnNote InlineCall expr)
rhs_fvs = freeVarsOf rhs
body_fvs = freeVarsOf body
- ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
+ [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
new_to_drop = body_binds ++ -- the bindings used only in the body
[(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
-- Push rhs_binds into the right hand side of the binding
rhs' = fiExpr rhs_binds rhs
- rhs_fvs' = rhs_fvs `unionIdSets` floatedBindsFVs rhs_binds
+ rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
= fiExpr new_to_drop body
rhss_fvs = map freeVarsOf rhss
body_fvs = freeVarsOf body
- (body_binds:rhss_binds, shared_binds)
- = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
+ (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
new_to_drop = -- the bindings used only in the body
body_binds ++
-- the bindings used both in rhs and body or in more than one rhs
shared_binds
- rhs_fvs' = unionIdSets (unionManyIdSets rhss_fvs)
- (unionManyIdSets (map floatedBindsFVs rhss_binds))
+ rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
+ (unionVarSets (map floatedBindsFVs rhss_binds))
-- Push rhs_binds into the right hand side of the binding
fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
-> [(Id, CoreExpr)]
fi_bind to_drops pairs
- = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
+ = [ (binder, fiExpr to_drop rhs)
+ | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
\end{code}
For @Case@, the possible ``drop points'' for the \tr{to_drop}
alternatives/default [default FVs always {\em first}!].
\begin{code}
-fiExpr to_drop (_, AnnCase scrut alts)
- = let
- fvs_scrut = freeVarsOf scrut
- drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts)
- in
- case (sepBindsByDropPoint drop_pts_fvs to_drop)
- of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
- mkCoLets' drop_here (Case (fiExpr scrut_drops scrut)
- (fi_alts deflt_drops alts_drops alts))
-
+fiExpr to_drop (_, AnnCase scrut case_bndr alts)
+ = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr
+ (zipWith fi_alt alts_drops alts))
where
- ----------------------------
- -- pin default FVs on first!
- --
- get_fvs_from_deflt_and_alts (AnnAlgAlts alts deflt)
- = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
-
- get_fvs_from_deflt_and_alts (AnnPrimAlts alts deflt)
- = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
-
- get_deflt_fvs AnnNoDefault = emptyIdSet
- get_deflt_fvs (AnnBindDefault b rhs) = freeVarsOf rhs
-
- ----------------------------
- fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
- = AlgAlts
- [ (con, params, fiExpr to_drop rhs)
- | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ]
- (fi_default to_drop_deflt deflt)
-
- fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
- = PrimAlts
- [ (lit, fiExpr to_drop rhs)
- | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ]
- (fi_default to_drop_deflt deflt)
-
- fi_default to_drop AnnNoDefault = NoDefault
- fi_default to_drop (AnnBindDefault b e) = BindDefault b (fiExpr to_drop e)
+ (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop
+ scrut_fvs = freeVarsOf scrut
+ alts_fvs = map alt_fvs alts
+ alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
+ -- Delete case_bndr and args from free vars of rhs
+ -- to get free vars of alt
+
+ fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
\end{code}
+
%************************************************************************
%* *
\subsection{@sepBindsByDropPoint@}
\begin{code}
sepBindsByDropPoint
- :: [FreeVarsSet] -- one set of FVs per drop point
- -> FloatingBinds -- candidate floaters
- -> ([FloatingBinds], -- floaters that *can* be floated into
- -- the corresponding drop point
- FloatingBinds) -- everything else, bindings which must
- -- not be floated inside any drop point
+ :: [FreeVarsSet] -- One set of FVs per drop point
+ -> FloatingBinds -- Candidate floaters
+ -> [FloatingBinds] -- FIRST one is bindings which must not be floated
+ -- inside any drop point; the rest correspond
+ -- one-to-one with the input list of FV sets
+
+-- Every input floater is returned somewhere in the result;
+-- none are dropped, not even ones which don't seem to be
+-- free in *any* of the drop-point fvs. Why? Because, for example,
+-- a binding (let x = E in B) might have a specialised version of
+-- x (say x') stored inside x, but x' isn't free in E or B.
sepBindsByDropPoint drop_pts []
- = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens
+ = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens
sepBindsByDropPoint drop_pts floaters
- = let
- (must_stay_here : per_drop_pt)
- = split' floaters ((emptyIdSet : drop_pts) `zip` repeat [])
- in
- (per_drop_pt, must_stay_here)
+ = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
where
- split' [] drop_boxes = map (reverse . snd) drop_boxes
+ go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [FloatingBinds]
+ -- The *first* one in the argument list is the drop_here set
+ -- The FloatingBinds in the lists are in the reverse of
+ -- the normal FloatingBinds order; that is, they are the right way round!
+
+ go [] drop_boxes = map (reverse . snd) drop_boxes
- split' (bind:binds) drop_boxes
- = split' binds drop_boxes'
- where
- drop_boxes' = zipWith drop drop_flags drop_boxes
- drop_flags | no_of_branches == 1 -- Exactly one branch
- = used_in_flags
- | otherwise -- Zero or many branches; drop it here
- = True : repeat False
+ go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes
+ = go binds (insert drop_boxes (drop_here : used_in_flags))
+ -- insert puts the find in box whose True flag comes first
+ where
+ (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
+ | (fvs, drops) <- drop_boxes]
- binders = bindersOf (fst bind)
- no_of_branches = length [() | True <- used_in_flags]
- used_in_flags = [ any (`elementOfIdSet` branch_fvs) binders
- | (branch_fvs,_) <- drop_boxes ]
+ drop_here = used_here || not (exactlyOneTrue used_in_flags)
- drop True (drop_fvs, box) = (drop_fvs `unionIdSets` fvsOfBind bind, bind:box)
- drop False (drop_fvs, box) = (drop_fvs, box)
-
+ insert ((fvs,drops) : drop_boxes) (True : _)
+ = ((fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) : drop_boxes)
+ insert (drop_box : drop_boxes) (False : others)
+ = drop_box : insert drop_boxes others
+ insert _ _ = panic "sepBindsByDropPoint" -- Should never happen
- fvsOfBind (_,fvs) = fvs
+exactlyOneTrue :: [Bool] -> Bool
+exactlyOneTrue flags = case [() | True <- flags] of
+ [_] -> True
+ other -> False
floatedBindsFVs :: FloatingBinds -> FreeVarsSet
-floatedBindsFVs binds = unionManyIdSets (map snd binds)
+floatedBindsFVs binds = unionVarSets (map snd binds)
mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
-mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
+mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
+ -- Remember to_drop is in *reverse* dependency order
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[FloatOut]{Float bindings outwards (towards the top level)}
import CoreSyn
import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats )
+import ErrUtils ( dumpIfSet )
import CostCentre ( dupifyCC, CostCentre )
-import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv,
- Id
- )
+import Id ( Id )
+import Const ( isWHNFCon )
+import VarEnv
+import CoreLint ( beginPass, endPass )
import PprCore
-import SetLevels -- all of it
+import SetLevels ( setLevels,
+ Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl
+ )
import BasicTypes ( Unused )
-import TyVar ( TyVar )
+import Var ( TyVar )
import UniqSupply ( UniqSupply )
import List ( partition )
import Outputable
@
\deq x ys -> let eq = eqFromEqDict deq in ...
@
-which might usefully be separated to
+vwhich might usefully be separated to
@
\deq -> let eq = eqFromEqDict deq in \xy -> ...
@
Well, maybe. We don't do this at the moment.
\begin{code}
-type LevelledExpr = GenCoreExpr (Id, Level) Id Unused
-type LevelledBind = GenCoreBinding (Id, Level) Id Unused
-type FloatingBind = (Level, Floater)
-type FloatingBinds = [FloatingBind]
-
-data Floater
- = LetFloater CoreBinding
- | CaseFloater (CoreExpr -> CoreExpr)
- -- A CoreExpr with a hole in it:
- -- "Give me a right-hand side of the
- -- (usually single) alternative, and
- -- I'll build the case..."
+type LevelledExpr = TaggedExpr Level
+type LevelledBind = TaggedBind Level
+type FloatBind = (Level, CoreBind)
+type FloatBinds = [FloatBind]
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-floatOutwards :: UniqSupply -> [CoreBinding] -> [CoreBinding]
+floatOutwards :: UniqSupply -> [CoreBind] -> IO [CoreBind]
floatOutwards us pgm
- = case (setLevels pgm us) of { annotated_w_levels ->
-
- case (unzip (map floatTopBind annotated_w_levels))
- of { (fss, final_toplev_binds_s) ->
-
- (if opt_D_verbose_core2core
- then pprTrace "Levels added:\n"
- (vcat (map (ppr) annotated_w_levels))
- else id
- )
- ( if not (opt_D_simplifier_stats) then
- id
- else
- let
- (tlets, ntlets, lams) = get_stats (sum_stats fss)
- in
- pprTrace "FloatOut stats: " (hcat [
- int tlets, ptext SLIT(" Lets floated to top level; "),
- int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
- int lams, ptext SLIT(" Lambda groups")])
- )
- concat final_toplev_binds_s
- }}
+ = do {
+ beginPass "Float out";
+
+ let { annotated_w_levels = setLevels pgm us ;
+ (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
+ } ;
+
+ dumpIfSet opt_D_verbose_core2core "Levels added:"
+ (vcat (map ppr annotated_w_levels));
+
+ let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
+
+ dumpIfSet opt_D_simplifier_stats "FloatOut stats:"
+ (hcat [ int tlets, ptext SLIT(" Lets floated to top level; "),
+ int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
+ int lams, ptext SLIT(" Lambda groups")]);
+
+ endPass "Float out"
+ opt_D_verbose_core2core {- no specific flag for dumping float-out -}
+ (concat binds_s')
+ }
floatTopBind bind@(NonRec _ _)
- = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
+ = case (floatBind emptyVarEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
(fs, floatsToBinds floats ++ [bind'])
}
floatTopBind bind@(Rec _)
- = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
+ = case (floatBind emptyVarEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
-- Actually floats will be empty
--false:ASSERT(null floats)
(fs, [Rec (floatsToBindPairs floats ++ pairs')])
floatBind :: IdEnv Level
-> Level
-> LevelledBind
- -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
+ -> (FloatStats, FloatBinds, CoreBind, IdEnv Level)
floatBind env lvl (NonRec (name,level) rhs)
= case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats',
NonRec name (install heres rhs'),
- addOneToIdEnv env name level)
+ extendVarEnv env name level)
}}
floatBind env lvl bind@(Rec pairs)
}
where
- new_env = growIdEnvList env (map fst pairs)
+ new_env = extendVarEnvList env (map fst pairs)
bind_level = getBindLevel bind
floatExpr :: IdEnv Level
-> Level
-> LevelledExpr
- -> (FloatStats, FloatingBinds, CoreExpr)
+ -> (FloatStats, FloatBinds, CoreExpr)
-floatExpr env _ (Var v) = (zero_stats, [], Var v)
-floatExpr env _ (Lit l) = (zero_stats, [], Lit l)
-floatExpr env _ (Prim op as) = (zero_stats, [], Prim op as)
-floatExpr env _ (Con con as) = (zero_stats, [], Con con as)
+floatExpr env _ (Var v) = (zeroStats, [], Var v)
+floatExpr env _ (Type ty) = (zeroStats, [], Type ty)
+floatExpr env lvl (Con con as)
+ = case floatList (floatExpr env lvl) as of { (stats, floats, as') ->
+ (stats, floats, Con con as') }
floatExpr env lvl (App e a)
- = case (floatExpr env lvl e) of { (fs, floating_defns, e') ->
- (fs, floating_defns, App e' a) }
+ = case (floatExpr env lvl e) of { (fse, floats_e, e') ->
+ case (floatExpr env lvl a) of { (fsa, floats_a, a') ->
+ (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }}
-floatExpr env lvl (Lam (TyBinder tv) e)
- = let
- incd_lvl = incMinorLvl lvl
- in
- case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
+floatExpr env lvl (Lam (tv,incd_lvl) e)
+ | isTyVar tv
+ = case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
-- Dump any bindings which absolutely cannot go any further
case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
- (fs, floats', Lam (TyBinder tv) (install heres e'))
+ (fs, floats', Lam tv (install heres e'))
}}
-floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs)
- = let
- new_env = addOneToIdEnv env arg incd_lvl
+floatExpr env lvl (Lam (arg,incd_lvl) rhs)
+ = ASSERT( isId arg )
+ let
+ new_env = extendVarEnv env arg incd_lvl
in
case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
(add_to_stats fs floats',
floats',
- Lam (ValBinder arg) (install heres rhs'))
+ Lam arg (install heres rhs'))
}}
floatExpr env lvl (Note note@(SCC cc) expr)
= case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
let
- -- annotate bindings floated outwards past an scc expression
+ -- Annotate bindings floated outwards past an scc expression
-- with the cc. We mark that cc as "duplicated", though.
annotated_defns = annotate (dupifyCC cc) floating_defns
in
(fs, annotated_defns, Note note expr') }
where
- annotate :: CostCentre -> FloatingBinds -> FloatingBinds
+ annotate :: CostCentre -> FloatBinds -> FloatBinds
annotate dupd_cc defn_groups
= [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
where
- ann_bind (LetFloater (NonRec binder rhs))
- = LetFloater (NonRec binder (ann_rhs rhs))
+ ann_bind (NonRec binder rhs)
+ = NonRec binder (ann_rhs rhs)
- ann_bind (LetFloater (Rec pairs))
- = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
+ ann_bind (Rec pairs)
+ = Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs]
- ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> Note (SCC dupd_cc) (fn rhs) )
-
- ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
- ann_rhs rhs@(Con _ _) = rhs -- no point in scc'ing WHNF data
- ann_rhs rhs = Note (SCC dupd_cc) rhs
+ ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
+ ann_rhs rhs@(Con con _) | isWHNFCon con = rhs -- no point in scc'ing WHNF data
+ ann_rhs rhs = Note (SCC dupd_cc) rhs
-- Note: Nested SCC's are preserved for the benefit of
-- cost centre stack profiling (Durham)
= case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
(add_stats fsb fse,
- rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
+ rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
body')
}}
where
bind_lvl = getBindLevel bind
-floatExpr env lvl (Case scrut alts)
- = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
-
- case (scrut', float_alts alts) of
- (_, (fsa, fda, alts')) ->
- (add_stats fse fsa, fda ++ fde, Case scrut' alts')
- }
- {- OLD CASE-FLOATING CODE: DROPPED FOR NOW. (SLPJ 7/2/94)
-
- (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
- | scrut_var_lvl `ltMajLvl` lvl ->
-
- -- Candidate for case floater; scrutinising a variable; it can
- -- escape outside a lambda; there's only one alternative.
- (fda ++ fde ++ [case_floater], rhs')
-
- where
- case_floater = (scrut_var_lvl, CaseFloater fn)
- fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
- scrut_var_lvl = case lookupIdEnv env scrut_var of
- Nothing -> Level 0 0
- Just lvl -> unTopify lvl
-
- END OF CASE FLOATING DROPPED -}
+floatExpr env lvl (Case scrut (case_bndr, case_lvl) alts)
+ = case floatExpr env lvl scrut of { (fse, fde, scrut') ->
+ case floatList float_alt alts of { (fsa, fda, alts') ->
+ (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts')
+ }}
where
- incd_lvl = incMinorLvl lvl
+ alts_env = extendVarEnv env case_bndr case_lvl
partition_fn = partitionByMajorLevel
-{- OMITTED
- We don't want to be too keen about floating lets out of case alternatives
- because they may benefit from seeing the evaluation done by the case.
-
- The main reason for doing this is to allocate in fewer larger blocks
- but that's really an STG-level issue.
-
- case alts of
- -- Just one alternative, then dump only
- -- what *has* to be dumped
- AlgAlts [_] NoDefault -> partitionByLevel
- AlgAlts [] (BindDefault _ _) -> partitionByLevel
- PrimAlts [_] NoDefault -> partitionByLevel
- PrimAlts [] (BindDefault _ _) -> partitionByLevel
-
- -- If there's more than one alternative, then
- -- this is a dumping point
- other -> partitionByMajorLevel
--}
-
- float_alts (AlgAlts alts deflt)
- = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
- case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
- (foldr add_stats fsd fsas,
- concat fdas ++ fdd,
- AlgAlts alts' deflt') }}
-
- float_alts (PrimAlts alts deflt)
- = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
- case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
- (foldr add_stats fsd fsas,
- concat fdas ++ fdd,
- PrimAlts alts' deflt') }}
-
- -------------
- float_alg_alt (con, bs, rhs)
+ float_alt (con, bs, rhs)
= let
bs' = map fst bs
- new_env = growIdEnvList env bs
+ new_env = extendVarEnvList alts_env bs
in
- case (floatExpr new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
- case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
+ case (floatExpr new_env case_lvl rhs) of { (fs, rhs_floats, rhs') ->
+ case (partition_fn case_lvl rhs_floats) of { (rhs_floats', heres) ->
(fs, rhs_floats', (con, bs', install heres rhs')) }}
- --------------
- float_prim_alt (lit, rhs)
- = case (floatExpr env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
- case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats', (lit, install heres rhs')) }}
-
- --------------
- float_deflt NoDefault = (zero_stats, [], NoDefault)
-
- float_deflt (BindDefault (b,lvl) rhs)
- = case (floatExpr new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
- case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats', BindDefault b (install heres rhs')) }}
- where
- new_env = addOneToIdEnv env b lvl
+
+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
+floatList f [] = (zeroStats, [], [])
+floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
+ case floatList f as of { (fs_as, binds_as, bs) ->
+ (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }}
\end{code}
%************************************************************************
get_stats (FlS a b c) = (a, b, c)
-zero_stats = FlS 0 0 0
+zeroStats = FlS 0 0 0
-sum_stats xs = foldr add_stats zero_stats xs
+sum_stats xs = foldr add_stats zeroStats xs
add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
= FlS (a1 + a2) (b1 + b2) (c1 + c2)
to_very_top (my_lvl, _) = isTopLvl my_lvl
\end{code}
+
%************************************************************************
%* *
\subsection{Utility bits for floating}
partitionByMajorLevel, partitionByLevel
:: Level -- Partitioning level
- -> FloatingBinds -- Defns to be divided into 2 piles...
+ -> FloatBinds -- Defns to be divided into 2 piles...
- -> (FloatingBinds, -- Defns with level strictly < partition level,
- FloatingBinds) -- The rest
+ -> (FloatBinds, -- Defns with level strictly < partition level,
+ FloatBinds) -- The rest
partitionByMajorLevel ctxt_lvl defns
\end{code}
\begin{code}
-floatsToBinds :: FloatingBinds -> [CoreBinding]
-floatsToBinds floats = map get_bind floats
- where
- get_bind (_, LetFloater bind) = bind
- get_bind (_, CaseFloater _) = panic "floatsToBinds"
+floatsToBinds :: FloatBinds -> [CoreBind]
+floatsToBinds floats = map snd floats
-floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
+floatsToBindPairs :: FloatBinds -> [(Id,CoreExpr)]
floatsToBindPairs floats = concat (map mk_pairs floats)
where
- mk_pairs (_, LetFloater (Rec pairs)) = pairs
- mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
- mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
+ mk_pairs (_, Rec pairs) = pairs
+ mk_pairs (_, NonRec binder rhs) = [(binder,rhs)]
-install :: FloatingBinds -> CoreExpr -> CoreExpr
+install :: FloatBinds -> CoreExpr -> CoreExpr
install defn_groups expr
= foldr install_group expr defn_groups
where
- install_group (_, LetFloater defns) body = Let defns body
- install_group (_, CaseFloater fn) body = fn body
+ install_group (_, defns) body = Let defns body
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
#include "HsVersions.h"
-import CoreSyn ( CoreBinding )
+-- Just a stub for now
+import CoreSyn ( CoreBind )
import UniqSupply ( UniqSupply )
-import Util ( panic{-ToDo:rm?-} )
+import Util ( panic )
--import Type ( cloneTyVarFromTemplate, mkTyVarTy,
-- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
-- foldrId, buildId
-- )
--import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
--- replaceIdInfo, mkSysLocal, idType
+-- mkSysLocal, idType
-- )
--import IdInfo
--import Maybes
\begin{code}
mkFoldrBuildWW
:: UniqSupply
- -> [CoreBinding]
- -> [CoreBinding]
+ -> [CoreBind]
+ -> [CoreBind]
mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
worker_ty = mkForallTy (templ ++ [alphaTyVar])
(foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
- wrapper_id = addInlinePragma id
+ wrapper_id = setInlinePragma id IWantToBeINLINEd
worker_id = mkWorkerId worker_new_uq id worker_ty
- noIdInfo
-- TODO : CHECK if mkWorkerId is thr
-- right function to use ..
-- Now the bodies
- c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty noSrcLoc
- n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty noSrcLoc
+ c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty
+ n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty
worker_rhs
= mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
-96/03: We aren't using this at the moment
-
\begin{code}
module LiberateCase ( liberateCase ) where
#include "HsVersions.h"
-import Util ( panic )
-
-liberateCase = panic "LiberateCase.liberateCase: ToDo"
-
-{- LATER: to end of file:
-import CoreUnfold ( UnfoldingGuidance(..) )
-import Id ( localiseId )
-import IdInfo { InlinePragInfo(..) }
+import CmdLineOpts ( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
+import CoreLint ( beginPass, endPass )
+import CoreSyn
+import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
+import Var ( Id )
+import VarEnv
import Maybes
import Outputable
import Util
Better code, because 'a' is free inside the inner letrec, rather
than needing projection from v.
+Other examples we'd like to catch with this kind of transformation
+
+ last [] = error
+ last (x:[]) = x
+ last (x:xs) = last xs
+
+We'd like to avoid the redundant pattern match, transforming to
+
+ last [] = error
+ last (x:[]) = x
+ last (x:(y:ys)) = last' y ys
+ where
+ last' y [] = y
+ last' _ (y:ys) = last' y ys
+
+ (is this necessarily an improvement)
+
+
+Similarly drop:
+
+ drop n [] = []
+ drop 0 xs = xs
+ drop n (x:xs) = drop (n-1) xs
+
+Would like to pass n along unboxed.
+
To think about (Apr 94)
~~~~~~~~~~~~~~
-- (top-level and imported things have
-- a level of zero)
- (IdEnv CoreBinding)-- Binds *only* recursively defined
+ (IdEnv CoreBind)-- Binds *only* recursively defined
-- Ids, to their own binding group,
-- and *only* in their own RHSs
-- really
initEnv :: Int -> LibCaseEnv
-initEnv bomb_size = LibCaseEnv bomb_size 0 nullIdEnv nullIdEnv []
+initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
\end{code}
Programs
~~~~~~~~
\begin{code}
-liberateCase :: Int -> [CoreBinding] -> [CoreBinding]
-liberateCase bomb_size prog
- = do_prog (initEnv bomb_size) prog
+liberateCase :: [CoreBind] -> IO [CoreBind]
+liberateCase binds
+ = do {
+ beginPass "Liberate case" ;
+ let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
+ endPass "Liberate case"
+ opt_D_verbose_core2core {- no specific flag for dumping -}
+ binds'
+ }
where
do_prog env [] = []
do_prog env (bind:binds) = bind' : do_prog env' binds
~~~~~~~~
\begin{code}
-libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding)
+libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
libCaseBind env (NonRec binder rhs)
= (addBinders env [binder], NonRec binder (libCase env rhs))
-- that the same process doesn't occur for ever!
extended_env
- = addRecBinds env [ (localiseId binder, libCase env_body rhs)
+ = addRecBinds env [ (binder, libCase env_body rhs)
| (binder, rhs) <- pairs ]
-- Why "localiseId" above? Because we're creating a new local
-- Why does it matter? Because the codeGen keeps a separate
-- environment for top-level Ids, and it is disastrous for it
-- to think that something is top-level when it isn't.
+ --
+ -- [May 98: all this is now handled by SimplCore.tidyCore]
rhs_small_enough rhs
- = case (calcUnfoldingGuidance NoPragmaInfo lIBERATE_BOMB_SIZE rhs) of
+ = case (calcUnfoldingGuidance lIBERATE_BOMB_SIZE rhs) of
UnfoldNever -> False
_ -> True -- we didn't BOMB, so it must be OK
-> CoreExpr
-> CoreExpr
-libCase env (Lit lit) = Lit lit
-libCase env (Var v) = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
-libCase env (App fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
-libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty
-libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
-libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
-libCase env (CoTyLam tv body) = CoTyLam tv (libCase env body)
+libCase env (Var v) = libCaseId env v
+libCase env (Type ty) = Type ty
+libCase env (App fun arg) = App (libCase env fun) (libCase env arg)
+libCase env (Con con args) = Con con (map (libCase env) args)
libCase env (Note note body) = Note note (libCase env body)
libCase env (Lam binder body)
where
(env_body, bind') = libCaseBind env bind
-libCase env (Case scrut alts)
- = Case (libCase env scrut) (libCaseAlts env_alts alts)
+libCase env (Case scrut bndr alts)
+ = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
where
- env_alts = case scrut of
- Var scrut_var -> addScrutedVar env scrut_var
- other -> env
-\end{code}
-
-
-Case alternatives
-~~~~~~~~~~~~~~~~~
+ env_alts = addBinders env [bndr]
+ env_with_scrut = case scrut of
+ Var scrut_var -> addScrutedVar env scrut_var
+ other -> env
-\begin{code}
-libCaseAlts env (AlgAlts alts deflt)
- = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
- where
- do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
-
-libCaseAlts env (PrimAlts alts deflt)
- = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
- where
- do_alt (lit,rhs) = (lit, libCase env rhs)
-
-libCaseDeflt env NoDefault
- = NoDefault
-libCaseDeflt env (BindDefault binder rhs)
- = BindDefault binder (libCase (addBinders env [binder]) rhs)
+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
\end{code}
-Atoms and Ids
-~~~~~~~~~~~~~
+Ids
+~~~
\begin{code}
-libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
-libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
-
-libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
-libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
-libCaseAtom env (LitArg lit) = []
-
-libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
+libCaseId :: LibCaseEnv -> Id -> CoreExpr
libCaseId env v
| maybeToBool maybe_rec_bind && -- It's a use of a recursive thing
there_are_free_scruts -- with free vars scrutinised in RHS
- = [the_bind]
+ = Let the_bind (Var v)
| otherwise
- = []
+ = Var v
where
- maybe_rec_bind :: Maybe CoreBinding -- The binding of the recursive thingy
+ maybe_rec_bind :: Maybe CoreBind -- The binding of the recursive thingy
maybe_rec_bind = lookupRecId env v
- Just the_bind = maybe_rec_bind
+ Just the_bind = maybe_rec_bind
rec_id_level = lookupLevel env v
Utility functions
~~~~~~~~~~~~~~~~~
\begin{code}
-addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv
+addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders
= LibCaseEnv bomb lvl lvl_env' rec_env scruts
where
- lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
+ lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)
addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
= LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
where
lvl' = lvl + 1
- lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
- rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
+ lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
+ rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
addScrutedVar :: LibCaseEnv
-> Id -- This Id is being scrutinised by a case expression
| otherwise = env
where
scruts' = (scrut_var, lvl) : scruts
- bind_lvl = case lookupIdEnv lvl_env scrut_var of
+ bind_lvl = case lookupVarEnv lvl_env scrut_var of
Just lvl -> lvl
Nothing -> topLevel
-lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
+lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
#ifndef DEBUG
- = lookupIdEnv rec_env id
+ = lookupVarEnv rec_env id
#else
- = case (lookupIdEnv rec_env id) of
+ = case (lookupVarEnv rec_env id) of
xxx@(Just _) -> xxx
xxx -> xxx
#endif
lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
- = case lookupIdEnv lvl_env id of
+ = case lookupVarEnv lvl_env id of
Just lvl -> lvl
Nothing -> topLevel
= not (null free_scruts)
where
free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
--}
\end{code}
--- /dev/null
+__interface MagicUFs 1 0 where
+__export MagicUFs MagicUnfoldingFun mkMagicUnfoldingFun;
+1 data MagicUnfoldingFun;
+1 mkMagicUnfoldingFun :: Unique.Unique -> MagicUnfoldingFun ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[MagicUFs]{Magic unfoldings that the simplifier knows about}
#include "HsVersions.h"
-import Id ( addInlinePragma )
import CoreSyn
-import SimplEnv ( SimplEnv )
-import SimplMonad ( SmplM, SimplCount )
+import SimplMonad ( SimplM, SimplCont )
import Type ( mkFunTys )
import TysWiredIn ( mkListTy )
import Unique ( Unique{-instances-} )
\begin{code}
data MagicUnfoldingFun
- = MUF ( SimplEnv -- state of play in simplifier...
- -- (note: we can get simplifier switches
- -- from the SimplEnv)
- -> [CoreArg] -- arguments
- -> Maybe (SmplM CoreExpr))
+ = MUF ( SimplCont -> Maybe (SimplM CoreExpr))
-- Just result, or Nothing
\end{code}
magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
\end{code}
-Give us an MUF and stuff to apply it to, and we'll give you back the
-answer.
+Give us an MUF and stuff to apply it to, and we'll give you back the answer.
+
\begin{code}
applyMagicUnfoldingFun
:: MagicUnfoldingFun
- -> SimplEnv
- -> [CoreArg]
- -> Maybe (SmplM CoreExpr)
+ -> SimplCont
+ -> Maybe (SimplM CoreExpr)
-applyMagicUnfoldingFun (MUF fun) env args = fun env args
+applyMagicUnfoldingFun (MUF fun) cont = fun cont
\end{code}
%************************************************************************
build_fun :: SimplEnv
-> [CoreArg]
- -> Maybe (SmplM CoreExpr)
+ -> Maybe (SimplM CoreExpr)
build_fun env [TypeArg ty,ValArg (VarArg e)]
| switchIsSet env SimplDoInlineFoldrBuild
= Just result
\begin{code}
augment_fun :: SimplEnv
-> [CoreArg]
- -> Maybe (SmplM CoreExpr)
+ -> Maybe (SimplM CoreExpr)
augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
| switchIsSet env SimplDoInlineFoldrBuild
\begin{code}
foldr_fun :: SimplEnv
-> [CoreArg]
- -> Maybe (SmplM CoreExpr)
+ -> Maybe (SimplM CoreExpr)
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
| do_fb_red && isConsFun env arg_k && isNilForm env arg_z
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
\begin{code}
module OccurAnal (
- occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
+ occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
+ markBinderInsideLambda
) where
#include "HsVersions.h"
import BinderInfo
-import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
+import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUtils ( idSpecVars )
-import Digraph ( stronglyConnCompR, SCC(..) )
-import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
- omitIfaceSigForId, isSpecPragmaId, getIdSpecialisation,
- idType, idUnique, Id,
- emptyIdSet, unionIdSets, mkIdSet,
- elementOfIdSet,
- addOneToIdSet, IdSet,
-
- IdEnv, nullIdEnv, unitIdEnv, combineIdEnvs,
- delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
- mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv
+import CoreUtils ( exprIsTrivial, idSpecVars )
+import Const ( Con(..), Literal(..) )
+import Id ( idWantsToBeINLINEd,
+ getInlinePragma, setInlinePragma,
+ omitIfaceSigForId,
+ getIdSpecialisation,
+ idType, idUnique, Id
)
+import IdInfo ( InlinePragInfo(..), OccInfo(..) )
import SpecEnv ( isEmptySpecEnv )
+
+import VarSet
+import VarEnv
+
+import PrelInfo ( noRepStrIds, noRepIntegerIds )
import Name ( isExported, isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
-import PprCore
+import Digraph ( stronglyConnCompR, SCC(..) )
import Unique ( u2i )
import UniqFM ( keysUFM )
-import Util ( zipWithEqual )
+import Util ( zipWithEqual, mapAndUnzip )
import Outputable
\end{code}
\begin{code}
occurAnalyseBinds
- :: [CoreBinding] -- input
- -> (SimplifierSwitch -> Bool)
- -> [SimplifiableCoreBinding] -- output
-
-occurAnalyseBinds binds simplifier_sw_chkr
- | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
- (pprGenericBindings new_binds)
- new_binds
- | otherwise = new_binds
+ :: (SimplifierSwitch -> Bool)
+ -> [CoreBind]
+ -> [CoreBind]
+
+occurAnalyseBinds simplifier_sw_chkr binds
+ = binds'
where
- new_binds = concat binds'
(_, _, binds') = occAnalTop initial_env binds
initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
- (\id in_scope -> isLocallyDefined id) -- Anything local is interesting
- emptyIdSet -- Not actually used
+ (\id -> isLocallyDefined id) -- Anything local is interesting
+ emptyVarSet
\end{code}
occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
-> CoreExpr
-> (IdEnv BinderInfo, -- Occ info for interesting free vars
- SimplifiableCoreExpr)
+ CoreExpr)
occurAnalyseExpr interesting expr
= occAnal initial_env expr
where
initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
- (\id locals -> interesting id || elementOfIdSet id locals)
- emptyIdSet
+ interesting
+ emptyVarSet
-occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
+occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
\begin{code}
occAnalTop :: OccEnv -- What's in scope
- -> [CoreBinding]
+ -> [CoreBind]
-> (IdEnv BinderInfo, -- Occurrence info
- IdEnv Id, -- Indirection elimination info
- [[SimplifiableCoreBinding]]
+ IdEnv Id, -- Indirection elimination info
+ [CoreBind]
)
-occAnalTop env [] = (emptyDetails, nullIdEnv, [])
+
+occAnalTop env [] = (emptyDetails, emptyVarEnv, [])
+
+-- Special case for eliminating indirections
+-- Note: it's a shortcoming that this only works for
+-- non-recursive bindings. Elminating indirections
+-- makes perfect sense for recursive bindings too, but
+-- it's more complicated to implement, so I haven't done so
+
occAnalTop env (bind : binds)
= case bind of
- NonRec exported_id (Var local_id)
- | isExported exported_id && -- Only if this is exported
+ NonRec exported_id (Var local_id) | shortMeOut ind_env exported_id local_id
+ -> -- Aha! An indirection; let's eliminate it!
+ (scope_usage, ind_env', binds')
+ where
+ ind_env' = extendVarEnv ind_env local_id exported_id
+
+ other -> -- Ho ho! The normal case
+ (final_usage, ind_env, new_binds ++ binds')
+ where
+ (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
+ where
+ new_env = env `addNewCands` (bindersOf bind)
+ (scope_usage, ind_env, binds') = occAnalTop new_env binds
- isLocallyDefined local_id && -- Only if this one is defined in this
- -- module, so that we *can* change its
- -- binding to be the exported thing!
+ -- Deal with any indirections
+ zap_bind (NonRec bndr rhs)
+ | bndr `elemVarEnv` ind_env = Rec (zap (bndr,rhs))
+ -- The Rec isn't strictly necessary, but it's convenient
+ zap_bind (Rec pairs)
+ | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
- not (isExported local_id) && -- Only if this one is not itself exported,
- -- since the transformation will nuke it
+ zap_bind bind = bind
- not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is
- -- something like a constructor, whose
- -- definition is implicitly exported and
- -- which must not vanish.
-
+ zap pair@(bndr,rhs) = case lookupVarEnv ind_env bndr of
+ Nothing -> [pair]
+ Just exported_id -> [(bndr, Var exported_id),
+ (exported_id, rhs)]
+
+shortMeOut ind_env exported_id local_id
+ = isExported exported_id && -- Only if this is exported
+
+ isLocallyDefined local_id && -- Only if this one is defined in this
+ -- module, so that we *can* change its
+ -- binding to be the exported thing!
+
+ not (isExported local_id) && -- Only if this one is not itself exported,
+ -- since the transformation will nuke it
+
+ not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is
+ -- something like a constructor, whose
+ -- definition is implicitly exported and
+ -- which must not vanish.
-- To illustrate the preceding check consider
-- data T = MkT Int
-- mkT = MkT
-- the MkT constructor.
-- Slightly gruesome, this.
- not (maybeToBool (lookupIdEnv ind_env local_id))
- -- Only if not already substituted for
- -> -- Aha! An indirection; let's eliminate it!
- (scope_usage, ind_env', binds')
- where
- ind_env' = addOneToIdEnv ind_env local_id exported_id
-
- other
- -> -- The normal case
- (final_usage, ind_env, (new_binds : binds'))
- where
- (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
- where
- new_env = env `addNewCands` (bindersOf bind)
- (scope_usage, ind_env, binds') = occAnalTop new_env binds
-
- -- Deal with any indirections
- zap_bind (NonRec bndr rhs)
- | bndr `elemIdEnv` ind_env = Rec (zap (bndr,rhs))
- -- The Rec isn't strictly necessary, but it's convenient
- zap_bind (Rec pairs)
- | or [id `elemIdEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
-
- zap_bind bind = bind
-
- zap pair@(bndr,rhs) = case lookupIdEnv ind_env bndr of
- Nothing -> [pair]
- Just exported_id -> [(bndr, Var exported_id),
- (exported_id, rhs)]
+ not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
\end{code}
~~~~~~~~
\begin{code}
+type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached
+
type Node details = (details, Int, [Int]) -- The Ints are gotten from the Unique,
-- which is gotten from the Id.
-type Details1 = (Id, UsageDetails, SimplifiableCoreExpr)
-type Details2 = ((Id, BinderInfo), SimplifiableCoreExpr)
+type Details1 = (Id, UsageDetails, CoreExpr)
+type Details2 = (IdWithOccInfo, CoreExpr)
occAnalBind :: OccEnv
- -> CoreBinding
+ -> CoreBind
-> UsageDetails -- Usage details of scope
-> (UsageDetails, -- Of the whole let(rec)
- [SimplifiableCoreBinding])
+ [CoreBind])
occAnalBind env (NonRec binder rhs) body_usage
- | isNeeded env body_usage binder -- It's mentioned in body
+ | isDeadBinder tagged_binder -- It's not mentioned
+ = (body_usage, [])
+
+ | otherwise -- It's mentioned in the body
= (final_body_usage `combineUsageDetails` rhs_usage,
[NonRec tagged_binder rhs'])
- | otherwise -- Not mentioned, so drop dead code
- = (body_usage, [])
-
where
- binder' = nukeNoInlinePragma binder
- (rhs_usage, rhs') = occAnalRhs env binder' rhs
- (final_body_usage, tagged_binder) = tagBinder body_usage binder'
+ (final_body_usage, tagged_binder) = tagBinder body_usage binder
+ (rhs_usage, rhs') = occAnalRhs env binder rhs
\end{code}
Dropping dead code for recursive bindings is done in a very simple way:
new_env = env `addNewCands` binders
analysed_pairs :: [Details1]
- analysed_pairs = [ (nukeNoInlinePragma bndr, rhs_usage, rhs')
+ analysed_pairs = [ (bndr, rhs_usage, rhs')
| (bndr, rhs) <- pairs,
let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
]
-- by just extracting the keys from the finite map. Grimy, but fast.
-- Previously we had this:
-- [ bndr | bndr <- bndrs,
- -- maybeToBool (lookupIdEnv rhs_usage bndr)]
+ -- maybeToBool (lookupVarEnv rhs_usage bndr)]
-- which has n**2 cost, and this meant that edges_from alone
-- consumed 10% of total runtime!
edges_from :: UsageDetails -> [Int]
-- Non-recursive SCC
do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
- | isNeeded env body_usage bndr
- = (combined_usage, new_bind : binds_so_far)
- | otherwise
+ | isDeadBinder tagged_bndr
= (body_usage, binds_so_far) -- Dead code
+ | otherwise
+ = (combined_usage, new_bind : binds_so_far)
where
total_usage = combineUsageDetails body_usage rhs_usage
(combined_usage, tagged_bndr) = tagBinder total_usage bndr
-- Recursive SCC
do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
- | any (isNeeded env body_usage) bndrs
- = (combined_usage, final_bind:binds_so_far)
- | otherwise
+ | all isDeadBinder tagged_bndrs
= (body_usage, binds_so_far) -- Dead code
+ | otherwise
+ = (combined_usage, final_bind:binds_so_far)
where
- details = [details | (details, _, _) <- cycle]
- bndrs = [bndr | (bndr, _, _) <- details]
- rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details]
- total_usage = foldr combineUsageDetails body_usage rhs_usages
- (combined_usage, tagged_binders) = tagBinders total_usage bndrs
- final_bind = Rec (reOrderRec env new_cycle)
-
- new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
- mk_new_bind (bndr, occ_info) ((_, _, rhs'), key, keys) = (((bndr, occ_info), rhs'), key, keys)
+ details = [details | (details, _, _) <- cycle]
+ bndrs = [bndr | (bndr, _, _) <- details]
+ rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details]
+ total_usage = foldr combineUsageDetails body_usage rhs_usages
+ (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs
+ final_bind = Rec (reOrderRec env new_cycle)
+
+ new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_bndrs cycle)
+ mk_new_bind tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys)
\end{code}
@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
that the simplifier will generally do a good job if it works from top bottom,
recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
+==============
+[June 98: I don't understand the following paragraphs, and I've
+ changed the a=b case again so that it isn't a special case any more.]
+
Here's a case that bit me:
letrec
My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
Perhaps something cleverer would suffice.
+===============
You might think that you can prevent non-termination simply by making
sure that we simplify a recursive binding's RHS in an environment that
-- Common case of simple self-recursion
reOrderRec env (CyclicSCC [bind])
- = [((addNoInlinePragma bndr, occ_info), rhs)]
+ = [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
where
- (((bndr, occ_info), rhs), _, _) = bind
+ ((tagged_bndr, rhs), _, _) = bind
-reOrderRec env (CyclicSCC binds)
+reOrderRec env (CyclicSCC (bind : binds))
= -- Choose a loop breaker, mark it no-inline,
-- do SCC analysis on the rest, and recursively sort them out
concat (map (reOrderRec env) (stronglyConnCompR unchosen))
++
- [((addNoInlinePragma bndr, occ_info), rhs)]
+ [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
where
- (chosen_pair, unchosen) = choose_loop_breaker binds
- ((bndr,occ_info), rhs) = chosen_pair
-
- -- Choosing the loop breaker; heursitic
- choose_loop_breaker (bind@(details, _, _) : rest)
- | not (null rest) &&
- bad_choice details
- = (chosen, bind : unchosen) -- Don't pick it
- | otherwise -- Pick it
- = (details,rest)
+ (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
+ (tagged_bndr, rhs) = chosen_pair
+
+ -- This loop looks for the bind with the lowest score
+ -- to pick as the loop breaker. The rest accumulate in
+ choose_loop_breaker (details,_,_) loop_sc acc []
+ = (details, acc) -- Done
+
+ choose_loop_breaker loop_bind loop_sc acc (bind : binds)
+ | sc < loop_sc -- Lower score so pick this new one
+ = choose_loop_breaker bind sc (loop_bind : acc) binds
+
+ | otherwise -- No lower so don't pick it
+ = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
where
- (chosen, unchosen) = choose_loop_breaker rest
-
- bad_choice ((bndr, occ_info), rhs)
- = var_rhs rhs -- Dont pick var RHS
- || inlineMe env bndr -- Dont pick INLINE thing
- || isOneFunOcc occ_info -- Dont pick single-occ thing
- || not_fun_ty (idType bndr) -- Dont pick data-ty thing
- || not (isEmptySpecEnv (getIdSpecialisation bndr))
+ sc = score bind
+
+ score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker
+ score ((bndr, rhs), _, _)
+ | exprIsTrivial rhs &&
+ not (isExported bndr) = 3 -- Practically certain to be inlined
+ | inlineCandidate bndr = 3 -- Likely to be inlined
+ | not_fun_ty (idType bndr) = 2 -- Data types help with cases
+ | not (isEmptySpecEnv (getIdSpecialisation bndr)) = 1
-- Avoid things with a SpecEnv; we'd like
- -- to take advantage of the SpecEnv in the subsuequent bindings
-
- -- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
- -- We stick to just FunOccs because if we're not going to be able
- -- to inline the thing on this round it might be better to pick
- -- this one as the loop breaker. Real example (the Enum Ordering instance
- -- from PrelBase):
+ -- to take advantage of the SpecEnv in the subsequent bindings
+ | otherwise = 0
+
+ inlineCandidate :: Id -> Bool
+ inlineCandidate id
+ = case getInlinePragma id of
+ IWantToBeINLINEd -> True
+ IMustBeINLINEd -> True
+ ICanSafelyBeINLINEd _ _ -> True
+ other -> False
+
+ -- Real example (the Enum Ordering instance from PrelBase):
-- rec f = \ x -> case d of (p,q,r) -> p x
-- g = \ x -> case d of (p,q,r) -> q x
-- d = (v, f, g)
-- Here, f and g occur just once; but we can't inline them into d.
-- On the other hand we *could* simplify those case expressions if
-- we didn't stupidly choose d as the loop breaker.
+ -- But we won't because constructor args are marked "Many".
not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
where
(_, rho_ty) = splitForAllTys ty
-
- -- A variable RHS
- var_rhs (Var v) = True
- var_rhs other_rhs = False
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
ToDo: try using the occurrence info for the inline'd binder.
[March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
+[June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
[March 98] A new wrinkle is that if the binder has specialisations inside
it then we count the specialised Ids as "extra rhs's". That way
\begin{code}
occAnalRhs :: OccEnv
-> Id -> CoreExpr -- Binder and rhs
- -> (UsageDetails, SimplifiableCoreExpr)
+ -> (UsageDetails, CoreExpr)
+{- DELETED SLPJ June 98: seems quite bogus to me
occAnalRhs env id (Var v)
| isCandidate env v
- = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
+ = (unitVarEnv v (markMany (funOccurrence 0)), Var v)
| otherwise
= (emptyDetails, Var v)
+-}
occAnalRhs env id rhs
- | inlineMe env id
- = (mapIdEnv markMany total_usage, rhs')
+ | idWantsToBeINLINEd id
+ = (mapVarEnv markMany total_usage, rhs')
| otherwise
= (total_usage, rhs')
where
(rhs_usage, rhs') = occAnal env rhs
- total_usage = foldr add rhs_usage (idSpecVars id)
- add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
- -- (i.e manyOcc) because many copies
- -- of the specialised thing can appear
+ lazy_rhs_usage = mapVarEnv markLazy rhs_usage
+ total_usage = foldVarSet add lazy_rhs_usage spec_ids
+ add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
+ -- (i.e manyOcc) because many copies
+ -- of the specialised thing can appear
+ spec_ids = idSpecVars id
+\end{code}
+
\end{code}
Expressions
occAnal :: OccEnv
-> CoreExpr
-> (UsageDetails, -- Gives info only about the "interesting" Ids
- SimplifiableCoreExpr)
+ CoreExpr)
-occAnal env (Var v)
- | isCandidate env v
- = (unitIdEnv v (funOccurrence 0), Var v)
-
- | otherwise
- = (emptyDetails, Var v)
+occAnal env (Type t) = (emptyDetails, Type t)
-occAnal env (Lit lit) = (emptyDetails, Lit lit)
-occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
+occAnal env (Var v)
+ | isCandidate env v = (unitVarEnv v funOccZero, Var v)
+ | otherwise = (emptyDetails, Var v)
\end{code}
We regard variables that occur as constructor arguments as "dangerousToDup":
Constructors are rather like lambdas in this way.
\begin{code}
+ -- For NoRep literals we have to report an occurrence of
+ -- the things which tidyCore will later add, so that when
+ -- we are compiling the very module in which those thin-air Ids
+ -- are defined we have them in scope!
+occAnal env expr@(Con (Literal lit) args)
+ = ASSERT( null args )
+ (mk_lit_uds lit, expr)
+ where
+ mk_lit_uds (NoRepStr _ _) = try noRepStrIds
+ mk_lit_uds (NoRepInteger _ _) = try noRepIntegerIds
+ mk_lit_uds lit = emptyDetails
+
+ try vs = foldr add emptyDetails vs
+ add v uds | isCandidate env v = extendVarEnv uds v funOccZero
+ | otherwise = uds
+
occAnal env (Con con args)
- = (mapIdEnv markDangerousToDup (occAnalArgs env args),
- Con con args)
+ = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') ->
+ let
+ arg_uds = foldr combineUsageDetails emptyDetails arg_uds_s
+
+ -- We mark the free vars of the argument of a constructor as "many"
+ -- This means that nothing gets inlined into a constructor argument
+ -- position, which is what we want. Typically those constructor
+ -- arguments are just variables, or trivial expressions.
+ final_arg_uds = case con of
+ DataCon _ -> mapVarEnv markMany arg_uds
+ other -> arg_uds
+ in
+ (final_arg_uds, Con con args')
+ }
+\end{code}
+\begin{code}
occAnal env (Note note@(SCC cc) body)
- = (mapIdEnv markInsideSCC usage, Note note body')
- where
- (usage, body') = occAnal env body
+ = case occAnal env body of { (usage, body') ->
+ (mapVarEnv markInsideSCC usage, Note note body')
+ }
occAnal env (Note note body)
- = (usage, Note note body')
- where
- (usage, body') = occAnal env body
+ = case occAnal env body of { (usage, body') ->
+ (usage, Note note body')
+ }
+\end{code}
+\begin{code}
occAnal env (App fun arg)
- = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
- where
- (fun_usage, fun') = occAnal env fun
- arg_usage = occAnalArg env arg
+ = case occAnal env fun of { (fun_usage, fun') ->
+ case occAnal env arg of { (arg_usage, arg') ->
+ (fun_usage `combineUsageDetails` mapVarEnv markLazy arg_usage, App fun' arg')
+ }}
+
-- For value lambdas we do a special hack. Consider
-- (\x. \y. ...x...)
-- If we did nothing, x is used inside the \y, so would be marked
-- as dangerous to dup. But in the common case where the abstraction
-- is applied to two arguments this is over-pessimistic.
--- So instead we don't take account of the \y when dealing with x's usage;
--- instead, the simplifier is careful when partially applying lambdas
-
-occAnal env expr@(Lam (ValBinder binder) body)
- = (mapIdEnv markDangerousToDup final_usage,
- foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
+-- So instead, we just mark each binder with its occurrence
+-- info in the *body* of the multiple lambda.
+-- Then, the simplifier is careful when partially applying lambdas.
+
+occAnal env expr@(Lam _ _)
+ = case occAnal (env `addNewCands` binders) body of { (body_usage, body') ->
+ let
+ (final_usage, tagged_binders) = tagBinders body_usage binders
+ in
+ (mapVarEnv markInsideLam final_usage,
+ mkLams tagged_binders body') }
where
- (binders,body) = collectValBinders expr
- (body_usage, body') = occAnal (env `addNewCands` binders) body
- (final_usage, tagged_binders) = tagBinders body_usage binders
-
--- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
-occAnal env (Lam (TyBinder tyvar) body)
- = case occAnal env body of { (body_usage, body') ->
- (mapIdEnv markDangerousToDup body_usage,
- Lam (TyBinder tyvar) body') }
--- where
--- (body_usage, body') = occAnal env body
-
-occAnal env (Case scrut alts)
- = case occAnalAlts env alts of { (alts_usage, alts') ->
- case occAnal env scrut of { (scrut_usage, scrut') ->
- let
- det = scrut_usage `combineUsageDetails` alts_usage
- in
- if isNullIdEnv det then
- (det, Case scrut' alts')
- else
- (det, Case scrut' alts') }}
-{-
- (scrut_usage `combineUsageDetails` alts_usage,
- Case scrut' alts')
+ (binders, body) = collectBinders expr
+
+
+occAnal env (Case scrut bndr alts)
+ = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
+ case occAnal env scrut of { (scrut_usage, scrut') ->
+ let
+ alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
+ (alts_usage1, tagged_bndr) = tagBinder alts_usage bndr
+ total_usage = scrut_usage `combineUsageDetails` alts_usage1
+ in
+ total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }}
where
- (scrut_usage, scrut') = occAnal env scrut
- (alts_usage, alts') = occAnalAlts env alts
--}
+ alt_env = env `addNewCand` bndr
occAnal env (Let bind body)
= case occAnal new_env body of { (body_usage, body') ->
case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
- (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
+ (final_usage, mkLets new_binds body') }}
where
- new_env = env `addNewCands` (bindersOf bind)
--- (body_usage, body') = occAnal new_env body
--- (final_usage, new_binds) = occAnalBind env bind body_usage
+ new_env = env `addNewCands` (bindersOf bind)
\end{code}
Case alternatives
~~~~~~~~~~~~~~~~~
\begin{code}
-occAnalAlts env (AlgAlts alts deflt)
- = (foldr combineAltsUsageDetails deflt_usage alts_usage,
- -- Note: combine*Alts*UsageDetails...
- AlgAlts alts' deflt')
- where
- (alts_usage, alts') = unzip (map do_alt alts)
- (deflt_usage, deflt') = occAnalDeflt env deflt
-
- do_alt (con, args, rhs)
- = (final_usage, (con, tagged_args, rhs'))
- where
- new_env = env `addNewCands` args
- (rhs_usage, rhs') = occAnal new_env rhs
- (final_usage, tagged_args) = tagBinders rhs_usage args
-
-occAnalAlts env (PrimAlts alts deflt)
- = (foldr combineAltsUsageDetails deflt_usage alts_usage,
- -- Note: combine*Alts*UsageDetails...
- PrimAlts alts' deflt')
- where
- (alts_usage, alts') = unzip (map do_alt alts)
- (deflt_usage, deflt') = occAnalDeflt env deflt
-
- do_alt (lit, rhs)
- = (rhs_usage, (lit, rhs'))
- where
- (rhs_usage, rhs') = occAnal env rhs
-
-occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
-
-occAnalDeflt env (BindDefault binder rhs)
- = (final_usage, BindDefault tagged_binder rhs')
- where
- new_env = env `addNewCand` binder
- (rhs_usage, rhs') = occAnal new_env rhs
- (final_usage, tagged_binder) = tagBinder rhs_usage binder
-\end{code}
-
-
-Atoms
-~~~~~
-\begin{code}
-occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
-
-occAnalArgs env atoms
- = foldr do_one_atom emptyDetails atoms
- where
- do_one_atom (VarArg v) usage
- | isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
- do_one_atom other_arg usage = usage
-
-
-occAnalArg :: OccEnv -> CoreArg -> UsageDetails
-
-occAnalArg env (VarArg v)
- | isCandidate env v = unitDetails v (argOccurrence 0)
- | otherwise = emptyDetails
-occAnalArg _ _ = emptyDetails
+occAnalAlt env (con, bndrs, rhs)
+ = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') ->
+ let
+ (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
+ in
+ (final_usage, (con, tagged_bndrs, rhs')) }
\end{code}
-- False <=> OK to use INLINEPragma information
-- True <=> ignore INLINEPragma information
- (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
- -- given the set of in-scope variables
+ (Id -> Bool) -- Tells whether an Id occurrence is interesting,
+ -- given the set of in-scope variables
IdSet -- In-scope Ids
addNewCands :: OccEnv -> [Id] -> OccEnv
addNewCands (OccEnv ip ifun cands) ids
- = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids)
+ = OccEnv ip ifun (cands `unionVarSet` mkVarSet ids)
addNewCand :: OccEnv -> Id -> OccEnv
addNewCand (OccEnv ip ifun cands) id
- = OccEnv ip ifun (addOneToIdSet cands id)
+ = OccEnv ip ifun (extendVarSet cands id)
isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ ifun cands) id = ifun id cands
-
-inlineMe :: OccEnv -> Id -> Bool
-inlineMe env id
- = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
- not ignore_inline_prag &&
- -}
- idWantsToBeINLINEd id
+isCandidate (OccEnv _ ifun cands) id = id `elemVarSet` cands || ifun id
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
:: UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetails usage1 usage2
- = combineIdEnvs addBinderInfo usage1 usage2
+ = plusVarEnv_C addBinderInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
- = combineIdEnvs orBinderInfo usage1 usage2
+ = plusVarEnv_C orBinderInfo usage1 usage2
addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
addOneOcc usage id info
- = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
+ = plusVarEnv_C addBinderInfo usage (unitVarEnv id info)
-- ToDo: make this more efficient
-emptyDetails = (nullIdEnv :: UsageDetails)
+emptyDetails = (emptyVarEnv :: UsageDetails)
-unitDetails id info = (unitIdEnv id info :: UsageDetails)
+unitDetails id info = (unitVarEnv id info :: UsageDetails)
tagBinders :: UsageDetails -- Of scope
-> [Id] -- Binders
-> (UsageDetails, -- Details with binders removed
- [(Id,BinderInfo)]) -- Tagged binders
-
-tagBinders usage binders =
- let
- usage' = usage `delManyFromIdEnv` binders
- uss = [ (binder, usage_of usage binder) | binder <- binders ]
- in
- if isNullIdEnv usage' then
- (usage', uss)
- else
- (usage', uss)
-{-
- = (usage `delManyFromIdEnv` binders,
- [ (binder, usage_of usage binder) | binder <- binders ]
- )
--}
+ [IdWithOccInfo]) -- Tagged binders
+
+tagBinders usage binders
+ = let
+ usage' = usage `delVarEnvList` binders
+ uss = map (setBinderPrag usage) binders
+ in
+ usage' `seq` (usage', uss)
+
tagBinder :: UsageDetails -- Of scope
-> Id -- Binders
-> (UsageDetails, -- Details with binders removed
- (Id,BinderInfo)) -- Tagged binders
-
-tagBinder usage binder =
- let
- usage' = usage `delOneFromIdEnv` binder
- us = usage_of usage binder
- cont =
- if isNullIdEnv usage' then -- Bogus test to force evaluation.
- (usage', (binder, us))
- else
- (usage', (binder, us))
- in
- if isDeadOcc us then -- Ditto
- cont
- else
- cont
-
-
-usage_of usage binder
- | isExported binder || isSpecPragmaId binder
- = noBinderInfo -- Visible-elsewhere things count as many
+ IdWithOccInfo) -- Tagged binders
+
+tagBinder usage binder
+ = let
+ usage' = usage `delVarEnv` binder
+ binder' = setBinderPrag usage binder
+ in
+ usage' `seq` (usage', binder')
+
+
+setBinderPrag :: UsageDetails -> CoreBndr -> CoreBndr
+setBinderPrag usage bndr
+ | isTyVar bndr
+ = bndr
+
| otherwise
- = case (lookupIdEnv usage binder) of
- Nothing -> deadOccurrence
- Just info -> info
+ = case old_prag of
+ NoInlinePragInfo -> new_bndr
+ IAmDead -> new_bndr -- The next three are annotations
+ ICanSafelyBeINLINEd _ _ -> new_bndr -- from the previous iteration of
+ IAmALoopBreaker -> new_bndr -- the occurrence analyser
-isNeeded env usage binder = not (isDeadOcc (usage_of usage binder))
-\end{code}
+ IAmASpecPragmaId -> bndr -- Don't ever overwrite or drop these as dead
+
+ other | its_now_dead -> new_bndr -- Overwrite the others iff it's now dead
+ | otherwise -> bndr
+
+ where
+ old_prag = getInlinePragma bndr
+ new_bndr = setInlinePragma bndr new_prag
+ its_now_dead = case new_prag of
+ IAmDead -> True
+ other -> False
+ new_prag = occInfoToInlinePrag occ_info
+
+ occ_info
+ | isExported bndr = noBinderInfo
+ -- Don't use local usage info for visible-elsewhere things
+ -- But NB that we do set NoInlinePragma for exported things
+ -- thereby nuking any IAmALoopBreaker from a previous pass.
+
+ | otherwise = case lookupVarEnv usage bndr of
+ Nothing -> deadOccurrence
+ Just info -> info
+
+markBinderInsideLambda :: CoreBndr -> CoreBndr
+markBinderInsideLambda bndr
+ | isTyVar bndr
+ = bndr
+
+ | otherwise
+ = case getInlinePragma bndr of
+ ICanSafelyBeINLINEd not_in_lam nalts
+ -> bndr `setInlinePragma` ICanSafelyBeINLINEd InsideLam nalts
+ other -> bndr
+
+funOccZero = funOccurrence 0
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
\end{code}
\begin{code}
-doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
+doStaticArgs :: [CoreBind] -> UniqSupply -> [CoreBind]
doStaticArgs binds
- = initSAT (mapSAT sat_bind binds)
+ = do {
+ beginPass "Static argument";
+ let { binds' = initSAT (mapSAT sat_bind binds) };
+ endPass "Static argument"
+ False -- No specific flag for dumping SAT
+ binds'
+ }
where
sat_bind (NonRec binder expr)
= emptyEnvSAT `thenSAT_`
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
SATEnv(..), isStatic, dropStatics
) where
-import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
+import Type ( mkTyVarTy, mkSigmaTy,
splitSigmaTy, splitFunTys,
- glueTyArgs, instantiateTy, TauType,
- Class, ThetaType, SigmaType,
+ glueTyArgs, substTy,
InstTyEnv(..)
)
import MkId ( mkSysLocal )
-import Id ( idType )
-import SrcLoc ( SrcLoc, noSrcLoc )
+import Id ( idType, idName, mkUserId )
import UniqSupply
import Util
deriving Eq
delOneFromSAEnv v us env
- = ((), delOneFromIdEnv env v)
+ = ((), delVarEnv env v)
updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
updSAEnv Nothing
insSAEnv :: Id -> SATInfo -> SatM ()
insSAEnv b info us env
- = ((), addOneToIdEnv env b info)
+ = ((), extendVarEnv env b info)
\end{code}
%************************************************************************
initSAT :: SatM a -> UniqSupply -> a
-initSAT f us = fst (f us nullIdEnv)
+initSAT f us = fst (f us emptyVarEnv)
thenSAT m k us env
= case splitUniqSupply us of { (s1, s2) ->
k s2 menv }}
emptyEnvSAT :: SatM ()
-emptyEnvSAT us _ = ((), nullIdEnv)
+emptyEnvSAT us _ = ((), emptyVarEnv)
returnSAT v us env = (v, env)
\begin{code}
getSATInfo :: Id -> SatM (Maybe SATInfo)
getSATInfo var us env
- = (lookupIdEnv env var, env)
+ = (lookupVarEnv env var, env)
newSATName :: Id -> Type -> SatM Id
newSATName id ty us env
= case (getUnique us) of { unique ->
- (mkSysLocal new_str unique ty noSrcLoc, env) }
- where
- new_str = getOccName id _APPEND_ SLIT("_sat")
+ let
+ new_name = mkCompoundName SLIT("$sat") unique (idName id)
+ in
+ (mkUserId new_name ty, env) }
getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
-- A better fix is to use binder directly but with the TopLevel
-- tag (or Exported tag) modified.
fake_binder = mkSysLocal
- (getOccName binder _APPEND_ SLIT("_fsat"))
- (uniqueOf binder)
+ (getUnique binder)
(idType binder)
- noSrcLoc
rec_body = mkValLam non_static_args
( Let (NonRec fake_binder nonrec_rhs)
{-in-} (dropArgs rhs))
origLams' _ e' = e'
new_ty tyargs args
- = instantiateTy (mk_inst_tyenv tyargs tv_tmpl)
+ = substTy (mk_inst_tyenv tyargs tv_tmpl)
(mkSigmaTy tv_tmpl' dict_tys' tau_ty')
where
-- get type info for the local function:
reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
tau_ty' = glueTyArgs reg_arg_tys' res_type
- mk_inst_tyenv [] _ = emptyTyVarEnv
- mk_inst_tyenv (Static s:args) (t:ts) = addToTyVarEnv (mk_inst_tyenv args ts) t s
+ mk_inst_tyenv [] _ = emptyVarEnv
+ mk_inst_tyenv (Static s:args) (t:ts) = extendVarEnv (mk_inst_tyenv args ts) t s
mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts
dropStatics [] t = t
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{SetLevels}
#include "HsVersions.h"
-import AnnCoreSyn
import CoreSyn
-import CoreUtils ( coreExprType, idSpecVars )
-import CoreUnfold ( FormSummary, whnfOrBottom, mkFormSummary )
-import FreeVars -- all of it
-import MkId ( mkSysLocal )
-import Id ( idType,
- nullIdEnv, addOneToIdEnv, growIdEnvList,
- unionManyIdSets, unionIdSets, minusIdSet, mkIdSet,
- idSetToList, Id,
- lookupIdEnv, IdEnv
- )
-import SrcLoc ( noSrcLoc )
-import Type ( isUnpointedType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, Type )
-import TyVar ( emptyTyVarEnv, addToTyVarEnv,
- growTyVarEnvList, lookupTyVarEnv,
- tyVarSetToList,
- TyVarEnv, TyVar,
- unionManyTyVarSets, unionTyVarSets
- )
-import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
- mapAndUnzip3Us, getUnique, UniqSM,
- UniqSupply
+import CoreUtils ( coreExprType, exprIsTrivial, idFreeVars, exprIsBottom
)
-import BasicTypes ( Unused )
-import Maybes ( maybeToBool )
-import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
+import FreeVars -- all of it
+import Id ( Id, idType, mkUserLocal )
+import Name ( varOcc )
+import Var ( IdOrTyVar )
+import VarEnv
+import VarSet
+import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
+import VarSet
+import VarEnv
+import UniqSupply ( initUs, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs,
+ mapAndUnzip3Us, UniqSM, UniqSupply )
+import Maybes ( maybeToBool )
+import Util ( zipWithEqual, zipEqual, panic, assertPanic )
import Outputable
isLeakFreeType x y = False -- safe option; ToDo
\begin{code}
data Level
- = Top -- Means *really* the top level.
+ = Top -- Means *really* the top level; short for (Level 0 0).
| Level Int -- Level number of enclosing lambdas
Int -- Number of big-lambda and/or case expressions between
-- here and the nearest enclosing lambda
\end{code}
The {\em level number} on a (type-)lambda-bound variable is the
-nesting depth of the (type-)lambda which binds it. On an expression,
-it's the maximum level number of its free (type-)variables. On a
-let(rec)-bound variable, it's the level of its RHS. On a case-bound
-variable, it's the number of enclosing lambdas.
+nesting depth of the (type-)lambda which binds it. The outermost lambda
+has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
+
+On an expression, it's the maximum level number of its free
+(type-)variables. On a let(rec)-bound variable, it's the level of its
+RHS. On a case-bound variable, it's the number of enclosing lambdas.
Top-level variables: level~0. Those bound on the RHS of a top-level
definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
at @Level 0 0@; it is never @Top@.
\begin{code}
-type LevelledExpr = GenCoreExpr (Id, Level) Id Unused
-type LevelledArg = GenCoreArg Id Unused
-type LevelledBind = GenCoreBinding (Id, Level) Id Unused
-
-type LevelEnvs = (IdEnv Level, -- bind Ids to levels
- TyVarEnv Level) -- bind type variables to levels
+type LevelledExpr = TaggedExpr Level
+type LevelledArg = TaggedArg Level
+type LevelledBind = TaggedBind Level
tOP_LEVEL = Top
isTopMajLvl Top = True
isTopMajLvl (Level maj _) = maj == 0
-unTopify :: Level -> Level
-unTopify Top = Level 0 0
-unTopify lvl = lvl
-
instance Outputable Level where
ppr Top = ptext SLIT("<Top>")
ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
\end{code}
+\begin{code}
+type LevelEnv = VarEnv Level
+
+varLevel :: LevelEnv -> IdOrTyVar -> Level
+varLevel env v
+ = case lookupVarEnv env v of
+ Just level -> level
+ Nothing -> tOP_LEVEL
+
+maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxIdLvl env var lvl | isTyVar var = lvl
+ | otherwise = case lookupVarEnv env var of
+ Just lvl' -> maxLvl lvl' lvl
+ Nothing -> lvl
+
+maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxTyVarLvl env var lvl | isId var = lvl
+ | otherwise = case lookupVarEnv env var of
+ Just lvl' -> maxLvl lvl' lvl
+ Nothing -> lvl
+\end{code}
+
%************************************************************************
%* *
\subsection{Main level-setting code}
%************************************************************************
\begin{code}
-setLevels :: [CoreBinding]
+setLevels :: [CoreBind]
-> UniqSupply
-> [LevelledBind]
setLevels binds us
- = do_them binds us
+ = initLvl us (do_them binds)
where
-- "do_them"'s main business is to thread the monad along
-- It gives each top binding the same empty envt, because
-- things unbound in the envt have level number zero implicitly
- do_them :: [CoreBinding] -> LvlM [LevelledBind]
+ do_them :: [CoreBind] -> LvlM [LevelledBind]
do_them [] = returnLvl []
do_them (b:bs)
= lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
- do_them bs `thenLvl` \ lvld_binds ->
+ do_them bs `thenLvl` \ lvld_binds ->
returnLvl (lvld_bind ++ lvld_binds)
-initial_envs = (nullIdEnv, emptyTyVarEnv)
+initialEnv = emptyVarEnv
lvlTopBind (NonRec binder rhs)
- = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
+ = lvlBind Top initialEnv (AnnNonRec binder (freeVars rhs))
-- Rhs can have no free vars!
lvlTopBind (Rec pairs)
- = lvlBind (Level 0 0) initial_envs (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
+ = lvlBind Top initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
\end{code}
%************************************************************************
The binding stuff works for top level too.
\begin{code}
-type CoreBindingWithFVs = AnnCoreBinding Id Id Unused FVInfo
-
lvlBind :: Level
- -> LevelEnvs
- -> CoreBindingWithFVs
- -> LvlM ([LevelledBind], LevelEnvs)
+ -> LevelEnv
+ -> CoreBindWithFVs
+ -> LvlM ([LevelledBind], LevelEnv)
-lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec name rhs)
- = setFloatLevel (Just name) {- Already let-bound -}
- ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') ->
+lvlBind ctxt_lvl env (AnnNonRec name rhs)
+ = setFloatLevel (Just name) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') ->
let
- new_envs = (addOneToIdEnv venv name final_lvl, tenv)
+ new_env = extendVarEnv env name final_lvl
in
- returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
+ returnLvl ([NonRec (name, final_lvl) rhs'], new_env)
where
ty = idType name
-lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs)
- = decideRecFloatLevel ctxt_lvl envs binders rhss
- `thenLvl` \ (final_lvl, extra_binds, rhss') ->
+lvlBind ctxt_lvl env (AnnRec pairs)
+ = decideRecFloatLevel ctxt_lvl env binders rhss `thenLvl` \ (final_lvl, extra_binds, rhss') ->
let
binders_w_lvls = binders `zip` repeat final_lvl
- new_envs = (growIdEnvList venv binders_w_lvls, tenv)
+ new_env = extendVarEnvList env binders_w_lvls
in
- returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs)
+ returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_env)
where
(binders,rhss) = unzip pairs
\end{code}
\begin{code}
lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
- -> LevelEnvs -- Level of in-scope names/tyvars
+ -> LevelEnv -- Level of in-scope names/tyvars
-> CoreExprWithFVs -- input expression
-> LvlM LevelledExpr -- Result expression
\end{code}
If there were another lambda in @r@'s rhs, it would get level-2 as well.
\begin{code}
-lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
-lvlExpr _ _ (_, AnnLit l) = returnLvl (Lit l)
-lvlExpr _ _ (_, AnnCon con args) = returnLvl (Con con args)
-lvlExpr _ _ (_, AnnPrim op args) = returnLvl (Prim op args)
+lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
+lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg)
- = lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
- returnLvl (App fun' arg)
+lvlExpr ctxt_lvl env (_, AnnCon con args)
+ = mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' ->
+ returnLvl (Con con args')
-lvlExpr ctxt_lvl envs (_, AnnNote note expr)
- = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
+lvlExpr ctxt_lvl env (_, AnnApp fun arg)
+ = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' ->
+ lvlMFE ctxt_lvl env arg `thenLvl` \ arg' ->
+ returnLvl (App fun' arg')
+
+lvlExpr ctxt_lvl env (_, AnnNote note expr)
+ = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
returnLvl (Note note expr')
-- We don't split adjacent lambdas. That is, given
-- Why not? Because partial applications are fairly rare, and splitting
-- lambdas makes them more expensive.
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
- = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
- returnLvl (foldr (Lam . ValBinder) body' lvld_args)
+lvlExpr ctxt_lvl env (_, AnnLam bndr rhs)
+ = lvlMFE incd_lvl new_env body `thenLvl` \ body' ->
+ returnLvl (mkLams lvld_bndrs body')
where
- incd_lvl = incMajorLvl ctxt_lvl
- (args, body) = annCollectValBinders rhs
- lvld_args = [(a,incd_lvl) | a <- (arg:args)]
- new_venv = growIdEnvList venv lvld_args
-
--- We don't need to play such tricks for type lambdas, because
--- they don't get annotated
-
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
- = lvlExpr incd_lvl (venv, new_tenv) body `thenLvl` \ body' ->
- returnLvl (Lam (TyBinder tyvar) body')
+ bndr_is_id = isId bndr
+ bndr_is_tyvar = isTyVar bndr
+ (bndrs, body) = go rhs
+
+ incd_lvl | bndr_is_id = incMajorLvl ctxt_lvl
+ | otherwise = incMinorLvl ctxt_lvl
+ lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
+ new_env = extendVarEnvList env lvld_bndrs
+
+ go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr
+ || bndr_is_tyvar && isTyVar bndr
+ = case go rhs of { (bndrs, body) -> (bndr:bndrs, body) }
+ go body = ([], body)
+
+lvlExpr ctxt_lvl env (_, AnnLet bind body)
+ = lvlBind ctxt_lvl env bind `thenLvl` \ (binds', new_env) ->
+ lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
+ returnLvl (mkLets binds' body')
+
+lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
+ = lvlMFE ctxt_lvl env expr `thenLvl` \ expr' ->
+ mapLvl lvl_alt alts `thenLvl` \ alts' ->
+ returnLvl (Case expr' (case_bndr, incd_lvl) alts')
where
- incd_lvl = incMinorLvl ctxt_lvl
- new_tenv = addToTyVarEnv tenv tyvar incd_lvl
-
-lvlExpr ctxt_lvl envs (_, AnnLet bind body)
- = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
- lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' ->
- returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
-
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
- = lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
- lvl_alts alts `thenLvl` \ alts' ->
- returnLvl (Case expr' alts')
- where
expr_type = coreExprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
-
- lvl_alts (AnnAlgAlts alts deflt)
- = mapLvl lvl_alt alts `thenLvl` \ alts' ->
- lvl_deflt deflt `thenLvl` \ deflt' ->
- returnLvl (AlgAlts alts' deflt')
- where
- lvl_alt (con, bs, e)
- = let
- bs' = [ (b, incd_lvl) | b <- bs ]
- new_envs = (growIdEnvList venv bs', tenv)
- in
- lvlMFE incd_lvl new_envs e `thenLvl` \ e' ->
- returnLvl (con, bs', e')
-
- lvl_alts (AnnPrimAlts alts deflt)
- = mapLvl lvl_alt alts `thenLvl` \ alts' ->
- lvl_deflt deflt `thenLvl` \ deflt' ->
- returnLvl (PrimAlts alts' deflt')
- where
- lvl_alt (lit, e)
- = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
- returnLvl (lit, e')
-
- lvl_deflt AnnNoDefault = returnLvl NoDefault
-
- lvl_deflt (AnnBindDefault b expr)
- = let
- new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
- in
- lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
- returnLvl (BindDefault (b, incd_lvl) expr')
+ alts_env = extendVarEnv env case_bndr incd_lvl
+
+ lvl_alt (con, bs, rhs)
+ = let
+ bs' = [ (b, incd_lvl) | b <- bs ]
+ new_env = extendVarEnvList alts_env bs'
+ in
+ lvlMFE incd_lvl new_env rhs `thenLvl` \ rhs' ->
+ returnLvl (con, bs', rhs')
\end{code}
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
\begin{code}
lvlMFE :: Level -- Level of innermost enclosing lambda/tylam
- -> LevelEnvs -- Level of in-scope names/tyvars
+ -> LevelEnv -- Level of in-scope names/tyvars
-> CoreExprWithFVs -- input expression
-> LvlM LevelledExpr -- Result expression
-lvlMFE ctxt_lvl envs@(venv,_) ann_expr
- | isUnpointedType ty -- Can't let-bind it
- = lvlExpr ctxt_lvl envs ann_expr
+lvlMFE ctxt_lvl env (_, AnnType ty)
+ = returnLvl (Type ty)
+
+lvlMFE ctxt_lvl env ann_expr
+ | isUnLiftedType ty -- Can't let-bind it
+ = lvlExpr ctxt_lvl env ann_expr
| otherwise -- Not primitive type so could be let-bound
= setFloatLevel Nothing {- Not already let-bound -}
- ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') ->
+ ctxt_lvl env ann_expr ty `thenLvl` \ (final_lvl, expr') ->
returnLvl expr'
where
ty = coreExprType (deAnnotate ann_expr)
setFloatLevel :: Maybe Id -- Just id <=> the expression is already let-bound to id
-- Nothing <=> it's a possible MFE
-> Level -- of context
- -> LevelEnvs
+ -> LevelEnv
-> CoreExprWithFVs -- Original rhs
- -> Type -- Type of rhs
+ -> Type -- Type of rhs
-> LvlM (Level, -- Level to attribute to this let-binding
LevelledExpr) -- Final rhs
-setFloatLevel maybe_let_bound ctxt_lvl envs@(venv, tenv)
- expr@(FVInfo fvs tfvs might_leak, _) ty
--- Invariant: ctxt_lvl is never = Top
--- Beautiful ASSERT, dudes (WDP 95/04)...
+setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty
-- Now deal with (by not floating) trivial non-let-bound expressions
-- which just aren't worth let-binding in order to float. We always
-- for top level.
| not alreadyLetBound
- && (manifestly_whnf || not will_float_past_lambda)
- = -- Pin whnf non-let-bound expressions,
+ && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda)
+ = -- Pin trivial non-let-bound expressions,
-- or ones which aren't going anywhere useful
- lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
+ lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
returnLvl (ctxt_lvl, expr')
+{- SDM 7/98
+The above case used to read (whnf_or_bottom || not will_float_past_lambda).
+It was changed because we really do want to float out constructors if possible:
+this can save a great deal of needless allocation inside a loop. On the other
+hand, there's no point floating out nullary constructors and literals, hence
+the expr_is_trivial condition.
+-}
+
| alreadyLetBound && not worth_type_abstraction
= -- Process the expression with a new ctxt_lvl, obtained from
-- the free vars of the expression itself
- lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
- returnLvl (maybe_unTopify expr_lvl, expr')
+ lvlExpr expr_lvl env expr `thenLvl` \ expr' ->
+ returnLvl (expr_lvl, expr')
| otherwise -- This will create a let anyway, even if there is no
-- type variable to abstract, so we try to abstract anyway
- = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
+ = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr
`thenLvl` \ final_expr ->
returnLvl (expr_lvl, final_expr)
-- OLD LIE: The body of the let, just a type application, isn't worth floating
-- something non-trivial which depends on it.
where
alreadyLetBound = maybeToBool maybe_let_bound
-
-
-
- real_fvs = case maybe_let_bound of
- Nothing -> fvs -- Just the expr fvs
- Just id -> fvs `unionIdSets` mkIdSet (idSpecVars id)
- -- Tiresome! Add the specVars
-
- fv_list = idSetToList real_fvs
- tv_list = tyVarSetToList tfvs
- expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
- ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
- tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
+
+ fvs = case maybe_let_bound of
+ Nothing -> expr_fvs
+ Just id -> expr_fvs `unionVarSet` idFreeVars id
+
+ ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL fvs
+ tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL fvs
+ expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
- will_float_past_lambda = -- Will escape lambda if let-bound
- ids_only_lvl `ltMajLvl` ctxt_lvl
-
- worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
- -- if type abstracted
- (ids_only_lvl `ltLvl` tyvars_only_lvl)
- && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
-
- de_ann_expr = deAnnotate expr
-
- is_trivial (App e a)
- | notValArg a = is_trivial e
- is_trivial (Var _) = True
- is_trivial _ = False
-
- offending_tyvars = filter offending tv_list
- --non_offending_tyvars = filter (not . offending) tv_list
- --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
-
- offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
-
- manifestly_whnf = whnfOrBottom (mkFormSummary de_ann_expr)
-
- maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
- maybe_unTopify lvl = lvl
- {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
- -- so that the let will not go past the *last* lambda if it can
- -- generate a space leak. If it is already in major level 0
- -- It won't do any harm to give it a Level 1 0.
- -- we should do the same test not only for things with level Top,
- -- but also for anything that gets a major level 0.
- the problem is that
- f = \a -> let x = [1..1000]
- in zip a x
- ==>
- f = let x = [1..1000]
- in \a -> zip a x
- is just as bad as floating x to the top level.
- Notice it would be OK in cases like
- f = \a -> let x = [1..1000]
- y = length x
- in a + y
- ==>
- f = let x = [1..1000]
- y = length x
- in \a -> a + y
- as x will be gc'd after y is updated.
- [We did not hit any problems with the above (Level 0 0) code
- in nofib benchmark]
- -}
+ -- Will escape lambda if let-bound
+ will_float_past_lambda = ids_only_lvl `ltMajLvl` ctxt_lvl
+
+ -- Will escape (more) lambda(s)/type lambda(s) if type abstracted
+ worth_type_abstraction = (ids_only_lvl `ltLvl` tyvars_only_lvl)
+ && not expr_is_trivial -- Avoids abstracting trivial type applications
+
+ offending_tyvars = filter offending_tv (varSetElems fvs)
+ offending_tv var | isId var = False
+ | otherwise = ids_only_lvl `ltLvl` varLevel env var
+
+ expr_is_trivial = exprIsTrivial de_ann_expr
+ expr_is_bottom = exprIsBottom de_ann_expr
+ de_ann_expr = deAnnotate expr
\end{code}
Abstract wrt tyvars, by making it just as if we had seen
variables, then we just return E.
\begin{code}
-abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
- = lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' ->
+abstractWrtTyVars offending_tyvars ty env lvl expr
+ = lvlExpr incd_lvl new_env expr `thenLvl` \ expr' ->
newLvlVar poly_ty `thenLvl` \ poly_var ->
let
- poly_var_rhs = mkTyLam offending_tyvars expr'
+ poly_var_rhs = mkLams tyvar_lvls expr'
poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
- poly_var_app = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
+ poly_var_app = mkTyApps (Var poly_var) (mkTyVarTys offending_tyvars)
final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
in
returnLvl final_expr
poly_ty = mkForAllTys offending_tyvars ty
-- These defns are just like those in the TyLam case of lvlExpr
- (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
-
- next lvl tyvar = (lvl1, (tyvar,lvl1))
- where lvl1 = incMinorLvl lvl
-
- new_tenv = growTyVarEnvList tenv tyvar_lvls
- new_envs = (venv, new_tenv)
+ incd_lvl = incMinorLvl lvl
+ tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars]
+ new_env = extendVarEnvList env tyvar_lvls
\end{code}
Recursive definitions. We want to transform
type lambdas.
\begin{code}
-decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
- | isTopMajLvl ids_only_lvl && -- Destination = top
- not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
- = -- Pin it here
- let
- ids_w_lvls = ids `zip` repeat ctxt_lvl
- new_envs = (growIdEnvList venv ids_w_lvls, tenv)
- in
- mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' ->
- returnLvl (ctxt_lvl, [], rhss')
-
-{- OMITTED; see comments above near isWorthFloatingExpr
-
- | not (any (isWorthFloating True . deAnnotate) rhss)
- = -- Pin it here
- mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
- returnLvl (ctxt_lvl, [], rhss')
-
--}
-
+decideRecFloatLevel ctxt_lvl env ids rhss
| ids_only_lvl `ltLvl` tyvars_only_lvl
= -- Abstract wrt tyvars;
-- offending_tyvars is definitely non-empty
-- (I love the ASSERT to check this... WDP 95/02)
let
- -- These defns are just like those in the TyLam case of lvlExpr
- (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
-
- next lvl tyvar = (lvl1, (tyvar,lvl1))
- where lvl1 = incMinorLvl lvl
-
- ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
- new_tenv = growTyVarEnvList tenv tyvar_lvls
- new_venv = growIdEnvList venv ids_w_incd_lvl
- new_envs = (new_venv, new_tenv)
+ incd_lvl = incMinorLvl ids_only_lvl
+ tyvars_w_lvl = [(var,incd_lvl) | var <- offending_tyvars]
+ ids_w_lvl = [(var,incd_lvl) | var <- ids]
+ new_env = extendVarEnvList env (tyvars_w_lvl ++ ids_w_lvl)
in
- mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' ->
+ mapLvl (lvlExpr incd_lvl new_env) rhss `thenLvl` \ rhss' ->
mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
let
ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
-- The "d_rhss" are the right-hand sides of "D" and "D'"
-- in the documentation above
- d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
+ d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
-- "local_binds" are "D'" in the documentation above
- local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
+ local_binds = zipWithEqual "SetLevels" NonRec ids_w_lvl d_rhss
- poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
- | rhs' <- rhss' -- mkCoLet* requires Core...
+ poly_var_rhss = [ mkLams tyvars_w_lvl (mkLets local_binds rhs')
+ | rhs' <- rhss'
]
poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
= -- Let it float freely
let
ids_w_lvls = ids `zip` repeat expr_lvl
- new_envs = (growIdEnvList venv ids_w_lvls, tenv)
+ new_env = extendVarEnvList env ids_w_lvls
in
- mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss `thenLvl` \ rhss' ->
+ mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' ->
returnLvl (expr_lvl, [], rhss')
where
- tys = map idType ids
-
- fvs = (unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `unionIdSets`
- mkIdSet (concat (map idSpecVars ids)))
- `minusIdSet` mkIdSet ids
-
- tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
- `unionTyVarSets`
- tyVarsOfTypes tys
- -- Why the "tyVarsOfTypes" part? Consider this:
- -- /\a -> letrec x::a = x in E
- -- Now, there are no explicit free type variables in the RHS of x,
- -- but nevertheless "a" is free in its definition. So we add in
- -- the free tyvars of the types of the binders.
- -- This actually happened in the defn of errorIO in IOBase.lhs:
- -- errorIO (ST io) = case (errorIO# io) of
- -- _ -> bottom
- -- where
- -- bottom = bottom -- Never evaluated
- -- I don't think this can every happen for non-recursive bindings.
-
- fv_list = idSetToList fvs
- tv_list = tyVarSetToList tfvs
-
- ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
- tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
- expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
+ -- Finding the free vars of the binding group is annoying
+ bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars ids))
+ `minusVarSet`
+ mkVarSet ids
- offending_tyvars
- | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
- | otherwise = []
+ ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL bind_fvs
+ tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs
+ expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
+ offending_tyvars = filter offending_tv (varSetElems bind_fvs)
+ offending_tv var | isId var = False
+ | otherwise = ids_only_lvl `ltLvl` varLevel env var
offending_tyvar_tys = mkTyVarTys offending_tyvars
- poly_tys = map (mkForAllTys offending_tyvars) tys
- offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
-\end{code}
-
-
-\begin{code}
-{- ******** OMITTED NOW
-
-isWorthFloating :: Bool -- True <=> already let-bound
- -> CoreExpr -- The expression
- -> Bool
-
-isWorthFloating alreadyLetBound expr
-
- | alreadyLetBound = isWorthFloatingExpr expr
-
- | otherwise = -- No point in adding a fresh let-binding for a WHNF, because
- -- floating it isn't beneficial enough.
- isWorthFloatingExpr expr &&
- not (whnfOrBottom expr)
-********** -}
-
-isWorthFloatingExpr :: CoreExpr -> Bool
-
-isWorthFloatingExpr (Var v) = False
-isWorthFloatingExpr (Lit lit) = False
-isWorthFloatingExpr (App e arg)
- | notValArg arg = isWorthFloatingExpr e
-isWorthFloatingExpr (Con con as)
- | all notValArg as = False -- Just a type application
-isWorthFloatingExpr _ = True
-
-canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
-
-canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
-canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
-
-valSuggestsLeakFree expr = whnfOrBottom expr
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Help functions}
-%* *
-%************************************************************************
-
-\begin{code}
-idLevel :: IdEnv Level -> Id -> Level
-idLevel venv v
- = case lookupIdEnv venv v of
- Just level -> level
- Nothing -> tOP_LEVEL
-
-tyvarLevel :: TyVarEnv Level -> TyVar -> Level
-tyvarLevel tenv tyvar
- = case lookupTyVarEnv tenv tyvar of
- Just level -> level
- Nothing -> tOP_LEVEL
-\end{code}
-
-\begin{code}
-annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
- = (arg:args, body)
- where
- (args, body) = annCollectValBinders rhs
-
-annCollectValBinders body
- = ([], body)
+ tys = map idType ids
+ poly_tys = map (mkForAllTys offending_tyvars) tys
\end{code}
%************************************************************************
\begin{code}
type LvlM result = UniqSM result
+initLvl = initUs
thenLvl = thenUs
returnLvl = returnUs
mapLvl = mapUs
\begin{code}
newLvlVar :: Type -> LvlM Id
-
-newLvlVar ty us
- = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc
+newLvlVar ty = getUniqueUs `thenLvl` \ uniq ->
+ returnUs (mkUserLocal (varOcc SLIT("lvl")) uniq ty)
\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-\section[SimplCase]{Simplification of `case' expression}
-
-Support code for @Simplify@.
-
-\begin{code}
-module SimplCase ( simplCase, bindLargeRhs ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
-
-import BinderInfo -- too boring to try to select things...
-import CmdLineOpts ( SimplifierSwitch(..) )
-import CoreSyn
-import CoreUnfold ( Unfolding(..) )
-import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
- unTagBindersAlts, unTagBinders, coreExprType
- )
-import Id ( idType, isDataCon, getIdDemandInfo, dataConArgTys,
- DataCon, GenId{-instance Eq-},
- Id
- )
-import IdInfo ( willBeDemanded, DemandInfo )
-import Literal ( isNoRepLit, Literal{-instance Eq-} )
-import Maybes ( maybeToBool )
-import PrelVals ( voidId )
-import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
-import SimplVar ( simplBinder, simplBinders )
-import SimplUtils ( newId, newIds )
-import SimplEnv
-import SimplMonad
-import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys )
-import TyCon ( isDataTyCon )
-import TysPrim ( voidTy )
-import Util ( Eager, runEager, appEager,
- isIn, isSingleton, zipEqual, panic, assertPanic )
-import Outputable
-\end{code}
-
-Float let out of case.
-
-\begin{code}
-simplCase :: SimplEnv
- -> InExpr -- Scrutinee
- -> (SubstEnvs, InAlts) -- Alternatives, and their static environment
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> OutType -- Type of result expression
- -> SmplM OutExpr
-
-simplCase env (Let bind body) alts rhs_c result_ty
- | not (switchIsSet env SimplNoLetFromCase)
- = -- Float the let outside the case scrutinee (if not disabled by flag)
- tick LetFloatFromCase `thenSmpl_`
- simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
-\end{code}
-
-OK to do case-of-case if
-
-* we allow arbitrary code duplication
-
-OR
-
-* the inner case has one alternative
- case (case e of (a,b) -> rhs) of
- ...
- pi -> rhsi
- ...
- ===>
- case e of
- (a,b) -> case rhs of
- ...
- pi -> rhsi
- ...
-
-IF neither of these two things are the case, we avoid code-duplication
-by abstracting the outer rhss wrt the pattern variables. For example
-
- case (case e of { p1->rhs1; ...; pn -> rhsn }) of
- (x,y) -> body
-===>
- let b = \ x y -> body
- in
- case e of
- p1 -> case rhs1 of (x,y) -> b x y
- ...
- pn -> case rhsn of (x,y) -> b x y
-
-
-OK, so outer case expression gets duplicated, but that's all. Furthermore,
- (a) the binding for "b" will be let-no-escaped, so no heap allocation
- will take place; the "call" to b will simply be a stack adjustment
- and a jump
- (b) very commonly, at least some of the rhsi's will be constructors, which
- makes life even simpler.
-
-All of this works equally well if the outer case has multiple rhss.
-
-
-\begin{code}
-simplCase env (Case inner_scrut inner_alts) (subst_envs, outer_alts) rhs_c result_ty
- | switchIsSet env SimplCaseOfCase
- = -- Ha! Do case-of-case
- tick CaseOfCase `thenSmpl_`
-
- if no_need_to_bind_large_alts
- then
- simplCase env inner_scrut (getSubstEnvs env, inner_alts)
- (\env' rhs -> simplCase env' rhs (subst_envs, outer_alts) rhs_c result_ty)
- result_ty
- else
- bindLargeAlts env_alts outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
- let
- rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
- in
- simplCase env inner_scrut (getSubstEnvs env, inner_alts)
- (\env rhs -> simplCase env rhs (subst_envs, outer_alts') rhs_c' result_ty)
- -- We used to have "emptySubstEnvs" instead of subst_envs here,
- -- but that is *wrong*. The outer_alts' still have the old
- -- binders from outer_alts, with un-substituted types,
- -- so we must keep their subst_envs with them. It does
- -- no harm to the freshly-manufactured part of outer_alts',
- -- because it'll have nothing in the domain of subst_envs anyway
- result_ty
- `thenSmpl` \ case_expr ->
- returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
-
- where
- env_alts = setSubstEnvs env subst_envs
-
- no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
- isSingleton (nonErrorRHSs inner_alts)
-\end{code}
-
-Case of an application of error.
-
-\begin{code}
-simplCase env scrut alts rhs_c result_ty
- | maybeToBool maybe_error_app
- = -- Look for an application of an error id
- tick CaseOfError `thenSmpl_`
- simplExpr env retyped_error_app [] result_ty
- -- Ignore rhs_c!
- -- We must apply simplExpr because "rhs" isn't yet simplified.
- -- The ice is a little thin because body_ty is an OutType; but it's ok really
- where
- maybe_error_app = maybeErrorApp scrut (Just result_ty)
- Just retyped_error_app = maybe_error_app
-\end{code}
-
-Finally the default case
-
-\begin{code}
-simplCase env other_scrut (subst_envs, alts) rhs_c result_ty
- = simplTy env scrut_ty `appEager` \ scrut_ty' ->
- simplExpr env_scrut other_scrut [] scrut_ty' `thenSmpl` \ scrut' ->
- completeCase env_alts scrut' alts rhs_c
- where
- -- When simplifying the scrutinee of a complete case that
- -- has no default alternative
- env_scrut = case alts of
- AlgAlts _ NoDefault -> setCaseScrutinee env
- PrimAlts _ NoDefault -> setCaseScrutinee env
- other -> env
-
- env_alts = setSubstEnvs env subst_envs
-
- scrut_ty = coreExprType (unTagBinders other_scrut)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Simplify-case]{Completing case-expression simplification}
-%* *
-%************************************************************************
-
-\begin{code}
-completeCase
- :: SimplEnv
- -> OutExpr -- The already-simplified scrutinee
- -> InAlts -- The un-simplified alternatives
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> SmplM OutExpr -- The whole case expression
-\end{code}
-
-Scrutinising a literal or constructor.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's an obvious win to do:
-
- case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
-
-and the similar thing for primitive case. If we have
-
- case x of ...
-
-and x is known to be of constructor form, then we'll already have
-inlined the constructor to give (case (C a b) of ...), so we don't
-need to check for the variable case separately.
-
-Sanity check: we don't have a good
-story to tell about case analysis on NoRep things. ToDo.
-
-\begin{code}
-completeCase env (Lit lit) alts rhs_c
- | not (isNoRepLit lit)
- = -- Ha! Select the appropriate alternative
- tick KnownBranch `thenSmpl_`
- completePrimCaseWithKnownLit env lit alts rhs_c
-
-completeCase env expr@(Con con con_args) alts rhs_c
- = -- Ha! Staring us in the face -- select the appropriate alternative
- tick KnownBranch `thenSmpl_`
- completeAlgCaseWithKnownCon env con con_args alts rhs_c
-\end{code}
-
-Case elimination
-~~~~~~~~~~~~~~~~
-Start with a simple situation:
-
- case x# of ===> e[x#/y#]
- y# -> e
-
-(when x#, y# are of primitive type, of course).
-We can't (in general) do this for algebraic cases, because we might
-turn bottom into non-bottom!
-
-Actually, we generalise this idea to look for a case where we're
-scrutinising a variable, and we know that only the default case can
-match. For example:
-\begin{verbatim}
- case x of
- 0# -> ...
- other -> ...(case x of
- 0# -> ...
- other -> ...) ...
-\end{code}
-Here the inner case can be eliminated. This really only shows up in
-eliminating error-checking code.
-
-Lastly, we generalise the transformation to handle this:
-
- case e of ===> r
- True -> r
- False -> r
-
-We only do this for very cheaply compared r's (constructors, literals
-and variables). If pedantic bottoms is on, we only do it when the
-scrutinee is a PrimOp which can't fail.
-
-We do it *here*, looking at un-simplified alternatives, because we
-have to check that r doesn't mention the variables bound by the
-pattern in each alternative, so the binder-info is rather useful.
-
-So the case-elimination algorithm is:
-
- 1. Eliminate alternatives which can't match
-
- 2. Check whether all the remaining alternatives
- (a) do not mention in their rhs any of the variables bound in their pattern
- and (b) have equal rhss
-
- 3. Check we can safely ditch the case:
- * PedanticBottoms is off,
- or * the scrutinee is an already-evaluated variable
- or * the scrutinee is a primop which is ok for speculation
- -- ie we want to preserve divide-by-zero errors, and
- -- calls to error itself!
-
- or * [Prim cases] the scrutinee is a primitive variable
-
- or * [Alg cases] the scrutinee is a variable and
- either * the rhs is the same variable
- (eg case x of C a b -> x ===> x)
- or * there is only one alternative, the default alternative,
- and the binder is used strictly in its scope.
- [NB this is helped by the "use default binder where
- possible" transformation; see below.]
-
-
-If so, then we can replace the case with one of the rhss.
-
-\begin{code}
-completeCase env scrut alts rhs_c
- | switchIsSet env SimplDoCaseElim &&
-
- binders_unused &&
-
- all_rhss_same &&
-
- (not (switchIsSet env SimplPedanticBottoms) ||
- scrut_is_evald ||
- scrut_is_eliminable_primitive ||
- rhs1_is_scrutinee ||
- scrut_is_var_and_single_strict_default
- )
-
- = tick CaseElim `thenSmpl_`
- rhs_c new_env rhs1
- where
- -- Find the non-excluded rhss of the case; always at least one
- (rhs1:rhss) = possible_rhss
- all_rhss_same = all (cheap_eq rhs1) rhss
-
- -- Find the reduced set of possible rhss, along with an indication of
- -- whether none of their binders are used
- (binders_unused, possible_rhss, new_env)
- = case alts of
- PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
- deflt_rhs ++ rhss,
- new_env)
- where
- (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
-
- -- Eliminate unused rhss if poss
- rhss = case scrut_form of
- OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
- not (alt_lit `is_elem` not_these)
- ]
- other -> [rhs | (_,rhs) <- alts]
-
- AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
- deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
- new_env)
- where
- (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
-
- -- Eliminate unused alts if poss
- possible_alts = case scrut_form of
- OtherCon not_these ->
- -- Remove alts which can't match
- [alt | alt@(alt_con,_,_) <- alts,
- not (alt_con `is_elem` not_these)]
-
- other -> alts
-
- alt_binders_unused (con, args, rhs) = all is_dead args
- is_dead (_, DeadCode) = True
- is_dead other_arg = False
-
- -- If the scrutinee is a variable, look it up to see what we know about it
- scrut_form = case scrut of
- Var v -> lookupUnfolding env v
- other -> NoUnfolding
-
- -- If the scrut is already eval'd then there's no worry about
- -- eliminating the case
- scrut_is_evald = isEvaluated scrut_form
-
- scrut_is_eliminable_primitive
- = case scrut of
- Prim op _ -> primOpOkForSpeculation op
- Var _ -> case alts of
- PrimAlts _ _ -> True -- Primitive, hence non-bottom
- AlgAlts _ _ -> False -- Not primitive
- other -> False
-
- -- case v of w -> e{strict in w} ===> e[v/w]
- scrut_is_var_and_single_strict_default
- = case scrut of
- Var _ -> case alts of
- AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
- other -> False
- other -> False
-
- elim_deflt_binder NoDefault -- No Binder
- = (True, [], env)
- elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
- = (True, [rhs], env)
- elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
- = case scrut of
- Var v -> -- Binder used, but can be eliminated in favour of scrut
- (True, [rhs], bindIdToAtom env used_binder (VarArg v))
- non_var -> -- Binder used, and can't be elimd
- (False, [rhs], env)
-
- -- Check whether the chosen unique rhs (ie rhs1) is the same as
- -- the scrutinee. Remember that the rhs is as yet unsimplified.
- rhs1_is_scrutinee = case (scrut, rhs1) of
- (Var scrut_var, Var rhs_var)
- -> case (lookupIdSubst env rhs_var) of
- Nothing -> rhs_var == scrut_var
- Just (SubstVar rhs_var') -> rhs_var' == scrut_var
- other -> False
- other -> False
-
- is_elem x ys = isIn "completeCase" x ys
-\end{code}
-
-Scrutinising anything else. If it's a variable, it can't be bound to a
-constructor or literal, because that would have been inlined
-
-\begin{code}
-completeCase env scrut alts rhs_c
- = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
- mkCoCase env scrut alts'
-\end{code}
-
-
-
-
-\begin{code}
-bindLargeAlts :: SimplEnv
- -> InAlts
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
- -> OutType -- Result type
- -> SmplM ([OutBinding], -- Extra bindings
- InAlts) -- Modified alts
-
-bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
- = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
- bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
- returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
- where
- do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
- (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
- returnSmpl (bind, (con,args,rhs'))
-
-bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
- = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
- bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
- returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
- where
- do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
- (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
- returnSmpl (bind, (lit,rhs'))
-
-bindLargeDefault env NoDefault rhs_ty rhs_c
- = returnSmpl ([], NoDefault)
-bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
- = bindLargeRhs env [binder] rhs_ty
- (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
- returnSmpl ([bind], BindDefault binder rhs')
-\end{code}
-
- bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
- | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
- rhs_id x1 .. xn)
-
-\begin{code}
-bindLargeRhs :: SimplEnv
- -> [InBinder] -- The args wrt which the rhs should be abstracted
- -> OutType
- -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
- -> SmplM (OutBinding, -- New bindings (singleton or empty)
- InExpr) -- Modified rhs
-
-bindLargeRhs env args rhs_ty rhs_c
- | null used_args && isUnpointedType rhs_ty
- -- If we try to lift a primitive-typed something out
- -- for let-binding-purposes, we will *caseify* it (!),
- -- with potentially-disastrous strictness results. So
- -- instead we turn it into a function: \v -> e
- -- where v::Void. Since arguments of type
- -- VoidPrim don't generate any code, this gives the
- -- desired effect.
- --
- -- The general structure is just the same as for the common "otherwise~ case
- = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
- newId voidTy `thenSmpl` \ void_arg_id ->
- rhs_c env `thenSmpl` \ prim_new_body ->
-
- returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
- App (Var prim_rhs_fun_id) (VarArg voidId))
-
- | otherwise
- = -- Generate the rhs
- simplBinders env used_args `thenSmpl` \ (new_env, used_args') ->
- let
- rhs_fun_ty :: OutType
- rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
- in
-
- -- Make the new binding Id. NB: it's an OutId
- newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
- rhs_c new_env `thenSmpl` \ rhs' ->
- let
- final_rhs = mkValLam used_args' rhs'
- in
- returnSmpl (NonRec rhs_fun_id final_rhs,
- foldl App (Var rhs_fun_id) used_arg_atoms)
- -- This is slightly wierd. We're retuning an OutId as part of the
- -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
- -- it's processed the OutId won't be found in the environment, so it
- -- will be left unmodified.
- where
-
- used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
- used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
- dead DeadCode = True
- dead other = False
-
- prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
-\end{code}
-
-Case alternatives when we don't know the scrutinee
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-A special case for case default. If we have
-\begin{verbatim}
-case x of
- p1 -> e1
- y -> default_e
-\end{verbatim}
-it is best to make sure that \tr{default_e} mentions \tr{x} in
-preference to \tr{y}. The code generator can do a cheaper job if it
-doesn't have to come up with a binding for \tr{y}.
-
-\begin{code}
-simplAlts :: SimplEnv
- -> OutExpr -- Simplified scrutinee;
- -- only of interest if its a var,
- -- in which case we record its form
- -> InAlts
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> SmplM OutAlts
--- For single-constructor types
--- case e of y -> b ===> case e of (a,b) -> let y = (a,b) in b
-
-simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
- | maybeToBool maybe_data_ty &&
- not (null cons) && -- Not an abstract type (can arise if we're pruning tydecl imports)
- null other_cons &&
- isDataTyCon tycon -- doesn't apply to (constructor-less) newtypes
- = newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
- let
- new_args = [ (b, bad_occ_info) | b <- new_bindees ]
- con_app = mkCon con ty_args (map VarArg new_bindees)
- new_rhs = Let (NonRec bndr con_app) rhs
- in
- simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
- where
- maybe_data_ty = splitAlgTyConApp_maybe (idType id)
- Just (tycon, ty_args, cons) = maybe_data_ty
- (con:other_cons) = cons
- inst_con_arg_tys = dataConArgTys con ty_args
- bad_occ_info = ManyOcc 0 -- Non-committal!
-
-simplAlts env scrut (AlgAlts alts deflt) rhs_c
- = mapSmpl do_alt alts `thenSmpl` \ alts' ->
- simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
- returnSmpl (AlgAlts alts' deflt')
- where
- deflt_form = OtherCon [con | (con,_,_) <- alts]
- do_alt (con, con_args, rhs)
- = simplBinders env con_args `thenSmpl` \ (env1, con_args') ->
- let
- new_env = case scrut of
- Var v -> extendEnvGivenNewRhs env1 v (Con con args)
- where
- (_, ty_args, _) = splitAlgTyConApp (idType v)
- args = map TyArg ty_args ++ map VarArg con_args'
-
- other -> env1
- in
- rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (con, con_args', rhs')
-
-simplAlts env scrut (PrimAlts alts deflt) rhs_c
- = mapSmpl do_alt alts `thenSmpl` \ alts' ->
- simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
- returnSmpl (PrimAlts alts' deflt')
- where
- deflt_form = OtherLit [lit | (lit,_) <- alts]
- do_alt (lit, rhs)
- = let
- new_env = case scrut of
- Var v -> extendEnvGivenNewRhs env v (Lit lit)
- other -> env
- in
- rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (lit, rhs')
-\end{code}
-
-Use default binder where possible
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There's one complication when simplifying the default clause of
-a case expression. If we see
-
- case x of
- x' -> ...x...x'...
-
-we'd like to convert it to
-
- case x of
- x' -> ...x'...x'...
-
-Reason 1: then there might be just one occurrence of x, and it can be
-inlined as the case scrutinee. So we spot this case when dealing with
-the default clause, and add a binding to the environment mapping x to
-x'.
-
-Reason 2: if the body is strict in x' then we can eliminate the
-case altogether. By using x' in preference to x we give the max chance
-of the strictness analyser finding that the body is strict in x'.
-
-On the other hand, if x does *not* get inlined, then we'll actually
-get somewhat better code from the former expression. So when
-doing Core -> STG we convert back!
-
-\begin{code}
-simplDefault
- :: SimplEnv
- -> OutExpr -- Simplified scrutinee
- -> InDefault -- Default alternative to be completed
- -> Unfolding -- Gives form of scrutinee
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
- -> SmplM OutDefault
-
-simplDefault env scrut NoDefault form rhs_c
- = returnSmpl NoDefault
-
--- Special case for variable scrutinee; see notes above.
-simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
- info_from_this_case rhs_c
- = simplBinder env binder `thenSmpl` \ (env1, binder') ->
- let
- env2 = extendEnvGivenNewRhs env1 scrut_var (Var binder')
-
- -- Add form details for the default binder
- scrut_unf = lookupUnfolding env scrut_var
- new_env = extendEnvGivenUnfolding env2 binder' noBinderInfo scrut_unf
- -- Use noBinderInfo rather than occ_info because we've
- -- added more occurrences by binding the scrut_var to it
- in
- rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (BindDefault binder' rhs')
-
-simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
- info_from_this_case rhs_c
- = simplBinder env binder `thenSmpl` \ (env1, binder') ->
- let
- new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
- in
- rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (BindDefault binder' rhs')
-\end{code}
-
-Case alternatives when we know what the scrutinee is
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-completePrimCaseWithKnownLit
- :: SimplEnv
- -> Literal
- -> InAlts
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> SmplM OutExpr
-
-completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
- = search_alts alts
- where
- search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
-
- search_alts ((alt_lit, rhs) : _)
- | alt_lit == lit
- = -- Matching alternative!
- rhs_c env rhs
-
- search_alts (_ : other_alts)
- = -- This alternative doesn't match; keep looking
- search_alts other_alts
-
- search_alts []
- = case deflt of
- NoDefault -> -- Blargh!
- panic "completePrimCaseWithKnownLit: No matching alternative and no default"
-
- BindDefault binder rhs -> -- OK, there's a default case
- -- Just bind the Id to the atom and continue
- let
- new_env = bindIdToAtom env binder (LitArg lit)
- in
- rhs_c new_env rhs
-\end{code}
-
-@completeAlgCaseWithKnownCon@: We know the constructor, so we can
-select one case alternative (or default). If we choose the default:
-we do different things depending on whether the constructor was
-staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
-[let-bind it] or we just know the \tr{y} is now the same as some other
-var [substitute \tr{y} out of existence].
-
-\begin{code}
-completeAlgCaseWithKnownCon
- :: SimplEnv
- -> DataCon -> [InArg]
- -- Scrutinee is (con, type, value arguments)
- -> InAlts
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> SmplM OutExpr
-
-completeAlgCaseWithKnownCon env con con_args a@(AlgAlts alts deflt) rhs_c
- = ASSERT(isDataCon con)
- search_alts alts
- where
- search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
-
- search_alts ((alt_con, alt_args, rhs) : _)
- | alt_con == con
- = -- Matching alternative!
- let
- val_args = filter isValArg con_args
- new_env = foldr bind env (zipEqual "SimplCase" alt_args val_args)
- bind (bndr, atom) env = bindIdToAtom env bndr atom
- in
- rhs_c new_env rhs
-
- search_alts (_ : other_alts)
- = -- This alternative doesn't match; keep looking
- search_alts other_alts
-
- search_alts []
- = -- No matching alternative
- case deflt of
- NoDefault -> -- Blargh!
- pprPanic "completeAlgCaseWithKnownCon: No matching alternative and no default"
- (ppr con <+> ppr con_args $$ ppr a)
-
- BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
- -- let-bind the binder to the constructor
- simplBinder env binder `thenSmpl` \ (env1, id') ->
- let
- new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
- in
- rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
-\end{code}
-
-Case absorption and identity-case elimination
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
-\end{code}
-
-@mkCoCase@ tries the following transformation (if possible):
-
-case v of ==> case v of
- p1 -> rhs1 p1 -> rhs1
- ... ...
- pm -> rhsm pm -> rhsm
- d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
- {or (prim) case v of d -> rhsn}
- pn -> rhsn ...
- ... po -> rhso[v/d]
- po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
- d' -> rhsd
-
-which merges two cases in one case when -- the default alternative of
-the outer case scrutises the same variable as the outer case This
-transformation is called Case Merging. It avoids that the same
-variable is scrutinised multiple times.
-
-There's a closely-related transformation:
-
-case e of ==> case e of
- p1 -> rhs1 p1 -> rhs1
- ... ...
- pm -> rhsm pm -> rhsm
- d -> case d of pn -> let d = pn in rhsn
- pn -> rhsn ...
- ... po -> let d = po in rhso
- po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
- d' -> rhsd
-
-Here, the let's are essential, because d isn't in scope any more.
-Sigh. Of course, they may be unused, in which case they'll be
-eliminated on the next round. Unfortunately, we can't figure out
-whether or not they are used at this juncture.
-
-NB: The binder in a BindDefault USED TO BE guaranteed unused if the
-scrutinee is a variable, because it'll be mapped to the scrutinised
-variable. Hence the [v/d] substitions can be omitted.
-
-ALAS, now the default binder is used by preference, so we have to
-generate trivial lets to express the substitutions, which will be
-eliminated on the next pass.
-
-The following code handles *both* these transformations (one
-equation for AlgAlts, one for PrimAlts):
-
-\begin{code}
-mkCoCase env scrut (AlgAlts outer_alts
- (BindDefault deflt_var
- (Case (Var scrut_var')
- (AlgAlts inner_alts inner_deflt))))
- | switchIsSet env SimplCaseMerge &&
- ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
- deflt_var == scrut_var') -- Second transformation
- = -- Aha! The default-absorption rule applies
- tick CaseMerge `thenSmpl_`
- returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
- (munge_alg_deflt deflt_var inner_deflt)))
- -- NB: see comment in this location for the PrimAlts case
- where
- -- Check scrutinee
- scrut_is_var = case scrut of {Var v -> True; other -> False}
- scrut_var = case scrut of Var v -> v
-
- -- Eliminate any inner alts which are shadowed by the outer ones
- reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
- not (con `is_elem` outer_cons)]
- outer_cons = [con | (con,_,_) <- outer_alts]
- is_elem = isIn "mkAlgAlts"
-
- -- Add the lets if necessary
- munged_reduced_inner_alts = map munge_alt reduced_inner_alts
-
- munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
- where
- v | scrut_is_var = Var scrut_var
- | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
-
- arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
- (_, arg_tys, _) -> arg_tys
-
-mkCoCase env scrut (PrimAlts
- outer_alts
- (BindDefault deflt_var (Case
- (Var scrut_var')
- (PrimAlts inner_alts inner_deflt))))
- | switchIsSet env SimplCaseMerge &&
- ((scrut_is_var && scrut_var == scrut_var') ||
- deflt_var == scrut_var')
- = -- Aha! The default-absorption rule applies
- tick CaseMerge `thenSmpl_`
- returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
- (munge_prim_deflt deflt_var inner_deflt)))
-
- -- Nota Bene: we don't recurse to mkCoCase again, because the
- -- default will now have a binding in it that prevents
- -- mkCoCase doing anything useful. Much worse, in this
- -- PrimAlts case the binding in the default branch is another
- -- Case, so if we recurse to mkCoCase we will get into an
- -- infinite loop.
- --
- -- ToDo: think of a better way to do this. At the moment
- -- there is at most one case merge per round. That's probably
- -- plenty but it seems unclean somehow.
- where
- -- Check scrutinee
- scrut_is_var = case scrut of {Var v -> True; other -> False}
- scrut_var = case scrut of Var v -> v
-
- -- Eliminate any inner alts which are shadowed by the outer ones
- reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
- not (lit `is_elem` outer_lits)]
- outer_lits = [lit | (lit,_) <- outer_alts]
- is_elem = isIn "mkPrimAlts"
-
- -- Add the lets (well cases actually) if necessary
- -- The munged alternative looks like
- -- lit -> case lit of d -> rhs
- -- The next pass will certainly eliminate the inner case, but
- -- it isn't easy to do so right away.
- munged_reduced_inner_alts = map munge_alt reduced_inner_alts
-
- munge_alt (lit, rhs)
- | scrut_is_var = (lit, Case (Var scrut_var)
- (PrimAlts [] (BindDefault deflt_var rhs)))
- | otherwise = (lit, Case (Lit lit)
- (PrimAlts [] (BindDefault deflt_var rhs)))
-\end{code}
-
-Now the identity-case transformation:
-
- case e of ===> e
- True -> True;
- False -> False
-
-and similar friends.
-
-\begin{code}
-mkCoCase env scrut alts
- | identity_alts alts
- = tick CaseIdentity `thenSmpl_`
- returnSmpl scrut
- where
- identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
- identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
-
- identity_alg_alt (con, args, Con con' args')
- = con == con'
- && and (zipWith eq_arg args args')
- && length args == length args'
- identity_alg_alt other
- = False
-
- identity_prim_alt (lit, Lit lit') = lit == lit'
- identity_prim_alt other = False
-
- -- For the default case we want to spot both
- -- x -> x
- -- and
- -- case y of { ... ; x -> y }
- -- as "identity" defaults
- identity_deflt NoDefault = True
- identity_deflt (BindDefault binder (Var x)) = x == binder ||
- case scrut of
- Var y -> y == x
- other -> False
- identity_deflt _ = False
-
- eq_arg binder (VarArg x) = binder == x
- eq_arg _ _ = False
-\end{code}
-
-The catch-all case
-
-\begin{code}
-mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
-\end{code}
-
-Boring local functions used above. They simply introduce a trivial binding
-for the binder, d', in an inner default; either
- let d' = deflt_var in rhs
-or
- case deflt_var of d' -> rhs
-depending on whether it's an algebraic or primitive case.
-
-\begin{code}
-munge_prim_deflt _ NoDefault = NoDefault
-
-munge_prim_deflt deflt_var (BindDefault d' rhs)
- = BindDefault deflt_var (Case (Var deflt_var)
- (PrimAlts [] (BindDefault d' rhs)))
-
-munge_alg_deflt _ NoDefault = NoDefault
-
-munge_alg_deflt deflt_var (BindDefault d' rhs)
- = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
-
--- This line caused a generic version of munge_deflt (ie one used for
--- both alg and prim) to space leak massively. No idea why.
--- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
-\end{code}
-
-\begin{code}
-cheap_eq :: InExpr -> InExpr -> Bool
- -- A cheap equality test which bales out fast!
-
-cheap_eq (Var v1) (Var v2) = v1==v2
-cheap_eq (Lit l1) (Lit l2) = l1==l2
-cheap_eq (Con con1 args1) (Con con2 args2)
- = con1 == con2 && args1 `eq_args` args2
-
-cheap_eq (Prim op1 args1) (Prim op2 args2)
- = op1 ==op2 && args1 `eq_args` args2
-
-cheap_eq (App f1 a1) (App f2 a2)
- = f1 `cheap_eq` f2 && a1 `eq_arg` a2
-
-cheap_eq _ _ = False
-
--- ToDo: make CoreArg an instance of Eq
-eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
-eq_args [] [] = True
-eq_args _ _ = False
-
-eq_arg (LitArg l1) (LitArg l2) = l1 == l2
-eq_arg (VarArg v1) (VarArg v2) = v1 == v2
-eq_arg (TyArg t1) (TyArg t2) = t1 == t2
-eq_arg _ _ = False
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SimplCore]{Driver for simplifying @Core@ programs}
#include "HsVersions.h"
-import AnalFBWW ( analFBWW )
-import Bag ( isEmptyBag, foldBag )
-import BinderInfo ( BinderInfo{-instance Outputable-} )
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
- opt_D_show_passes,
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
+ SwitchResult, switchIsOn,
+ opt_D_dump_occur_anal,
+ opt_D_dump_simpl_iterations,
opt_D_simplifier_stats,
opt_D_dump_simpl,
opt_D_verbose_core2core,
- opt_DoCoreLinting,
- opt_FoldrBuildOn,
- opt_ReportWhyUnfoldingsDisallowed,
- opt_ShowImportSpecs,
- opt_LiberateCaseThreshold
+ opt_D_dump_occur_anal
)
-import CoreLint ( lintCoreBindings )
+import CoreLint ( beginPass, endPass )
import CoreSyn
-import CoreUtils ( coreExprType )
-import SimplUtils ( etaCoreExpr, typeOkForCase )
+import PprCore ( pprCoreBindings )
+import OccurAnal ( occurAnalyseBinds )
+import CoreUtils ( exprIsTrivial, coreExprType )
+import Simplify ( simplBind )
+import SimplUtils ( etaCoreExpr, findDefault )
+import SimplMonad
import CoreUnfold
-import Literal ( Literal(..), literalType, mkMachInt, mkMachInt_safe )
-import ErrUtils ( ghcExit, dumpIfSet, doIfSet )
-import FiniteMap ( FiniteMap, emptyFM )
+import Const ( Con(..), Literal(..), literalType, mkMachInt )
+import ErrUtils ( dumpIfSet )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import FoldrBuildWW ( mkFoldrBuildWW )
-import MkId ( mkSysLocal, mkUserId )
-import Id ( setIdVisibility, getIdSpecialisation, setIdSpecialisation,
- getIdDemandInfo, idType,
- nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
- lookupIdEnv, IdEnv,
- Id
+import Id ( Id, mkSysLocal, mkUserId,
+ setIdVisibility, setIdUnfolding,
+ getIdSpecialisation, setIdSpecialisation,
+ getInlinePragma, setInlinePragma,
+ idType, setIdType
)
-import IdInfo ( willBeDemanded, DemandInfo )
-import Name ( isExported, isLocallyDefined,
- isLocalName, uniqToOccName,
- setNameVisibility,
+import IdInfo ( InlinePragInfo(..) )
+import VarEnv
+import VarSet
+import Name ( isExported, mkSysLocalName,
Module, NamedThing(..), OccName(..)
)
-import TyCon ( TyCon )
+import TyCon ( TyCon, isDataTyCon )
import PrimOp ( PrimOp(..) )
-import PrelVals ( unpackCStringId, unpackCString2Id,
+import PrelInfo ( unpackCStringId, unpackCString2Id,
integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId
+ integerPlusTwoId, integerMinusOneId,
+ int2IntegerId, addr2IntegerId
)
-import Type ( splitAlgTyConApp_maybe, isUnpointedType, Type )
-import TysWiredIn ( stringTy, isIntegerTy )
+import Type ( Type, splitAlgTyConApp_maybe,
+ isUnLiftedType, mkTyVarTy, Type )
+import TysWiredIn ( isIntegerTy )
import LiberateCase ( liberateCase )
-import MagicUFs ( MagicUnfoldingFun )
-import PprCore
import PprType ( nmbrType )
import SAT ( doStaticArgs )
-import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
-import SimplPgm ( simplifyPgm )
-import Specialise
-import SpecEnv ( substSpecEnv, isEmptySpecEnv )
+import Specialise ( specProgram)
+import SpecEnv ( specEnvToList, specEnvFromList )
import StrictAnal ( saWwTopBinds )
-import TyVar ( TyVar, nameTyVar, emptyTyVarEnv )
-import Unique ( Unique{-instance Eq-}, Uniquable(..),
- integerTyConKey, ratioTyConKey,
- mkUnique, incrUnique,
- initTidyUniques
+import Var ( TyVar, setTyVarName )
+import Unique ( Unique, Uniquable(..),
+ ratioTyConKey, mkUnique, incrUnique, initTidyUniques
)
-import UniqSupply ( UniqSupply, mkSplitUniqSupply,
- splitUniqSupply, getUnique
- )
-import UniqFM ( UniqFM, lookupUFM, addToUFM, delFromUFM )
-import Util ( mapAccumL )
-import SrcLoc ( noSrcLoc )
+import UniqSupply ( UniqSupply, splitUniqSupply )
import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
import Bag
import Maybes
\end{code}
\begin{code}
-core2core :: [CoreToDo] -- spec of what core-to-core passes to do
- -> FAST_STRING -- module name (profiling only)
- -> UniqSupply -- a name supply
- -> [TyCon] -- local data tycons and tycon specialisations
- -> [CoreBinding] -- input...
- -> IO [CoreBinding] -- results: program
-
-core2core core_todos module_name us local_tycons binds
- = -- Do the main business
- foldl_mn do_core_pass
- (binds, us, zeroSimplCount)
- core_todos
- >>= \ (processed_binds, us', simpl_stats) ->
+core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
+ -> FAST_STRING -- Module name (profiling only)
+ -> UniqSupply -- A name supply
+ -> [CoreBind] -- Input
+ -> IO [CoreBind] -- Result
+
+core2core core_todos module_name us binds
+ = do
+ -- Do the main business
+ processed_binds <- doCorePasses us binds core_todos
-- Do the final tidy-up
- let
- final_binds = tidyCorePgm module_name processed_binds
- in
- lintCoreBindings "TidyCorePgm" True final_binds >>
+ final_binds <- tidyCorePgm module_name processed_binds
+ -- Return results
+ return final_binds
+
+doCorePasses us binds []
+ = return binds
+
+doCorePasses us binds (to_do : to_dos)
+ = do
+ let (us1, us2) = splitUniqSupply us
+ binds1 <- doCorePass us1 binds to_do
+ doCorePasses us2 binds1 to_dos
+
+doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm sw_chkr us binds
+doCorePass us binds CoreLiberateCase = _scc_ "LiberateCase" liberateCase binds
+doCorePass us binds CoreDoFloatInwards = _scc_ "FloatInwards" floatInwards binds
+doCorePass us binds CoreDoFullLaziness = _scc_ "CoreFloating" floatOutwards us binds
+doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs us binds
+doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saWwTopBinds us binds
+doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds
+\end{code}
- -- Dump output
- dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core)
- "Core transformations"
- (pprCoreBindings final_binds) >>
- -- Report statistics
- doIfSet opt_D_simplifier_stats
- (hPutStr stderr ("\nSimplifier Stats:\n") >>
- hPutStr stderr (showSimplCount simpl_stats) >>
- hPutStr stderr "\n") >>
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
- -- Return results
- return final_binds
+\begin{code}
+simplifyPgm :: (SimplifierSwitch -> SwitchResult)
+ -> UniqSupply
+ -> [CoreBind] -- Input
+ -> IO [CoreBind] -- New bindings
+
+simplifyPgm sw_chkr us binds
+ = do {
+ beginPass "Simplify";
+
+ (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
+
+ dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
+ (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
+ text "",
+ pprSimplCount counts]);
+
+ endPass "Simplify"
+ (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
+ binds'
+ }
where
- --------------
- do_core_pass info@(binds, us, simpl_stats) to_do =
- case (splitUniqSupply us) of
- (us1,us2) ->
- case to_do of
- CoreDoSimplify simpl_sw_chkr
- -> _scc_ "CoreSimplify"
- begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
- then " (foldr/build)" else "") >>
- case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
- (p, it_cnt, simpl_stats2)
- -> end_pass us2 p simpl_stats2
- ("Simplify (" ++ show it_cnt ++ ")"
- ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
- then " foldr/build" else "")
-
- CoreDoFoldrBuildWorkerWrapper
- -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
- begin_pass "FBWW" >>
- case (mkFoldrBuildWW us1 binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "FBWW" }
-
- CoreDoFoldrBuildWWAnal
- -> _scc_ "CoreDoFoldrBuildWWAnal"
- begin_pass "AnalFBWW" >>
- case (analFBWW binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "AnalFBWW" }
-
- CoreLiberateCase
- -> _scc_ "LiberateCase"
- begin_pass "LiberateCase" >>
- case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "LiberateCase" }
-
- CoreDoFloatInwards
- -> _scc_ "FloatInwards"
- begin_pass "FloatIn" >>
- case (floatInwards binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "FloatIn" }
-
- CoreDoFullLaziness
- -> _scc_ "CoreFloating"
- begin_pass "FloatOut" >>
- case (floatOutwards us1 binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "FloatOut" }
-
- CoreDoStaticArgs
- -> _scc_ "CoreStaticArgs"
- begin_pass "StaticArgs" >>
- case (doStaticArgs binds us1) of { binds2 ->
- end_pass us2 binds2 simpl_stats "StaticArgs" }
- -- Binds really should be dependency-analysed for static-
- -- arg transformation... Not to worry, they probably are.
- -- (I don't think it *dies* if they aren't [WDP 94/04/15])
-
- CoreDoStrictness
- -> _scc_ "CoreStranal"
- begin_pass "StrAnal" >>
- case (saWwTopBinds us1 binds) of { binds2 ->
- end_pass us2 binds2 simpl_stats "StrAnal" }
-
- CoreDoSpecialising
- -> _scc_ "Specialise"
- begin_pass "Specialise" >>
- case (specProgram us1 binds) of { p ->
- end_pass us2 p simpl_stats "Specialise"
- }
-
- CoreDoPrintCore -- print result of last pass
- -> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
- (pprCoreBindings binds) >>
- return (binds, us1, simpl_stats)
-
- -------------------------------------------------
-
- begin_pass what
- = if opt_D_show_passes
- then hPutStr stderr ("*** Core2Core: "++what++"\n")
- else return ()
-
- end_pass us2 binds2
- simpl_stats2 what
- = -- Report verbosely, if required
- dumpIfSet opt_D_verbose_core2core what
- (pprCoreBindings binds2) >>
-
- lintCoreBindings what True {- spec_done -} binds2 >>
- -- The spec_done flag tells the linter to
- -- complain about unboxed let-bindings
- -- But we're not specialising unboxed types any more,
- -- so its irrelevant.
-
- return
- (binds2, -- processed binds, possibly run thru CoreLint
- us2, -- UniqSupply for the next guy
- simpl_stats2 -- accumulated simplifier stats
- )
-
-
--- here so it can be inlined...
-foldl_mn f z [] = return z
-foldl_mn f z (x:xs) = f z x >>= \ zz ->
- foldl_mn f zz xs
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+ simpl_switch_is_on = switchIsOn sw_chkr
+
+ core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
+ | otherwise = empty
+
+ iteration us iteration_no counts binds
+ = do {
+ -- Occurrence analysis
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
+ dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
+ (pprCoreBindings tagged_binds);
+
+ -- Simplify
+ let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
+ all_counts = counts `plusSimplCount` counts'
+ } ;
+
+ -- Stop if nothing happened; don't dump output
+ if isZeroSimplCount counts' then
+ return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+ else do {
+
+ -- Dump the result of this iteration
+ dumpIfSet opt_D_dump_simpl_iterations
+ ("Simplifier iteration " ++ show iteration_no
+ ++ " out of " ++ show max_iterations)
+ (vcat[pprSimplCount counts',
+ text "",
+ core_iter_dump binds']) ;
+
+ -- Stop if we've run out of iterations
+ if iteration_no == max_iterations then
+ do {
+ if max_iterations > 1 then
+ hPutStr stderr ("NOTE: Simplifier still going after " ++
+ show max_iterations ++
+ " iterations; bailing out.\n")
+ else return ();
+
+ return ("Simplifier baled out", iteration_no, all_counts, binds')
+ }
+
+ -- Else loop
+ else iteration us2 (iteration_no + 1) all_counts binds'
+ } }
+ where
+ (us1, us2) = splitUniqSupply us
+
+
+simplTopBinds [] = returnSmpl []
+simplTopBinds (bind1 : binds) = (simplBind bind1 $
+ simplTopBinds binds) `thenSmpl` \ (binds1', binds') ->
+ returnSmpl (binds1' ++ binds')
\end{code}
-
%************************************************************************
%* *
\subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
time
3. Make the representation of NoRep literals explicit, and
- float their bindings to the top level
-
+ float their bindings to the top level. We only do the floating
+ part for NoRep lits inside a lambda (else no gain). We need to
+ take care with let x = "foo" in e
+ that we don't end up with a silly binding
+ let x = y in e
+ with a floated "foo". What a bore.
+
4. Convert
case x of {...; x' -> ...x'...}
==>
case x of {...; _ -> ...x... }
See notes in SimplCase.lhs, near simplDefault for the reasoning here.
-5. *Mangle* cases involving fork# and par# in the discriminant. The
- original templates for these primops (see @PrelVals.lhs@) constructed
- case expressions with boolean results solely to fool the strictness
- analyzer, the simplifier, and anyone else who might want to fool with
- the evaluation order. At this point in the compiler our evaluation
- order is safe. Therefore, we convert expressions of the form:
+5. *Mangle* cases involving par# in the discriminant. The unfolding
+ for par in PrelConc.lhs include case expressions with integer
+ results solely to fool the strictness analyzer, the simplifier,
+ and anyone else who might want to fool with the evaluation order.
+ At this point in the compiler our evaluation order is safe.
+ Therefore, we convert expressions of the form:
case par# e of
- True -> rhs
- False -> parError#
+ 0# -> rhs
+ _ -> parError#
==>
case par# e of
_ -> rhs
-6. Eliminate polymorphic case expressions. We can't generate code for them yet.
+ fork# isn't handled like this - it's an explicit IO operation now.
+ The reason is that fork# returns a ThreadId#, which gets in the
+ way of the above scheme. And anyway, IO is the only guaranteed
+ way to enforce ordering --SDM.
+
+6. Mangle cases involving seq# in the discriminant. Up to this
+ point, seq# will appear like this:
+
+ case seq# e of
+ 0# -> seqError#
+ _ -> ...
+
+ where the 0# branch is purely to bamboozle the strictness analyser
+ (see case 5 above). This code comes from an unfolding for 'seq'
+ in Prelude.hs. We translate this into
+
+ case e of
+ _ -> ...
+
+ Now that the evaluation order is safe. The code generator knows
+ how to push a seq frame on the stack if 'e' is of function type,
+ or is polymorphic.
+
+
+7. Do eta reduction for lambda abstractions appearing in:
+ - the RHS of case alternatives
+ - the body of a let
+
+ These will otherwise turn into local bindings during Core->STG;
+ better to nuke them if possible. (In general the simplifier does
+ eta expansion not eta reduction, up to this point.)
-7. Do eta reduction for lambda abstractions appearing in:
- - the RHS of case alternatives
- - the body of a let
- These will otherwise turn into local bindings during Core->STG; better to
- nuke them if possible. (In general the simplifier does eta expansion not
- eta reduction, up to this point.)
+9. Give all binders a nice print-name. Their uniques aren't changed;
+ rather we give them lexically unique occ-names, so that we can
+ safely print the OccNae only in the interface file. [Bad idea to
+ change the uniques, because the code generator makes global labels
+ from the uniques for local thunks etc.]
-8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
- for multi-constructor types.
-9. Give all binders a nice print-name. Their uniques aren't changed; rather we give
- them lexically unique occ-names, so that we can safely print the OccNae only
- in the interface file. [Bad idea to change the uniques, because the code
- generator makes global labels from the uniques for local thunks etc.]
+Special case
+~~~~~~~~~~~~
+NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
+things, and we need local Ids for non-floated stuff):
+ Don't float stuff out of a binder that's marked as a bottoming Id.
+ Reason: it doesn't do any good, and creates more CAFs that increase
+ the size of SRTs.
+
+eg.
+
+ f = error "string"
+
+is translated to
+
+ f' = unpackCString# "string"
+ f = error f'
+
+hence f' and f become CAFs. Instead, the special case for
+tidyTopBinding below makes sure this comes out as
+
+ f = let f' = unpackCString# "string" in error f'
+
+and we can safely ignore f as a CAF, since it can only ever be entered once.
\begin{code}
-tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
+tidyCorePgm :: Module -> [CoreBind] -> IO [CoreBind]
tidyCorePgm mod binds_in
- = initTM mod nullIdEnv $
- tidyTopBindings binds_in `thenTM` \ binds ->
- returnTM (bagToList binds)
+ = do
+ beginPass "Tidy Core"
+
+ let binds_out = bagToList (initTM mod (tidyTopBindings binds_in))
+
+ endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
\end{code}
Top level bindings
= tidyTopBinding b $
tidyTopBindings bs
-tidyTopBinding :: CoreBinding
- -> TopTidyM (Bag CoreBinding)
- -> TopTidyM (Bag CoreBinding)
+tidyTopBinding :: CoreBind
+ -> TopTidyM (Bag CoreBind)
+ -> TopTidyM (Bag CoreBind)
tidyTopBinding (NonRec bndr rhs) thing_inside
= initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
- mungeTopBinder bndr $ \ bndr' ->
+ tidyTopBinder bndr $ \ bndr' ->
thing_inside `thenTM` \ binds ->
- returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
+ let
+ this_bind {- | isBottomingId bndr
+ = unitBag (NonRec bndr' (foldrBag Let rhs' floats))
+ | otherwise -}
+ = floats `snocBag` NonRec bndr' rhs'
+ in
+ returnTM (this_bind `unionBags` binds)
tidyTopBinding (Rec pairs) thing_inside
- = mungeTopBinders binders $ \ binders' ->
+ = tidyTopBinders binders $ \ binders' ->
initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
thing_inside `thenTM` \ binds_inside ->
returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
(binders, rhss) = unzip pairs
\end{code}
+\begin{code}
+tidyTopBinder :: Id -> (Id -> TopTidyM (Bag CoreBind)) -> TopTidyM (Bag CoreBind)
+tidyTopBinder id thing_inside
+ = mungeTopBndr id $ \ id' ->
+ let
+ spec_items = specEnvToList (getIdSpecialisation id')
+ in
+ if null spec_items then
+
+ -- Common case, no specialisations to tidy
+ thing_inside id'
+ else
+ -- Oh well, tidy those specialisations
+ initNestedTM (mapTM tidySpecItem spec_items) `thenTM` \ (spec_items', floats) ->
+ let
+ id'' = setIdSpecialisation id' (specEnvFromList spec_items')
+ in
+ extendEnvTM id (Var id'') $
+ thing_inside id'' `thenTM` \ binds ->
+ returnTM (floats `unionBags` binds)
+
+tidyTopBinders [] k = k []
+tidyTopBinders (b:bs) k = tidyTopBinder b $ \ b' ->
+ tidyTopBinders bs $ \ bs' ->
+ k (b' : bs')
+
+tidySpecItem (tyvars, tys, rhs)
+ = newBndrs tyvars $ \ tyvars' ->
+ mapTM tidyTy tys `thenTM` \ tys' ->
+ tidyCoreExpr rhs `thenTM` \ rhs' ->
+ returnTM (tyvars', tys', rhs')
+\end{code}
Expressions
~~~~~~~~~~~
\begin{code}
-tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
- returnTM (Var v')
+tidyCoreExpr (Var v) = lookupId v
-tidyCoreExpr (Lit lit)
- = litToRep lit `thenTM` \ (_, lit_expr) ->
- returnTM lit_expr
+tidyCoreExpr (Type ty)
+ = tidyTy ty `thenTM` \ ty' ->
+ returnTM (Type ty')
tidyCoreExpr (App fun arg)
= tidyCoreExpr fun `thenTM` \ fun' ->
- tidyCoreArg arg `thenTM` \ arg' ->
+ tidyCoreExpr arg `thenTM` \ arg' ->
returnTM (App fun' arg')
+tidyCoreExpr (Con (Literal lit) args)
+ = ASSERT( null args )
+ litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
+ getInsideLambda `thenTM` \ in_lam ->
+ if in_lam && not (exprIsTrivial lit_expr) then
+ -- It must have been a no-rep literal with a
+ -- non-trivial representation; and we're inside a lambda;
+ -- so float it to the top
+ addTopFloat lit_ty lit_expr `thenTM` \ v ->
+ returnTM (Var v)
+ else
+ returnTM lit_expr
+
tidyCoreExpr (Con con args)
- = mapTM tidyCoreArg args `thenTM` \ args' ->
+ = mapTM tidyCoreExpr args `thenTM` \ args' ->
returnTM (Con con args')
-tidyCoreExpr (Prim prim args)
- = tidyPrimOp prim `thenTM` \ prim' ->
- mapTM tidyCoreArg args `thenTM` \ args' ->
- returnTM (Prim prim' args')
-
-tidyCoreExpr (Lam (ValBinder v) body)
- = newId v $ \ v' ->
+tidyCoreExpr (Lam bndr body)
+ = newBndr bndr $ \ bndr' ->
+ insideLambda bndr $
tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Lam (ValBinder v') body')
-
-tidyCoreExpr (Lam (TyBinder tv) body)
- = newTyVar tv $ \ tv' ->
- tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Lam (TyBinder tv') body')
-
- -- Try for let-to-case (see notes in Simplify.lhs for why
- -- some let-to-case stuff is deferred to now).
-tidyCoreExpr (Let (NonRec bndr rhs) body)
- | willBeDemanded (getIdDemandInfo bndr) &&
- not rhs_is_whnf && -- Don't do it if RHS is already in WHNF
- typeOkForCase (idType bndr)
- = ASSERT( not (isUnpointedType (idType bndr)) )
- tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
- where
- rhs_is_whnf = case mkFormSummary rhs of
- VarForm -> True
- ValueForm -> True
- other -> False
+ returnTM (Lam bndr' body')
tidyCoreExpr (Let (NonRec bndr rhs) body)
= tidyCoreExpr rhs `thenTM` \ rhs' ->
- newId bndr $ \ bndr' ->
- tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (Let (NonRec bndr' rhs') body')
+ tidyBindNonRec bndr rhs' body
tidyCoreExpr (Let (Rec pairs) body)
- = newIds bndrs $ \ bndrs' ->
+ = newBndrs bndrs $ \ bndrs' ->
mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
tidyCoreExprEta body `thenTM` \ body' ->
returnTM (Let (Rec (bndrs' `zip` rhss')) body')
= tidyCoreExprEta body `thenTM` \ body' ->
returnTM (Note note body')
--- Wierd case for par, seq, fork etc. See notes above.
-tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
- | funnyParallelOp op
+-- seq#: see notes above.
+tidyCoreExpr (Case scrut@(Con (PrimOp SeqOp) [Type _, e]) bndr alts)
+ = tidyCoreExpr e `thenTM` \ e' ->
+ newBndr bndr $ \ bndr' ->
+ let new_bndr = setIdType bndr' (coreExprType e') in
+ tidyCoreExprEta default_rhs `thenTM` \ rhs' ->
+ returnTM (Case e' new_bndr [(DEFAULT,[],rhs')])
+ where
+ (other_alts, maybe_default) = findDefault alts
+ Just default_rhs = maybe_default
+
+-- par#: see notes above.
+tidyCoreExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
+ | funnyParallelOp op && maybeToBool maybe_default
= tidyCoreExpr scrut `thenTM` \ scrut' ->
- newId binder $ \ binder' ->
- tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
-
--- Eliminate polymorphic case, for which we can't generate code just yet
-tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
- | not (typeOkForCase (idType deflt_bndr))
- = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
- case scrut of
- Var v -> lookupId v `thenTM` \ v' ->
- extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
- other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
-
-tidyCoreExpr (Case scrut alts)
+ newBndr bndr $ \ bndr' ->
+ tidyCoreExprEta default_rhs `thenTM` \ rhs' ->
+ returnTM (Case scrut' bndr' [(DEFAULT,[],rhs')])
+ where
+ (other_alts, maybe_default) = findDefault alts
+ Just default_rhs = maybe_default
+
+tidyCoreExpr (Case scrut case_bndr alts)
= tidyCoreExpr scrut `thenTM` \ scrut' ->
- tidy_alts scrut' alts `thenTM` \ alts' ->
- returnTM (Case scrut' alts')
+ newBndr case_bndr $ \ case_bndr' ->
+ mapTM tidy_alt alts `thenTM` \ alts' ->
+ returnTM (Case scrut' case_bndr' alts')
where
- tidy_alts scrut (AlgAlts alts deflt)
- = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
- tidy_deflt scrut deflt `thenTM` \ deflt' ->
- returnTM (AlgAlts alts' deflt')
-
- tidy_alts scrut (PrimAlts alts deflt)
- = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
- tidy_deflt scrut deflt `thenTM` \ deflt' ->
- returnTM (PrimAlts alts' deflt')
-
- tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
- tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (con, bndrs', rhs')
-
- tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (lit,rhs')
-
- -- We convert case x of {...; x' -> ...x'...}
- -- to
- -- case x of {...; _ -> ...x... }
- --
- -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
- -- It's quite easily done: simply extend the environment to bind the
- -- default binder to the scrutinee.
-
- tidy_deflt scrut NoDefault = returnTM NoDefault
- tidy_deflt scrut (BindDefault bndr rhs)
- = newId bndr $ \ bndr' ->
- extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
- returnTM (BindDefault bndr' rhs')
- where
- extend_env = case scrut of
- Var v -> extendEnvTM bndr v
- other -> \x -> x
+ tidy_alt (con,bndrs,rhs) = newBndrs bndrs $ \ bndrs' ->
+ tidyCoreExprEta rhs `thenTM` \ rhs' ->
+ returnTM (con, bndrs', rhs')
tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
returnTM (etaCoreExpr e')
-\end{code}
-
-Arguments
-~~~~~~~~~
-\begin{code}
-tidyCoreArg :: CoreArg -> NestTidyM CoreArg
-
-tidyCoreArg (VarArg v)
- = lookupId v `thenTM` \ v' ->
- returnTM (VarArg v')
-
-tidyCoreArg (LitArg lit)
- = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
- case lit_expr of
- Var v -> returnTM (VarArg v)
- Lit l -> returnTM (LitArg l)
- other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
- returnTM (VarArg v)
-
-tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
- returnTM (TyArg ty')
-\end{code}
-\begin{code}
-tidyPrimOp (CCallOp fn casm gc cconv tys ty)
- = mapTM tidyTy tys `thenTM` \ tys' ->
- tidyTy ty `thenTM` \ ty' ->
- returnTM (CCallOp fn casm gc cconv tys' ty')
+tidyBindNonRec bndr val' body
+ | exprIsTrivial val'
+ = extendEnvTM bndr val' (tidyCoreExpr body)
-tidyPrimOp other_prim_op = returnTM other_prim_op
-\end{code}
+ | otherwise
+ = newBndr bndr $ \ bndr' ->
+ tidyCoreExpr body `thenTM` \ body' ->
+ returnTM (Let (NonRec bndr' val') body')
+\end{code}
%************************************************************************
litToRep :: Literal -> NestTidyM (Type, CoreExpr)
-litToRep (NoRepStr s)
- = returnTM (stringTy, rhs)
+litToRep (NoRepStr s ty)
+ = returnTM (ty, rhs)
where
rhs = if (any is_NUL (_UNPK_ s))
then -- Must cater for NULs in literal string
- mkGenApp (Var unpackCString2Id)
- [LitArg (MachStr s),
- LitArg (mkMachInt_safe (toInteger (_LENGTH_ s)))]
+ mkApps (Var unpackCString2Id)
+ [mkLit (MachStr s),
+ mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
else -- No NULs in the string
- App (Var unpackCStringId) (LitArg (MachStr s))
+ App (Var unpackCStringId) (mkLit (MachStr s))
is_NUL c = c == '\0'
\end{code}
litToRep (NoRepInteger i integer_ty)
= returnTM (integer_ty, rhs)
where
- rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
- | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
+ rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
+ | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
| i == 2 = Var integerPlusTwoId
| i == (-1) = Var integerMinusOneId
| i > tARGET_MIN_INT && -- Small enough, so start from an Int
i < tARGET_MAX_INT
- = Prim Int2IntegerOp [LitArg (mkMachInt (fromInteger i))]
+ = App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
| otherwise -- Big, so start from a string
- = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
+ = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
litToRep (NoRepRational r rational_ty)
- = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
- tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
- returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
+ = tidyCoreExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
+ tidyCoreExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
+ returnTM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
where
(ratio_data_con, integer_ty)
= case (splitAlgTyConApp_maybe rational_ty) of
Just (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
+ -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
(con, i_ty)
_ -> (panic "ratio_data_con", panic "integer_ty")
-litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
+litToRep other_lit = returnTM (literalType other_lit, mkLit other_lit)
\end{code}
\begin{code}
-funnyParallelOp SeqOp = True
funnyParallelOp ParOp = True
-funnyParallelOp ForkOp = True
funnyParallelOp _ = False
\end{code}
\begin{code}
type TidyM a state = Module
- -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
+ -> Bool -- True <=> inside a *value* lambda
+ -> (TyVarEnv Type, IdEnv CoreExpr, IdOrTyVarSet)
+ -- Substitution and in-scope binders
-> state
-> (a, state)
type TopTidyM a = TidyM a Unique
type NestTidyM a = TidyM a (Unique, -- Global names
Unique, -- Local names
- Bag CoreBinding) -- Floats
+ Bag CoreBind) -- Floats
(initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
-initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
-initTM mod env m
- = case m mod env initialTopTidyUnique of
+initTM :: Module -> TopTidyM a -> a
+initTM mod m
+ = case m mod False {- not inside lambda -} empty_env initialTopTidyUnique of
(result, _) -> result
+ where
+ empty_env = (emptyVarEnv, emptyVarEnv, emptyVarSet)
-initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
-initNestedTM m mod env global_us
- = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
+initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBind)
+initNestedTM m mod in_lam env global_us
+ = case m mod in_lam env (global_us, initialNestedTidyUnique, emptyBag) of
(result, (global_us', _, floats)) -> ((result, floats), global_us')
-returnTM v mod env usf = (v, usf)
-thenTM m k mod env usf = case m mod env usf of
- (r, usf') -> k r mod env usf'
+returnTM v mod in_lam env usf = (v, usf)
+thenTM m k mod in_lam env usf = case m mod in_lam env usf of
+ (r, usf') -> k r mod in_lam env usf'
mapTM f [] = returnTM []
-mapTM f (x:xs) = f x `thenTM` \ r ->
+mapTM f (x:xs) = f x `thenTM` \ r ->
mapTM f xs `thenTM` \ rs ->
returnTM (r:rs)
-\end{code}
+insideLambda :: CoreBndr -> NestTidyM a -> NestTidyM a
+insideLambda bndr m mod in_lam env usf | isId bndr = m mod True env usf
+ | otherwise = m mod in_lam env usf
-\begin{code}
--- Need to extend the environment when we munge a binder, so that occurrences
--- of the binder will print the correct way (e.g. as a global not a local)
-mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
-mungeTopBinder id thing_inside mod env us
- = -- Give it a new print-name unless it's an exported thing
- -- setNameVisibility also does the local/global thing
- let
- (id1, us') | isExported id = (id, us)
- | otherwise
- = (setIdVisibility (Just mod) us id,
- incrUnique us)
+getInsideLambda :: NestTidyM Bool
+getInsideLambda mod in_lam env usf = (in_lam, usf)
+\end{code}
- -- Tidy the Id's SpecEnv
- spec_env = getIdSpecialisation id
- id2 | isEmptySpecEnv spec_env = id1
- | otherwise = setIdSpecialisation id1 (tidySpecEnv env spec_env)
+Need to extend the environment when we munge a binder, so that
+occurrences of the binder will print the correct way (e.g. as a global
+not a local).
- new_env = addToUFM env id (ValBinder id2)
- in
- thing_inside id2 mod new_env us'
+In cases where we don't clone the binder (because it's an exported
+id), we still zap the unfolding and inline pragma info so that
+unnecessary gumph isn't carried into the code generator. This fixes a
+nasty space leak.
-tidySpecEnv env spec_env
- = substSpecEnv
- emptyTyVarEnv -- Top level only
- (tidy_spec_rhs env)
- spec_env
+\begin{code}
+mungeTopBndr id thing_inside mod in_lam env@(ty_env, val_env, in_scope) us
+ = thing_inside id' mod in_lam (ty_env, val_env', in_scope') us'
where
- -- tidy_spec_rhs is another horrid little hacked-up function for
- -- the RHS of specialisation templates.
- -- It assumes there is no type substitution.
- --
- -- See also SimplVar.substSpecEnvRhs Urgh
- tidy_spec_rhs env (Var v) = case lookupUFM env v of
- Just (ValBinder v') -> Var v'
- Nothing -> Var v
- tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of
- Just (ValBinder v') -> VarArg v'
- Nothing -> VarArg v)
- tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg
- tidy_spec_rhs env (Lam b e) = Lam b (tidy_spec_rhs env' e)
- where
- env' = case b of
- ValBinder id -> delFromUFM env id
- TyBinder _ -> env
-
-mungeTopBinders [] k = k []
-mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
- mungeTopBinders bs $ \ bs' ->
- k (b' : bs')
+ (id', us') | isExported id = (zapSomeIdInfo id, us)
+ | otherwise = (zapSomeIdInfo (setIdVisibility (Just mod) us id),
+ incrUnique us)
+ val_env' = extendVarEnv val_env id (Var id')
+ in_scope' = extendVarSet in_scope id'
+
+zapSomeIdInfo id = id `setIdUnfolding` noUnfolding `setInlinePragma` new_ip
+ where new_ip = case getInlinePragma id of
+ ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo
+ something_else -> something_else
addTopFloat :: Type -> CoreExpr -> NestTidyM Id
-addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
+addTopFloat lit_ty lit_rhs mod in_lam env (gus, lus, floats)
= let
gus' = incrUnique gus
- lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
+ lit_local = mkSysLocal gus lit_ty
lit_id = setIdVisibility (Just mod) gus lit_local
in
(lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
-lookupId :: Id -> TidyM Id state
-lookupId v mod env usf
- = case lookupUFM env v of
- Nothing -> (v, usf)
- Just (ValBinder v') -> (v', usf)
+lookupId :: Id -> TidyM CoreExpr state
+lookupId v mod in_lam (_, val_env, _) usf
+ = case lookupVarEnv val_env v of
+ Nothing -> (Var v, usf)
+ Just e -> (e, usf)
-extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
-extendEnvTM v v' m mod env usf
- = m mod (addOneToIdEnv env v (ValBinder v')) usf
+extendEnvTM :: Id -> CoreExpr -> (TidyM a state) -> TidyM a state
+extendEnvTM v e m mod in_lam (ty_env, val_env, in_scope) usf
+ = m mod in_lam (ty_env, extendVarEnv val_env v e, in_scope) usf
\end{code}
Making new local binders
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-newId id thing_inside mod env (gus, local_uniq, floats)
+newBndr tyvar thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
+ | isTyVar tyvar
+ = let
+ local_uniq' = incrUnique local_uniq
+ tyvar' = setTyVarName tyvar (mkSysLocalName local_uniq)
+ ty_env' = extendVarEnv ty_env tyvar (mkTyVarTy tyvar')
+ in_scope' = extendVarSet in_scope tyvar'
+ in
+ thing_inside tyvar' mod in_lam (ty_env', val_env, in_scope') (gus, local_uniq', floats)
+
+newBndr id thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
+ | isId id
= let
-- Give the Id a fresh print-name, *and* rename its type
local_uniq' = incrUnique local_uniq
- name' = setNameVisibility Nothing local_uniq (getName id)
- ty' = nmbr_ty env local_uniq' (idType id)
+ name' = mkSysLocalName local_uniq
+ ty' = nmbrType ty_env local_uniq' (idType id)
+
id' = mkUserId name' ty'
- -- NB: This throws away the IdInfo of the Id, which we
- -- no longer need. That means we don't need to
- -- run over it with env, nor renumber it
- --
- -- NB: the Id's unique remains unchanged; it's only
- -- its print name that is affected by local_uniq
-
- env' = addToUFM env id (ValBinder id')
+ -- NB: This throws away the IdInfo of the Id, which we
+ -- no longer need. That means we don't need to
+ -- run over it with env, nor renumber it.
+
+ val_env' = extendVarEnv val_env id (Var id')
+ in_scope' = extendVarSet in_scope id'
in
- thing_inside id' mod env' (gus, local_uniq', floats)
+ thing_inside id' mod in_lam (ty_env, val_env', in_scope') (gus, local_uniq', floats)
-newIds [] thing_inside
+newBndrs [] thing_inside
= thing_inside []
-newIds (bndr:bndrs) thing_inside
- = newId bndr $ \ bndr' ->
- newIds bndrs $ \ bndrs' ->
+newBndrs (bndr:bndrs) thing_inside
+ = newBndr bndr $ \ bndr' ->
+ newBndrs bndrs $ \ bndrs' ->
thing_inside (bndr' : bndrs')
-
-
-newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
- = let
- local_uniq' = incrUnique local_uniq
- tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
- env' = addToUFM env tyvar (TyBinder tyvar')
- in
- thing_inside tyvar' mod env' (gus, local_uniq', floats)
\end{code}
Re-numbering types
~~~~~~~~~~~~~~~~~~
\begin{code}
-tidyTy ty mod env usf@(_, local_uniq, _)
- = (nmbr_ty env local_uniq ty, usf)
+tidyTy ty mod in_lam (ty_env, val_env, in_scope) usf@(_, local_uniq, _)
+ = (nmbrType ty_env local_uniq ty, usf)
-- We can use local_uniq as a base for renaming forall'd variables
-- in the type; we don't need to know how many are consumed.
-
--- This little impedance-matcher calls nmbrType with the right arguments
-nmbr_ty env uniq ty
- = nmbrType tv_env uniq ty
- where
- tv_env :: TyVar -> TyVar
- tv_env tyvar = case lookupUFM env tyvar of
- Just (TyBinder tyvar') -> tyvar'
- other -> tyvar
\end{code}
+-- Get rid of this function when we move to the new code generator.
+\begin{code}
+typeOkForCase :: Type -> Bool
+typeOkForCase ty
+ | isUnLiftedType ty -- Primitive case
+ = True
+
+ | otherwise
+ = case (splitAlgTyConApp_maybe ty) of
+ Just (tycon, ty_args, []) -> False
+ Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
+ other -> False
+ -- Null data cons => type is abstract, which code gen can't
+ -- currently handle. (ToDo: when return-in-heap is universal we
+ -- don't need to worry about this.)
+\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1996
-%
-\section[SimplEnv]{Environment stuff for the simplifier}
-
-\begin{code}
-module SimplEnv (
- nullSimplEnv,
- getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
- emptySubstEnvs, getSubstEnvs,
-
- bindTyVar, bindTyVars, simplTy,
-
- lookupIdSubst, lookupOutIdEnv,
-
- bindIdToAtom, bindIdToExpr,
-
- markDangerousOccs,
- lookupUnfolding, isEvaluated,
- extendEnvGivenBinding, extendEnvGivenNewRhs,
- extendEnvGivenUnfolding,
-
- lookForConstructor,
-
- getSwitchChecker, switchIsSet, getSimplIntSwitch,
- switchOffInlining, setCaseScrutinee,
-
- setEnclosingCC, getEnclosingCC,
-
- -- Types
- SwitchChecker,
- SimplEnv, SubstEnvs,
- UnfoldConApp,
- SubstInfo(..),
-
- InId, InBinder, InBinding, InType,
- OutId, OutBinder, OutBinding, OutType,
-
- InExpr, InAlts, InDefault, InArg,
- OutExpr, OutAlts, OutDefault, OutArg
- ) where
-
-#include "HsVersions.h"
-
-import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
- isOneFunOcc,
- BinderInfo
- )
-import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
- SimplifierSwitch(..), SwitchResult(..)
- )
-import CoreSyn
-import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
- okToInline,
- Unfolding(..), FormSummary(..),
- calcUnfoldingGuidance )
-import CoreUtils ( coreExprCc )
-import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre,
- costsAreSubsumed, noCostCentreAttached, subsumedCosts,
- currentOrSubsumedCosts
- )
-import FiniteMap -- lots of things
-import Id ( IdEnv, IdSet, Id,
- getInlinePragma,
- nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
- addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
- idMustBeINLINEd
- )
-import Literal ( Literal )
-import Maybes ( expectJust )
-import OccurAnal ( occurAnalyseExpr )
-import PprCore -- various instances
-import Type ( instantiateTy, Type )
-import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
- TyVarSet, emptyTyVarSet,
- TyVar
- )
-import Unique ( Unique{-instance Outputable-}, Uniquable(..) )
-import UniqFM ( addToUFM, addToUFM_C, ufmToList, mapUFM )
-import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Simplify-types]{Type declarations}
-%* *
-%************************************************************************
-
-\begin{code}
-type InId = Id -- Not yet cloned
-type InBinder = (InId, BinderInfo)
-type InType = Type -- Ditto
-type InBinding = SimplifiableCoreBinding
-type InExpr = SimplifiableCoreExpr
-type InAlts = SimplifiableCoreCaseAlts
-type InDefault = SimplifiableCoreCaseDefault
-type InArg = SimplifiableCoreArg
-
-type OutId = Id -- Cloned
-type OutBinder = Id
-type OutType = Type -- Cloned
-type OutBinding = CoreBinding
-type OutExpr = CoreExpr
-type OutAlts = CoreCaseAlts
-type OutDefault = CoreCaseDefault
-type OutArg = CoreArg
-
-type SwitchChecker = SimplifierSwitch -> SwitchResult
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @SimplEnv@ type}
-%* *
-%************************************************************************
-
-
-INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
-this? WDP 94/06) This allows us to neglect keeping everything paired
-with its static environment.
-
-The environment contains bindings for all
- {\em in-scope,}
- {\em locally-defined}
-things.
-
-For such things, any unfolding is found in the environment, not in the
-Id. Unfoldings in the Id itself are used only for imported things
-(otherwise we get trouble because we have to simplify the unfoldings
-inside the Ids, etc.).
-
-\begin{code}
-data SimplEnv
- = SimplEnv
- SwitchChecker
- CostCentre -- The enclosing cost-centre (when profiling)
- SimplTypeEnv -- Maps old type variables to new clones
- SimplValEnv -- Maps locally-bound Ids to new clones
- ConAppMap -- Maps constructor applications back to OutIds
-
-type SimplTypeEnv = (TyVarSet, -- In-scope tyvars (in result)
- TyVarEnv Type) -- Type substitution
- -- If t is in the in-scope set, it certainly won't be
- -- in the domain of the substitution, and vice versa
-
-type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope
- -- Ids (in result), range gives info about them
- IdEnv SubstInfo) -- Id substitution
- -- The first envt tells what Ids are in scope; it
- -- corresponds to the TyVarSet in SimplTypeEnv
-
- -- The substitution usually maps an Id to its clone,
- -- but if the orig defn is a let-binding, and
- -- the RHS of the let simplifies to an atom,
- -- we just add the binding to the substitution and elide the let.
- --
- -- Ids in the domain of the substitution are *not* in scope;
- -- they *must* be substituted for the given OutArg
-
-type SubstEnvs = (TyVarEnv Type, IdEnv SubstInfo)
-
-data SubstInfo
- = SubstVar OutId -- The Id maps to an already-substituted atom
- | SubstLit Literal -- ...ditto literal
- | SubstExpr -- Id maps to an as-yet-unsimplified expression
- (TyVarEnv Type) -- ...hence we need to capture the substitution
- (IdEnv SubstInfo) -- environments too
- SimplifiableCoreExpr
-
-type StuffAboutId = (OutId, -- Always has the same unique as the
- -- Id that maps to it; but may have better
- -- IdInfo, and a correctly-substituted type,
- -- than the occurrences of the Id. So use
- -- this to replace occurrences
-
- BinderInfo, -- How it occurs
- -- We keep this info so we can modify it when
- -- something changes.
-
- Unfolding) -- Info about what it is bound to
-\end{code}
-
-
-\begin{code}
-nullSimplEnv :: SwitchChecker -> SimplEnv
-
-nullSimplEnv sw_chkr
- = SimplEnv sw_chkr subsumedCosts
- (emptyTyVarSet, emptyTyVarEnv)
- (nullIdEnv, nullIdEnv)
- nullConApps
-
- -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
- -- for the rhs of top level defs is "OST_CENTRE". Consider
- -- f = \x -> e
- -- g = \y -> let v = f y in scc "x" (v ...)
- -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
- -- want to inline "v" since its CC is dynamically determined.
-
-
-getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv)
-getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env)
-
-setTyEnv :: SimplEnv -> SimplTypeEnv -> SimplEnv
-setTyEnv (SimplEnv chkr encl_cc _ in_id_env con_apps) ty_env
- = SimplEnv chkr encl_cc ty_env in_id_env con_apps
-
-setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv
-setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env
- = SimplEnv chkr encl_cc ty_env id_env con_apps
-
-getSubstEnvs :: SimplEnv -> SubstEnvs
-getSubstEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) = (ty_subst, id_subst)
-
-emptySubstEnvs :: SubstEnvs
-emptySubstEnvs = (emptyTyVarEnv, nullIdEnv)
-
-setSubstEnvs :: SimplEnv -> SubstEnvs -> SimplEnv
-setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
- (ty_subst, id_subst)
- = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
-
-combineEnvs :: SimplEnv -- Get substitution from here
- -> SimplEnv -- Get in-scope info from here
- -> SimplEnv
-combineEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _)
- (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
- = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
-
-zapSubstEnvs :: SimplEnv -> SimplEnv
-zapSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
- = SimplEnv chkr encl_cc (in_scope_tyvars, emptyTyVarEnv) (in_scope_ids, nullIdEnv) con_apps
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Command-line switches}
-%* *
-%************************************************************************
-
-\begin{code}
-getSwitchChecker :: SimplEnv -> SwitchChecker
-getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
-
-switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-switchIsSet (SimplEnv chkr _ _ _ _) switch
- = switchIsOn chkr switch
-
-getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
-getSimplIntSwitch chkr switch
- = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-
- -- Crude, but simple
-setCaseScrutinee :: SimplEnv -> SimplEnv
-setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps)
- = SimplEnv chkr' encl_cc ty_env id_env con_apps
- where
- chkr' SimplCaseScrutinee = SwBool True
- chkr' other = chkr other
-\end{code}
-
-@switchOffInlining@ is used to prepare the environment for simplifying
-the RHS of an Id that's marked with an INLINE pragma. It is going to
-be inlined wherever they are used, and then all the inlining will take
-effect. Meanwhile, there isn't much point in doing anything to the
-as-yet-un-INLINEd rhs. Furthermore, it's very important to switch off
-inlining! because
- (a) not doing so will inline a worker straight back into its wrapper!
-
-and (b) Consider the following example
- let f = \pq -> BIG
- in
- let g = \y -> f y y
- {-# INLINE g #-}
- in ...g...g...g...g...g...
-
- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
- and thence copied multiple times when g is inlined.
-
- Andy disagrees! Example:
- all xs = foldr (&&) True xs
- any p = all . map p {-# INLINE any #-}
-
- Problem: any won't get deforested, and so if it's exported and
- the importer doesn't use the inlining, (eg passes it as an arg)
- then we won't get deforestation at all.
- We havn't solved this problem yet!
-
-We prepare the envt by simply modifying the id_env, which has
-all the unfolding info. At one point we did it by modifying the chkr so
-that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
-simplifications happening in the body of the RHS.
-
-6/98 update:
-
-We don't prevent inlining from happening for identifiers
-that are marked as must-be-inlined. An example of where
-doing this is crucial is:
-
- class Bar a => Foo a where
- ...g....
- {-# INLINE f #-}
- f :: Foo a => a -> b
- f x = ....Foo_sc1...
-
-If `f' needs to peer inside Foo's superclass, Bar, it refers
-to the appropriate super class selector, which is marked as
-must-inlineable. We don't generate any code for a superclass
-selector, so failing to inline it in the RHS of `f' will
-leave a reference to a non-existent id, with bad consequences.
-
-\begin{code}
-switchOffInlining :: SimplEnv -> SimplEnv
-switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
- = SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps
- where
- forget (id, binder_info, rhs_info)
- | idMustBeINLINEd id = (id, binder_info, rhs_info)
- | otherwise = (id, noBinderInfo, NoUnfolding)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{The ``enclosing cost-centre''}
-%* *
-%************************************************************************
-
-\begin{code}
-setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
-
-setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc
- = SimplEnv chkr encl_cc ty_env id_env con_apps
-
-getEnclosingCC :: SimplEnv -> CostCentre
-getEnclosingCC (SimplEnv chkr encl_cc ty_env id_env con_apps) = encl_cc
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @TypeEnv@ part}
-%* *
-%************************************************************************
-
-These two "bind" functions extend the tyvar substitution.
-They don't affect what tyvars are in scope.
-
-\begin{code}
-bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv
-bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) tyvar ty
- = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
- where
- new_ty_subst = addToTyVarEnv ty_subst tyvar ty
-
-bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv
-bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) extra_subst
- = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
- where
- new_ty_subst = ty_subst `plusTyVarEnv` extra_subst
-\end{code}
-
-\begin{code}
-simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The ``Id env'' part}
-%* *
-%************************************************************************
-
-notInScope forgets that the specified binder is in scope.
-It is used when we decide to bind a let(rec) bound thing to
-an atom, *after* the Id has been added to the in-scope mapping by simplBinder.
-
-\begin{code}
-notInScope :: SimplEnv -> OutBinder -> SimplEnv
-notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) id
- = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
- where
- new_in_scope_ids = delOneFromIdEnv in_scope_ids id
-\end{code}
-
-These "bind" functions extend the Id substitution.
-
-\begin{code}
-bindIdToAtom :: SimplEnv
- -> InBinder
- -> OutArg -- Val args only, please
- -> SimplEnv
-
-bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
- (in_id,occ_info) atom
- = SimplEnv chkr encl_cc ty_env id_env' con_apps
- where
- id_env' = case atom of
- LitArg lit -> (in_scope_ids, addOneToIdEnv id_subst in_id (SubstLit lit))
- VarArg id -> (modifyOccInfo in_scope_ids (uniqueOf id) occ_info,
- addOneToIdEnv id_subst in_id (SubstVar id))
-
-bindIdToExpr :: SimplEnv
- -> InBinder
- -> SimplifiableCoreExpr
- -> SimplEnv
-
-bindIdToExpr (SimplEnv chkr encl_cc ty_env@(_, ty_subst) (in_scope_ids, id_subst) con_apps)
- (in_id,occ_info) expr
- = ASSERT( isOneFunOcc occ_info ) -- Binder occurs just once, safely, so no
- -- need to adjust occurrence info for RHS,
- -- unlike bindIdToAtom
- SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst') con_apps
- where
- id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{The @OutIdEnv@}
-%* *
-%************************************************************************
-
-\begin{code}
-lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo
-lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id
-
-lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding)
-lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id
-
-lookupUnfolding :: SimplEnv -> OutId -> Unfolding
-lookupUnfolding env id
- = case lookupOutIdEnv env id of
- Just (_,_,info) -> info
- Nothing -> NoUnfolding
-
-modifyOutEnvItem :: (OutId, BinderInfo, Unfolding) -- Existing
- -> (OutId, BinderInfo, Unfolding) -- New
- -> (OutId, BinderInfo, Unfolding)
-modifyOutEnvItem (_, _, info1) (id, occ, info2)
- = (id, occ, case (info1, info2) of
- (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
- (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
- (_, NoUnfolding) -> info1
- other -> info2)
-\end{code}
-
-
-\begin{code}
-isEvaluated :: Unfolding -> Bool
-isEvaluated (OtherLit _) = True
-isEvaluated (OtherCon _) = True
-isEvaluated (CoreUnfolding ValueForm _ expr) = True
-isEvaluated other = False
-\end{code}
-
-
-
-\begin{code}
-extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv
-extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
- out_id occ_info rhs_info
- = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
- where
- new_in_scope_ids = addToUFM in_scope_ids out_id (out_id, occ_info, rhs_info)
-\end{code}
-
-
-\begin{code}
-modifyOccInfo in_scope_ids uniq new_occ
- = modifyIdEnv_Directly modify_fn in_scope_ids uniq
- where
- modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
-
-markDangerousOccs (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) atoms
- = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
- where
- new_in_scope_ids = foldl (modifyIdEnv modify_fn) in_scope_ids [v | VarArg v <- atoms]
- modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{The @ConAppMap@ type}
-%* *
-%************************************************************************
-
-The @ConAppMap@ maps applications of constructors (to value atoms)
-back to an association list that says "if the constructor was applied
-to one of these lists-of-Types, then this OutId is your man (in a
-non-gender-specific sense)". I.e., this is a reversed mapping for
-(part of) the main OutIdEnv
-
-\begin{code}
-type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
-
-data UnfoldConApp
- = UCA OutId -- data constructor
- [OutArg] -- *value* arguments; see use below
-\end{code}
-
-\begin{code}
-nullConApps = emptyFM
-
-extendConApps con_apps id (Con con args)
- = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
- where
- val_args = filter isValArg args -- Literals and Ids
- ty_args = [ty | TyArg ty <- args] -- Just types
-
-extendConApps con_apps id other_rhs = con_apps
-\end{code}
-
-\begin{code}
-lookForConstructor env@(SimplEnv _ _ _ _ con_apps) (Con con args)
- | switchIsSet env SimplReuseCon
- = case lookupFM con_apps (UCA con val_args) of
- Nothing -> Nothing
-
- Just assocs -> case [id | (tys, id) <- assocs,
- and (zipWith (==) tys ty_args)]
- of
- [] -> Nothing
- (id:_) -> Just id
- where
- val_args = filter isValArg args -- Literals and Ids
- ty_args = [ty | TyArg ty <- args] -- Just types
-
-lookForConstructor env other = Nothing
-\end{code}
-
-NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
-for nullary constructors, but now we only do constructor re-use in
-let-bindings the special case isn't necessary any more.
-
-\begin{verbatim}
- = -- Don't re-use nullary constructors; it's a waste. Consider
- -- let
- -- a = leInt#! p q
- -- in
- -- case a of
- -- True -> ...
- -- False -> False
- --
- -- Here the False in the second case will get replace by "a", hardly
- -- a good idea
- Nothing
-\end{verbatim}
-
-
-The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
-it, so we can use it for a @FiniteMap@ key.
-
-\begin{code}
-instance Eq UnfoldConApp where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord UnfoldConApp where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = cmp_app a b
-
-cmp_app (UCA c1 as1) (UCA c2 as2)
- = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
- where
- -- ToDo: make an "instance Ord CoreArg"???
-
- cmp_arg (VarArg x) (VarArg y) = x `compare` y
- cmp_arg (LitArg x) (LitArg y) = x `compare` y
- cmp_arg (TyArg x) (TyArg y) = panic "SimplEnv.cmp_app:TyArgs"
- cmp_arg x y
- | tag x _LT_ tag y = LT
- | otherwise = GT
- where
- tag (VarArg _) = ILIT(1)
- tag (LitArg _) = ILIT(2)
- tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
-\end{code}
-
-
-@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
-of a new binding. There is a horrid case we have to take care about,
-due to Andr\'e Santos:
-@
- type Array_type b = Array Int b;
- type Descr_type = (Int,Int);
-
- tabulate :: (Int -> x) -> Descr_type -> Array_type x;
- tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
-
- f_iaamain a_xs=
- let {
- f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
- f_aareorder a_index a_ar=
- let {
- f_aareorder' a_i= a_ar ! (a_index ! a_i)
- } in tabulate f_aareorder' (bounds a_ar);
- r_index=tabulate ((+) 1) (1,1);
- arr = listArray (1,1) a_xs;
- arg = f_aareorder r_index arr
- } in elems arg
-@
-Now, when the RHS of arg gets simplified, we inline f_aareorder to get
-@
- arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
- in tabulate f_aareorder' (bounds arr)
-@
-Note that r_index is not inlined, because it was bound to a_index which
-occurs inside a lambda.
-
-Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
-then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
-analyse it, we won't spot the inside-lambda property of r_index, so r_index
-will get inlined inside the lambda. AARGH.
-
-Solution: when we occurrence-analyse the new RHS we have to go back
-and modify the info recorded in the UnfoldEnv for the free vars
-of the RHS. In the example we'd go back and record that r_index is now used
-inside a lambda.
-
-\begin{code}
-extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenNewRhs env out_id rhs
- = extendEnvGivenBinding env noBinderInfo out_id rhs
-
-extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
- occ_info out_id rhs
- = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
- where
- new_in_scope_ids | okToInline out_id
- (whnfOrBottom form)
- (couldBeSmallEnoughToInline out_id guidance)
- occ_info
- = env_with_unfolding
- | otherwise
- = in_scope_ids
- -- Don't bother to munge the OutIdEnv unless there is some possibility
- -- that the thing might be inlined. We check this by calling okToInline suitably.
-
- new_con_apps = _scc_ "eegnr.conapps"
- extendConApps con_apps out_id rhs
-
- -- Modify the occ info for rhs's interesting free variables.
- -- That's to take account of:
- -- let a = \x -> BIG in
- -- let b = \f -> f a
- -- in ...b...b...b...
- -- Here "a" occurs exactly once. "b" simplifies to a small value.
- -- So "b" will be inlined at each call site, and there's a good chance
- -- that "a" will too. So we'd better modify "a"s occurrence info to
- -- record the fact that it can now occur many times by virtue that "b" can.
- env_with_unfolding = _scc_ "eegnr.modify_occ"
- foldl zap env1 (ufmToList fv_occ_info)
- zap env (uniq,_) = modifyOccInfo env uniq occ_info
-
-
- -- Add an unfolding and rhs_info for the new Id.
- -- If the out_id is already in the OutIdEnv (which should be the
- -- case because it was put there by simplBinder)
- -- then just replace the unfolding, leaving occurrence info alone.
- env1 = _scc_ "eegnr.modify_out"
- addToUFM_C modifyOutEnvItem in_scope_ids out_id
- (out_id, occ_info, rhs_info)
-
- -- Occurrence-analyse the RHS
- -- The "interesting" free variables we want occurrence info for are those
- -- in the OutIdEnv that have only a single occurrence right now.
- (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
- occurAnalyseExpr is_interesting rhs_w_cc
-
- is_interesting v = _scc_ "eegnr.mkidset"
- case lookupIdEnv in_scope_ids v of
- Just (_, occ, _) -> isOneOcc occ
- other -> False
-
- -- Compute unfolding details
- rhs_info = CoreUnfolding form guidance template
- form = _scc_ "eegnr.form_sum"
- mkFormSummary rhs
- guidance = _scc_ "eegnr.guidance"
- calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
-
- -- Attach a cost centre to the RHS if necessary
- rhs_w_cc | currentOrSubsumedCosts encl_cc
- || not (noCostCentreAttached (coreExprCc rhs))
- = rhs
- | otherwise
- = Note (SCC encl_cc) rhs
-\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[SimplMonad]{The simplifier Monad}
\begin{code}
module SimplMonad (
- SmplM,
+ InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
+ OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+
+ -- The continuation type
+ SimplCont(..), DupFlag(..), contIsDupable,
+
+ -- The monad
+ SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
-- Unique supply
getUniqueSmpl, getUniquesSmpl,
+ newId, newIds,
-- Counting
- SimplCount{-abstract-}, TickType(..), tick, tickN, tickUnfold,
- simplCount, detailedSimplCount,
- zeroSimplCount, showSimplCount, combineSimplCounts
+ SimplCount, TickType(..), TickCounts,
+ tick, tickUnfold,
+ getSimplCount, zeroSimplCount, pprSimplCount,
+ plusSimplCount, isZeroSimplCount,
+
+ -- Switch checker
+ SwitchChecker, getSwitchChecker, getSimplIntSwitch,
+
+ -- Cost centres
+ getEnclosingCC, setEnclosingCC,
+
+ -- Environments
+ InScopeEnv, SubstEnv,
+ getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
+ emptySubstEnv, getSubstEnv, setSubstEnv, zapSubstEnv,
+ extendIdSubst, extendTySubst,
+ getTyEnv, getValEnv,
+ getSimplBinderStuff, setSimplBinderStuff,
+ switchOffInlining
) where
#include "HsVersions.h"
-import MkId ( mkSysLocal )
-import Id ( mkIdWithNewUniq, Id )
-import SimplEnv
-import SrcLoc ( noSrcLoc )
-import TyVar ( TyVar )
-import Type ( Type )
-import UniqSupply ( getUnique, getUniques, splitUniqSupply,
+import Id ( Id, mkSysLocal, idMustBeINLINEd )
+import IdInfo ( InlinePragInfo(..) )
+import CoreSyn
+import CoreUtils ( IdSubst, SubstCoreExpr )
+import CostCentre ( CostCentreStack, subsumedCCS )
+import Var ( TyVar )
+import VarEnv
+import VarSet
+import Type ( Type, TyVarSubst )
+import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
+import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), intSwitchSet )
import Unique ( Unique )
-import Util ( zipWithEqual, Eager, appEager )
+import Maybes ( expectJust )
+import Util ( zipWithEqual )
import Outputable
-import Ix
infixr 9 `thenSmpl`, `thenSmpl_`
\end{code}
%************************************************************************
%* *
+\subsection[Simplify-types]{Type declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+type InBinder = CoreBndr
+type InId = Id -- Not yet cloned
+type InType = Type -- Ditto
+type InBind = CoreBind
+type InExpr = CoreExpr
+type InAlt = CoreAlt
+type InArg = CoreArg
+
+type OutBinder = CoreBndr
+type OutId = Id -- Cloned
+type OutType = Type -- Cloned
+type OutBind = CoreBind
+type OutExpr = CoreExpr
+type OutAlt = CoreAlt
+type OutArg = CoreArg
+
+type SwitchChecker = SimplifierSwitch -> SwitchResult
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The continuation data type}
+%* *
+%************************************************************************
+
+\begin{code}
+data SimplCont
+ = Stop
+
+ | CoerceIt DupFlag
+ InType SubstEnv
+ SimplCont
+
+ | ApplyTo DupFlag
+ InExpr SubstEnv -- The argument, as yet unsimplified,
+ SimplCont -- and its subst-env
+
+ | Select DupFlag
+ InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
+ SimplCont
+
+instance Outputable SimplCont where
+ ppr Stop = ptext SLIT("Stop")
+ ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
+ ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
+ (nest 4 (ppr alts)) $$ ppr cont
+ ppr (CoerceIt dup ty se cont) = (ptext SLIT("CoerceIt") <+> ppr dup <+> ppr ty) $$ ppr cont
+
+data DupFlag = OkToDup | NoDup
+
+instance Outputable DupFlag where
+ ppr OkToDup = ptext SLIT("ok")
+ ppr NoDup = ptext SLIT("nodup")
+
+contIsDupable :: SimplCont -> Bool
+contIsDupable Stop = True
+contIsDupable (ApplyTo OkToDup _ _ _) = True
+contIsDupable (Select OkToDup _ _ _ _) = True
+contIsDupable (CoerceIt OkToDup _ _ _) = True
+contIsDupable other = False
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Monad plumbing}
%* *
%************************************************************************
(Command-line switches move around through the explicitly-passed SimplEnv.)
\begin{code}
-type SmplM result
- = UniqSupply
- -> SimplCount -- things being threaded
- -> (result, SimplCount)
+type SimplM result -- We thread the unique supply because
+ = SimplEnv -- constantly splitting it is rather expensive
+ -> UniqSupply
+ -> SimplCount
+ -> (result, UniqSupply, SimplCount)
+
+data SimplEnv
+ = SimplEnv {
+ seChkr :: SwitchChecker,
+ seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+ seSubst :: SubstEnv, -- The current substitution
+ seInScope :: InScopeEnv -- Says what's in scope and gives info about it
+ }
\end{code}
\begin{code}
-initSmpl :: UniqSupply -- no init count; set to 0
- -> SmplM a
- -> (a, SimplCount)
+initSmpl :: SwitchChecker
+ -> UniqSupply -- No init count; set to 0
+ -> SimplM a
+ -> (a, SimplCount)
+
+initSmpl chkr us m = case m (emptySimplEnv chkr) us zeroSimplCount of
+ (result, _, count) -> (result, count)
-initSmpl us m = m us zeroSimplCount
{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}
-returnSmpl :: a -> SmplM a
-returnSmpl e us sc = (e, sc)
+returnSmpl :: a -> SimplM a
+returnSmpl e env us sc = (e, us, sc)
-thenSmpl :: SmplM a -> (a -> SmplM b) -> SmplM b
-thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
+thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
-thenSmpl m k us sc0
- = case splitUniqSupply us of { (s1, s2) ->
- case (m s1 sc0) of { (m_result, sc1) ->
- k m_result s2 sc1 }}
+thenSmpl m k env us0 sc0
+ = case (m env us0 sc0) of
+ (m_result, us1, sc1) -> k m_result env us1 sc1
-thenSmpl_ m k us sc0
- = case splitUniqSupply us of { (s1, s2) ->
- case (m s1 sc0) of { (_, sc1) ->
- k s2 sc1 }}
+thenSmpl_ m k env us0 sc0
+ = case (m env us0 sc0) of
+ (_, us1, sc1) -> k env us1 sc1
+\end{code}
-mapSmpl :: (a -> SmplM b) -> [a] -> SmplM [b]
-mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
+
+\begin{code}
+mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
+mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
mapSmpl f [] = returnSmpl []
mapSmpl f (x:xs)
mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
returnSmpl (acc'', x':xs')
+\end{code}
-getUniqueSmpl :: SmplM Unique
-getUniqueSmpl us sc = (getUnique us, sc)
-getUniquesSmpl :: Int -> SmplM [Unique]
-getUniquesSmpl n us sc = (getUniques n us, sc)
+%************************************************************************
+%* *
+\subsection{The unique supply}
+%* *
+%************************************************************************
+
+\begin{code}
+getUniqueSmpl :: SimplM Unique
+getUniqueSmpl env us sc = case splitUniqSupply us of
+ (us1, us2) -> (uniqFromSupply us1, us2, sc)
+
+getUniquesSmpl :: Int -> SimplM [Unique]
+getUniquesSmpl n env us sc = case splitUniqSupply us of
+ (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
\end{code}
%* *
%************************************************************************
+\begin{code}
+doTickSmpl :: (SimplCount -> SimplCount) -> SimplM ()
+doTickSmpl f env us sc = sc' `seq` ((), us, sc')
+ where
+ sc' = f sc
+
+getSimplCount :: SimplM SimplCount
+getSimplCount env us sc = (sc, us, sc)
+\end{code}
+
+
The assoc list isn't particularly costly, because we only use
the number of ticks in ``real life.''
\begin{code}
data SimplCount
- = SimplCount FAST_INT -- number of ticks
- [(TickType, Int)] -- assoc list of all diff kinds of ticks
- UnfoldingHistory
+ = SimplCount !TickCounts
+ !UnfoldingHistory
+
+type TickCounts = [(TickType, Int)] -- Assoc list of all diff kinds of ticks
+ -- Kept in increasing order of TickType
+ -- Zeros not present
type UnfoldingHistory = (Int, -- N
- [(Id,Int)], -- Last N unfoldings
- [(Id,Int)]) -- The MaxUnfoldHistory unfoldings before that
+ [Id], -- Last N unfoldings
+ [Id]) -- The MaxUnfoldHistory unfoldings before that
data TickType
- = UnfoldingDone | MagicUnfold | ConReused
- | CaseFloatFromLet | CaseOfCase
- | LetFloatFromLet | LetFloatFromCase
- | KnownBranch | Let2Case
- | CaseMerge | CaseElim
+ = PreInlineUnconditionally
+ | PostInlineUnconditionally
+ | UnfoldingDone
+ | MagicUnfold
+ | CaseOfCase
+ | LetFloatFromLet
+ | KnownBranch
+ | Let2Case
+ | Case2Let
+ | CaseMerge
+ | CaseElim
| CaseIdentity
- | AtomicRhs -- Rhs of a let-expression was an atom
| EtaExpansion
| CaseOfError
- | TyBetaReduction
| BetaReduction
| SpecialisationDone
- {- BEGIN F/B ENTRIES -}
- -- the 8 rules
- | FoldrBuild -- foldr f z (build g) ==>
- | FoldrAugment -- foldr f z (augment g z) ==>
- | Foldr_Nil -- foldr f z [] ==>
- | Foldr_List -- foldr f z (x:...) ==>
-
- | FoldlBuild -- foldl f z (build g) ==>
- | FoldlAugment -- foldl f z (augment g z) ==>
- | Foldl_Nil -- foldl f z [] ==>
- | Foldl_List -- foldl f z (x:...) ==>
-
- | Foldr_Cons_Nil -- foldr (:) [] => id
- | Foldr_Cons -- foldr (:) => flip (++)
-
- | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
- | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
- | Str_UnpackNil -- unpackAppendPS__ [] "hello" => "hello"
- {- END F/B ENTRIES -}
- deriving (Eq, Ord, Ix)
-
-instance Text TickType where
- showsPrec p UnfoldingDone = showString "UnfoldingDone "
- showsPrec p MagicUnfold = showString "MagicUnfold "
- showsPrec p ConReused = showString "ConReused "
- showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
- showsPrec p CaseOfCase = showString "CaseOfCase "
- showsPrec p LetFloatFromLet = showString "LetFloatFromLet "
- showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
- showsPrec p KnownBranch = showString "KnownBranch "
- showsPrec p Let2Case = showString "Let2Case "
- showsPrec p CaseMerge = showString "CaseMerge "
- showsPrec p CaseElim = showString "CaseElim "
- showsPrec p CaseIdentity = showString "CaseIdentity "
- showsPrec p AtomicRhs = showString "AtomicRhs "
- showsPrec p EtaExpansion = showString "EtaExpansion "
- showsPrec p CaseOfError = showString "CaseOfError "
- showsPrec p TyBetaReduction = showString "TyBetaReduction "
- showsPrec p BetaReduction = showString "BetaReduction "
- showsPrec p SpecialisationDone
- = showString "Specialisation "
-
- -- Foldr/Build Stuff:
- showsPrec p FoldrBuild = showString "FoldrBuild "
- showsPrec p FoldrAugment = showString "FoldrAugment "
- showsPrec p Foldr_Nil = showString "Foldr_Nil "
- showsPrec p Foldr_List = showString "Foldr_List "
-
- showsPrec p FoldlBuild = showString "FoldlBuild "
- showsPrec p FoldlAugment = showString "FoldlAugment "
- showsPrec p Foldl_Nil = showString "Foldl_Nil "
- showsPrec p Foldl_List = showString "Foldl_List "
-
- showsPrec p Foldr_Cons_Nil = showString "Foldr_Cons_Nil "
- showsPrec p Foldr_Cons = showString "Foldr_Cons "
-
- showsPrec p Str_FoldrStr = showString "Str_FoldrStr "
- showsPrec p Str_UnpackCons = showString "Str_UnpackCons "
- showsPrec p Str_UnpackNil = showString "Str_UnpackNil "
-
-showSimplCount :: SimplCount -> String
-
-showSimplCount (SimplCount _ stuff (_, unf1, unf2))
- = shw stuff ++ "\nMost recent unfoldings: " ++ showSDoc (ppr (reverse unf2 ++ reverse unf1))
+ | FillInCaseDefault
+ | LeavesExamined
+ deriving (Eq, Ord, Show)
+
+pprSimplCount :: SimplCount -> SDoc
+pprSimplCount (SimplCount stuff (_, unf1, unf2))
+ = vcat (map ppr_item stuff)
+ $$ (text "Most recent unfoldings (most recent at top):"
+ $$ nest 4 (vcat (map ppr (unf1 ++ unf2))))
where
- shw [] = ""
- shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
- | otherwise = shw tns
+ ppr_item (t,n) = text (show t) <+> char '\t' <+> ppr n
zeroSimplCount :: SimplCount
-zeroSimplCount
- = SimplCount ILIT(0) stuff (0, [], [])
- where
- stuff =
- [ (UnfoldingDone, 0),
- (MagicUnfold, 0),
- (ConReused, 0),
- (CaseFloatFromLet, 0),
- (CaseOfCase, 0),
- (LetFloatFromLet, 0),
- (LetFloatFromCase, 0),
- (KnownBranch, 0),
- (Let2Case, 0),
- (CaseMerge, 0),
- (CaseElim, 0),
- (CaseIdentity, 0),
- (AtomicRhs, 0),
- (EtaExpansion, 0),
- (CaseOfError, 0),
- (TyBetaReduction,0),
- (BetaReduction,0),
- (SpecialisationDone,0),
- -- Foldr/Build Stuff:
- (FoldrBuild, 0),
- (FoldrAugment, 0),
- (Foldr_Nil, 0),
- (Foldr_List, 0),
- (FoldlBuild, 0),
- (FoldlAugment, 0),
- (Foldl_Nil, 0),
- (Foldl_List, 0),
- (Foldr_Cons_Nil, 0),
- (Foldr_Cons, 0),
-
- (Str_FoldrStr, 0),
- (Str_UnpackCons, 0),
- (Str_UnpackNil, 0) ]
---
---= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
--- [ i := 0 | i <- indices zeroSimplCount ]
+zeroSimplCount = SimplCount [] (0, [], [])
+
+isZeroSimplCount :: SimplCount -> Bool
+isZeroSimplCount (SimplCount [] _) = True
+isZeroSimplCount (SimplCount [(LeavesExamined,_)] _) = True
+isZeroSimplCount other = False
+
+-- incTick is careful to be pretty strict, so we don't
+-- get a huge buildup of thunks
+incTick :: TickType -> FAST_INT -> TickCounts -> TickCounts
+incTick tick_type n []
+ = [(tick_type, IBOX(n))]
+
+incTick tick_type n (x@(ttype, I# cnt#) : xs)
+ = case tick_type `compare` ttype of
+ LT -> -- Insert here
+ (tick_type, IBOX(n)) : x : xs
+
+ EQ -> -- Increment
+ case cnt# +# n of
+ incd -> (ttype, IBOX(incd)) : xs
+
+ GT -> -- Move on
+ rest `seq` x : rest
+ where
+ rest = incTick tick_type n xs
+
+-- Second argument is more recent stuff
+plusSimplCount :: SimplCount -> SimplCount -> SimplCount
+plusSimplCount (SimplCount tc1 uh1) (SimplCount tc2 uh2)
+ = SimplCount (plusTickCounts tc1 tc2) (plusUnfolds uh1 uh2)
+
+plusTickCounts :: TickCounts -> TickCounts -> TickCounts
+plusTickCounts ts1 [] = ts1
+plusTickCounts [] ts2 = ts2
+plusTickCounts ((tt1,n1) : ts1) ((tt2,n2) : ts2)
+ = case tt1 `compare` tt2 of
+ LT -> (tt1,n1) : plusTickCounts ts1 ((tt2,n2) : ts2)
+ EQ -> (tt1,n1+n2) : plusTickCounts ts1 ts2
+ GT -> (tt2,n2) : plusTickCounts ((tt1,n1) : ts1) ts2
+
+-- Second argument is the more recent stuff
+plusUnfolds uh1 (0, h2, t2) = uh1 -- Nothing recent
+plusUnfolds (n1, h1, t1) (n2, h2, []) = (n2, h2, (h1++t1)) -- Small amount recent
+plusUnfolds (n1, h1, t1) uh2 = uh2 -- Decent batch recent
\end{code}
+
Counting-related monad functions:
+
\begin{code}
-tick :: TickType -> SmplM ()
-
-tick tick_type us (SimplCount n stuff unf)
- = -- pprTrace "Tick: " (text (show tick_type)) $
-#ifdef OMIT_SIMPL_COUNTS
- ((), SimplCount (n _ADD_ ILIT(1) stuff unf)) stuff -- don't change anything
-#else
- new_stuff `seqL`
- ((), SimplCount (n _ADD_ ILIT(1)) new_stuff unf)
+tick :: TickType -> SimplM ()
+
+tick tick_type
+ = doTickSmpl f
where
- new_stuff = inc_tick tick_type ILIT(1) stuff
-#endif
+ f (SimplCount stuff unf) = SimplCount (incTick tick_type ILIT(1) stuff) unf
maxUnfoldHistory :: Int
maxUnfoldHistory = 20
-tickUnfold :: Id -> SmplM ()
-tickUnfold id us (SimplCount n stuff (n_unf, unf1, unf2))
- = -- pprTrace "Unfolding: " (ppr id) $
- new_stuff `seqL`
- new_unf `seqTriple`
- ((), SimplCount (n _ADD_ ILIT(1)) new_stuff new_unf)
+tickUnfold :: Id -> SimplM ()
+tickUnfold id
+ = doTickSmpl f
+ where
+ f (SimplCount stuff (n_unf, unf1, unf2))
+ | n_unf >= maxUnfoldHistory = SimplCount new_stuff (1, [id], unf1)
+ | otherwise = SimplCount new_stuff (n_unf+1, id:unf1, unf2)
+ where
+ new_stuff = incTick UnfoldingDone ILIT(1) stuff
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Command-line switches}
+%* *
+%************************************************************************
+
+\begin{code}
+getSwitchChecker :: SimplM SwitchChecker
+getSwitchChecker env us sc = (seChkr env, us, sc)
+
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+ = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
+\end{code}
+
+
+@switchOffInlining@ is used to prepare the environment for simplifying
+the RHS of an Id that's marked with an INLINE pragma. It is going to
+be inlined wherever they are used, and then all the inlining will take
+effect. Meanwhile, there isn't much point in doing anything to the
+as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
+inlining! because
+ (a) not doing so will inline a worker straight back into its wrapper!
+
+and (b) Consider the following example
+ let f = \pq -> BIG
+ in
+ let g = \y -> f y y
+ {-# INLINE g #-}
+ in ...g...g...g...g...g...
+
+ Now, if that's the ONLY occurrence of f, it will be inlined inside g,
+ and thence copied multiple times when g is inlined.
+
+ Andy disagrees! Example:
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+
+ Problem: any won't get deforested, and so if it's exported and
+ the importer doesn't use the inlining, (eg passes it as an arg)
+ then we won't get deforestation at all.
+ We havn't solved this problem yet!
+
+We prepare the envt by simply modifying the in_scope_env, which has all the
+unfolding info. At one point we did it by modifying the chkr so that
+it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
+important, simplifications happening in the body of the RHS.
+
+6/98 update:
+
+We *don't* prevent inlining from happening for identifiers
+that are marked as IMustBeINLINEd. An example of where
+doing this is crucial is:
+
+ class Bar a => Foo a where
+ ...g....
+ {-# INLINE f #-}
+ f :: Foo a => a -> b
+ f x = ....Foo_sc1...
+
+If `f' needs to peer inside Foo's superclass, Bar, it refers
+to the appropriate super class selector, which is marked as
+must-inlineable. We don't generate any code for a superclass
+selector, so failing to inline it in the RHS of `f' will
+leave a reference to a non-existent id, with bad consequences.
+
+ALSO NOTE that we do all this by modifing the inline-pragma,
+not by zapping the unfolding. The latter may still be useful for
+knowing when something is evaluated.
+
+June 98 update: I've gone back to dealing with this by adding
+the EssentialUnfoldingsOnly switch. That doesn't stop essential
+unfoldings, nor inlineUnconditionally stuff; and the thing's going
+to be inlined at every call site anyway. Running over the whole
+environment seems like wild overkill.
+
+\begin{code}
+switchOffInlining :: SimplM a -> SimplM a
+switchOffInlining m env@(SimplEnv { seChkr = sw_chkr }) us sc
+ = m (env { seChkr = new_chkr }) us sc
where
- new_stuff = inc_tick UnfoldingDone ILIT(1) stuff
+ new_chkr EssentialUnfoldingsOnly = SwBool True
+ new_chkr other = sw_chkr other
+\end{code}
- new_unf | n_unf >= maxUnfoldHistory = (1, [unf_item], unf1)
- | otherwise = (n_unf+1, unf_item:unf1, unf2)
-
- unf_item = (id, IBOX(n))
+%************************************************************************
+%* *
+\subsubsection{The ``enclosing cost-centre''}
+%* *
+%************************************************************************
- -- force list to avoid getting a chain of @inc_tick@ applications
- -- building up on the heap. (Only true when not dumping stats).
-seqL [] y = y
-seqL (_:_) y = y
+\begin{code}
+getEnclosingCC :: SimplM CostCentreStack
+getEnclosingCC env us sc = (seCC env, us, sc)
-seqTriple (_,_,_) y = y
+setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
+setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
+\end{code}
-tickN :: TickType -> Int -> SmplM ()
-tickN tick_type 0 us counts
- = ((), counts)
-tickN tick_type IBOX(increment) us (SimplCount n stuff unf)
- = -- pprTrace "Tick: " (text (show tick_type)) $
-#ifdef OMIT_SIMPL_COUNTS
- ((), SimplCount (n _ADD_ increment) stuff) -- don't change anything
-#else
- new_stuff `seqL`
- ((), SimplCount (n _ADD_ increment) new_stuff unf)
- where
- new_stuff = inc_tick tick_type increment stuff
+%************************************************************************
+%* *
+\subsubsection{The @SimplEnv@ type}
+%* *
+%************************************************************************
+\begin{code}
+type SubstEnv = (TyVarSubst, IdSubst)
+ -- The range of these substitutions is OutType and OutExpr resp
+ --
+ -- The substitution is idempotent
+ -- It *must* be applied; things in its domain simply aren't
+ -- bound in the result.
+ --
+ -- The substitution usually maps an Id to its clone,
+ -- but if the orig defn is a let-binding, and
+ -- the RHS of the let simplifies to an atom,
+ -- we just add the binding to the substitution and elide the let.
+
+type InScopeEnv = IdOrTyVarSet
+ -- Domain includes *all* in-scope TyVars and Ids
+ --
+ -- The elements of the set may have better IdInfo than the
+ -- occurrences of in-scope Ids, and (more important) they will
+ -- have a correctly-substituted type. So we use a lookup in this
+ -- set to replace occurrences
+
+-- INVARIANT: If t is in the in-scope set, it certainly won't be
+-- in the domain of the SubstEnv, and vice versa
+\end{code}
-inc_tick tick_type n [] = panic "couldn't inc_tick!"
-inc_tick tick_type n (x@(ttype, I# cnt#) : xs)
- | ttype == tick_type = case cnt# +# n of
- incd -> (ttype,IBOX(incd)) : xs
+\begin{code}
+emptySubstEnv :: SubstEnv
+emptySubstEnv = (emptyVarEnv, emptyVarEnv)
- | otherwise = case inc_tick tick_type n xs of { [] -> [x]; ls -> x:ls }
-#endif
+emptySimplEnv :: SwitchChecker -> SimplEnv
-simplCount :: SmplM Int
-simplCount us sc@(SimplCount n _ _) = (IBOX(n), sc)
+emptySimplEnv sw_chkr
+ = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
+ seSubst = emptySubstEnv,
+ seInScope = emptyVarSet }
-detailedSimplCount :: SmplM SimplCount
-detailedSimplCount us sc = (sc, sc)
+ -- The top level "enclosing CC" is "SUBSUMED".
-combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
+getTyEnv :: SimplM (TyVarSubst, InScopeEnv)
+getTyEnv (SimplEnv {seSubst = (ty_subst,_), seInScope = in_scope}) us sc
+ = ((ty_subst, in_scope), us, sc)
-#ifdef OMIT_SIMPL_COUNTS
-combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
- = SimplCount (n1 _ADD_ n2)
- stuff2 -- just pick one
- unf2
-#else
-combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
- = new_stuff `seqL`
- SimplCount (n1 _ADD_ n2) new_stuff unf2 -- Just pick the second for unfold history
- where
- new_stuff = zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2
+getValEnv :: SimplM (IdSubst, InScopeEnv)
+getValEnv (SimplEnv {seSubst = (_, id_subst), seInScope = in_scope}) us sc
+ = ((id_subst, in_scope), us, sc)
+
+getInScope :: SimplM InScopeEnv
+getInScope env us sc = (seInScope env, us, sc)
+
+setInScope :: InScopeEnv -> SimplM a -> SimplM a
+setInScope in_scope m env us sc = m (env {seInScope = in_scope}) us sc
+
+extendInScope :: CoreBndr -> SimplM a -> SimplM a
+extendInScope v m env@(SimplEnv {seInScope = in_scope}) us sc
+ = m (env {seInScope = extendVarSet in_scope v}) us sc
+
+extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
+extendInScopes vs m env@(SimplEnv {seInScope = in_scope}) us sc
+ = m (env {seInScope = foldl extendVarSet in_scope vs}) us sc
+
+modifyInScope :: CoreBndr -> SimplM a -> SimplM a
+modifyInScope v m env us sc
+#ifdef DEBUG
+ | not (v `elemVarSet` seInScope env )
+ = pprTrace "modifyInScope: not in scope:" (ppr v)
+ m env us sc
#endif
+ | otherwise
+ = extendInScope v m env us sc
+
+getSubstEnv :: SimplM SubstEnv
+getSubstEnv env us sc = (seSubst env, us, sc)
+
+setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
+setSubstEnv subst_env m env us sc = m (env {seSubst = subst_env}) us sc
+
+extendIdSubst :: Id -> SubstCoreExpr -> SimplM a -> SimplM a
+extendIdSubst id expr m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
+ = m (env { seSubst = (ty_subst, extendVarEnv id_subst id expr) }) us sc
+
+extendTySubst :: TyVar -> OutType -> SimplM a -> SimplM a
+extendTySubst tv ty m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
+ = m (env { seSubst = (extendVarEnv ty_subst tv ty, id_subst) }) us sc
+
+zapSubstEnv :: SimplM a -> SimplM a
+zapSubstEnv m env us sc = m (env {seSubst = emptySubstEnv}) us sc
+
+getSimplBinderStuff :: SimplM (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
+getSimplBinderStuff (SimplEnv {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
+ = ((ty_subst, id_subst, in_scope, us), us, sc)
+
+setSimplBinderStuff :: (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
+ -> SimplM a -> SimplM a
+setSimplBinderStuff (ty_subst, id_subst, in_scope, us) m env _ sc
+ = m (env {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
+\end{code}
+
+
+\begin{code}
+newId :: Type -> (Id -> SimplM a) -> SimplM a
+ -- Extends the in-scope-env too
+newId ty m env@(SimplEnv {seInScope = in_scope}) us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> m v (env {seInScope = extendVarSet in_scope v}) us2 sc
+ where
+ v = mkSysLocal (uniqFromSupply us1) ty
+
+newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
+newIds tys m env@(SimplEnv {seInScope = in_scope}) us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc
+ where
+ vs = zipWithEqual "newIds" mkSysLocal (uniqsFromSupply (length tys) us1) tys
\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1996
-%
-\section[SimplPgm]{Interface to the simplifier}
-
-\begin{code}
-module SimplPgm ( simplifyPgm ) where
-
-#include "HsVersions.h"
-
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_iterations,
- switchIsOn, SimplifierSwitch(..), SwitchResult
- )
-import CoreSyn
-import Id ( mkIdEnv, lookupIdEnv, IdEnv
- )
-import Maybes ( catMaybes )
-import OccurAnal ( occurAnalyseBinds )
-import PprCore ( pprCoreBinding ) -- added SOF
-import SimplEnv
-import SimplMonad
-import Simplify ( simplTopBinds )
-import TyVar ( TyVarEnv )
-import UniqSupply ( thenUs, returnUs, mapUs,
- splitUniqSupply, UniqSM,
- UniqSupply
- )
-import Util ( isIn, isn'tIn, removeDups, trace )
-import Outputable
-
-\end{code}
-
-\begin{code}
-simplifyPgm :: [CoreBinding] -- input
- -> (SimplifierSwitch->SwitchResult)
- -> SimplCount -- info about how many times
- -- each transformation has occurred
- -> UniqSupply
- -> ([CoreBinding], -- output
- Int, -- info about how much happened
- SimplCount) -- accumulated simpl stats
-
-simplifyPgm binds s_sw_chkr simpl_stats us
- = --case (splitUniqSupply us) of { (s1, s2) ->
- case (initSmpl us (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
- (pgm2, it_count, combineSimplCounts simpl_stats simpl_stats2) }
- where
- simpl_switch_is_on = switchIsOn s_sw_chkr
-
- max_simpl_iterations = getSimplIntSwitch s_sw_chkr MaxSimplifierIterations
-
- simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount)
-
- simpl_pgm n iterations pgm
- = -- find out what top-level binders are used,
- -- and prepare to unfold all the "simple" bindings
- let
- tagged_pgm = _scc_ "OccAnal" occurAnalyseBinds pgm simpl_switch_is_on
- in
- -- do the business
- simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm ->
-
- -- Quit if we didn't actually do anything; otherwise,
- -- try again (if suitable flags)
-
- simplCount `thenSmpl` \ r ->
- detailedSimplCount `thenSmpl` \ dr ->
- let
- show_status = pprTrace "Simplifer run: " (vcat [
- hcat [ptext SLIT("iteration "),
- int iterations,
- ptext SLIT(" out of "),
- int max_simpl_iterations],
- text (showSimplCount dr),
- if opt_D_dump_simpl_iterations then
- vcat (map (pprCoreBinding) new_pgm)
- else
- empty
- ])
- in
-
- (if opt_D_verbose_core2core
- || simpl_switch_is_on ShowSimplifierProgress
- then show_status
- else id)
-
- (let stop_now = r == n {-nothing happened-}
- || (if iterations >= max_simpl_iterations then
- (if max_simpl_iterations > 1 {-otherwise too boring-} then
- trace
- ("NOTE: Simplifier still going after " ++
- show max_simpl_iterations ++
- " iterations; bailing out.")
- else id)
- True
- else
- False)
- in
- if stop_now then
- returnSmpl (new_pgm, iterations, dr)
- else
- simpl_pgm r (iterations + 1) new_pgm
- )
-\end{code}
-
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[SimplUtils]{The simplifier utilities}
\begin{code}
module SimplUtils (
-
- newId, newIds,
-
- floatExposesHNF,
-
- etaCoreExpr, mkRhsTyLam,
-
- etaExpandCount,
-
- simplIdWantsToBeINLINEd,
-
- singleConstructorType, typeOkForCase,
-
- substSpecEnvRhs
+ simplBinder, simplBinders, simplIds,
+ mkRhsTyLam,
+ etaCoreExpr,
+ etaExpandCount,
+ mkCase, findAlt, findDefault
) where
#include "HsVersions.h"
import BinderInfo
-import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
+import CmdLineOpts ( opt_DoEtaReduction, switchIsOn, SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( mkFormSummary, exprIsTrivial, FormSummary(..) )
-import MkId ( mkSysLocal )
-import Id ( idType, isBottomingId, getIdArity,
- addInlinePragma, addIdDemandInfo,
- idWantsToBeINLINEd, dataConArgTys, Id,
- lookupIdEnv, delOneFromIdEnv
+import CoreUtils ( exprIsCheap, exprIsTrivial, exprFreeVars, cheapEqExpr,
+ FormSummary(..),
+ substId, substIds
+ )
+import Id ( Id, idType, isBottomingId, getIdArity, isId, idName,
+ getInlinePragma, setInlinePragma,
+ getIdDemandInfo
)
-import IdInfo ( ArityInfo(..), DemandInfo )
+import IdInfo ( arityLowerBound, InlinePragInfo(..) )
+import Demand ( isStrict )
import Maybes ( maybeToBool )
-import PrelVals ( augmentId, buildId )
-import PrimOp ( primOpIsCheap )
-import SimplEnv
+import Const ( Con(..) )
+import Name ( isLocalName )
import SimplMonad
-import Type ( tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, getTyVar_maybe,
- splitAlgTyConApp_maybe, instantiateTy, Type
- )
-import TyCon ( isDataTyCon )
-import TyVar ( mkTyVarSet, intersectTyVarSets, elementOfTyVarSet, tyVarSetToList,
- delFromTyVarEnv
+import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys,
+ splitTyConApp_maybe, mkTyVarTy, substTyVar
)
-import SrcLoc ( noSrcLoc )
-import Util ( isIn, zipWithEqual, panic, assertPanic )
-
+import Var ( setVarUnique )
+import VarSet
+import UniqSupply ( splitUniqSupply, uniqFromSupply )
+import Util ( zipWithEqual, mapAccumL )
+import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{New ids}
+\section{Dealing with a single binder}
%* *
%************************************************************************
+When we hit a binder we may need to
+ (a) apply the the type envt (if non-empty) to its type
+ (b) apply the type envt and id envt to its SpecEnv (if it has one)
+ (c) give it a new unique to avoid name clashes
+
\begin{code}
-newId :: Type -> SmplM Id
-newId ty
- = getUniqueSmpl `thenSmpl` \ uniq ->
- returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc)
-
-newIds :: [Type] -> SmplM [Id]
-newIds tys
- = getUniquesSmpl (length tys) `thenSmpl` \ uniqs ->
- returnSmpl (zipWithEqual "newIds" mk_id tys uniqs)
- where
- mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
+simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
+simplBinders bndrs thing_inside
+ = getSwitchChecker `thenSmpl` \ sw_chkr ->
+ getSimplBinderStuff `thenSmpl` \ stuff ->
+ let
+ must_clone = switchIsOn sw_chkr SimplPleaseClone
+ (stuff', bndrs') = mapAccumL (subst_binder must_clone) stuff bndrs
+ in
+ setSimplBinderStuff stuff' $
+ thing_inside bndrs'
+
+simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
+simplBinder bndr thing_inside
+ = getSwitchChecker `thenSmpl` \ sw_chkr ->
+ getSimplBinderStuff `thenSmpl` \ stuff ->
+ let
+ must_clone = switchIsOn sw_chkr SimplPleaseClone
+ (stuff', bndr') = subst_binder must_clone stuff bndr
+ in
+ setSimplBinderStuff stuff' $
+ thing_inside bndr'
+
+-- Same semantics as simplBinders, but a little less
+-- plumbing and hence a little more efficient.
+-- Maybe not worth the candle?
+simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
+simplIds ids thing_inside
+ = getSwitchChecker `thenSmpl` \ sw_chkr ->
+ getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
+ let
+ must_clone = switchIsOn sw_chkr SimplPleaseClone
+ (id_subst', in_scope', us', ids') = substIds (simpl_clone_fn must_clone)
+ ty_subst id_subst in_scope us ids
+ in
+ setSimplBinderStuff (ty_subst, id_subst', in_scope', us') $
+ thing_inside ids'
+
+subst_binder must_clone (ty_subst, id_subst, in_scope, us) bndr
+ | isTyVar bndr
+ = case substTyVar ty_subst in_scope bndr of
+ (ty_subst', in_scope', bndr') -> ((ty_subst', id_subst, in_scope', us), bndr')
+
+ | otherwise
+ = case substId (simpl_clone_fn must_clone) ty_subst id_subst in_scope us bndr of
+ (id_subst', in_scope', us', bndr')
+ -> ((ty_subst, id_subst', in_scope', us'), bndr')
+
+simpl_clone_fn must_clone in_scope us id
+ | (must_clone && isLocalName (idName id))
+ || id `elemVarSet` in_scope
+ = case splitUniqSupply us of
+ (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2))
+
+ | otherwise
+ = Nothing
\end{code}
%************************************************************************
%* *
-\subsection{Floating}
+\subsection{Local tyvar-lifting}
%* *
%************************************************************************
-The function @floatExposesHNF@ tells whether let/case floating will
-expose a head normal form. It is passed booleans indicating the
-desired strategy.
-
-\begin{code}
-floatExposesHNF
- :: Bool -- Float let(rec)s out of rhs
- -> Bool -- Float cheap primops out of rhs
- -> GenCoreExpr bdr Id flexi
- -> Bool
-
-floatExposesHNF float_lets float_primops rhs
- = try rhs
- where
- try (Case (Prim _ _) (PrimAlts alts deflt) )
- | float_primops && null alts
- = or (try_deflt deflt : map try_alt alts)
-
- try (Let bind body) | float_lets = try body
-
- -- `build g'
- -- is like a HNF,
- -- because it *will* become one.
- -- likewise for `augment g h'
- --
- try (App (App (Var bld) _) _) | bld == buildId = True
- try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
-
- try other = case mkFormSummary other of
- VarForm -> True
- ValueForm -> True
- other -> False
- {- but *not* necessarily "BottomForm"...
-
- We may want to float a let out of a let to expose WHNFs,
- but to do that to expose a "bottom" is a Bad Idea:
- let x = let y = ...
- in ...error ...y... -- manifestly bottom using y
- in ...
- =/=>
- let y = ...
- in let x = ...error ...y...
- in ...
-
- as y is only used in case of an error, we do not want
- to allocate it eagerly as that's a waste.
- -}
-
- try_alt (lit,rhs) = try rhs
-
- try_deflt NoDefault = False
- try_deflt (BindDefault _ rhs) = try rhs
-\end{code}
-
-
-Local tyvar-lifting
-~~~~~~~~~~~~~~~~~~~
mkRhsTyLam tries this transformation, when the big lambda appears as
the RHS of a let(rec) binding:
into
letrec g' = /\a -> ... g' a ...
in
- let f = /\ a -> f a
+ let f = /\ a -> g' a
which is better. In effect, it means that big lambdas don't impede
let-floating.
G = F . Let {xi = xi' tvs}
\begin{code}
-mkRhsTyLam [] body = returnSmpl body
+mkRhsTyLam (Lam b e)
+ | isTyVar b = case collectTyBinders e of
+ (bs,body) -> mkRhsTyLam_help (b:bs) body
+
+mkRhsTyLam other_expr -- No-op if not a type lambda
+ = returnSmpl other_expr
-mkRhsTyLam tyvars body
+
+mkRhsTyLam_help tyvars body
= go (\x -> x) body
where
- main_tyvar_set = mkTyVarSet tyvars
+ main_tyvar_set = mkVarSet tyvars
go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
= go (fn . Let bind) body
go fn (Let bind@(NonRec var rhs) body)
- = mk_poly tyvars_here var_ty `thenSmpl` \ (var', rhs') ->
+ = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
- returnSmpl (Let (NonRec var' (mkTyLam tyvars_here (fn rhs))) body')
+ returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
where
- var_ty = idType var
tyvars_here = tyvars
- -- tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfTypes var_ty)
+ -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
-- tyvars_here was an attempt to reduce the number of tyvars
-- wrt which the new binding is abstracted. But the naive
-- approach of abstract wrt the tyvars free in the Id's type
-- abstracting wrt *all* the tyvars. We'll see if that
-- gives rise to problems. SLPJ June 98
+ var_ty = idType var
+
go fn (Let (Rec prs) body)
- = mapAndUnzipSmpl (mk_poly tyvars_here) var_tys `thenSmpl` \ (vars', rhss') ->
+ = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
let
gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
in
go gn body `thenSmpl` \ body' ->
- returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars_here (gn rhs) | rhs <- rhss])) body')
+ returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
where
(vars,rhss) = unzip prs
- var_tys = map idType vars
- tyvars_here = tyvars -- See notes on tyvars_here above
+ tyvars_here = tyvars
+ -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
+ -- See notes with tyvars_here above
- go fn body = returnSmpl (mkTyLam tyvars (fn body))
+ var_tys = map idType vars
- mk_poly tyvars_here var_ty
- = newId (mkForAllTys tyvars_here var_ty) `thenSmpl` \ poly_id ->
- returnSmpl (poly_id, mkTyApp (Var poly_id) (mkTyVarTys tyvars_here))
+ go fn body = returnSmpl (mkLams tyvars (fn body))
+
+ mk_poly tyvars_here var
+ = newId (mkForAllTys tyvars_here (idType var)) $ \ poly_id ->
+ let
+ -- It's crucial to copy the inline-prag of the original var, because
+ -- we're looking at occurrence-analysed but as yet unsimplified code!
+ -- In particular, we mustn't lose the loop breakers.
+ --
+ -- *However* we don't want to retain a single-occurrence or dead-var info
+ -- because we're adding a load of "silly bindings" of the form
+ -- var _U_ = poly_var t1 t2
+ -- with a must-inline pragma on the silly binding to prevent the
+ -- poly-var from being inlined right back in. Since poly_var now
+ -- occurs inside an INLINE binding, it should be given a ManyOcc,
+ -- else it may get inlined unconditionally
+ poly_inline_prag = case getInlinePragma var of
+ ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo
+ IAmDead -> NoInlinePragInfo
+ var_inline_prag -> var_inline_prag
+
+ poly_id' = setInlinePragma poly_id poly_inline_prag
+ in
+ returnSmpl (poly_id', mkTyApps (Var poly_id') (mkTyVarTys tyvars_here))
- mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
+ mk_silly_bind var rhs = NonRec (setInlinePragma var IWantToBeINLINEd) rhs
-- The addInlinePragma is really important! If we don't say
-- INLINE on these silly little bindings then look what happens!
-- Suppose we start with:
-- * so we're back to square one
-- The silly binding for g* must be INLINE, so that no inlining
-- will happen in its RHS.
+ -- PS: Jun 98: actually this isn't important any more;
+ -- inlineUnconditionally will catch the type applicn
+ -- and inline it unconditionally, without ever trying
+ -- to simplify the RHS
\end{code}
-Eta reduction
-~~~~~~~~~~~~~
+
+%************************************************************************
+%* *
+\subsection{Eta reduction}
+%* *
+%************************************************************************
+
@etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
e.g. \ x y -> f x y ===> f
try to make the unfolding smaller;
b) In tidyCoreExpr, which is done just before converting to STG.
-But we only do this if it gets rid of a whole lambda, not part.
-The idea is that lambdas are often quite helpful: they indicate
-head normal forms, so we don't want to chuck them away lightly.
-But if they expose a simple variable then we definitely win. Even
-if they expose a type application we win. So we check for this special
-case.
-
-It does arise:
-
- f xs = [y | (y,_) <- xs]
-
-gives rise to a recursive function for the list comprehension, and
-f turns out to be just a single call to this recursive function.
-
-Doing eta on type lambdas is useful too:
-
- /\a -> <expr> a ===> <expr>
-
-where <expr> doesn't mention a.
-This is sometimes quite useful, because we can get the sequence:
-
- f ab d = let d1 = ...d... in
- letrec f' b x = ...d...(f' b)... in
- f' b
-specialise ==>
-
- f.Int b = letrec f' b x = ...dInt...(f' b)... in
- f' b
-
-float ==>
+But we only do this if
+ i) It gets rid of a whole lambda, not part.
+ The idea is that lambdas are often quite helpful: they indicate
+ head normal forms, so we don't want to chuck them away lightly.
- f' b x = ...dInt...(f' b)...
- f.Int b = f' b
-
-Now we really want to simplify to
-
- f.Int = f'
-
-and then replace all the f's with f.Ints.
-
-N.B. We are careful not to partially eta-reduce a sequence of type
-applications since this breaks the specialiser:
-
- /\ a -> f Char# a =NO=> f Char#
+ ii) It exposes a simple variable or a type application; in short
+ it exposes a "trivial" expression. (exprIsTrivial)
\begin{code}
etaCoreExpr :: CoreExpr -> CoreExpr
-
+ -- ToDo: we should really check that we don't turn a non-bottom
+ -- lambda into a bottom variable. Sigh
etaCoreExpr expr@(Lam bndr body)
| opt_DoEtaReduction
- = case etaCoreExpr body of
- App fun arg | eta_match bndr arg &&
- residual_ok fun
- -> fun -- Eta
- other -> expr -- Can't eliminate it, so do nothing at all
+ = check (reverse binders) body
where
- eta_match (ValBinder v) (VarArg v') = v == v'
- eta_match (TyBinder tv) (TyArg ty) = case getTyVar_maybe ty of
- Nothing -> False
- Just tv' -> tv == tv'
- eta_match bndr arg = False
-
- residual_ok :: CoreExpr -> Bool -- Checks for type application
- -- and function not one of the
- -- bound vars
-
- (VarArg v) `mentions` (ValBinder v') = v == v'
- (TyArg ty) `mentions` (TyBinder tv) = tv `elementOfTyVarSet` tyVarsOfType ty
- bndr `mentions` arg = False
-
- residual_ok (Var v)
- = not (VarArg v `mentions` bndr)
- residual_ok (App fun arg)
- | arg `mentions` bndr = False
- | otherwise = residual_ok fun
- residual_ok (Note (Coerce to_ty from_ty) body)
- | TyArg to_ty `mentions` bndr
- || TyArg from_ty `mentions` bndr = False
- | otherwise = residual_ok body
-
- residual_ok other = False -- Safe answer
- -- This last clause may seem conservative, but consider:
- -- primops, constructors, and literals, are impossible here
- -- let and case are unlikely (the argument would have been floated inside)
- -- SCCs we probably want to be conservative about (not sure, but it's safe to be)
+ (binders, body) = collectBinders expr
+
+ check [] body
+ | exprIsTrivial body && not (any (`elemVarSet` body_fvs) binders)
+ = body -- Success!
+ where
+ body_fvs = exprFreeVars body
+
+ check (b : bs) (App fun arg)
+ | (varToCoreExpr b `cheapEqExpr` arg)
+ && not (is_strict_binder b)
+ = check bs fun
+
+ check _ _ = expr -- Bale out
+
+ -- We don't want to eta-abstract (\x -> f x) if x carries a "strict"
+ -- demand info. That demand info conveys useful information to the
+ -- call site, via the let-to-case transform, so we don't want to discard it.
+ is_strict_binder b = isId b && isStrict (getIdDemandInfo b)
etaCoreExpr expr = expr -- The common case
\end{code}
-Eta expansion
-~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Eta expansion}
+%* *
+%************************************************************************
+
@etaExpandCount@ takes an expression, E, and returns an integer n,
such that
100, to represent "infinity", which is a bit of a hack.
\begin{code}
-etaExpandCount :: GenCoreExpr bdr Id flexi
+etaExpandCount :: CoreExpr
-> Int -- Number of extra args you can safely abstract
-etaExpandCount (Lam (ValBinder _) body)
+etaExpandCount (Lam b body)
+ | isId b
= 1 + etaExpandCount body
etaExpandCount (Let bind body)
- | all manifestlyCheap (rhssOfBind bind)
+ | all exprIsCheap (rhssOfBind bind)
= etaExpandCount body
-etaExpandCount (Case scrut alts)
- | manifestlyCheap scrut
- = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
+etaExpandCount (Case scrut _ alts)
+ | exprIsCheap scrut
+ = minimum [etaExpandCount rhs | (_,_,rhs) <- alts]
etaExpandCount fun@(Var _) = eta_fun fun
+
+etaExpandCount (App fun (Type ty))
+ = eta_fun fun
etaExpandCount (App fun arg)
- | notValArg arg = eta_fun fun
- | otherwise = case etaExpandCount fun of
- 0 -> 0
- n -> n-1 -- Knock off one
+ | exprIsCheap arg = case etaExpandCount fun of
+ 0 -> 0
+ n -> n-1 -- Knock off one
etaExpandCount other = 0 -- Give up
-- Lit, Con, Prim,
-- Case with non-whnf scrutinee
-----------------------------
-eta_fun :: GenCoreExpr bdr Id flexi -- The function
- -> Int -- How many args it can safely be applied to
+eta_fun :: CoreExpr -- The function
+ -> Int -- How many args it can safely be applied to
-eta_fun (App fun arg) | notValArg arg = eta_fun fun
+eta_fun (App fun (Type ty)) = eta_fun fun
-eta_fun expr@(Var v)
+eta_fun (Var v)
| isBottomingId v -- Bottoming ids have "infinite arity"
= 10000 -- Blargh. Infinite enough!
-eta_fun expr@(Var v) = idMinArity v
+eta_fun (Var v) = arityLowerBound (getIdArity v)
eta_fun other = 0 -- Give up
\end{code}
-@manifestlyCheap@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form, or is cheap to get to WHNF.
-By ``cheap'' we mean a computation we're willing to duplicate in order
-to bring a couple of lambdas together. The main examples of things
-which aren't WHNF but are ``cheap'' are:
-
- * case e of
- pi -> ei
-
- where e, and all the ei are cheap; and
-
- * let x = e
- in b
-
- where e and b are cheap; and
- * op x1 ... xn
-
- where op is a cheap primitive operator
+%************************************************************************
+%* *
+\subsection{Case absorption and identity-case elimination}
+%* *
+%************************************************************************
\begin{code}
-manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
-
-manifestlyCheap (Var _) = True
-manifestlyCheap (Lit _) = True
-manifestlyCheap (Con _ _) = True
-manifestlyCheap (Note _ e) = manifestlyCheap e
-manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
-manifestlyCheap (Prim op _) = primOpIsCheap op
-
-manifestlyCheap (Let bind body)
- = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
+mkCase :: SwitchChecker -> OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
+\end{code}
-manifestlyCheap (Case scrut alts)
- = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
+@mkCase@ tries the following transformation (if possible):
+
+case e of b { ==> case e of b {
+ p1 -> rhs1 p1 -> rhs1
+ ... ...
+ pm -> rhsm pm -> rhsm
+ _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn}
+ {or (prim) case b of b' { _ -> rhsn}}
+ pn -> rhsn ...
+ ... po -> rhso[b/b']
+ po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd}
+ _ -> rhsd
+}
+
+which merges two cases in one case when -- the default alternative of
+the outer case scrutises the same variable as the outer case This
+transformation is called Case Merging. It avoids that the same
+variable is scrutinised multiple times.
-manifestlyCheap other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, _, vargs) ->
- case fun of
+\begin{code}
+mkCase sw_chkr scrut outer_bndr outer_alts
+ | switchIsOn sw_chkr SimplCaseMerge
+ && maybeToBool maybe_case_in_default
+
+ = tick CaseMerge `thenSmpl_`
+ returnSmpl (Case scrut outer_bndr new_alts)
+ -- Warning: don't call mkCase recursively!
+ -- Firstly, there's no point, because inner alts have already had
+ -- mkCase applied to them, so they won't have a case in their default
+ -- Secondly, if you do, you get an infinite loop, because the bindNonRec
+ -- in munge_rhs puts a case into the DEFAULT branch!
+ where
+ new_alts = outer_alts_without_deflt ++ munged_inner_alts
+ maybe_case_in_default = case findDefault outer_alts of
+ (outer_alts_without_default,
+ Just (Case (Var scrut_var) inner_bndr inner_alts))
+
+ | outer_bndr == scrut_var
+ -> Just (outer_alts_without_default, inner_bndr, inner_alts)
+ other -> Nothing
+
+ Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
+
+ -- Eliminate any inner alts which are shadowed by the outer ones
+ outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
+
+ munged_inner_alts = [ (con, args, munge_rhs rhs)
+ | (con, args, rhs) <- inner_alts,
+ not (con `elem` outer_cons) -- Eliminate shadowed inner alts
+ ]
+ munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
+\end{code}
- Var f | isBottomingId f -> True -- Application of a function which
- -- always gives bottom; we treat this as
- -- a WHNF, because it certainly doesn't
- -- need to be shared!
+Now the identity-case transformation:
- Var f -> let
- num_val_args = length vargs
- in
- num_val_args == 0 || -- Just a type application of
- -- a variable (f t1 t2 t3)
- -- counts as WHNF
- num_val_args < idMinArity f
+ case e of ===> e
+ True -> True;
+ False -> False
- _ -> False
- }
+and similar friends.
+\begin{code}
+mkCase sw_chkr scrut case_bndr alts
+ | all identity_alt alts
+ = tick CaseIdentity `thenSmpl_`
+ returnSmpl scrut
+ where
+ identity_alt (DEFAULT, [], Var v) = v == case_bndr
+ identity_alt (con, args, Con con' args') = con == con' &&
+ and (zipWithEqual "mkCase"
+ cheapEqExpr
+ (map Type arg_tys ++ map varToCoreExpr args)
+ args')
+ identity_alt other = False
+
+ arg_tys = case splitTyConApp_maybe (idType case_bndr) of
+ Just (tycon, arg_tys) -> arg_tys
\end{code}
+The catch-all case
\begin{code}
-simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
-
-simplIdWantsToBeINLINEd id env
- = {- We used to arrange that in the final simplification pass we'd switch
- off all INLINE pragmas, so that we'd inline workers back into the
- body of their wrapper if the wrapper hadn't itself been inlined by then.
- This occurred especially for methods in dictionaries.
-
- We no longer do this:
- a) there's a good chance that the exported wrapper will get
- inlined in some importing scope, in which case we don't
- want to lose the w/w idea.
-
- b) The occurrence analyser must agree about what has an
- INLINE pragma. Not hard, but delicate.
-
- c) if the worker gets inlined we have to tell the wrapepr
- that it's no longer a wrapper, else the interface file stuff
- asks for a worker that no longer exists.
-
- if switchIsSet env IgnoreINLINEPragma
- then False
- else
- -}
-
- idWantsToBeINLINEd id
-
-idMinArity id = case getIdArity id of
- UnknownArity -> 0
- ArityAtLeast n -> n
- ArityExactly n -> n
-
-singleConstructorType :: Type -> Bool
-singleConstructorType ty
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
- other -> False
-
-typeOkForCase :: Type -> Bool
-typeOkForCase ty
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, ty_args, []) -> False
- Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
- other -> False
- -- Null data cons => type is abstract, which code gen can't
- -- currently handle. (ToDo: when return-in-heap is universal we
- -- don't need to worry about this.)
+mkCase sw_chkr other_scrut case_bndr other_alts
+ = returnSmpl (Case other_scrut case_bndr other_alts)
\end{code}
-
-substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
-It exploits the known structure of a SpecEnv's RHS to have fewer
-equations.
-
\begin{code}
-substSpecEnvRhs te ve rhs
- = go te ve rhs
+findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
+findDefault [] = ([], Nothing)
+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
+ ([], Just rhs)
+findDefault (alt : alts) = case findDefault alts of
+ (alts', deflt) -> (alt : alts', deflt)
+
+findAlt :: Con -> [CoreAlt] -> CoreAlt
+findAlt con alts
+ = go alts
where
- go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
- go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
- Just (SubstVar v') -> VarArg v'
- Just (SubstLit l) -> LitArg l
- Nothing -> VarArg v)
- go te ve (Var v) = case lookupIdEnv ve v of
- Just (SubstVar v') -> Var v'
- Just (SubstLit l) -> Lit l
- Nothing -> Var v
-
- -- These equations are a bit half baked, because
- -- they don't deal properly wih capture.
- -- But I'm sure it'll never matter... sigh.
- go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
- where
- te' = delFromTyVarEnv te tyvar
-
- go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
- where
- ve' = delOneFromIdEnv ve v
+ go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
+ go (alt : alts) | matches alt = alt
+ | otherwise = go alts
+
+ matches (DEFAULT, _, _) = True
+ matches (con1, _, _) = con == con1
\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1996
-%
-\section[SimplVar]{Simplifier stuff related to variables}
-
-\begin{code}
-module SimplVar (
- completeVar,
- simplBinder, simplBinders, simplTyBinder, simplTyBinders
- ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} Simplify ( simplExpr )
-
-import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
-import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- FormSummary, whnfOrBottom, okToInline,
- smallEnoughToInline )
-import CoreUtils ( coreExprCc )
-import BinderInfo ( BinderInfo, noBinderInfo )
-
-import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
-import Id ( idType, getIdUnfolding, externallyVisibleId,
- getIdSpecialisation, setIdSpecialisation,
- idMustBeINLINEd, idHasNoFreeTyVars,
- mkIdWithNewUniq, mkIdWithNewType,
- IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
- )
-import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, emptySpecEnv )
-import OccurAnal ( occurAnalyseGlobalExpr )
-import Literal ( isNoRepLit )
-import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
-import SimplEnv
-import SimplMonad
-import Type ( instantiateTy, mkTyVarTy )
-import TyCon ( tyConFamilySize )
-import TyVar ( TyVar, cloneTyVar,
- isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
- addOneToTyVarSet, elementOfTyVarSet
- )
-import Maybes ( maybeToBool )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Simplify-var]{Completing variables}
-%* *
-%************************************************************************
-
-This where all the heavy-duty unfolding stuff comes into its own.
-
-\begin{code}
-completeVar env inline_call var args result_ty
-
- | maybeToBool maybe_magic_result
- = tick MagicUnfold `thenSmpl_`
- magic_result
-
- -- Look for existing specialisations before
- -- trying inlining
- | maybeToBool maybe_specialisation
- = tick SpecialisationDone `thenSmpl_`
- simplExpr (bindTyVars env spec_bindings)
- (occurAnalyseGlobalExpr spec_template)
- remaining_args
- result_ty
-
-
- -- Look for an unfolding. There's a binding for the
- -- thing, but perhaps we want to inline it anyway
- | has_unfolding
- && (idMustBeINLINEd var ||
- (not essential_unfoldings_only
- -- If "essential_unfoldings_only" is true we do no inlinings at all,
- -- EXCEPT for things that absolutely have to be done
- -- (see comments with idMustBeINLINEd)
- && (inline_call || ok_to_inline)
- && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)))
- =
-{-
- pprTrace "Unfolding" (ppr var) $
- simplCount `thenSmpl` \ n ->
- (if n > 1000 then
- pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
- else
- id
- )
- (if n>4000 then
- returnSmpl (mkGenApp (Var var) args)
- else
--}
- tickUnfold var `thenSmpl_`
- simplExpr unf_env unf_template args result_ty
-
- | inline_call -- There was an InlineCall note, but we didn't inline!
- = returnSmpl (mkGenApp (Note InlineCall (Var var')) args)
-
- | otherwise
- = returnSmpl (mkGenApp (Var var') args)
-
- where
- (var', occ_info, unfolding) = case lookupOutIdEnv env var of
- Just stuff -> stuff
- Nothing -> (var, noBinderInfo, getIdUnfolding var)
-
- ---------- Magic unfolding stuff
- maybe_magic_result = case unfolding of
- MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
- env args
- other -> Nothing
- Just magic_result = maybe_magic_result
-
- ---------- Unfolding stuff
- has_unfolding = case unfolding of
- CoreUnfolding _ _ _ -> True
- other -> False
-
- CoreUnfolding form guidance unf_template = unfolding
- unf_env = zapSubstEnvs env
- -- The template is already simplified, so don't re-substitute.
- -- This is VITAL. Consider
- -- let x = e in
- -- let y = \z -> ...x... in
- -- \ x -> ...y...
- -- We'll clone the inner \x, adding x->x' in the id_subst
- -- Then when we inline y, we must *not* replace x by x' in
- -- the inlined copy!!
-
- ---------- Specialisation stuff
- (ty_args, remaining_args) = initialTyArgs args
- maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
- Just (spec_bindings, spec_template) = maybe_specialisation
-
-
- ---------- Switches
- sw_chkr = getSwitchChecker env
- essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
- is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee
- ok_to_inline = okToInline var (whnfOrBottom form) small_enough occ_info
- small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance
- arg_evals = [is_evald arg | arg <- args, isValArg arg]
-
- is_evald (VarArg v) = isEvaluated (lookupUnfolding env v)
- is_evald (LitArg l) = True
-
-
-
-
--- costCentreOk checks that it's ok to inline this thing
--- The time it *isn't* is this:
---
--- f x = let y = E in
--- scc "foo" (...y...)
---
--- Here y has a "current cost centre", and we can't inline it inside "foo",
--- regardless of whether E is a WHNF or not.
-
-costCentreOk cc_encl cc_rhs
- = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs)
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Dealing with a single binder}
-%* *
-%************************************************************************
-
-When we hit a binder we may need to
- (a) apply the the type envt (if non-empty) to its type
- (b) apply the type envt and id envt to its SpecEnv (if it has one)
- (c) give it a new unique to avoid name clashes
-
-\begin{code}
-simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
-simplBinder env (id, occ_info)
- | no_need_to_clone -- Not in scope (or cloning disabled), so no need to clone
- && empty_ty_subst -- No type substitution to do inside the Id
- && isNullIdEnv id_subst -- No id substitution to do inside the Id
- = let
- env' = setIdEnv env (new_in_scope_ids id, id_subst)
- in
- returnSmpl (env', id)
-
- | otherwise
- =
-#if DEBUG
- -- I reckon the empty-env thing should catch
- -- most no-free-tyvars things, so this test should be redundant
--- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
-#endif
- (let
- -- id1 has its type zapped
- id1 | empty_ty_subst = id
- | otherwise = mkIdWithNewType id ty'
- -- id2 has its SpecEnv zapped (see comment inside Simplify.completeBind)
- id2 | empty_spec_env = id1
- | otherwise = setIdSpecialisation id1 emptySpecEnv
- in
- if no_need_to_clone then
- -- No need to clone, but we *must* zap any current substitution
- -- for the variable. For example:
- -- (\x.e) with id_subst = [x |-> e']
- -- Here we must simply zap the substitution for x
- let
- new_id_subst = delOneFromIdEnv id_subst id
- new_env = setIdEnv env (new_in_scope_ids id2, new_id_subst)
- in
- returnSmpl (new_env, id2)
- else
- -- Must clone
- getUniqueSmpl `thenSmpl` \ uniq ->
- let
- id3 = mkIdWithNewUniq id2 uniq
- new_env = setIdEnv env (new_in_scope_ids id3,
- addOneToIdEnv id_subst id (SubstVar id3))
- in
- returnSmpl (new_env, id3)
- )
- where
- ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
-
- empty_ty_subst = isEmptyTyVarEnv ty_subst
- empty_spec_env = isEmptySpecEnv (getIdSpecialisation id)
-
- no_need_to_clone = not need_to_clone
- need_to_clone = not (externallyVisibleId id) &&
- ( elemIdEnv id in_scope_ids || clone_binds_please)
- {-
- The SimplCloneBinds option isn't just here as another simplifier knob we can
- twiddle. Prior to floating bindings outwards, we have to make sure that no
- duplicate bindings exist as floating may cause bindings with identical
- uniques to come into scope, with disastrous consequences.
-
- To avoid this situation, we make sure that cloning is turned *on* in the
- simplifier pass prior to running an outward floating pass.
- -}
- clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
-
- new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
-
- ty = idType id
- ty' = instantiateTy ty_subst ty
-
- sw_chkr = getSwitchChecker env
-
-
-simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
-simplBinders env binders = mapAccumLSmpl simplBinder env binders
-\end{code}
-
-\begin{code}
-simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
-simplTyBinder env tyvar
- | no_need_to_clone
- = -- No need to clone; but must zap any binding for tyvar
- -- see comments with simplBinder above
- let
- env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar,
- delFromTyVarEnv ty_subst tyvar)
- in
- returnSmpl (env', tyvar)
-
- | otherwise -- Need to clone
- = getUniqueSmpl `thenSmpl` \ uniq ->
- let
- tyvar' = cloneTyVar tyvar uniq
- env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar',
- addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar'))
- in
- returnSmpl (env', tyvar')
- where
- ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
- no_need_to_clone = not (tyvar `elementOfTyVarSet` tyvars) &&
- not clone_binds_please
-
- clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
- sw_chkr = getSwitchChecker env
-
-
-simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
-simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
-\end{code}
+++ /dev/null
-_interface_ Simplify 1
-_exports_
-Simplify simplBind simplExpr;
-_declarations_
-1 simplBind _:_ SimplEnv.SimplEnv
- -> SimplEnv.InBinding
- -> (SimplEnv.SimplEnv -> SimplMonad.SmplM SimplEnv.OutExpr)
- -> SimplEnv.OutType
- -> SimplMonad.SmplM SimplEnv.OutExpr ;;
-1 simplExpr _:_ SimplEnv.SimplEnv
- -> SimplEnv.InExpr -> [SimplEnv.OutArg]
- -> SimplEnv.OutType
- -> SimplMonad.SmplM SimplEnv.OutExpr ;;
-
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
\begin{code}
-module Simplify ( simplTopBinds, simplExpr, simplBind ) where
+module Simplify ( simplExpr, simplBind ) where
#include "HsVersions.h"
-import BinderInfo
-import CmdLineOpts ( SimplifierSwitch(..) )
-import ConFold ( completePrim )
-import CoreUnfold ( Unfolding, mkFormSummary, noUnfolding,
- exprIsTrivial, whnfOrBottom, inlineUnconditionally,
- FormSummary(..)
+import CmdLineOpts ( switchIsOn, opt_SccProfilingOn,
+ opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings,
+ SimplifierSwitch(..)
)
-import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
-import CoreSyn
-import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
- unTagBinders, squashableDictishCcExpr
+import SimplMonad
+import SimplUtils ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam,
+ simplBinder, simplBinders, simplIds, findDefault
)
-import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
- addIdArity, getIdArity, getIdSpecialisation, setIdSpecialisation,
- getIdDemandInfo, addIdDemandInfo, isSpecPragmaId
+import Var ( TyVar, mkSysTyVar, tyVarKind )
+import VarEnv
+import VarSet
+import Id ( Id, idType,
+ getIdUnfolding, setIdUnfolding,
+ getIdSpecialisation, setIdSpecialisation,
+ getIdDemandInfo, setIdDemandInfo,
+ getIdArity, setIdArity,
+ setInlinePragma, getInlinePragma, idMustBeINLINEd,
+ idWantsToBeINLINEd
)
+import IdInfo ( InlinePragInfo(..), OccInfo(..),
+ ArityInfo, atLeastArity, arityLowerBound, unknownArity
+ )
+import Demand ( Demand, isStrict, wwLazy )
+import Const ( isWHNFCon, conOkForAlt )
+import ConFold ( cleverMkPrimApp )
+import PrimOp ( PrimOp )
+import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys )
+import Const ( Con(..) )
+import MagicUFs ( applyMagicUnfoldingFun )
import Name ( isExported, isLocallyDefined )
-import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
- atLeastArity, unknownArity )
-import Literal ( isNoRepLit )
-import Maybes ( maybeToBool )
-import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
-import SimplCase ( simplCase, bindLargeRhs )
-import SimplEnv
-import SimplMonad
-import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders )
-import SimplUtils
-import SpecEnv ( isEmptySpecEnv, substSpecEnv )
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
- mkFunTys, splitAlgTyConApp_maybe,
- splitFunTys, splitFunTy_maybe, isUnpointedType
+import CoreSyn
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ mkUnfolding, smallEnoughToInline,
+ isEvaldUnfolding
)
-import TysPrim ( realWorldStatePrimTy )
-import Util ( Eager, appEager, returnEager, runEager, mapEager,
- isSingleton, zipEqual, zipWithEqual, mapAndUnzip
+import CoreUtils ( IdSubst, SubstCoreExpr(..),
+ cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
+ coreExprType, exprIsCheap, substExpr,
+ FormSummary(..), mkFormSummary, whnfOrBottom
)
-import Outputable
-
+import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv )
+import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
+import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy, applyTys,
+ mkFunTy, splitFunTys, splitTyConApp_maybe, funResultTy )
+import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
+import TysPrim ( realWorldStatePrimTy )
+import PrelVals ( realWorldPrimId )
+import BasicTypes ( StrictnessMark(..) )
+import Maybes ( maybeToBool )
+import Util ( zipWithEqual, stretchZipEqual )
+import PprCore
+import Outputable
\end{code}
-The controlling flags, and what they do
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-passes:
-------
--fsimplify = run the simplifier
--ffloat-inwards = runs the float lets inwards pass
--ffloat = runs the full laziness pass
- (ToDo: rename to -ffull-laziness)
--fupdate-analysis = runs update analyser
--fstrictness = runs strictness analyser
--fsaturate-apps = saturates applications (eta expansion)
-
-options:
--------
--ffloat-past-lambda = OK to do full laziness.
- (ToDo: remove, as the full laziness pass is
- useless without this flag, therefore
- it is unnecessary. Just -ffull-laziness
- should be kept.)
-
--ffloat-lets-ok = OK to float lets out of lets if the enclosing
- let is strict or if the floating will expose
- a WHNF [simplifier].
-
--ffloat-primops-ok = OK to float out of lets cases whose scrutinee
- is a primop that cannot fail [simplifier].
-
--fcode-duplication-ok = allows the previous option to work on cases with
- multiple branches [simplifier].
-
--flet-to-case = does let-to-case transformation [simplifier].
-
--fcase-of-case = does case of case transformation [simplifier].
-
--fpedantic-bottoms = does not allow:
- case x of y -> e ===> e[x/y]
- (which may turn bottom into non-bottom)
-
-
- NOTES ON INLINING
- ~~~~~~~~~~~~~~~~~
-
-Inlining is one of the delicate aspects of the simplifier. By
-``inlining'' we mean replacing an occurrence of a variable ``x'' by
-the RHS of x's definition. Thus
-
- let x = e in ...x... ===> let x = e in ...e...
-
-We have two mechanisms for inlining:
-
-1. Unconditional. The occurrence analyser has pinned an (OneOcc
-FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
-certainly safe to inline this variable, and to drop its binding''.
-(...Umm... if n <= 1; if n > 1, it is still safe, provided you are
-happy to be duplicating code...) When it encounters such a beast, the
-simplifer binds the variable to its RHS (in the id_env) and continues.
-It doesn't even look at the RHS at that stage. It also drops the
-binding altogether.
-
-2. Conditional. In all other situations, the simplifer simplifies
-the RHS anyway, and keeps the new binding. It also binds the new
-(cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
-
-Here, ``suitable'' might mean NoUnfolding (if the occurrence
-info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
-the variable has an INLINE pragma on it). The idea is that anything
-in the UnfoldEnv is safe to use, but also has an enclosing binding if
-you decide not to use it.
-
-Head normal forms
-~~~~~~~~~~~~~~~~~
-We *never* put a non-HNF unfolding in the UnfoldEnv except in the
-INLINE-pragma case.
-
-At one time I thought it would be OK to put non-HNF unfoldings in for
-variables which occur only once [if they got inlined at that
-occurrence the RHS of the binding would become dead, so no duplication
-would occur]. But consider:
-@
- let x = <expensive>
- f = \y -> ...y...y...y...
- in f x
-@
-Now, it seems that @x@ appears only once, but even so it is NOT safe
-to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
-duplicate the references to @x@.
-
-Because of this, the "unconditional-inline" mechanism above is the
-only way in which non-HNFs can get inlined.
-
-INLINE pragmas
-~~~~~~~~~~~~~~
-
-When a variable has an INLINE pragma on it --- which includes wrappers
-produced by the strictness analyser --- we treat it rather carefully.
-
-For a start, we are careful not to substitute into its RHS, because
-that might make it BIG, and the user said "inline exactly this", not
-"inline whatever you get after inlining other stuff inside me". For
-example
-
- let f = BIG
- in {-# INLINE y #-} y = f 3
- in ...y...y...
-
-Here we don't want to substitute BIG for the (single) occurrence of f,
-because then we'd duplicate BIG when we inline'd y. (Exception:
-things in the UnfoldEnv with UnfoldAlways flags, which originated in
-other INLINE pragmas.)
-
-So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
-going into such an RHS.
-
-What about imports? They don't really matter much because we only
-inline relatively small things via imports.
-
-We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
-INLINE pragma. We also do this for the RHSs of recursive decls,
-before looking at the recursive decls. That way we achieve the effect
-of inlining a wrapper in the body of its worker, in the case of a
-mutually-recursive worker/wrapper split.
-
-
-%************************************************************************
-%* *
-\subsection[Simplify-simplExpr]{The main function: simplExpr}
-%* *
-%************************************************************************
-
-At the top level things are a little different.
- * No cloning (not allowed for exported Ids, unnecessary for the others)
- * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
-
-\begin{code}
-simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
+The guts of the simplifier is in this module, but the driver
+loop for the simplifier is in SimplPgm.lhs.
--- Dead code is now discarded by the occurrence analyser,
-
-simplTopBinds env binds
- = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
- simpl_top_binds env (concat binds_s)
- where
- simpl_top_binds env [] = returnSmpl []
-
- simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
- = --- No cloning necessary at top level
- simplBinder env binder `thenSmpl` \ (env1, out_id) ->
- simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) ->
- completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1) ->
- simpl_top_binds new_env binds `thenSmpl` \ binds2 ->
- returnSmpl (binds1 ++ binds2)
-
- simpl_top_binds env (Rec pairs : binds)
- = -- No cloning necessary at top level, but we nevertheless
- -- add the Ids to the environment. This makes sure that
- -- info carried on the Id (such as arity info) gets propagated
- -- to occurrences.
- --
- -- This may seem optional, but I found an occasion when it Really matters.
- -- Consider foo{n} = ...foo...
- -- baz* = foo
- --
- -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
- -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
- -- thing: baz*{n} = ...baz...
- --
- -- Sure we could have made the indirection-shorting a bit cleverer, but
- -- propagating pragma info is a Good Idea anyway.
- simplBinders env (map fst pairs) `thenSmpl` \ (env1, out_ids) ->
- simplRecursiveGroup env1 out_ids pairs `thenSmpl` \ (bind', new_env) ->
- simpl_top_binds new_env binds `thenSmpl` \ binds' ->
- returnSmpl (Rec bind' : binds')
-\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-
-\begin{code}
-simplExpr :: SimplEnv
- -> InExpr -> [OutArg]
- -> OutType -- Type of (e args); i.e. type of overall result
- -> SmplM OutExpr
-\end{code}
-
-The expression returned has the same meaning as the input expression
-applied to the specified arguments.
-
-
-Variables
-~~~~~~~~~
-
\begin{code}
-simplExpr env (Var var) args result_ty
- = simplVar env False {- No InlineCall -} var args result_ty
-\end{code}
+simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr
-Literals
-~~~~~~~~
+simplExpr (Note InlineCall (Var v)) cont
+ = simplVar True v cont
-\begin{code}
-simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
-#ifdef DEBUG
-simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
-#endif
-\end{code}
+simplExpr (Var v) cont
+ = simplVar False v cont
-Primitive applications are simple.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+simplExpr (Con (PrimOp op) args) cont
+ = mapSmpl simplArg args `thenSmpl` \ args' ->
+ rebuild (cleverMkPrimApp op args') cont
-NB: Prim expects an empty argument list! (Because it should be
-saturated and not higher-order. ADR)
+simplExpr (Con con@(DataCon _) args) cont
+ = simplConArgs args $ \ args' ->
+ rebuild (Con con args') cont
-\begin{code}
-simplExpr env (Prim op prim_args) args result_ty
- = ASSERT (null args)
- mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
- simpl_op op `appEager` \ op' ->
- completePrim env op' prim_args'
+simplExpr expr@(Con con@(Literal _) args) cont
+ = ASSERT( null args )
+ rebuild expr cont
+
+simplExpr (App fun arg) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplExpr fun (ApplyTo NoDup arg se cont)
+
+simplExpr (Case scrut bndr alts) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplExpr scrut (Select NoDup bndr alts se cont)
+
+simplExpr (Note (Coerce to from) e) cont
+ | to == from = simplExpr e cont
+ | otherwise = getSubstEnv `thenSmpl` \ se ->
+ simplExpr e (CoerceIt NoDup to se cont)
+
+-- hack: we only distinguish subsumed cost centre stacks for the purposes of
+-- inlining. All other CCCSs are mapped to currentCCS.
+simplExpr (Note (SCC cc) e) cont
+ = setEnclosingCC currentCCS $
+ simplExpr e Stop `thenSmpl` \ e ->
+ rebuild (mkNote (SCC cc) e) cont
+
+simplExpr (Note note e) cont
+ = simplExpr e Stop `thenSmpl` \ e' ->
+ rebuild (mkNote note e') cont
+
+-- Let to case, but only if the RHS isn't a WHNF
+simplExpr (Let (NonRec bndr rhs) body) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplBeta bndr rhs se body cont
+
+simplExpr (Let bind body) cont
+ = (simplBind bind $
+ simplExpr body cont) `thenSmpl` \ (binds', e') ->
+ returnSmpl (mkLets binds' e')
+
+-- Type-beta reduction
+simplExpr expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
+ = ASSERT( isTyVar bndr )
+ tick BetaReduction `thenSmpl_`
+ setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' ->
+ extendTySubst bndr ty' $
+ simplExpr body body_cont
+
+-- Ordinary beta reduction
+simplExpr expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
+ = tick BetaReduction `thenSmpl_`
+ simplBeta bndr' arg arg_se body body_cont
where
- -- PrimOps just need any types in them renamed.
+ bndr' = zapLambdaBndr bndr body body_cont
- simpl_op (CCallOp label is_asm may_gc cconv arg_tys result_ty)
- = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
- simplTy env result_ty `appEager` \ result_ty' ->
- returnEager (CCallOp label is_asm may_gc cconv arg_tys' result_ty')
+simplExpr (Lam bndr body) cont
+ = simplBinder bndr $ \ bndr' ->
+ simplExpr body Stop `thenSmpl` \ body' ->
+ rebuild (Lam bndr' body') cont
- simpl_op other_op = returnEager other_op
-\end{code}
-Constructor applications
-~~~~~~~~~~~~~~~~~~~~~~~~
-Nothing to try here. We only reuse constructors when they appear as the
-rhs of a let binding (see completeLetBinding).
-
-\begin{code}
-simplExpr env (Con con con_args) args result_ty
- = ASSERT( null args )
- mapEager (simplArg env) con_args `appEager` \ con_args' ->
- returnSmpl (Con con con_args')
+simplExpr (Type ty) cont
+ = ASSERT( case cont of { Stop -> True; other -> False } )
+ simplType ty `thenSmpl` \ ty' ->
+ returnSmpl (Type ty')
\end{code}
-Applications are easy too:
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Just stuff 'em in the arg stack
-
+---------------------------------
\begin{code}
-simplExpr env (App fun arg) args result_ty
- = simplArg env arg `appEager` \ arg' ->
- simplExpr env fun (arg' : args) result_ty
+simplArg :: InArg -> SimplM OutArg
+simplArg arg = simplExpr arg Stop
\end{code}
-Type lambdas
-~~~~~~~~~~~~
-
-First the case when it's applied to an argument.
+---------------------------------
+simplConArgs makes sure that the arguments all end up being atomic.
+That means it may generate some Lets, hence the
\begin{code}
-simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
- = tick TyBetaReduction `thenSmpl_`
- simplExpr (bindTyVar env tyvar ty) body args result_ty
+simplConArgs :: [InArg] -> ([OutArg] -> SimplM CoreExpr) -> SimplM CoreExpr
+simplConArgs [] thing_inside
+ = thing_inside []
+
+simplConArgs (arg:args) thing_inside
+ = switchOffInlining (simplArg arg) `thenSmpl` \ arg' ->
+ -- Simplify the RHS with inlining switched off, so that
+ -- only absolutely essential things will happen.
+
+ simplConArgs args $ \ args' ->
+
+ -- If the argument ain't trivial, then let-bind it
+ if exprIsTrivial arg' then
+ thing_inside (arg' : args')
+ else
+ newId (coreExprType arg') $ \ arg_id ->
+ thing_inside (Var arg_id : args') `thenSmpl` \ res ->
+ returnSmpl (bindNonRec arg_id arg' res)
\end{code}
+---------------------------------
\begin{code}
-simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
- = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') ->
- let
- new_result_ty = applyTy result_ty (mkTyVarTy tyvar')
- in
- simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
- returnSmpl (Lam (TyBinder tyvar') body')
-
-#ifdef DEBUG
-simplExpr env e@(Lam (TyBinder _) _) args@(_ : _) result_ty
- = pprPanic "simplExpr:TyLam with non-TyArg" (ppr e $$ ppr args)
-#endif
+simplType :: InType -> SimplM OutType
+simplType ty
+ = getTyEnv `thenSmpl` \ (ty_subst, in_scope) ->
+ returnSmpl (fullSubstTy ty_subst in_scope ty)
\end{code}
-Ordinary lambdas
-~~~~~~~~~~~~~~~~
-
-There's a complication with lambdas that aren't saturated.
-Suppose we have:
-
- (\x. \y. ...x...)
-
-If we did nothing, x is used inside the \y, so would be marked
-as dangerous to dup. But in the common case where the abstraction
-is applied to two arguments this is over-pessimistic.
-So instead we don't take account of the \y when dealing with x's usage;
-instead, the simplifier is careful when partially applying lambdas.
-
\begin{code}
-simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
- = go 0 env expr orig_args
- where
- go n env (Lam (ValBinder binder) body) (val_arg : args)
- | isValArg val_arg -- The lambda has an argument
- = tick BetaReduction `thenSmpl_`
- go (n+1) (bindIdToAtom env binder val_arg) body args
-
- go n env expr@(Lam (ValBinder binder) body) args
- -- The lambda is un-saturated, so we must zap the occurrence info
- -- on the arguments we've already beta-reduced into the body of the lambda
- = ASSERT( null args ) -- Value lambda must match value argument!
- let
- new_env = markDangerousOccs env orig_args
- in
- simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
- `thenSmpl` \ (expr', arity) ->
- returnSmpl expr'
-
- go n env non_val_lam_expr args -- The lambda had enough arguments
- = simplExpr env non_val_lam_expr args result_ty
-\end{code}
+-- Find out whether the lambda is saturated,
+-- if not zap the over-optimistic info in the binder
+
+zapLambdaBndr bndr body body_cont
+ | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont
+ -- The "20" is to catch pathalogical cases with bazillions of arguments
+ -- because we are using an n**2 algorithm here
+ = bndr -- No need to zap
+ | otherwise
+ = setInlinePragma (setIdDemandInfo bndr wwLazy)
+ safe_inline_prag
+ where
+ inline_prag = getInlinePragma bndr
+ demand = getIdDemandInfo bndr
-Let expressions
-~~~~~~~~~~~~~~~
+ safe_info = is_safe_inline_prag && not (isStrict demand)
-\begin{code}
-simplExpr env (Let bind body) args result_ty
- = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
-\end{code}
+ is_safe_inline_prag = case inline_prag of
+ ICanSafelyBeINLINEd StrictOcc nalts -> False
+ ICanSafelyBeINLINEd LazyOcc nalts -> False
+ other -> True
-Case expressions
-~~~~~~~~~~~~~~~~
+ safe_inline_prag = case inline_prag of
+ ICanSafelyBeINLINEd _ nalts
+ -> ICanSafelyBeINLINEd InsideLam nalts
+ other -> inline_prag
-\begin{code}
-simplExpr env expr@(Case scrut alts) args result_ty
- = simplCase env scrut
- (getSubstEnvs env, alts)
- (\env rhs -> simplExpr env rhs args result_ty)
- result_ty
+ definitely_saturated 0 _ _ = False -- Too expensive to find out
+ definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
+ definitely_saturated n (Lam _ _) other_cont = False
+ definitely_saturated n _ _ = True
\end{code}
+%************************************************************************
+%* *
+\subsection{Variables}
+%* *
+%************************************************************************
Coercions
~~~~~~~~~
\begin{code}
-simplExpr env (Note (Coerce to_ty from_ty) body) args result_ty
- = simplCoerce env to_ty from_ty body args result_ty
-
-simplExpr env (Note (SCC cc) body) args result_ty
- = simplSCC env cc body args result_ty
+simplVar inline_call var cont
+ = getValEnv `thenSmpl` \ (id_subst, in_scope) ->
+ case lookupVarEnv id_subst var of
+ Just (Done e)
+ -> zapSubstEnv (simplExpr e cont)
+
+ Just (SubstMe e ty_subst id_subst)
+ -> setSubstEnv (ty_subst, id_subst) (simplExpr e cont)
+
+ Nothing -> let
+ var' = case lookupVarSet in_scope var of
+ Just v' -> v'
+ Nothing ->
+#ifdef DEBUG
+ if isLocallyDefined var && not (idMustBeINLINEd var) then
+ -- Not in scope
+ pprTrace "simplVar:" (ppr var) var
+ else
+#endif
+ var
+ in
+ getSwitchChecker `thenSmpl` \ sw_chkr ->
+ completeVar sw_chkr in_scope inline_call var' cont
+
+completeVar sw_chkr in_scope inline_call var cont
+ | maybeToBool maybe_magic_result
+ = tick MagicUnfold `thenSmpl_`
+ magic_result
+
+ -- Look for existing specialisations before trying inlining
+ | maybeToBool maybe_specialisation
+ = tick SpecialisationDone `thenSmpl_`
+ setSubstEnv (spec_bindings, emptyVarEnv) (
+ -- See note below about zapping the substitution here
+
+ simplExpr spec_template remaining_cont
+ )
--- InlineCall is simple enough to deal with on the spot
--- The only complication is that we slide the InlineCall
--- inwards past any function arguments
-simplExpr env (Note InlineCall expr) args result_ty
- = go expr args
- where
- go (Var v) args = simplVar env True {- InlineCall -} v args result_ty
+ -- Don't actually inline the scrutinee when we see
+ -- case x of y { .... }
+ -- and x has unfolding (C a b). Why not? Because
+ -- we get a silly binding y = C a b. If we don't
+ -- inline knownCon can directly substitute x for y instead.
+ | has_unfolding && is_case_scrutinee && unfolding_is_constr
+ = knownCon (Var var) con con_args cont
+
+ -- Look for an unfolding. There's a binding for the
+ -- thing, but perhaps we want to inline it anyway
+ | has_unfolding && (inline_call || ok_to_inline)
+ = getEnclosingCC `thenSmpl` \ encl_cc ->
+ if must_be_unfolded || costCentreOk encl_cc (coreExprCc unf_template)
+ then -- OK to unfold
+
+ tickUnfold var `thenSmpl_` (
+
+ zapSubstEnv $
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
+#ifdef DEBUG
+ if opt_D_dump_inlinings then
+ pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
+ simplExpr unf_template cont
+ else
+#endif
+ simplExpr unf_template cont
+ )
+ else
+#ifdef DEBUG
+ pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
+#endif
+ -- Can't unfold because of bad cost centre
+ rebuild (Var var) cont
- go (App fun arg) args = simplArg env arg `appEager` \ arg' ->
- go fun (arg' : args)
+ | inline_call -- There was an InlineCall note, but we didn't inline!
+ = rebuild (Note InlineCall (Var var)) cont
- go other args = -- Unexpected discard; report it
- pprTrace "simplExpr: discarding InlineCall" (ppr expr) $
- simplExpr env other args result_ty
-\end{code}
+ | otherwise
+ = rebuild (Var var) cont
+ where
+ unfolding = getIdUnfolding var
+
+ ---------- Magic unfolding stuff
+ maybe_magic_result = case unfolding of
+ MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
+ cont
+ other -> Nothing
+ Just magic_result = maybe_magic_result
+
+ ---------- Unfolding stuff
+ has_unfolding = case unfolding of
+ CoreUnfolding _ _ _ -> True
+ other -> False
+
+ -- overrides cost-centre business
+ must_be_unfolded = case getInlinePragma var of
+ IMustBeINLINEd -> True
+ _ -> False
+
+ CoreUnfolding form guidance unf_template = unfolding
+
+ unfolding_is_constr = case unf_template of
+ Con con _ -> conOkForAlt con
+ other -> False
+ Con con con_args = unf_template
+
+ ---------- Specialisation stuff
+ ty_args = initial_ty_args cont
+ remaining_cont = drop_ty_args cont
+ maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
+ Just (spec_bindings, spec_template) = maybe_specialisation
+
+ initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
+ = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
+ -- Having to do the substitution here is a bit of a bore
+ initial_ty_args other_cont = []
+
+ drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
+ drop_ty_args other_cont = other_cont
+
+ ---------- Switches
+ ok_to_inline = okToInline essential_unfoldings_only is_case_scrutinee var form guidance cont
+ essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
+
+ is_case_scrutinee = case cont of
+ Select _ _ _ _ _ -> True
+ other -> False
+
+----------- costCentreOk
+-- costCentreOk checks that it's ok to inline this thing
+-- The time it *isn't* is this:
+--
+-- f x = let y = E in
+-- scc "foo" (...y...)
+--
+-- Here y has a "current cost centre", and we can't inline it inside "foo",
+-- regardless of whether E is a WHNF or not.
+
+costCentreOk ccs_encl cc_rhs
+ = not opt_SccProfilingOn
+ || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
+ || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
+\end{code}
%************************************************************************
%* *
-\subsection{Simplify RHS of a Let/Letrec}
+\subsection{Bindings}
%* *
%************************************************************************
-simplRhsExpr does arity-expansion. That is, given:
-
- * a right hand side /\ tyvars -> \a1 ... an -> e
- * the information (stored in BinderInfo) that the function will always
- be applied to at least k arguments
-
-it transforms the rhs to
-
- /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
-
-This is a Very Good Thing!
-
\begin{code}
-simplRhsExpr
- :: SimplEnv
- -> InBinder
- -> InExpr
- -> OutId -- The new binder (used only for its type)
- -> SmplM (OutExpr, ArityInfo)
-\end{code}
-
+simplBind :: CoreBind -> SimplM a -> SimplM ([CoreBind], a)
-\begin{code}
-simplRhsExpr env binder@(id,occ_info) rhs new_id
- | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
- -- Deal with the data type case, in which case the elaborate
- -- eta-expansion nonsense is really quite a waste of time.
- = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
- returnSmpl (rhs', ArityExactly 0)
-
- | otherwise -- OK, use the big hammer
- = -- Deal with the big lambda part
- simplTyBinders rhs_env tyvars `thenSmpl` \ (lam_env, tyvars') ->
+simplBind (NonRec bndr rhs) thing_inside
+ = simplTopRhs bndr rhs `thenSmpl` \ (binds, rhs', arity, in_scope) ->
+ setInScope in_scope $
+ completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ (maybe_bind, res) ->
let
- body_ty = applyTys rhs_ty (mkTyVarTys tyvars')
+ binds' = case maybe_bind of
+ Just (bndr,rhs) -> binds ++ [NonRec bndr rhs]
+ Nothing -> binds
in
- -- Deal with the little lambda part
- -- Note that we call simplLam even if there are no binders,
- -- in case it can do arity expansion.
- simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
+ returnSmpl (binds', res)
- -- Put on the big lambdas, trying to float out any bindings caught inside
- mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
+simplBind (Rec pairs) thing_inside
+ = simplIds (map fst pairs) $ \ bndrs' ->
+ -- NB: bndrs' don't have unfoldings or spec-envs
+ -- We add them as we go down, using simplPrags
- returnSmpl (rhs', arity)
+ go (pairs `zip` bndrs') `thenSmpl` \ (pairs', thing') ->
+ returnSmpl ([Rec pairs'], thing')
+ where
+ go [] = thing_inside `thenSmpl` \ res ->
+ returnSmpl ([], res)
+
+ go (((bndr, rhs), bndr') : pairs)
+ = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, rhs', arity, in_scope) ->
+ setInScope in_scope $
+ completeBindRec bndr (bndr' `setIdArity` arity)
+ rhs' (go pairs) `thenSmpl` \ (pairs', res) ->
+ returnSmpl (flatten rhs_binds pairs', res)
+
+ flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
+ flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2
+ flatten [] prs = prs
+
+
+completeBindRec bndr bndr' rhs' thing_inside
+ | postInlineUnconditionally bndr etad_rhs
+ -- NB: a loop breaker never has postInlineUnconditionally True
+ -- and non-loop-breakers only have *forward* references
+ = tick PostInlineUnconditionally `thenSmpl_`
+ extendIdSubst bndr (Done etad_rhs) thing_inside
+
+ | otherwise
+ = -- Here's the only difference from completeBindNonRec: we
+ -- don't do simplBinder first, because we've already
+ -- done simplBinder on the recursive binders
+ simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
+ modifyInScope bndr'' $
+ thing_inside `thenSmpl` \ (pairs, res) ->
+ returnSmpl ((bndr'', etad_rhs) : pairs, res)
where
- rhs_ty = idType new_id
- rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
- = switchOffInlining env1 -- See comments with switchOffInlining
- | otherwise
- = env1
-
- -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
- -- for the rhs of top level defs is "OST_CENTRE". Consider
- -- f = \x -> e
- -- g = \y -> let v = f y in scc "x" (v ...)
- -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
- -- want to inline "v" since its CC is dynamically determined.
-
- current_cc = getEnclosingCC env
- env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
- | otherwise = env
-
- (tyvars, body) = collectTyBinders rhs
+ etad_rhs = etaCoreExpr rhs'
\end{code}
-----------------------------------------------------------------
- An old special case that is now nuked.
-
-First a special case for variable right-hand sides
- v = w
-It's OK to simplify the RHS, but it's often a waste of time. Often
-these v = w things persist because v is exported, and w is used
-elsewhere. So if we're not careful we'll eta expand the rhs, only
-to eta reduce it in competeNonRec.
+%************************************************************************
+%* *
+\subsection{Right hand sides}
+%* *
+%************************************************************************
-If we leave the binding unchanged, we will certainly replace v by w at
-every occurrence of v, which is good enough.
+simplRhs basically just simplifies the RHS of a let(rec).
+It does two important optimisations though:
-In fact, it's *better* to replace v by w than to inline w in v's rhs,
-even if this is the only occurrence of w. Why? Because w might have
-IdInfo (such as strictness) that v doesn't.
+ * It floats let(rec)s out of the RHS, even if they
+ are hidden by big lambdas
-Furthermore, there might be other uses of w; if so, inlining w in
-v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
+ * It does eta expansion
-HOWEVER, we have to be careful if w is something that *must* be
-inlined. In particular, its binding may have been dropped. Here's
-an example that actually happened:
- let x = let y = e in y
- in f x
-The "let y" was floated out, and then (since y occurs once in a
-definitely inlinable position) the binding was dropped, leaving
- {y=e} let x = y in f x
-But now using the reasoning of this little section,
-y wasn't inlined, because it was a let x=y form.
+\begin{code}
+simplTopRhs :: InId -> InExpr
+ -> SimplM ([OutBind], OutExpr, ArityInfo, InScopeEnv)
+simplTopRhs bndr rhs
+ = getSubstEnv `thenSmpl` \ bndr_se ->
+ simplRhs bndr bndr_se rhs
+
+simplRhs :: InId -> SubstEnv -> InExpr
+ -> SimplM ([OutBind], OutExpr, ArityInfo, InScopeEnv)
+
+simplRhs bndr bndr_se rhs
+ | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
+ -- inline pragma. But be careful that the InScopeEnv that
+ -- we return does still have inlinings on!
+ = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
+ getInScope `thenSmpl` \ in_scope ->
+ returnSmpl ([], rhs', unknownArity, in_scope)
+
+ | float_exposes_hnf rhs
+ = mkRhsTyLam rhs `thenSmpl` \ rhs' ->
+ -- Swizzle the inner lets past the big lambda (if any)
+ float rhs'
+ | otherwise
+ = finish rhs
+ where
+ float (Let bind body) = tick LetFloatFromLet `thenSmpl_`
+ simplBind bind (float body) `thenSmpl` \ (binds1, (binds2, body', arity, in_scope)) ->
+ returnSmpl (binds1 ++ binds2, body', arity, in_scope)
+ float body = finish body
- HOWEVER
-This "optimisation" turned out to be a bad idea. If there's are
-top-level exported bindings like
+ finish rhs = simplRhs2 bndr bndr_se rhs `thenSmpl` \ (rhs', arity) ->
+ getInScope `thenSmpl` \ in_scope ->
+ returnSmpl ([], rhs', arity, in_scope)
- y = I# 3#
- x = y
+ float_exposes_hnf (Lam b e) | isTyVar b
+ = float_exposes_hnf e -- Ignore leading big lambdas
+ float_exposes_hnf (Let _ e) = try e -- Now look for nested lets
+ float_exposes_hnf e = False -- Don't bother if no lets!
-then y wasn't getting inlined in x's rhs, and we were getting
-bad code. So I've removed the special case from here, and
-instead we only try eta reduction and constructor reuse
-in completeNonRec if the thing is *not* exported.
+ try (Let _ e) = try e
+ try e = exprIsWHNF e
+\end{code}
+---------------------------------------------------------
+ Try eta expansion for RHSs
-\begin{pseudocode}
-simplRhsExpr env binder@(id,occ_info) (Var v) new_id
- | maybeToBool maybe_stop_at_var
- = returnSmpl (Var the_var, getIdArity the_var)
- where
- maybe_stop_at_var
- = case (runEager $ lookupId env v) of
- VarArg v' | not (must_unfold v') -> Just v'
- other -> Nothing
+We need to pass in the substitution environment for the RHS, because
+it might be different to the current one (see simplBeta, as called
+from simplExpr for an applied lambda). The binder needs to
- Just the_var = maybe_stop_at_var
+\begin{code}
+simplRhs2 bndr bndr_se rhs
+ = getSwitchChecker `thenSmpl` \ sw_chkr ->
+ simplBinders tyvars $ \ tyvars' ->
+ simplBinders ids $ \ ids' ->
+
+ if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
+ && not (null ids) -- Prevent eta expansion for both thunks
+ -- (would lose sharing) and variables (nothing gained).
+ -- To see why we ignore it for thunks, consider
+ -- let f = lookup env key in (f 1, f 2)
+ -- We'd better not eta expand f just because it is
+ -- always applied!
+ && not (null extra_arg_tys)
+ then
+ tick EtaExpansion `thenSmpl_`
+ setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
+ `thenSmpl` \ extra_arg_tys' ->
+ newIds extra_arg_tys' $ \ extra_bndrs' ->
+ simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
+ returnSmpl ( mkLams tyvars'
+ $ mkLams ids'
+ $ mkLams extra_bndrs' body',
+ atLeastArity (no_of_ids + no_of_extras))
+ else
+ simplExpr body Stop `thenSmpl` \ body' ->
+ returnSmpl ( mkLams tyvars'
+ $ mkLams ids' body',
+ atLeastArity no_of_ids)
- must_unfold v' = idMustBeINLINEd v'
- || case lookupOutIdEnv env v' of
- Just (_, _, InUnfolding _ _) -> True
- other -> False
-\end{pseudocode}
-
- End of old, nuked, special case.
-------------------------------------------------------------------
+ where
+ (tyvars, ids, body) = collectTyAndValBinders rhs
+ no_of_ids = length ids
+ potential_extra_arg_tys :: [InType] -- NB: InType
+ potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
+ (arg_tys, _) -> drop no_of_ids arg_tys
-%************************************************************************
-%* *
-\subsection{Simplify a lambda abstraction}
-%* *
-%************************************************************************
+ extra_arg_tys :: [InType]
+ extra_arg_tys = take no_extras_wanted potential_extra_arg_tys
+ no_of_extras = length extra_arg_tys
-Simplify (\binders -> body) trying eta expansion and reduction, given that
-the abstraction will always be applied to at least min_no_of_args.
+ no_extras_wanted = -- Use information about how many args the fn is applied to
+ (arity - no_of_ids) `max`
-\begin{code}
-simplValLam env expr min_no_of_args expr_ty
- | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
-
- exprIsTrivial expr || -- or it's a trivial RHS
- -- No eta expansion for trivial RHSs
- -- It's rather a Bad Thing to expand
- -- g = f alpha beta
- -- to
- -- g = \a b c -> f alpha beta a b c
- --
- -- The original RHS is "trivial" (exprIsTrivial), because it generates
- -- no code (renames f to g). But the new RHS isn't.
-
- null potential_extra_binder_tys || -- or ain't a function
- no_of_extra_binders <= 0 -- or no extra binders needed
- = simplBinders env binders `thenSmpl` \ (new_env, binders') ->
- simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
- returnSmpl (mkValLam binders' body', final_arity)
-
- | otherwise -- Eta expansion possible
- = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
- (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
- pprTrace "simplValLam" (vcat [ppr expr,
- ppr expr_ty,
- ppr binders,
- int no_of_extra_binders,
- ppr potential_extra_binder_tys])
- else \x -> x) $
-
- tick EtaExpansion `thenSmpl_`
- simplBinders env binders `thenSmpl` \ (new_env, binders') ->
- newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
- simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
- returnSmpl (
- mkValLam (binders' ++ extra_binders') body',
- final_arity
- )
+ -- See if the body could obviously do with more args
+ etaExpandCount body `max`
- where
- (binders,body) = collectValBinders expr
- no_of_binders = length binders
- (arg_tys, res_ty) = splitFunTys expr_ty
- potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
- pprTrace "simplValLam" (vcat [ppr expr,
- ppr expr_ty,
- ppr binders])
- else \x->x) $
- drop no_of_binders arg_tys
- body_ty = mkFunTys potential_extra_binder_tys res_ty
-
- -- Note: it's possible that simplValLam will be applied to something
- -- with a forall type. Eg when being applied to the rhs of
- -- let x = wurble
- -- where wurble has a forall-type, but no big lambdas at the top.
- -- We could be clever an insert new big lambdas, but we don't bother.
-
- etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
- extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
- final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
-
- no_of_extra_binders = -- First, use the info about how many args it's
- -- always applied to in its scope; but ignore this
- -- info for thunks. To see why we ignore it for thunks,
- -- consider let f = lookup env key in (f 1, f 2)
- -- We'd better not eta expand f just because it is
- -- always applied!
- (min_no_of_args - no_of_binders)
-
- -- Next, try seeing if there's a lambda hidden inside
- -- something cheap.
- -- etaExpandCount can reuturn a huge number (like 10000!) if
- -- it finds that the body is a call to "error"; hence
- -- the use of "min" here.
- `max`
- (etaExpandCount body `min` length potential_extra_binder_tys)
-
- -- Finally, see if it's a state transformer, in which
- -- case we eta-expand on principle! This can waste work,
- -- but usually doesn't
- `max`
- case potential_extra_binder_tys of
+ -- Finally, see if it's a state transformer, in which
+ -- case we eta-expand on principle! This can waste work,
+ -- but usually doesn't
+ case potential_extra_arg_tys of
[ty] | ty == realWorldStatePrimTy -> 1
other -> 0
+
+ arity = arityLowerBound (getIdArity bndr)
+
+ mk_cont [] = Stop
+ mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
\end{code}
%************************************************************************
%* *
-\subsection[Simplify-var]{Variables}
+\subsection{Binding}
%* *
%************************************************************************
-Check if there's a macro-expansion, and if so rattle on. Otherwise do
-the more sophisticated stuff.
-
\begin{code}
-simplVar env inline_call var args result_ty
- = case lookupIdSubst env var of
-
- Just (SubstExpr ty_subst id_subst expr)
- -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
-
- Just (SubstLit lit) -- A boring old literal
- -> ASSERT( null args )
- returnSmpl (Lit lit)
-
- Just (SubstVar var') -- More interesting! An id!
- -> completeVar env inline_call var' args result_ty
-
- Nothing -- Not in the substitution; hand off to completeVar
- -> completeVar env inline_call var args result_ty
-\end{code}
+simplBeta :: InId -- Binder
+ -> InExpr -> SubstEnv -- Arg, with its subst-env
+ -> InExpr -> SimplCont -- Lambda body
+ -> SimplM OutExpr
+#ifdef DEBUG
+simplBeta bndr rhs rhs_se body cont
+ | isTyVar bndr
+ = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
+#endif
+simplBeta bndr rhs rhs_se body cont
+ | (isStrict (getIdDemandInfo bndr) || is_dict bndr)
+ && not (exprIsWHNF rhs)
+ = tick Let2Case `thenSmpl_`
+ getSubstEnv `thenSmpl` \ body_se ->
+ setSubstEnv rhs_se $
+ simplExpr rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
-%************************************************************************
-%* *
-\subsection[Simplify-coerce]{Coerce expressions}
-%* *
-%************************************************************************
+ | preInlineUnconditionally bndr && not opt_NoPreInlining
+ = tick PreInlineUnconditionally `thenSmpl_`
+ case rhs_se of { (ty_subst, id_subst) ->
+ extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
+ simplExpr body cont }
-\begin{code}
--- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
-simplCoerce env to_ty from_ty expr@(Case scrut alts) args result_ty
- = simplCase env scrut (getSubstEnvs env, alts)
- (\env rhs -> simplCoerce env to_ty from_ty rhs args result_ty)
- result_ty
-
--- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
-simplCoerce env to_ty from_ty (Let bind body) args result_ty
- = simplBind env bind (\env -> simplCoerce env to_ty from_ty body args result_ty) result_ty
-
--- Default case
--- NB: we do *not* push the argments inside the coercion
-
-simplCoerce env to_ty from_ty expr args result_ty
- = simplTy env to_ty `appEager` \ to_ty' ->
- simplTy env from_ty `appEager` \ from_ty' ->
- simplExpr env expr [] from_ty' `thenSmpl` \ expr' ->
- returnSmpl (mkGenApp (mkCoerce to_ty' from_ty' expr') args)
+ | otherwise
+ = getSubstEnv `thenSmpl` \ bndr_se ->
+ setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
+ `thenSmpl` \ (floats, rhs', arity, in_scope) ->
+ setInScope in_scope $
+ completeBindNonRecE (bndr `setIdArity` arity) rhs' (
+ simplExpr body cont
+ ) `thenSmpl` \ body' ->
+ returnSmpl (mkLets floats body')
where
- -- Try cancellation; we do this "on the way up" because
- -- I think that's where it'll bite best
- mkCoerce to_ty1 from_ty1 (Note (Coerce to_ty2 from_ty2) body)
- = ASSERT( from_ty1 == to_ty2 )
- mkCoerce to_ty1 from_ty2 body
- mkCoerce to_ty from_ty body
- | to_ty == from_ty = body
- | otherwise = Note (Coerce to_ty from_ty) body
+ -- Return true only for dictionary types where the dictionary
+ -- has more than one component (else we risk poking on the component
+ -- of a newtype dictionary)
+ is_dict bndr
+ | not opt_DictsStrict = False
+ | otherwise
+ = case splitTyConApp_maybe (idType bndr) of
+ Nothing -> False
+ Just (tycon,tys) -> maybeToBool (tyConClass_maybe tycon) &&
+ length tys == tyConArity tycon &&
+ isDataTyCon tycon
\end{code}
-%************************************************************************
-%* *
-\subsection[Simplify-scc]{SCC expressions
-%* *
-%************************************************************************
+The completeBindNonRec family
+ - deals only with Ids, not TyVars
+ - take an already-simplified RHS
+ - always produce let bindings
-1) Eliminating nested sccs ...
-We must be careful to maintain the scc counts ...
+They do *not* attempt to do let-to-case. Why? Because
+they are used for top-level bindings, and in many situations where
+the "rhs" is known to be a WHNF (so let-to-case is inappropriate).
\begin{code}
-simplSCC env cc1 (Note (SCC cc2) expr) args result_ty
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
- -- eliminate inner scc if no call counts and same cc as outer
- = simplSCC env cc1 expr args result_ty
-
- | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
- -- eliminate outer scc if no call counts associated with either ccs
- = simplSCC env cc2 expr args result_ty
-\end{code}
+completeBindNonRec :: InId -- Binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM a -- Thing inside
+ -> SimplM (Maybe (OutId, OutExpr), a)
+completeBindNonRec bndr rhs thing_inside
+ | isDeadBinder bndr -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+ = thing_inside `thenSmpl` \ res ->
+ returnSmpl (Nothing,res)
+
+ | postInlineUnconditionally bndr etad_rhs
+ = tick PostInlineUnconditionally `thenSmpl_`
+ extendIdSubst bndr (Done etad_rhs) (
+ thing_inside `thenSmpl` \ res ->
+ returnSmpl (Nothing,res)
+ )
+
+ | otherwise -- Note that we use etad_rhs here
+ -- This gives maximum chance for a remaining binding
+ -- to be zapped by the indirection zapper in OccurAnal
+ = simplBinder bndr $ \ bndr' ->
+ simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
+ modifyInScope bndr'' $
+ thing_inside `thenSmpl` \ res ->
+ returnSmpl (Just (bndr'', etad_rhs), res)
+ where
+ etad_rhs = etaCoreExpr rhs
+
+completeBindNonRecE :: InId -> OutExpr -> SimplM OutExpr -> SimplM OutExpr
+completeBindNonRecE bndr rhs thing_inside
+ = completeBindNonRec bndr rhs thing_inside `thenSmpl` \ (maybe_bind, body) ->
+ returnSmpl (case maybe_bind of
+ Nothing -> body
+ Just (bndr, rhs) -> bindNonRec bndr rhs body)
+
+-- (simplPrags old_bndr new_bndr new_rhs) does two things
+-- (a) it attaches the new unfolding to new_bndr
+-- (b) it grabs the SpecEnv from old_bndr, applies the current
+-- substitution to it, and attaches it to new_bndr
+-- The assumption is that new_bndr, which is produced by simplBinder
+-- has no unfolding or specenv.
+
+simplPrags old_bndr new_bndr new_rhs
+ | isEmptySpecEnv spec_env
+ = returnSmpl (bndr_w_unfolding)
-2) Moving sccs inside lambdas ...
-
-\begin{code}
-simplSCC env cc (Lam binder@(ValBinder _) body) args result_ty
- | not (isSccCountCostCentre cc)
- -- move scc inside lambda only if no call counts
- = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
-
-simplSCC env cc (Lam binder body) args result_ty
- -- always ok to move scc inside type/usage lambda
- = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
-\end{code}
+ | otherwise
+ = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
+ let
+ spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
+ in
+ returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env')
+ where
+ bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
-3) Eliminating dict sccs ...
+ spec_env = getIdSpecialisation old_bndr
+ subst_val id_subst ty_subst in_scope expr
+ = substExpr ty_subst id_subst in_scope expr
+\end{code}
\begin{code}
-simplSCC env cc expr args result_ty
- | squashableDictishCcExpr cc expr
- -- eliminate dict cc if trivial dict expression
- = simplExpr env expr args result_ty
+preInlineUnconditionally :: InId -> Bool
+ -- Examines a bndr to see if it is used just once in a
+ -- completely safe way, so that it is safe to discard the binding
+ -- inline its RHS at the (unique) usage site, REGARDLESS of how
+ -- big the RHS might be. If this is the case we don't simplify
+ -- the RHS first, but just inline it un-simplified.
+ --
+ -- This is much better than first simplifying a perhaps-huge RHS
+ -- and then inlining and re-simplifying it.
+ --
+ -- NB: we don't even look at the RHS to see if it's trivial
+ -- We might have
+ -- x = y
+ -- where x is used many times, but this is the unique occurrence
+ -- of y. We should NOT inline x at all its uses, because then
+ -- we'd do the same for y -- aargh! So we must base this
+ -- pre-rhs-simplification decision solely on x's occurrences, not
+ -- on its rhs.
+preInlineUnconditionally bndr
+ = case getInlinePragma bndr of
+ ICanSafelyBeINLINEd InsideLam _ -> False
+ ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
+ -- one occurrence ==> safe!
+ other -> False
+
+
+postInlineUnconditionally :: InId -> OutExpr -> Bool
+ -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
+ -- It returns True if it's ok to discard the binding and inline the
+ -- RHS at every use site.
+
+ -- NOTE: This isn't our last opportunity to inline.
+ -- We're at the binding site right now, and
+ -- we'll get another opportunity when we get to the ocurrence(s)
+
+postInlineUnconditionally bndr rhs
+ | isExported bndr
+ = False
+ | otherwise
+ = case getInlinePragma bndr of
+ IAmALoopBreaker -> False
+ IMustNotBeINLINEd -> False
+ IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids
+
+ ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
+ -- Don't inline even WHNFs inside lambdas; this
+ -- isn't the last chance; see NOTE above.
+
+ ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
+
+ other -> exprIsTrivial rhs -- Duplicating is *free*
+ -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
+ -- Why? Because we don't even want to inline them into the
+ -- RHS of constructor arguments. See NOTE above
+
+inlineCase bndr scrut
+ = case getInlinePragma bndr of
+ -- Not expecting IAmALoopBreaker etc; this is a case binder!
+
+ ICanSafelyBeINLINEd StrictOcc one_branch
+ -> one_branch || exprIsDupable scrut
+ -- This case is the entire reason we distinguish StrictOcc from LazyOcc
+ -- We want eliminate the "case" only if we aren't going to
+ -- build a thunk instead, and that's what StrictOcc finds
+ -- For example:
+ -- case (f x) of y { DEFAULT -> g y }
+ -- Here we DO NOT WANT:
+ -- g (f x)
+ -- *even* if g is strict. We want to avoid constructing the
+ -- thunk for (f x)! So y gets a LazyOcc.
+
+ other -> exprIsTrivial scrut -- Duplication is free
+ && ( isUnLiftedType (idType bndr)
+ || scrut_is_evald_var -- So dropping the case won't change termination
+ || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again
+ -- termination doesn't change
+ where
+ -- Check whether or not scrut is known to be evaluted
+ -- It's not going to be a visible value (else the previous
+ -- blob would apply) so we just check the variable case
+ scrut_is_evald_var = case scrut of
+ Var v -> isEvaldUnfolding (getIdUnfolding v)
+ other -> False
\end{code}
-4) Moving arguments inside the body of an scc ...
-This moves the cost of doing the application inside the scc
-(which may include the cost of extracting methods etc)
+okToInline is used at call sites, so it is a bit more generous.
+It's a very important function that embodies lots of heuristics.
\begin{code}
-simplSCC env cc body args result_ty
- = let
- new_env = setEnclosingCC env cc
- in
- simplExpr new_env body args result_ty `thenSmpl` \ body' ->
- returnSmpl (Note (SCC cc) body')
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Simplify-bind]{Binding groups}
-%* *
-%************************************************************************
+okToInline :: Bool -- True <-> essential unfoldings only
+ -> Bool -- Case scrutinee
+ -> Id -- The Id
+ -> FormSummary -- The thing is WHNF or bottom;
+ -> UnfoldingGuidance
+ -> SimplCont
+ -> Bool -- True <=> inline it
+
+-- A non-WHNF can be inlined if it doesn't occur inside a lambda,
+-- and occurs exactly once or
+-- occurs once in each branch of a case and is small
+--
+-- If the thing is in WHNF, there's no danger of duplicating work,
+-- so we can inline if it occurs once, or is small
+
+okToInline essential_unfoldings_only is_case_scrutinee id form guidance cont
+ | essential_unfoldings_only
+ = idMustBeINLINEd id
+ -- If "essential_unfoldings_only" is true we do no inlinings at all,
+ -- EXCEPT for things that absolutely have to be done
+ -- (see comments with idMustBeINLINEd)
-\begin{code}
-simplBind :: SimplEnv
- -> InBinding
- -> (SimplEnv -> SmplM OutExpr)
- -> OutType
- -> SmplM OutExpr
-
-simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
-simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
+ | otherwise
+ = case getInlinePragma id of
+ IAmDead -> pprTrace "okToInline: dead" (ppr id) False
+
+ IAmASpecPragmaId -> False
+ IMustNotBeINLINEd -> False
+ IAmALoopBreaker -> False
+
+ IMustBeINLINEd -> True
+
+ IWantToBeINLINEd -> True --some_benefit -- Even INLINE pragmas don't *always*
+ -- cause inlining
+
+ ICanSafelyBeINLINEd inside_lam one_branch
+ -> --pprTrace "inline (occurs once): " (ppr id <+> ppr small_enough <+> ppr one_branch <+> ppr whnf <+> ppr some_benefit <+> ppr not_inside_lam) $
+ (small_enough || one_branch) &&
+ ((whnf && some_benefit) || not_inside_lam)
+
+ where
+ not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
+
+ other -> --pprTrace "inline: " (ppr id <+> ppr small_enough <+> ppr whnf <+> ppr some_benefit) $
+ whnf && small_enough && some_benefit
+ -- We could consider using exprIsCheap here,
+ -- as in postInlineUnconditionally, but unlike the latter we wouldn't
+ -- necessarily eliminate a thunk; and the "form" doesn't tell
+ -- us that.
+ where
+ whnf = whnfOrBottom form
+ small_enough = smallEnoughToInline id arg_evals is_case_scrutinee guidance
+ val_args = get_val_args cont
+ arg_evals = map is_evald val_args
+
+ some_benefit = contIsInteresting cont
+
+ is_evald (Var v) = isEvaldUnfolding (getIdUnfolding v)
+ is_evald (Con con _) = isWHNFCon con
+ is_evald other = False
+
+ get_val_args (ApplyTo _ arg _ cont)
+ | isValArg arg = arg : get_val_args cont
+ | otherwise = get_val_args cont
+ get_val_args other = []
+
+contIsInteresting :: SimplCont -> Bool
+contIsInteresting Stop = False
+contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
+contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
+contIsInteresting _ = True
\end{code}
+Comment about some_benefit above
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-%************************************************************************
-%* *
-\subsection[Simplify-let]{Let-expressions}
-%* *
-%************************************************************************
+We want to avoid inlining an expression where there can't possibly be
+any gain, such as in an argument position. Hence, if the continuation
+is interesting (eg. a case scrutinee, application etc.) then we
+inline, otherwise we don't.
-Float switches
-~~~~~~~~~~~~~~
-The booleans controlling floating have to be set with a little care.
-Here's one performance bug I found:
+Previously some_benefit used to return True only if the variable was
+applied to some value arguments. This didn't work:
- let x = let y = let z = case a# +# 1 of {b# -> E1}
- in E2
- in E3
- in E4
+ let x = _coerce_ (T Int) Int (I# 3) in
+ case _coerce_ Int (T Int) x of
+ I# y -> ....
-Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
-Before case_floating_ok included float_exposes_hnf, the case expression was floated
-*one level per simplifier iteration* outwards. So it made th s
+we want to inline x, but can't see that it's a constructor in a case
+scrutinee position, and some_benefit is False.
+Another example:
-Floating case from let
-~~~~~~~~~~~~~~~~~~~~~~
-When floating cases out of lets, remember this:
+dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
- let x* = case e of alts
- in <small expr>
+.... case dMonadST _@_ x0 of (a,b,c) -> ....
-where x* is sure to be demanded or e is a cheap operation that cannot
-fail, e.g. unboxed addition. Here we should be prepared to duplicate
-<small expr>. A good example:
+we'd really like to inline dMonadST here, but we *don't* want to
+inline if the case expression is just
- let x* = case y of
- p1 -> build e1
- p2 -> build e2
- in
- foldr c n x*
-==>
- case y of
- p1 -> foldr c n (build e1)
- p2 -> foldr c n (build e2)
+ case x of y { DEFAULT -> ... }
-NEW: We use the same machinery that we use for case-of-case to
-*always* do case floating from let, that is we let bind and abstract
-the original let body, and let the occurrence analyser later decide
-whether the new let should be inlined or not. The example above
-becomes:
+since we can just eliminate this case instead (x is in WHNF). Similar
+applies when x is bound to a lambda expression. Hence
+contIsInteresting looks for case expressions with just a single
+default case.
-==>
- let join_body x' = foldr c n x'
- in case y of
- p1 -> let x* = build e1
- in join_body x*
- p2 -> let x* = build e2
- in join_body x*
+%************************************************************************
+%* *
+\subsection{The main rebuilder}
+%* *
+%************************************************************************
-note that join_body is a let-no-escape.
-In this particular example join_body will later be inlined,
-achieving the same effect.
-ToDo: check this is OK with andy
+\begin{code}
+-------------------------------------------------------------------
+rebuild :: OutExpr -> SimplCont -> SimplM OutExpr
+
+rebuild expr cont
+ = tick LeavesExamined `thenSmpl_`
+ getSwitchChecker `thenSmpl` \ chkr ->
+ do_rebuild chkr expr (mkFormSummary expr) cont
+---------------------------------------------------------
+-- Stop continuation
-Let to case: two points
-~~~~~~~~~~~
+do_rebuild sw_chkr expr form Stop = returnSmpl expr
-Point 1. We defer let-to-case for all data types except single-constructor
-ones. Suppose we change
- let x* = e in b
-to
- case e of x -> b
+---------------------------------------------------------
+-- Coerce continuation
-It can be the case that we find that b ultimately contains ...(case x of ..)....
-and this is the only occurrence of x. Then if we've done let-to-case
-we can't inline x, which is a real pain. On the other hand, we lose no
-transformations by not doing this transformation, because the relevant
-case-of-X transformations are also implemented by simpl_bind.
+do_rebuild sw_chkr expr form (CoerceIt _ to_ty se cont)
+ = setSubstEnv se $
+ simplType to_ty `thenSmpl` \ to_ty' ->
+ do_rebuild sw_chkr (mk_coerce to_ty' expr) form cont
+ where
+ mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
+ mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
-If x is a single-constructor type, then we go ahead anyway, giving
- case e of (y,z) -> let x = (y,z) in b
+---------------------------------------------------------
+-- Dealing with
+-- * case (error "hello") of { ... }
-because now we can squash case-on-x wherever they occur in b.
+-- ToDo: deal with
+-- * (error "Hello") arg
-We do let-to-case on multi-constructor types in the tidy-up phase
-(tidyCoreExpr) mainly so that the code generator doesn't need to
-spot the demand-flag.
+do_rebuild sw_chkr expr BottomForm cont@(Select _ _ _ _ _)
+ = tick CaseOfError `thenSmpl_`
+ getInScope `thenSmpl` \ in_scope ->
+ let
+ (cont', result_ty) = find_result_ty in_scope cont
+ in
+ do_rebuild sw_chkr (mkNote (Coerce result_ty expr_ty) expr) BottomForm cont'
+ where
+ expr_ty = coreExprType expr
+ find_result_ty in_scope (ApplyTo _ _ _ cont)
+ = (cont, funResultTy expr_ty)
+ find_result_ty in_scope (Select _ _ ((_,_,rhs1):_) (ty_subst,_) cont)
+ = (cont, fullSubstTy ty_subst in_scope (coreExprType rhs1))
+
+---------------------------------------------------------
+-- Ordinary application
+
+do_rebuild sw_chkr expr form cont@(ApplyTo _ _ _ _)
+ = go expr cont
+ where -- This loop just saves repeated calculation of mkFormSummary
+ go e (ApplyTo _ arg se cont) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
+ go (App e arg') cont
+ go e cont = do_rebuild sw_chkr e (mkFormSummary e) cont
+
+
+---------------------------------------------------------
+-- Case of known constructor or literal
+
+do_rebuild sw_chkr expr@(Con con args) form cont@(Select _ _ _ _ _)
+ | conOkForAlt con -- Knocks out PrimOps and NoRepLits
+ = knownCon expr con args cont
+
+---------------------------------------------------------
+-- Case of other value (e.g. a partial application or lambda)
+-- Turn it back into a let
+
+do_rebuild sw_chkr expr ValueForm (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
+ = ASSERT( null bs && null alts )
+ tick Case2Let `thenSmpl_`
+ setSubstEnv se (
+ completeBindNonRecE bndr expr $
+ simplExpr rhs cont
+ )
-Point 2. It's important to try let-to-case before doing the
-strict-let-of-case transformation, which happens in the next equation
-for simpl_bind.
- let a*::Int = case v of {p1->e1; p2->e2}
- in b
+---------------------------------------------------------
+-- Case of something else; eliminating the case altogether
+-- See the extensive notes on case-elimination below
-(The * means that a is sure to be demanded.)
-If we do case-floating first we get this:
+do_rebuild sw_chkr scrut form (Select _ bndr alts se cont)
+ | switchIsOn sw_chkr SimplDoCaseElim
+ && all (cheapEqExpr rhs1) other_rhss
+ && inlineCase bndr scrut
+ && all binders_unused alts
- let k = \a* -> b
- in case v of
- p1-> let a*=e1 in k a
- p2-> let a*=e2 in k a
+ = -- Get rid of the case altogether
+ -- Remember to bind the binder though!
+ tick CaseElim `thenSmpl_`
+ setSubstEnv se (
+ extendIdSubst bndr (Done scrut) $
+ simplExpr rhs1 cont
+ )
+ where
+ (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
-Now watch what happens if we do let-to-case first:
+ binders_unused (_, bndrs, _) = all isDeadBinder bndrs
- case (case v of {p1->e1; p2->e2}) of
- Int a# -> let a*=I# a# in b
-===>
- let k = \a# -> let a*=I# a# in b
- in case v of
- p1 -> case e1 of I# a# -> k a#
- p1 -> case e2 of I# a# -> k a#
-The latter is clearly better. (Remember the reboxing let-decl for a
-is likely to go away, because after all b is strict in a.)
-We do not do let to case for WHNFs, e.g.
+---------------------------------------------------------
+-- Case of something else
- let x = a:b in ...
- =/=>
- case a:b of x in ...
+do_rebuild sw_chkr scrut form (Select _ case_bndr alts se cont)
+ = -- Prepare the continuation and case alternatives
+ prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
+ scrut_cons alts `thenSmpl` \ better_alts ->
+ prepareCaseCont better_alts cont $ \ cont' ->
+
+ -- Set the new subst-env in place (before dealing with the case binder)
+ setSubstEnv se $
+
+ -- Deal with the case binder
+ simplBinder case_bndr $ \ case_bndr' ->
-as this is less efficient. but we don't mind doing let-to-case for
-"bottom", as that will allow us to remove more dead code, if anything:
+ -- Deal with variable scrutinee
+ substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
+ let
+ case_bndr'' = zap_occ_info case_bndr'
+ in
- let x = error in ...
- ===>
- case error of x -> ...
- ===>
- error
+ -- Deal with the case alternaatives
+ simplAlts zap_occ_info scrut_cons case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
-Notice that let to case occurs only if x is used strictly in its body
-(obviously).
+ getSwitchChecker `thenSmpl` \ sw_chkr ->
+ mkCase sw_chkr scrut case_bndr'' alts'
+ where
+ -- scrut_cons tells what constructors the scrutinee can't possibly match
+ scrut_cons = case scrut of
+ Var v -> case getIdUnfolding v of
+ OtherCon cons -> cons
+ other -> []
+ other -> []
+\end{code}
+Blob of helper functions for the "case-of-something-else" situation.
\begin{code}
--- Dead code is now discarded by the occurrence analyser,
-
-simplNonRec env binder@(id,_) rhs body_c body_ty
- | inlineUnconditionally binder
- = -- The binder is used in definitely-inline way in the body
- -- So add it to the environment, drop the binding, and continue
- body_c (bindIdToExpr env binder rhs)
-
- | idWantsToBeINLINEd id
- = complete_bind env rhs -- Don't mess about with floating or let-to-case on
- -- INLINE things
-
- -- Do let-to-case right away for unpointed types
- -- These shouldn't occur much, but do occur right after desugaring,
- -- because we havn't done dependency analysis at that point, so
- -- we can't trivially do let-to-case (because there may be some unboxed
- -- things bound in letrecs that aren't really recursive).
- | isUnpointedType rhs_ty && not rhs_is_whnf
- = simplCase env rhs (getSubstEnvs env, PrimAlts [] (BindDefault binder (Var id)))
- (\env rhs -> complete_bind env rhs) body_ty
-
- -- Try let-to-case; see notes below about let-to-case
- | try_let_to_case &&
- will_be_demanded &&
- ( rhs_is_bot
- || (not rhs_is_whnf && singleConstructorType rhs_ty)
- -- Don't do let-to-case if the RHS is a constructor application.
- -- Even then only do it for single constructor types.
- -- For other types we defer doing it until the tidy-up phase at
- -- the end of simplification.
+knownCon expr con args (Select _ bndr alts se cont)
+ = tick KnownBranch `thenSmpl_`
+ setSubstEnv se (
+ case findAlt con alts of
+ (DEFAULT, bs, rhs) -> ASSERT( null bs )
+ completeBindNonRecE bndr expr $
+ simplExpr rhs cont
+
+ (Literal lit, bs, rhs) -> ASSERT( null bs )
+ extendIdSubst bndr (Done expr) $
+ -- Unconditionally substitute, because expr must
+ -- be a variable or a literal. It can't be a
+ -- NoRep literal because they don't occur in
+ -- case patterns.
+ simplExpr rhs cont
+
+ (DataCon dc, bs, rhs) -> completeBindNonRecE bndr expr $
+ extend bs real_args $
+ simplExpr rhs cont
+ where
+ real_args = drop (dataConNumInstArgs dc) args
)
- = tick Let2Case `thenSmpl_`
- simplCase env rhs (getSubstEnvs env, AlgAlts [] (BindDefault binder (Var id)))
- (\env rhs -> complete_bind env rhs) body_ty
- -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
- -- NB: it's tidier to call complete_bind not simpl_bind, else
- -- we nearly end up in a loop. Consider:
- -- let x = rhs in b
- -- ==> case rhs of (p,q) -> let x=(p,q) in b
- -- This effectively what the above simplCase call does.
- -- Now, the inner let is a let-to-case target again! Actually, since
- -- the RHS is in WHNF it won't happen, but it's a close thing!
-
- | otherwise
- = simpl_bind env rhs
where
- -- Try let-from-let
- simpl_bind env (Let bind rhs) | let_floating_ok
- = tick LetFloatFromLet `thenSmpl_`
- simplBind env (if will_be_demanded then bind
- else un_demandify_bind bind)
- (\env -> simpl_bind env rhs) body_ty
-
- -- Try case-from-let; this deals with a strict let of error too
- simpl_bind env (Case scrut alts) | case_floating_ok scrut
- = tick CaseFloatFromLet `thenSmpl_`
-
- -- First, bind large let-body if necessary
- if isSingleton (nonErrorRHSs alts)
- then
- simplCase env scrut (getSubstEnvs env, alts)
- (\env rhs -> simpl_bind env rhs) body_ty
- else
- bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
- let
- body_c' = \env -> simplExpr env new_body [] body_ty
- case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
- in
- simplCase env scrut (getSubstEnvs env, alts) case_c body_ty `thenSmpl` \ case_expr ->
- returnSmpl (Let extra_binding case_expr)
-
- -- None of the above; simplify rhs and tidy up
- simpl_bind env rhs = complete_bind env rhs
-
- complete_bind env rhs
- = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
- simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
- completeNonRec env_w_clone binder
- (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (mkCoLetsAny binds body')
-
-
- -- All this stuff is computed at the start of the simpl_bind loop
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- float_primops = switchIsSet env SimplOkToFloatPrimOps
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
- try_let_to_case = switchIsSet env SimplLetToCase
- no_float = switchIsSet env SimplNoLetFromStrictLet
-
- demand_info = getIdDemandInfo id
- will_be_demanded = willBeDemanded demand_info
- rhs_ty = idType id
-
- form = mkFormSummary rhs
- rhs_is_bot = case form of
- BottomForm -> True
- other -> False
- rhs_is_whnf = case form of
- VarForm -> True
- ValueForm -> True
- other -> False
-
- float_exposes_hnf = floatExposesHNF float_lets float_primops rhs
-
- let_floating_ok = (will_be_demanded && not no_float) ||
- always_float_let_from_let ||
- float_exposes_hnf
-
- case_floating_ok scrut = (will_be_demanded && not no_float) ||
- (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
- -- See note below
+ extend [] [] thing_inside = thing_inside
+ extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
+ extend bs args thing_inside
\end{code}
+\begin{code}
+prepareCaseCont [alt] cont thing_inside = thing_inside cont
+prepareCaseCont alts cont thing_inside = mkDupableCont cont thing_inside
+\end{code}
-@completeNonRec@ looks at the simplified post-floating RHS of the
-let-expression, with a view to turning
- x = e
-into
- x = y
-where y is just a variable. Now we can eliminate the binding
-altogether, and replace x by y throughout.
+substForVarScrut checks whether the scrutinee is a variable, v.
+If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
+that way, there's a chance that v will now only be used once, and hence inlined.
-There are two cases when we can do this:
+If we do this, then we have to nuke any occurrence info (eg IAmDead)
+in the case binder, because the case-binder now effectively occurs
+whenever v does. AND we have to do the same for the pattern-bound
+variables! Example:
- * When e is a constructor application, and we have
- another variable in scope bound to the same
- constructor application. [This is just a special
- case of common-subexpression elimination.]
+ (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
- * When e can be eta-reduced to a variable. E.g.
- x = \a b -> y a b
+Here, b and p are dead. But when we move the argment inside the first
+case RHS, and eliminate the second case, we get
+ case x or { (a,b) -> a b
-HOWEVER, if x is exported, we don't attempt this at all. Why not?
-Because then we can't remove the x=y binding, in which case we
-have just made things worse, perhaps a lot worse.
+Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
+happened. Hence the zap_occ_info function returned by substForVarScrut
\begin{code}
-completeNonRec env binder new_id new_rhs
- = returnSmpl (env', [NonRec b r | (b,r) <- binds])
- where
- (env', binds) = completeBind env binder new_id new_rhs
+substForVarScrut (Var v) case_bndr' thing_inside
+ | isLocallyDefined v -- No point for imported things
+ = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
+ `setInlinePragma` IMustBeINLINEd) $
+ -- We could extend the substitution instead, but it would be
+ -- a hack because then the substitution wouldn't be idempotent
+ -- any more.
+ thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
+
+substForVarScrut other_scrut case_bndr' thing_inside
+ = thing_inside (\ bndr -> bndr) -- NoOp on bndr
+\end{code}
+prepareCaseAlts does two things:
-completeBind :: SimplEnv
- -> InBinder -> OutId -> OutExpr -- Id and RHS
- -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
+1. Remove impossible alternatives
-completeBind env binder@(old_id,occ_info) new_id new_rhs
- | not (idMustNotBeINLINEd new_id)
- && atomic_rhs -- If rhs (after eta reduction) is atomic
- && not (isExported new_id) -- and binder isn't exported
- && not (isSpecPragmaId new_id) -- Don't discard spec prag Ids
+2. If the DEFAULT alternative can match only one possible constructor,
+ then make that constructor explicit.
+ e.g.
+ case e of x { DEFAULT -> rhs }
+ ===>
+ case e of x { (a,b) -> rhs }
+ where the type is a single constructor type. This gives better code
+ when rhs also scrutinises x or e.
- = -- Drop the binding completely
- let
- env1 = notInScope env new_id
- env2 = bindIdToAtom env1 binder the_arg
- in
- (env2, [])
-
- | otherwise -- Non-atomic
- -- The big deal here is that we simplify the
- -- SpecEnv of the Id, if any. We used to do that in simplBinders, but
- -- that didn't work because it didn't take account of the fact that
- -- one of the mutually recursive group might mention one of the others
- -- in its SpecEnv
- = let
- id_w_specenv | isEmptySpecEnv spec_env = new_id
- | otherwise = setIdSpecialisation new_id spec_env'
-
- env1 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
- = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding
- -- Still need to record the new_id with its SpecEnv
-
- | otherwise -- Can inline it
- = extendEnvGivenBinding env occ_info id_w_specenv new_rhs
-
- new_binds = [(id_w_specenv, new_rhs)]
- in
- (env1, new_binds)
-
+\begin{code}
+prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
+ | isDataTyCon tycon
+ = case (findDefault filtered_alts, missing_cons) of
+
+ ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
+ -> tick FillInCaseDefault `thenSmpl_`
+ let
+ (_,_,ex_tyvars,_,_,_) = dataConSig data_con
+ in
+ getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
+ let
+ ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+ mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ in
+ newIds (dataConArgTys
+ data_con
+ (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
+ returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
+
+ other -> returnSmpl filtered_alts
where
- spec_env = getIdSpecialisation old_id
- spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
- (ty_subst,id_subst) = getSubstEnvs env
-
- atomic_rhs = is_atomic eta'd_rhs
- eta'd_rhs = case lookForConstructor env new_rhs of
- Just v -> Var v
- other -> etaCoreExpr new_rhs
-
- the_arg = case eta'd_rhs of
- Var v -> VarArg v
- Lit l -> LitArg l
-\end{code}
+ -- Filter out alternatives that can't possibly match
+ filtered_alts = case scrut_cons of
+ [] -> alts
+ other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
-----------------------------------------------------------------------------
- A digression on constructor CSE
-
-Consider
-@
- f = \x -> case x of
- (y:ys) -> y:ys
- [] -> ...
-@
-Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
-bit on the compiler technology, but in general I believe not. For
-example, here's some code from a real program:
-@
-const.Int.max.wrk{-s2516-} =
- \ upk.s3297# upk.s3298# ->
- let {
- a.s3299 :: Int
- _N_ {-# U(P) #-}
- a.s3299 = I#! upk.s3297#
- } in
- case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
- _LT -> I#! upk.s3298#
- _EQ -> a.s3299
- _GT -> a.s3299
- }
-@
-The a.s3299 really isn't doing much good. We'd be better off inlining
-it. (Actually, let-no-escapery means it isn't as bad as it looks.)
-
-So the current strategy is to inline all known-form constructors, and
-only do the reverse (turn a constructor application back into a
-variable) when we find a let-expression:
-@
- let x = C a1 .. an
- in
- ... (let y = C a1 .. an in ...) ...
-@
-where it is always good to ditch the binding for y, and replace y by
-x.
- End of digression
-----------------------------------------------------------------------------
-
-----------------------------------------------------------------------------
- A digression on "optimising" coercions
-
- The trouble is that we kept transforming
- let x = coerce e
- y = coerce x
- in ...
- to
- let x' = coerce e
- y' = coerce x'
- in ...
- and counting a couple of ticks for this non-transformation
-\begin{pseudocode}
- -- We want to ensure that all let-bound Coerces have
- -- atomic bodies, so they can freely be inlined.
-completeNonRec env binder new_id (Coerce coercion ty rhs)
- | not (is_atomic rhs)
- = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
- completeNonRec env
- (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
- -- Dangerous occ because, like constructor args,
- -- it can be duplicated easily
- let
- atomic_rhs = case runEager $ lookupId env1 inner_id of
- LitArg l -> Lit l
- VarArg v -> Var v
- in
- completeNonRec env1 binder new_id
- (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
+ missing_cons = [data_con | data_con <- tyConDataCons tycon,
+ not (data_con `elem` handled_data_cons)]
+ handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++
+ [data_con | (DataCon data_con, _, _) <- filtered_alts]
- returnSmpl (env2, binds1 ++ binds2)
-\end{pseudocode}
-----------------------------------------------------------------------------
+-- The default case
+prepareCaseAlts _ scrut_cons alts
+ = returnSmpl alts -- Functions
+----------------------
+simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
+ = mapSmpl simpl_alt alts
+ where
+ inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
+ Just (tycon, inst_tys) -> inst_tys
+
+ -- handled_cons is all the constructors that are dealt
+ -- with, either by being impossible, or by there being an alternative
+ handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
+
+ simpl_alt (DEFAULT, _, rhs)
+ = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
+ simplExpr rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (DEFAULT, [], rhs')
+
+ simpl_alt (con, vs, rhs)
+ = -- Deal with the case-bound variables
+ -- Mark the ones that are in ! positions in the data constructor
+ -- as certainly-evaluated
+ simplBinders (add_evals con vs) $ \ vs' ->
+
+ -- Bind the case-binder to (Con args)
+ -- In the default case we record the constructors it *can't* be.
+ -- We take advantage of any OtherCon info in the case scrutinee
+ let
+ con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
+ in
+ modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
+ simplExpr rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (con, vs', rhs')
+
+
+ -- add_evals records the evaluated-ness of the bound variables of
+ -- a case pattern. This is *important*. Consider
+ -- data T = T !Int !Int
+ --
+ -- case x of { T a b -> T (a+1) b }
+ --
+ -- We really must record that b is already evaluated so that we don't
+ -- go and re-evaluated it when constructing the result.
-%************************************************************************
-%* *
-\subsection[Simplify-letrec]{Letrec-expressions}
-%* *
-%************************************************************************
+ add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
+ add_evals other_con vs = vs
-Letrec expressions
-~~~~~~~~~~~~~~~~~~
-Here's the game plan
+ add_eval v m | isTyVar v = Nothing
+ | otherwise = case m of
+ MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
+ NotMarkedStrict -> Just (zap_occ_info v)
+\end{code}
-1. Float any let(rec)s out of the RHSs
-2. Clone all the Ids and extend the envt with these clones
-3. Simplify one binding at a time, adding each binding to the
- environment once it's done.
-This relies on the occurrence analyser to
- a) break all cycles with an Id marked MustNotBeInlined
- b) sort the decls into topological order
-The former prevents infinite inlinings, and the latter means
-that we get maximum benefit from working top to bottom.
+Case elimination [see the code above]
+~~~~~~~~~~~~~~~~
+Start with a simple situation:
+
+ case x# of ===> e[x#/y#]
+ y# -> e
+
+(when x#, y# are of primitive type, of course). We can't (in general)
+do this for algebraic cases, because we might turn bottom into
+non-bottom!
+
+Actually, we generalise this idea to look for a case where we're
+scrutinising a variable, and we know that only the default case can
+match. For example:
+\begin{verbatim}
+ case x of
+ 0# -> ...
+ other -> ...(case x of
+ 0# -> ...
+ other -> ...) ...
+\end{code}
+Here the inner case can be eliminated. This really only shows up in
+eliminating error-checking code.
+We also make sure that we deal with this very common case:
-\begin{code}
-simplRec env pairs body_c body_ty
- = -- Do floating, if necessary
- floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
- let
- binders = map fst pairs'
- in
- simplBinders env binders `thenSmpl` \ (env_w_clones, ids') ->
- simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
+ case e of
+ x -> ...x...
- body_c new_env `thenSmpl` \ body' ->
+Here we are using the case as a strict let; if x is used only once
+then we want to inline it. We have to be careful that this doesn't
+make the program terminate when it would have diverged before, so we
+check that
+ - x is used strictly, or
+ - e is already evaluated (it may so if e is a variable)
- returnSmpl (Let (Rec pairs') body')
-\end{code}
+Lastly, we generalise the transformation to handle this:
-\begin{code}
--- The env passed to simplRecursiveGroup already has
--- bindings that clone the variables of the group.
-simplRecursiveGroup env new_ids []
- = returnSmpl ([], env)
-
-simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs)
- | inlineUnconditionally binder
- = -- Single occurrence, so drop binding and extend env with the inlining
- -- This is a little delicate, because what if the unique occurrence
- -- is *before* this binding? This'll never happen, because
- -- either it'll be marked "never inline" or else its occurrence will
- -- occur after its binding in the group.
- --
- -- If these claims aren't right Core Lint will spot an unbound
- -- variable. A quick fix is to delete this clause for simplRecursiveGroup
- let
- new_env = bindIdToExpr env binder rhs
- in
- simplRecursiveGroup new_env new_ids pairs
- | otherwise
- = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
- let
- new_id' = new_id `withArity` arity
- (new_env, new_binds') = completeBind env binder new_id' new_rhs
- in
- simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
- returnSmpl (new_binds' ++ new_pairs, final_env)
-\end{code}
+ case e of ===> r
+ True -> r
+ False -> r
+We only do this for very cheaply compared r's (constructors, literals
+and variables). If pedantic bottoms is on, we only do it when the
+scrutinee is a PrimOp which can't fail.
+We do it *here*, looking at un-simplified alternatives, because we
+have to check that r doesn't mention the variables bound by the
+pattern in each alternative, so the binder-info is rather useful.
-\begin{code}
-floatBind :: SimplEnv
- -> Bool -- True <=> Top level
- -> InBinding
- -> SmplM [InBinding]
-
-floatBind env top_level bind
- | not float_lets ||
- n_extras == 0
- = returnSmpl [bind]
-
- | otherwise
- = tickN LetFloatFromLet n_extras `thenSmpl_`
- -- It's important to increment the tick counts if we
- -- do any floating. A situation where this turns out
- -- to be important is this:
- -- Float in produces:
- -- letrec x = let y = Ey in Ex
- -- in B
- -- Now floating gives this:
- -- letrec x = Ex
- -- y = Ey
- -- in B
- --- We now want to iterate once more in case Ey doesn't
- -- mention x, in which case the y binding can be pulled
- -- out as an enclosing let(rec), which in turn gives
- -- the strictness analyser more chance.
- returnSmpl binds'
+So the case-elimination algorithm is:
- where
- binds' = fltBind bind
- n_extras = sum (map no_of_binds binds') - no_of_binds bind
-
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
-
- -- fltBind guarantees not to return leaky floats
- -- and all the binders of the floats have had their demand-info zapped
- fltBind (NonRec bndr rhs)
- = binds ++ [NonRec bndr rhs']
- where
- (binds, rhs') = fltRhs rhs
-
- fltBind (Rec pairs)
- = [Rec pairs']
- where
- pairs' = concat [ let
- (binds, rhs') = fltRhs rhs
- in
- foldr get_pairs [(bndr, rhs')] binds
- | (bndr, rhs) <- pairs
- ]
-
- get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
- get_pairs (Rec pairs) rest = pairs ++ rest
-
- -- fltRhs has same invariant as fltBind
- fltRhs rhs
- | (always_float_let_from_let ||
- floatExposesHNF True False rhs)
- = fltExpr rhs
-
- | otherwise
- = ([], rhs)
-
-
- -- fltExpr has same invariant as fltBind
- fltExpr (Let bind body)
- | not top_level || binds_wont_leak
- -- fltExpr guarantees not to return leaky floats
- = (binds' ++ body_binds, body')
- where
- binds_wont_leak = all leakFreeBind binds'
- (body_binds, body') = fltExpr body
- binds' = fltBind (un_demandify_bind bind)
-
- fltExpr expr = ([], expr)
+ 1. Eliminate alternatives which can't match
--- Crude but effective
-no_of_binds (NonRec _ _) = 1
-no_of_binds (Rec pairs) = length pairs
+ 2. Check whether all the remaining alternatives
+ (a) do not mention in their rhs any of the variables bound in their pattern
+ and (b) have equal rhss
-leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
-leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
+ 3. Check we can safely ditch the case:
+ * PedanticBottoms is off,
+ or * the scrutinee is an already-evaluated variable
+ or * the scrutinee is a primop which is ok for speculation
+ -- ie we want to preserve divide-by-zero errors, and
+ -- calls to error itself!
-leakFree (id,_) rhs = case getIdArity id of
- ArityAtLeast n | n > 0 -> True
- ArityExactly n | n > 0 -> True
- other -> whnfOrBottom (mkFormSummary rhs)
-\end{code}
+ or * [Prim cases] the scrutinee is a primitive variable
+ or * [Alg cases] the scrutinee is a variable and
+ either * the rhs is the same variable
+ (eg case x of C a b -> x ===> x)
+ or * there is only one alternative, the default alternative,
+ and the binder is used strictly in its scope.
+ [NB this is helped by the "use default binder where
+ possible" transformation; see below.]
-%************************************************************************
-%* *
-\subsection[Simplify-atoms]{Simplifying atoms}
-%* *
-%************************************************************************
-\begin{code}
-simplArg :: SimplEnv -> InArg -> Eager ans OutArg
-
-simplArg env (LitArg lit) = returnEager (LitArg lit)
-simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
- returnEager (TyArg ty')
-simplArg env arg@(VarArg id)
- = case lookupIdSubst env id of
- Just (SubstVar id') -> returnEager (VarArg id')
- Just (SubstLit lit) -> returnEager (LitArg lit)
- Just (SubstExpr _ __) -> panic "simplArg"
- Nothing -> case lookupOutIdEnv env id of
- Just (id', _, _) -> returnEager (VarArg id')
- Nothing -> returnEager arg
-\end{code}
+If so, then we can replace the case with one of the rhss.
+
%************************************************************************
%* *
-\subsection[Simplify-quickies]{Some local help functions}
+\subsection{Duplicating continuations}
%* *
%************************************************************************
-
\begin{code}
--- un_demandify_bind switches off the willBeDemanded Info field
--- for bindings floated out of a non-demanded let
-un_demandify_bind (NonRec binder rhs)
- = NonRec (un_demandify_bndr binder) rhs
-un_demandify_bind (Rec pairs)
- = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
-
-un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
-
-is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
-is_cheap_prim_app other = False
+mkDupableCont :: SimplCont
+ -> (SimplCont -> SimplM CoreExpr)
+ -> SimplM CoreExpr
+mkDupableCont cont thing_inside
+ | contIsDupable cont
+ = thing_inside cont
+
+mkDupableCont (CoerceIt _ ty se cont) thing_inside
+ = mkDupableCont cont $ \ cont' ->
+ thing_inside (CoerceIt OkToDup ty se cont')
+
+mkDupableCont (ApplyTo _ arg se cont) thing_inside
+ = mkDupableCont cont $ \ cont' ->
+ setSubstEnv se (simplExpr arg Stop) `thenSmpl` \ arg' ->
+ if exprIsDupable arg' then
+ thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
+ else
+ newId (coreExprType arg') $ \ bndr ->
+ thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
+ returnSmpl (bindNonRec bndr arg' res)
+
+mkDupableCont (Select _ case_bndr alts se cont) thing_inside
+ = tick CaseOfCase `thenSmpl_` (
+ mkDupableCont cont $ \ cont' ->
+
+ setSubstEnv se (
+ simplBinder case_bndr $ \ case_bndr' ->
+ mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
+ returnSmpl (concat alt_binds_s, case_bndr', alts')
+ ) `thenSmpl` \ (alt_binds, case_bndr', alts') ->
+
+ extendInScopes [b | NonRec b _ <- alt_binds] $
+ thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
+ returnSmpl (mkLets alt_binds res)
+ )
-computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
-computeResultType env expr_ty orig_args
- = simplTy env expr_ty `appEager` \ expr_ty' ->
+mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM ([CoreBind], CoreAlt)
+mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
+ = simplBinders bndrs $ \ bndrs' ->
+ simplExpr rhs cont `thenSmpl` \ rhs' ->
+ if exprIsDupable rhs' then
+ -- It's small, so don't bother to let-bind it
+ returnSmpl ([], (con, bndrs', rhs'))
+ else
+ -- It's big, so let-bind it
let
- go ty [] = ty
- go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
- go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
- Just (_, res_ty) -> go res_ty args
- Nothing ->
- pprPanic "computeResultType" (vcat [
- ppr (a:args),
- ppr orig_args,
- ppr expr_ty',
- ppr ty])
+ rhs_ty' = coreExprType rhs'
+ used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
in
- go expr_ty' orig_args
-
-
-var `withArity` UnknownArity = var
-var `withArity` arity = var `addIdArity` arity
-
-is_atomic (Var v) = True
-is_atomic (Lit l) = not (isNoRepLit l)
-is_atomic other = False
+ ( if null used_bndrs' && isUnLiftedType rhs_ty'
+ then newId realWorldStatePrimTy $ \ rw_id ->
+ returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
+ else
+ returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
+ )
+ `thenSmpl` \ (final_bndrs', final_args) ->
+
+ -- If we try to lift a primitive-typed something out
+ -- for let-binding-purposes, we will *caseify* it (!),
+ -- with potentially-disastrous strictness results. So
+ -- instead we turn it into a function: \v -> e
+ -- where v::State# RealWorld#. The value passed to this function
+ -- is realworld#, which generates (almost) no code.
+
+ -- There's a slight infelicity here: we pass the overall
+ -- case_bndr to all the join points if it's used in *any* RHS,
+ -- because we don't know its usage in each RHS separately
+
+ newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
+ returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
+ (con, bndrs', mkApps (Var join_bndr) final_args))
\end{code}
-
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[LambdaLift]{A STG-code lambda lifter}
import StgSyn
import Bag ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList )
-import MkId ( mkSysLocal )
-import Id ( idType, addIdArity,
- mkIdSet, unitIdSet, minusIdSet, setIdVisibility,
- unionManyIdSets, idSetToList, IdSet,
- nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv,
- Id
+import Id ( mkSysLocal, idType, setIdArity,
+ setIdVisibility, Id
)
-import IdInfo ( ArityInfo, exactArity )
+import VarSet
+import VarEnv
+import IdInfo ( exactArity )
import Name ( Module )
-import SrcLoc ( noSrcLoc )
import Type ( splitForAllTys, mkForAllTys, mkFunTys, Type )
-import UniqSupply ( getUnique, splitUniqSupply, UniqSupply )
+import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
import Util ( zipEqual, panic, assertPanic )
\end{code}
-> LiftM (StgExpr, LiftInfo)
-liftExpr expr@(StgCon con args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgCon con args _) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgConArg con) args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgVarArg v) args lvs)
+liftExpr expr@(StgApp v args)
= lookUp v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to
-- poke these bindings too early!
- returnLM (StgApp (StgVarArg sc) (map StgVarArg sc_args ++ args) lvs,
+ returnLM (StgApp sc (map StgVarArg sc_args ++ args),
emptyLiftInfo)
-- The lvs field is probably wrong, but we reconstruct it
-- anyway following lambda lifting
-liftExpr (StgCase scrut lv1 lv2 uniq alts)
+liftExpr (StgCase scrut lv1 lv2 bndr srt alts)
= liftExpr scrut `thenLM` \ (scrut', scrut_info) ->
lift_alts alts `thenLM` \ (alts', alts_info) ->
- returnLM (StgCase scrut' lv1 lv2 uniq alts', scrut_info `unionLiftInfo` alts_info)
+ returnLM (StgCase scrut' lv1 lv2 bndr srt alts', scrut_info `unionLiftInfo` alts_info)
where
lift_alts (StgAlgAlts ty alg_alts deflt)
= mapAndUnzipLM lift_alg_alt alg_alts `thenLM` \ (alg_alts', alt_infos) ->
returnLM ((lit, rhs'), rhs_info)
lift_deflt StgNoDefault = returnLM (StgNoDefault, emptyLiftInfo)
- lift_deflt (StgBindDefault var used rhs)
+ lift_deflt (StgBindDefault rhs)
= liftExpr rhs `thenLM` \ (rhs', rhs_info) ->
- returnLM (StgBindDefault var used rhs', rhs_info)
+ returnLM (StgBindDefault rhs', rhs_info)
\end{code}
Now the interesting cases. Let no escape isn't lifted. We turn it
let
-- Find the free vars of all the rhss,
-- excluding the binders themselves.
- rhs_free_vars = unionManyIdSets (map rhsFreeVars rhss)
- `minusIdSet`
- mkIdSet binders
+ rhs_free_vars = unionVarSets (map rhsFreeVars rhss)
+ `minusVarSet`
+ mkVarSet binders
rhs_info = unionLiftInfos rhs_infos
in
\end{code}
\begin{code}
-liftExpr (StgSCC ty cc expr)
+liftExpr (StgSCC cc expr)
= liftExpr expr `thenLM` \ (expr2, expr_info) ->
- returnLM (StgSCC ty cc expr2, expr_info)
+ returnLM (StgSCC cc expr2, expr_info)
\end{code}
A binding is liftable if it's a *function* (args not null) and never
\begin{code}
isLiftable :: StgRhs -> Bool
-isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
+isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) _ fvs _ args _)
-- Experimental evidence suggests we should lift only if we will be
-- abstracting up to 4 fvs.
here).
-}
-isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
+isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) _ fvs _ args _)
= if not (null args || -- Not a function
unapplied_occ || -- Has an occ with no args at all
arg_occ || -- Occurs in arg position
isLiftableRec other_rhs = False
rhsFreeVars :: StgRhs -> IdSet
-rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkIdSet fvs
+rhsFreeVars (StgRhsClosure _ _ _ fvs _ _ _) = mkVarSet fvs
rhsFreeVars other = panic "rhsFreeVars"
\end{code}
dontLiftRhs rhs@(StgRhsCon cc v args) = returnLM (rhs, emptyLiftInfo)
-dontLiftRhs (StgRhsClosure cc bi fvs upd args body)
+dontLiftRhs (StgRhsClosure cc bi srt fvs upd args body)
= liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgRhsClosure cc bi fvs upd args body', body_info)
+ returnLM (StgRhsClosure cc bi srt fvs upd args body', body_info)
\end{code}
\begin{code}
-- the set is its free vars
(Id,StgRhs)) -- Binding for supercombinator
-mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body)
+mkScPieces extra_arg_set (id, StgRhsClosure cc bi srt _ upd args body)
= ASSERT( n_args > 0 )
-- Construct the rhs of the supercombinator, and its Id
newSupercombinator sc_ty arity `thenLM` \ sc_id ->
returnLM ((sc_id, extra_args), (sc_id, sc_rhs))
where
n_args = length args
- extra_args = idSetToList extra_arg_set
+ extra_args = varSetElems extra_arg_set
arity = n_args + length extra_args
-- Construct the supercombinator type
(tyvars, rest) = splitForAllTys type_of_original_id
sc_ty = mkForAllTys tyvars (mkFunTys extra_arg_tys rest)
- sc_rhs = StgRhsClosure cc bi [] upd (extra_args ++ args) body
+ sc_rhs = StgRhsClosure cc bi srt [] upd (extra_args ++ args) body
\end{code}
runLM :: Module -> LiftFlags -> UniqSupply -> LiftM a -> a
-runLM mod flags us m = m mod flags us nullIdEnv
+runLM mod flags us m = m mod flags us emptyVarEnv
thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b
thenLM m k mod ci us idenv
-> LiftM Id
newSupercombinator ty arity mod ci us idenv
- = setIdVisibility (Just mod) uniq (mkSysLocal SLIT("sc") uniq ty noSrcLoc)
- `addIdArity` exactArity arity
- -- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it?
+ = setIdVisibility (Just mod) uniq (mkSysLocal uniq ty)
+ `setIdArity` exactArity arity
+ -- ToDo: rm the setIdArity? Just let subsequent stg-saturation pass do it?
where
- uniq = getUnique us
+ uniq = uniqFromSupply us
lookUp :: Id -> LiftM (Id,[Id])
lookUp v mod ci us idenv
- = case (lookupIdEnv idenv v) of
+ = case (lookupVarEnv idenv v) of
Just result -> result
Nothing -> (v, [])
addScInlines ids values m mod ci us idenv
= m mod ci us idenv'
where
- idenv' = growIdEnvList idenv (ids `zip_lazy` values)
+ idenv' = extendVarEnvList idenv (ids `zip_lazy` values)
-- zip_lazy zips two things together but matches lazily on the
-- second argument. This is important, because the ids are know here,
getFinalFreeVars :: IdSet -> LiftM IdSet
getFinalFreeVars free_vars mod ci us idenv
- = unionManyIdSets (map munge_it (idSetToList free_vars))
+ = unionVarSets (map munge_it (varSetElems free_vars))
where
munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real"
-- free var
- munge_it id = case (lookupIdEnv idenv id) of
- Just (_, args) -> mkIdSet args
- Nothing -> unitIdSet id
+ munge_it id = case (lookupVarEnv idenv id) of
+ Just (_, args) -> mkVarSet args
+ Nothing -> unitVarSet id
\end{code}
getScBinds :: LiftInfo -> [StgBinding]
getScBinds binds = bagToList binds
-looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarArg f') args _)
+looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ _ ls _)] (StgApp f' args)
= (f == f') && (length args == length ls)
looksLikeSATRhs _ _ = False
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+
+Run through the STG code and compute the Static Reference Table for
+each let-binding. At the same time, we figure out which top-level
+bindings have no CAF references, and record the fact in their IdInfo.
+
+\begin{code}
+module SRT where
+
+import Id ( Id, setIdCafInfo, getIdCafInfo, externallyVisibleId,
+ isBottomingId )
+import IdInfo ( CafInfo(..) )
+import StgSyn
+
+import UniqFM
+import UniqSet
+\end{code}
+
+\begin{code}
+computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
+computeSRTs binds = srtBinds emptyUFM binds
+\end{code}
+
+\begin{code}
+srtBinds :: UniqFM CafInfo -> [StgBinding] -> [(StgBinding,[Id])]
+srtBinds rho [] = []
+srtBinds rho (b:bs) =
+ srtTopBind rho b =: \(b, srt, rho) ->
+ (b,srt) : srtBinds rho bs
+\end{code}
+
+-----------------------------------------------------------------------------
+Circular algorithm for simultaneously figuring out CafInfo and SRT
+layout.
+
+Our functions have type
+
+ :: UniqFM CafInfo -- which top-level ids don't refer to any CAfs
+ -> SrtOffset -- next free offset within the SRT
+{- * -} -> StgExpr -- expression to analyse
+
+ -> (StgExpr, -- (e) newly annotated expression
+ UniqSet Id, -- (g) set of *all* global references
+ [Id], -- (s) SRT required for this expression
+ SrtOffset) -- (o) new offset
+
+(g) is a set containing all local top-level and imported ids referred
+to by the expression (e).
+
+The set of all global references is used to build the environment,
+which is passed in again. The environment is used to build the final
+SRT.
+
+We build a single SRT for a recursive binding group, which is why the
+SRT building is done at the binding level rather than the
+StgRhsClosure level.
+
+Hence, the only argument which we can look at before returning is the
+expression (marked with {- * -} above).
+
+The SRT is built up in reverse order, to avoid too many expensive
+appends. We therefore reverse the SRT before returning it, so that
+the offsets will be from the beginning of the SRT.
+
+-----------------------------------------------------------------------------
+Top-level Bindings
+
+The environment contains a mapping from local top-level bindings to
+CafInfo. The CafInfo is either
+
+ NoCafRefs - indicating that the id is not a CAF and furthermore
+ that it doesn't refer, even indirectly, to any CAFs.
+
+ MayHaveCafRefs - everything else.
+
+A function whose CafInfo is NoCafRefs will have an empty SRT, and its
+closure will not appear in the SRT of any other function (unless we're
+compiling without optimisation and the CafInfos haven't been emitted
+in the interface files).
+
+Top-Level recursive groups
+
+This gets a bit complicated, but the general idea is that we want a
+single SRT for the whole group, and we'd rather not have recursive
+references in it if at all possible.
+
+We collect all the global references for the group, and filter out
+those that are binders in the group and not CAFs themselves. This set
+of references is then used to infer the CafInfo for each of the
+binders in the group. Why is it done this way?
+
+ - if all the bindings in the group just refer to each other,
+ and none of them are CAFs, we'd like to get an empty SRT.
+
+ - if any of the bindings in the group refer to a CAF, this will
+ appear in the SRT.
+
+Hmm, that probably makes no sense.
+
+\begin{code}
+srtTopBind
+ :: UniqFM CafInfo
+ -> StgBinding
+ -> (StgBinding, -- the new binding
+ [Id], -- the SRT for this binding
+ UniqFM CafInfo) -- the new environment
+
+srtTopBind rho (StgNonRec binder rhs) =
+
+ -- no need to use circularity for non-recursive bindings
+ srtRhs rho 0{-initial offset-} rhs =: \(rhs, g, srt, off) ->
+ let
+ filtered_g = filter (mayHaveCafRefs rho) (uniqSetToList g)
+ caf_info = mk_caf_info rhs filtered_g
+ binder' = setIdCafInfo binder caf_info
+ rho' = addToUFM rho binder' caf_info
+ extra_refs = filter (`notElem` srt) filtered_g
+ bind_srt = reverse (extra_refs ++ srt)
+ in
+ case rhs of
+ StgRhsClosure _ _ _ _ _ _ _ ->
+ (StgNonRec binder' (attach_srt_rhs rhs 0 (length bind_srt)),
+ bind_srt, rho')
+
+ -- don't output an SRT for the constructor, but just remember
+ -- whether it had any caf references or not.
+ StgRhsCon _ _ _ -> (StgNonRec binder' rhs, [], rho')
+
+
+srtTopBind rho (StgRec bs) =
+ (attach_srt_bind (StgRec (reverse new_bs')) 0 (length bind_srt),
+ bind_srt, rho')
+ where
+ (binders,rhss) = unzip bs
+
+ non_caf_binders = [ b | (b, rhs) <- bs, not (caf_rhs rhs) ]
+
+ -- circular: rho' is calculated from g below
+ (new_bs, g, srt, _) = doBinds bs [] emptyUniqSet [] 0
+
+ -- filter out ourselves from the global references: it makes no
+ -- sense to refer recursively to our SRT unless the recursive
+ -- reference is required by a nested SRT.
+ filtered_g = filter (\id -> id `notElem` non_caf_binders &&
+ mayHaveCafRefs rho id) (uniqSetToList g)
+ extra_refs = filter (`notElem` srt) filtered_g
+ bind_srt = reverse (extra_refs ++ srt)
+ caf_infos = map (\rhs -> mk_caf_info rhs filtered_g) rhss
+ rho' = addListToUFM rho (zip binders caf_infos)
+ binders' = zipWith setIdCafInfo binders caf_infos
+
+ new_bs' = zip binders' (map snd new_bs)
+
+ doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off)
+ doBinds ((binder,rhs):binds) new_binds g srt off =
+ srtRhs rho' off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
+ let
+ g' = unionUniqSets rhs_g g
+ srt' = rhs_srt ++ srt
+ in
+ doBinds binds ((binder,rhs):new_binds) g' srt' off
+
+caf_rhs (StgRhsClosure _ _ _ free_vars _ [] body) = True
+caf_rhs _ = False
+\end{code}
+
+-----------------------------------------------------------------------------
+Non-top-level bindings
+
+\begin{code}
+srtBind :: UniqFM CafInfo -> Int -> StgBinding
+ -> (StgBinding, UniqSet Id, [Id], Int)
+
+srtBind rho off (StgNonRec binder rhs) =
+ srtRhs rho off rhs =: \(rhs, g, srt, off) ->
+ (StgNonRec binder rhs, g, srt, off)
+
+srtBind rho off (StgRec binds) =
+ (StgRec new_binds, g, srt, new_off)
+ where
+ -- process each binding
+ (new_binds, g, srt, new_off) = doBinds binds emptyUniqSet [] off []
+
+ doBinds [] g srt off new_binds = (reverse new_binds, g, srt, off)
+ doBinds ((binder,rhs):binds) g srt off new_binds =
+ srtRhs rho off rhs =: \(rhs, g', srt', off) ->
+ doBinds binds (unionUniqSets g g') (srt'++srt) off
+ ((binder,rhs):new_binds)
+\end{code}
+
+-----------------------------------------------------------------------------
+Right Hand Sides
+
+\begin{code}
+srtRhs :: UniqFM CafInfo -> Int -> StgRhs
+ -> (StgRhs, UniqSet Id, [Id], Int)
+
+srtRhs rho off (StgRhsClosure cc bi old_srt free_vars u args body) =
+ srtExpr rho off body =: \(body, g, srt, off) ->
+ (StgRhsClosure cc bi old_srt free_vars u args body, g, srt, off)
+
+srtRhs rho off e@(StgRhsCon cc con args) =
+ (e, getGlobalRefs rho args, [], off)
+\end{code}
+
+-----------------------------------------------------------------------------
+Expressions
+
+\begin{code}
+srtExpr :: UniqFM CafInfo -> Int -> StgExpr
+ -> (StgExpr, UniqSet Id, [Id], Int)
+
+srtExpr rho off e@(StgApp f args) =
+ (e, getGlobalRefs rho (StgVarArg f:args), [], off)
+
+srtExpr rho off e@(StgCon con args ty) =
+ (e, getGlobalRefs rho args, [], off)
+
+srtExpr rho off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
+ srtCaseAlts rho off alts =: \(alts, alts_g, alts_srt, alts_off) ->
+ let
+ extra_refs = filter (`notElem` alts_srt)
+ (filter (mayHaveCafRefs rho) (uniqSetToList alts_g))
+ this_srt = extra_refs ++ alts_srt
+ scrut_off = alts_off + length extra_refs
+ in
+ srtExpr rho scrut_off scrut =: \(scrut, scrut_g, scrut_srt, case_off) ->
+ let
+ g = unionUniqSets alts_g scrut_g
+ srt = scrut_srt ++ this_srt
+ srt_info = case length this_srt of
+ 0 -> NoSRT
+ len -> SRT off len
+ in
+ (StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off)
+
+srtExpr rho off (StgLet bind body) =
+ srtLet rho off bind body StgLet
+
+ -- let-no-escapes are delicate, see below
+srtExpr rho off (StgLetNoEscape live1 live2 bind body) =
+ srtLet rho off bind body (StgLetNoEscape live1 live2)
+ =: \(expr, g, srt, off') ->
+ let
+ -- find the SRT for the *whole* expression
+ length = off' - off
+ all_srt | length == 0 = NoSRT
+ | otherwise = SRT off length
+ in
+ (fixLNE_srt all_srt expr, g, srt, off')
+
+srtExpr rho off (StgSCC cc expr) =
+ srtExpr rho off expr =: \(expr, g, srt, off) ->
+ (StgSCC cc expr, g, srt, off)
+\end{code}
+
+-----------------------------------------------------------------------------
+Let-expressions
+
+This is quite complicated stuff...
+
+\begin{code}
+srtLet rho off bind body let_constr
+
+ -- If the bindings are all constructors, then we don't need to
+ -- buid an SRT at all...
+ | all_con_binds bind =
+ srtBind rho off bind =: \(bind, bind_g, bind_srt, off) ->
+ srtExpr rho off body =: \(body, body_g, body_srt, off) ->
+ let
+ g = unionUniqSets bind_g body_g
+ srt = body_srt ++ bind_srt
+ in
+ (let_constr bind body, g, srt, off)
+
+ -- we have some closure bindings...
+ | otherwise =
+
+ -- first, find the sub-SRTs in the binding
+ srtBind rho off bind =: \(bind, bind_g, bind_srt, bind_off) ->
+
+ -- Construct the SRT for this binding from its sub-SRTs and any new global
+ -- references which aren't already contained in one of the sub-SRTs (and
+ -- which are "live").
+ let
+ extra_refs = filter (`notElem` bind_srt)
+ (filter (mayHaveCafRefs rho) (uniqSetToList bind_g))
+ this_srt = extra_refs ++ bind_srt
+
+ -- Add the length of the new entries to the
+ -- current offset to get the next free offset in the global SRT.
+ body_off = bind_off + length extra_refs
+ in
+
+ -- now find the SRTs in the body
+ srtExpr rho body_off body =: \(body, body_g, body_srt, let_off) ->
+
+ let
+ -- union all the global references together
+ let_g = unionUniqSets bind_g body_g
+
+ -- concatenate the sub-SRTs
+ let_srt = body_srt ++ this_srt
+
+ -- attach the SRT info to the binding
+ bind' = attach_srt_bind bind off (length this_srt)
+ in
+ (let_constr bind' body, let_g, let_srt, let_off)
+\end{code}
+
+-----------------------------------------------------------------------------
+Case Alternatives
+
+\begin{code}
+srtCaseAlts :: UniqFM CafInfo -> Int -> StgCaseAlts ->
+ (StgCaseAlts, UniqSet Id, [Id], Int)
+
+srtCaseAlts rho off (StgAlgAlts t alts dflt) =
+ srtAlgAlts rho off alts [] emptyUniqSet []
+ =: \(alts, alts_g, alts_srt, off) ->
+ srtDefault rho off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
+ let
+ g = unionUniqSets alts_g dflt_g
+ srt = dflt_srt ++ alts_srt
+ in
+ (StgAlgAlts t alts dflt, g, srt, off)
+
+srtCaseAlts rho off (StgPrimAlts t alts dflt) =
+ srtPrimAlts rho off alts [] emptyUniqSet []
+ =: \(alts, alts_g, alts_srt, off) ->
+ srtDefault rho off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
+ let
+ g = unionUniqSets alts_g dflt_g
+ srt = dflt_srt ++ alts_srt
+ in
+ (StgPrimAlts t alts dflt, g, srt, off)
+
+srtAlgAlts rho off [] new_alts g srt = (reverse new_alts, g, srt, off)
+srtAlgAlts rho off ((con,args,used,rhs):alts) new_alts g srt =
+ srtExpr rho off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
+ let
+ g' = unionUniqSets rhs_g g
+ srt' = rhs_srt ++ srt
+ in
+ srtAlgAlts rho off alts ((con,args,used,rhs) : new_alts) g' srt'
+
+srtPrimAlts rho off [] new_alts g srt = (reverse new_alts, g, srt, off)
+srtPrimAlts rho off ((lit,rhs):alts) new_alts g srt =
+ srtExpr rho off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
+ let
+ g' = unionUniqSets rhs_g g
+ srt' = rhs_srt ++ srt
+ in
+ srtPrimAlts rho off alts ((lit,rhs) : new_alts) g' srt'
+
+srtDefault rho off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
+srtDefault rho off (StgBindDefault rhs) =
+ srtExpr rho off rhs =: \(rhs, g, srt, off) ->
+ (StgBindDefault rhs, g, srt, off)
+\end{code}
+
+-----------------------------------------------------------------------------
+
+Decide whether a closure looks like a CAF or not. In an effort to
+keep the number of CAFs (and hence the size of the SRTs) down, we
+would also like to look at the expression and decide whether it
+requires a small bounded amount of heap, so we can ignore it as a CAF.
+In these cases, we need to use an additional CAF list to keep track of
+non-collectable CAFs.
+
+We mark real CAFs as `MayHaveCafRefs' because this information is used
+to decide whether a particular closure needs to be referenced in an
+SRT or not.
+
+\begin{code}
+mk_caf_info
+ :: StgRhs -- right-hand-side of the definition
+ -> [Id] -- static references
+ -> CafInfo
+
+-- special case for expressions which are always bottom,
+-- such as 'error "..."'. We don't need to record it as
+-- a CAF, since it can only be entered once.
+mk_caf_info (StgRhsClosure _ _ _ free_vars _ [] e) srt
+ | isBottomingExpr e && null srt = NoCafRefs
+
+mk_caf_info (StgRhsClosure _ _ _ free_vars upd args body) srt
+ | isUpdatable upd = MayHaveCafRefs -- a real live CAF
+ | null srt = NoCafRefs -- function w/ no static references
+ | otherwise = MayHaveCafRefs -- function w/ some static references
+
+mk_caf_info (StgRhsCon cc con args) srt
+ | null srt = NoCafRefs -- constructor w/ no static references
+ | otherwise = MayHaveCafRefs -- otherwise, treat as a CAF
+
+isBottomingExpr (StgLet bind expr) = isBottomingExpr expr
+isBottomingExpr (StgApp f args) = isBottomingId f
+isBottomingExpr _ = False
+\end{code}
+
+-----------------------------------------------------------------------------
+
+Here we decide which Id's to place in the static reference table. An
+internal top-level id will be in the environment with the appropriate
+CafInfo, so we use that if available. An imported top-level Id will
+have the CafInfo attached. Otherwise, we just ignore the Id.
+
+\begin{code}
+getGlobalRefs :: UniqFM CafInfo -> [StgArg] -> UniqSet Id
+getGlobalRefs rho args = mkUniqSet (concat (map (globalRefArg rho) args))
+
+globalRefArg :: UniqFM CafInfo -> StgArg -> [Id]
+
+globalRefArg rho (StgVarArg id)
+
+ | otherwise =
+ case lookupUFM rho id of {
+ Just _ -> [id]; -- can't look at the caf_info yet...
+ Nothing ->
+
+ if externallyVisibleId id
+ then case getIdCafInfo id of
+ MayHaveCafRefs -> [id]
+ NoCafRefs -> []
+ else []
+ }
+
+globalRefArg rho _ = []
+\end{code}
+
+\begin{code}
+mayHaveCafRefs rho id =
+ case lookupUFM rho id of
+ Just MayHaveCafRefs -> True
+ Just NoCafRefs -> False
+ Nothing -> True
+\end{code}
+
+-----------------------------------------------------------------------------
+Misc stuff
+
+\begin{code}
+attach_srt_bind :: StgBinding -> Int -> Int -> StgBinding
+attach_srt_bind (StgNonRec binder rhs) off len =
+ StgNonRec binder (attach_srt_rhs rhs off len)
+attach_srt_bind (StgRec binds) off len =
+ StgRec [ (v,attach_srt_rhs rhs off len) | (v,rhs) <- binds ]
+
+attach_srt_rhs :: StgRhs -> Int -> Int -> StgRhs
+attach_srt_rhs (StgRhsCon cc con args) off length
+ = StgRhsCon cc con args
+attach_srt_rhs (StgRhsClosure cc bi _ free upd args rhs) off length
+ = StgRhsClosure cc bi srt free upd args rhs
+ where
+ srt | length == 0 = NoSRT
+ | otherwise = SRT off length
+
+
+all_con_binds (StgNonRec x rhs) = con_rhs rhs
+all_con_binds (StgRec bs) = all con_rhs (map snd bs)
+
+con_rhs (StgRhsCon _ _ _) = True
+con_rhs _ = False
+
+
+a =: k = k a
+\end{code}
+
+-----------------------------------------------------------------------------
+Fix up the SRT's in a let-no-escape.
+
+(for a description of let-no-escapes, see CgLetNoEscape.lhs)
+
+Here's the problem: a let-no-escape isn't represented by an activation
+record on the stack. It seems either very difficult or impossible to
+get the liveness bitmap right in the info table, so we don't do it
+this way (the liveness mask isn't constant).
+
+So, the question is how does the garbage collector get access to the
+SRT for the rhs of the let-no-escape? It can't see an info table, so
+it must get the SRT from somewhere else. Here's an example:
+
+ let-no-escape x = .... f ....
+ in case blah of
+ p -> .... x ... g ....
+
+(f and g are global). Suppose we garbage collect while evaluating
+'blah'. The stack will contain an activation record for the case,
+which will point to an SRT containing [g] (according to our SRT
+algorithm above). But, since the case continuation can call x, and
+hence f, the SRT should really be [f,g].
+
+another example:
+
+ let-no-escape {-rec-} z = \x -> case blah of
+ p1 -> .... f ...
+ p2 -> case blah2 of
+ p -> .... (z x') ...
+ in ....
+
+if we GC while evaluating blah2, then the case continuation on the
+stack needs to refer to [f] in its SRT, because we can reach f by
+calling z recursively.
+
+FIX:
+
+The following code fixes up a let-no-escape expression after we've run
+the SRT algorithm. It needs to know the SRT for the *whole*
+expression (this is plugged in instead of the SRT for case exprsesions
+in the body). The good news is that we only need to traverse nested
+case expressions, since the let-no-escape bound variable can't occur
+in the rhs of a let or in a case scrutinee.
+
+For recursive let-no-escapes, the body is processed as for
+non-recursive let-no-escapes, but case expressions in the rhs of each
+binding have their SRTs replaced with the SRT for the binding group
+(*not* the SRT of the whole let-no-escape expression).
+
+\begin{code}
+fixLNE_srt :: SRT -> StgExpr -> StgExpr
+fixLNE_srt all_srt (StgLetNoEscape live1 live2 (StgNonRec id rhs) body)
+ = StgLetNoEscape live1 live2 (StgNonRec id rhs) (fixLNE [id] all_srt body)
+
+fixLNE_srt all_srt (StgLetNoEscape live1 live2 (StgRec pairs) body)
+ = StgLetNoEscape live1 live2
+ (StgRec (map fixLNE_rec pairs)) (fixLNE binders all_srt body)
+ where
+ binders = map fst pairs
+ fixLNE_rec (id,StgRhsClosure cc bi srt fvs uf args e) =
+ (id, StgRhsClosure cc bi srt fvs uf args (fixLNE binders srt e))
+ fixLNE_rec (id,con) = (id,con)
+
+fixLNE :: [Id] -> SRT -> StgExpr -> StgExpr
+
+fixLNE ids srt expr@(StgCase scrut live rhs_live bndr old_srt alts)
+ | any (`elementOfUniqSet` rhs_live) ids
+ = StgCase scrut live rhs_live bndr srt (fixLNE_alts ids srt alts)
+ | otherwise = expr
+ -- can't be in the scrutinee, because it's a let-no-escape!
+
+fixLNE ids srt expr@(StgLetNoEscape live rhs_live bind body)
+ | any (`elementOfUniqSet` rhs_live) ids =
+ StgLetNoEscape live rhs_live (fixLNE_bind ids srt bind)
+ (fixLNE ids srt body)
+ | any (`elementOfUniqSet` live) ids =
+ StgLetNoEscape live rhs_live bind (fixLNE ids srt body)
+ | otherwise = expr
+
+fixLNE ids srt (StgLet bind body) = StgLet bind (fixLNE ids srt body)
+fixLNE ids srt (StgSCC cc expr) = StgSCC cc (fixLNE ids srt expr)
+fixLNE ids srt expr = expr
+
+fixLNE_alts ids srt (StgAlgAlts t alts dflt)
+ = StgAlgAlts t (map (fixLNE_algalt ids srt) alts) (fixLNE_dflt ids srt dflt)
+
+fixLNE_alts ids srt (StgPrimAlts t alts dflt)
+ = StgPrimAlts t (map (fixLNE_primalt ids srt) alts) (fixLNE_dflt ids srt dflt)
+
+fixLNE_algalt ids srt (con,args,used,rhs) = (con,args,used, fixLNE ids srt rhs)
+fixLNE_primalt ids srt (lit,rhs) = (lit, fixLNE ids srt rhs)
+
+fixLNE_dflt ids srt (StgNoDefault) = StgNoDefault
+fixLNE_dflt ids srt (StgBindDefault rhs) = StgBindDefault (fixLNE ids srt rhs)
+
+fixLNE_bind ids srt (StgNonRec bndr rhs)
+ = StgNonRec bndr (fixLNE_rhs ids srt rhs)
+fixLNE_bind ids srt (StgRec pairs)
+ = StgRec [ (bndr, fixLNE_rhs ids srt rhs) | (bndr,rhs) <- pairs ]
+
+fixLNE_rhs ids srt rhs@(StgRhsClosure cc bi old_srt fvs uf args expr)
+ | any (`elem` fvs) ids
+ = StgRhsClosure cc bi srt fvs uf args (fixLNE ids srt expr)
+ | otherwise = rhs
+fixLNE_rhs ids srt rhs@(StgRhsCon cc con args) = rhs
+
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[SimplStg]{Driver for simplifying @STG@ programs}
import StgSyn
import LambdaLift ( liftProgram )
-import CostCentre ( CostCentre )
+import CostCentre ( CostCentre, CostCentreStack )
import SCCfinal ( stgMassageForProfiling )
import StgLint ( lintStgBindings )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
+import SRT ( computeSRTs )
-import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
+import CmdLineOpts ( opt_SccGroup,
opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
opt_DoStgLinting,
StgToDo(..)
)
+import Id ( Id )
+import VarEnv
import ErrUtils ( doIfSet )
import UniqSupply ( splitUniqSupply, UniqSupply )
import Util ( panic, assertPanic, trace )
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
-> IO
- ([StgBinding], -- output program...
- ([CostCentre], -- local cost-centres that need to be decl'd
- [CostCentre])) -- "extern" cost-centres
+ ([(StgBinding,[Id])], -- output program...
+ ([CostCentre], -- local cost-centres that need to be decl'd
+ [CostCentre], -- "extern" cost-centres
+ [CostCentreStack])) -- pre-defined "singleton" cost centre stacks
stg2stg stg_todos module_name us binds
= case (splitUniqSupply us) of { (us4now, us4later) ->
vcat (map ppr (setStgVarInfo False binds)))) >>
-- Do the main business!
- foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
+ foldl_mn do_stg_pass (binds, us4now, ([],[],[])) stg_todos
>>= \ (processed_binds, _, cost_centres) ->
-- Do essential wind-up
-{- Nuked for now SLPJ Dec 96
-
- -- Essential wind-up: part (a), saturate RHSs
- -- This must occur *after* elimIndirections, because elimIndirections
- -- can change things' arities. Consider:
- -- x_local = f x
- -- x_global = \a -> x_local a
- -- Then elimIndirections will change the program to
- -- x_global = f x
- -- and lo and behold x_global's arity has changed!
- case (satStgRhs processed_binds us4later) of { saturated_binds ->
--}
-
-- Essential wind-up: part (b), do setStgVarInfo. It has to
-- happen regardless, because the code generator uses its
-- decorations.
-- correct, which is done by satStgRhs.
--
- return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
+ let
+ annotated_binds = setStgVarInfo do_let_no_escapes processed_binds
+ srt_binds = computeSRTs annotated_binds
+ in
+
+ return (srt_binds, cost_centres)
}
where
do_let_no_escapes = opt_StgDoLetNoEscapes
do_verbose_stg2stg = opt_D_verbose_stg2stg
-{-
- (do_unlocalising, unlocal_tag)
- = case opt_EnsureSplittableC of
- Just tag -> (True, _PK_ tag)
- Nothing -> (False, panic "tag")
--}
grp_name = case (opt_SccGroup) of
Just xx -> _PK_ xx
Nothing -> module_name -- default: module name
-------------
- stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
+ stg_linter = if opt_DoStgLinting
then lintStgBindings
else ( \ whodunnit binds -> binds )
StgDoStaticArgs -> panic "STG static argument transformation deleted"
StgDoUpdateAnalysis ->
- ASSERT(null (fst ccs) && null (snd ccs))
_scc_ "StgUpdAnal"
-- NB We have to do setStgVarInfo first! (There's one
-- place free-var info is used) But no let-no-escapes,
end_pass us2 what ccs binds2
= -- report verbosely, if required
(if do_verbose_stg2stg then
- hPutStr stderr (showSDoc
+ hPutStr stderr (show
(text ("*** "++what++":") $$ vcat (map ppr binds2)
))
else return ()) >>
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[StgStats]{Gathers statistical information about programs}
import StgSyn
+import Const ( Con(..) )
import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )
import Id (Id)
\end{code}
statRhs top (b, StgRhsCon cc con args)
= countOne (ConstructorBinds top)
-statRhs top (b, StgRhsClosure cc bi fv u args body)
+statRhs top (b, StgRhsClosure cc bi srt fv u args body)
= statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
countOne (
\begin{code}
statExpr :: StgExpr -> StatEnv
-statExpr (StgApp _ [] lvs)
- = countOne Literals
-statExpr (StgApp _ _ lvs)
+statExpr (StgApp _ _)
= countOne Applications
-statExpr (StgCon con as lvs)
+statExpr (StgCon (DataCon _) as _)
= countOne ConstructorApps
-statExpr (StgPrim op as lvs)
+statExpr (StgCon (PrimOp _) as _)
= countOne PrimitiveApps
-statExpr (StgSCC ty l e)
+statExpr (StgCon (Literal _) as _)
+ = countOne Literals
+
+statExpr (StgSCC l e)
= statExpr e
statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body
-statExpr (StgCase expr lve lva uniq alts)
+statExpr (StgCase expr lve lva bndr srt alts)
= statExpr expr `combineSE`
stat_alts alts
where
stat_deflt StgNoDefault = emptySE
- stat_deflt (StgBindDefault b u expr) = statExpr expr
+ stat_deflt (StgBindDefault expr) = statExpr expr
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[StgVarInfo]{Sets free/live variable info in STG syntax}
import StgSyn
-import Id ( emptyIdSet, mkIdSet, minusIdSet,
- unionIdSets, unionManyIdSets, isEmptyIdSet,
- unitIdSet, intersectIdSets,
- addIdArity, getIdArity,
- addOneToIdSet, IdSet,
- nullIdEnv, growIdEnvList, lookupIdEnv,
- unitIdEnv, combineIdEnvs, delManyFromIdEnv,
- rngIdEnv, IdEnv,
- GenId{-instance Eq-}, Id
- )
+import Id ( setIdArity, getIdArity, Id )
+import VarSet
+import VarEnv
import IdInfo ( ArityInfo(..) )
import Maybes ( maybeToBool )
import Name ( isLocallyDefined )
varsTopBinds [] = returnLne ([], emptyFVInfo)
varsTopBinds (bind:binds)
- = extendVarEnv env_extension (
+ = extendVarEnvLne env_extension (
varsTopBinds binds `thenLne` \ (binds', fv_binds) ->
varsTopBind binders' fv_binds bind `thenLne` \ (bind', fv_bind) ->
returnLne ((bind' : binds'),
StgNonRec binder rhs -> [(binder,rhs)]
StgRec pairs -> pairs
- binders' = [ binder `addIdArity` ArityExactly (rhsArity rhs)
+ binders' = [ binder `setIdArity` ArityExactly (rhsArity rhs)
| (binder, rhs) <- pairs
]
how_bound = LetrecBound
True {- top level -}
- emptyIdSet
+ emptyVarSet
varsTopBind :: [Id] -- New binders (with correct arity)
= varsAtoms args `thenLne` \ (args', fvs) ->
returnLne (StgRhsCon cc con args', fvs, getFVSet fvs)
-varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body)
- = extendVarEnv [ (zapArity a, LambdaBound) | a <- args ] (
+varsRhs scope_fv_info (binder, StgRhsClosure cc _ srt _ upd args body)
+ = extendVarEnvLne [ (zapArity a, LambdaBound) | a <- args ] (
do_body args body `thenLne` \ (body2, body_fvs, body_escs) ->
let
- set_of_args = mkIdSet args
+ set_of_args = mkVarSet args
rhs_fvs = body_fvs `minusFVBinders` args
- rhs_escs = body_escs `minusIdSet` set_of_args
+ rhs_escs = body_escs `minusVarSet` set_of_args
binder_info = lookupFVInfo scope_fv_info binder
+ upd' | null args && isPAP body2 = SingleEntry
+ | otherwise = upd
in
- returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2,
- rhs_fvs, rhs_escs)
+ returnLne (StgRhsClosure cc binder_info srt (getFVs rhs_fvs) upd'
+ args body2, rhs_fvs, rhs_escs)
)
where
-- Pick out special case of application in body of thunk
- do_body [] (StgApp (StgVarArg f) args _) = varsApp (Just upd) f args
- do_body _ other_body = varsExpr other_body
+ do_body [] (StgApp f args) = varsApp (Just upd) f args
+ do_body _ other_body = varsExpr other_body
\end{code}
+Detect thunks which will reduce immediately to PAPs, and make them
+non-updatable. This has several advantages:
+
+ - the non-updatable thunk behaves exactly like the PAP,
+
+ - the thunk is more efficient to enter, because it is
+ specialised to the task.
+
+ - we save one update frame, one stg_update_PAP, one update
+ and lots of PAP_enters.
+
+ - in the case where the thunk is top-level, we save building
+ a black hole and futhermore the thunk isn't considered to
+ be a CAF any more, so it doesn't appear in any SRTs.
+
+We do it here, because the arity information is accurate, and we need
+to do it before the SRT pass to save the SRT entries associated with
+any top-level PAPs.
+
+\begin{code}
+isPAP (StgApp f args)
+ = case getIdArity f of
+ ArityExactly n -> n > n_args
+ ArityAtLeast n -> n > n_args
+ _ -> False
+ where n_args = length args
+isPAP _ = False
+\end{code}
\begin{code}
varsAtoms :: [StgArg]
= mapAndUnzipLne var_atom atoms `thenLne` \ (args', fvs_lists) ->
returnLne (args', unionFVInfos fvs_lists)
where
- var_atom a@(StgLitArg _) = returnLne (a, emptyFVInfo)
var_atom a@(StgConArg _) = returnLne (a, emptyFVInfo)
var_atom a@(StgVarArg v)
- = lookupVarEnv v `thenLne` \ (v', how_bound) ->
+ = lookupVarLne v `thenLne` \ (v', how_bound) ->
returnLne (StgVarArg v', singletonFVInfo v' how_bound stgArgOcc)
\end{code}
decisions. Hence no black holes.
\begin{code}
-varsExpr (StgApp lit@(StgLitArg _) args _)
- = returnLne (StgApp lit [] emptyIdSet, emptyFVInfo, emptyIdSet)
-
-varsExpr (StgApp lit@(StgConArg _) args _)
- = panic "varsExpr StgConArg" -- Only occur in argument positions
-
-varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args
+varsExpr (StgApp f args) = varsApp Nothing f args
-varsExpr (StgCon con args _)
+varsExpr (StgCon con args res_ty)
= getVarsLiveInCont `thenLne` \ live_in_cont ->
varsAtoms args `thenLne` \ (args', args_fvs) ->
+ returnLne (StgCon con args' res_ty, args_fvs, getFVSet args_fvs)
- returnLne (StgCon con args' live_in_cont, args_fvs, getFVSet args_fvs)
-
-varsExpr (StgPrim op args _)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- varsAtoms args `thenLne` \ (args', args_fvs) ->
- returnLne (StgPrim op args' live_in_cont, args_fvs, getFVSet args_fvs)
-
-varsExpr (StgSCC ty label expr)
+varsExpr (StgSCC label expr)
= varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
- returnLne (StgSCC ty label expr2, fvs, escs) )
+ returnLne (StgSCC label expr2, fvs, escs) )
\end{code}
Cases require a little more real work.
\begin{code}
-varsExpr (StgCase scrut _ _ uniq alts)
+varsExpr (StgCase scrut _ _ bndr srt alts)
= getVarsLiveInCont `thenLne` \ live_in_cont ->
+ extendVarEnvLne [(zapArity bndr, CaseBound)] (
vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) ->
lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
let
- live_in_alts = live_in_cont `unionIdSets` alts_lvs
+ -- don't consider the default binder as being 'live in alts',
+ -- since this is from the point of view of the case expr, where
+ -- the default binder is not free.
+ live_in_alts = live_in_cont `unionVarSet`
+ (alts_lvs `minusVarSet` unitVarSet bndr)
in
-- we tell the scrutinee that everything live in the alts
-- is live in it, too.
) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
let
- live_in_whole_case = live_in_alts `unionIdSets` scrut_lvs
+ live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
in
returnLne (
- StgCase scrut2 live_in_whole_case live_in_alts uniq alts2,
- scrut_fvs `unionFVInfo` alts_fvs,
- alts_escs `unionIdSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape
- )
+ StgCase scrut2 live_in_whole_case live_in_alts bndr srt alts2,
+ (scrut_fvs `unionFVInfo` alts_fvs)
+ `minusFVBinders` [bndr],
+ (alts_escs `unionVarSet` (getFVSet scrut_fvs))
+ `minusVarSet` unitVarSet bndr
+
+ ))
where
vars_alts (StgAlgAlts ty alts deflt)
= mapAndUnzip3Lne vars_alg_alt alts
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionManyIdSets alts_escs_list
+ alts_escs = unionVarSets alts_escs_list
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
StgAlgAlts ty alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionIdSets` deflt_escs
+ alts_escs `unionVarSet` deflt_escs
)
where
vars_alg_alt (con, binders, worthless_use_mask, rhs)
- = extendVarEnv [(zapArity b, CaseBound) | b <- binders] (
+ = extendVarEnvLne [(zapArity b, CaseBound) | b <- binders] (
varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
let
good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
returnLne (
(con, binders, good_use_mask, rhs2),
rhs_fvs `minusFVBinders` binders,
- rhs_escs `minusIdSet` mkIdSet binders -- ToDo: remove the minusIdSet;
+ rhs_escs `minusVarSet` mkVarSet binders -- ToDo: remove the minusVarSet;
-- since escs won't include
-- any of these binders
))
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionManyIdSets alts_escs_list
+ alts_escs = unionVarSets alts_escs_list
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
StgPrimAlts ty alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionIdSets` deflt_escs
+ alts_escs `unionVarSet` deflt_escs
)
where
vars_prim_alt (lit, rhs)
returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
vars_deflt StgNoDefault
- = returnLne (StgNoDefault, emptyFVInfo, emptyIdSet)
+ = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
- vars_deflt (StgBindDefault binder _ rhs)
- = extendVarEnv [(zapArity binder, CaseBound)] (
- varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
- let
- used_in_rhs = binder `elementOfFVInfo` rhs_fvs
- in
- returnLne (
- StgBindDefault binder used_in_rhs rhs2,
- rhs_fvs `minusFVBinders` [binder],
- rhs_escs `minusIdSet` unitIdSet binder
- ))
+ vars_deflt (StgBindDefault rhs)
+ = varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ returnLne ( StgBindDefault rhs2, rhs_fvs, rhs_escs )
\end{code}
Lets not only take quite a bit of work, but this is where we convert
varsAtoms args `thenLne` \ (args', args_fvs) ->
- lookupVarEnv f `thenLne` \ (f', how_bound) ->
+ lookupVarLne f `thenLne` \ (f', how_bound) ->
let
n_args = length args
| otherwise -> stgNormalOcc
-- Record only that it occurs free
- myself = unitIdSet f'
+ myself = unitVarSet f'
- fun_escs | not_letrec_bound = emptyIdSet -- Only letrec-bound escapees are interesting
+ fun_escs | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
| otherwise = case f_arity of -- Letrec bound, so must have its arity
ArityExactly arity
- | arity == n_args -> emptyIdSet
+ | arity == n_args -> emptyVarSet
-- Function doesn't escape
| otherwise -> myself
-- Inexact application; it does escape
-- continuation, but it does no harm to just union the
-- two regardless.
- live_at_call
- = live_in_cont `unionIdSets` case how_bound of
- LetrecBound _ lvs -> lvs `minusIdSet` myself
- other -> emptyIdSet
+ -- XXX not needed?
+ -- live_at_call
+ -- = live_in_cont `unionVarSet` case how_bound of
+ -- LetrecBound _ lvs -> lvs `minusVarSet` myself
+ -- other -> emptyVarSet
in
returnLne (
- StgApp (StgVarArg f') args' live_at_call,
+ StgApp f' args',
fun_fvs `unionFVInfo` args_fvs,
- fun_escs `unionIdSets` (getFVSet args_fvs)
+ fun_escs `unionVarSet` (getFVSet args_fvs)
-- All the free vars of the args are disqualified
-- from being let-no-escaped.
)
-- we ain't in a let-no-escape world
getVarsLiveInCont `thenLne` \ live_in_cont ->
setVarsLiveInCont
- (if let_no_escape then live_in_cont else emptyIdSet)
+ (if let_no_escape then live_in_cont else emptyVarSet)
(vars_bind rec_bind_lvs rec_body_fvs bind)
`thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
-- together with the live_in_cont ones
lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs ->
let
- bind_lvs = lvs_from_fvs `unionIdSets` live_in_cont
+ bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
in
-- bind_fvs and bind_escs still include the binders of the let(rec)
-- but bind_lvs does not
-- Do the body
- extendVarEnv env_ext (
+ extendVarEnvLne env_ext (
varsExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
= (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
live_in_whole_let
- = bind_lvs `unionIdSets` (body_lvs `minusIdSet` set_of_binders)
+ = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
real_bind_escs = if let_no_escape then
bind_escs
getFVSet bind_fvs
-- Everything escapes which is free in the bindings
- let_escs = (real_bind_escs `unionIdSets` body_escs) `minusIdSet` set_of_binders
+ let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
- all_escs = bind_escs `unionIdSets` body_escs -- Still includes binders of
+ all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
-- this let(rec)
- no_binder_escapes = isEmptyIdSet (set_of_binders `intersectIdSets` all_escs)
+ no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
-- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
in
no_binder_escapes
))
where
- set_of_binders = mkIdSet binders
+ set_of_binders = mkVarSet binders
binders = case bind of
StgNonRec binder rhs -> [binder]
StgRec pairs -> map fst pairs
mk_binding bind_lvs (binder,rhs)
- = (binder `addIdArity` ArityExactly (stgArity rhs),
+ = (binder `setIdArity` ArityExactly (stgArity rhs),
LetrecBound False -- Not top level
live_vars
)
where
live_vars = if let_no_escape then
- addOneToIdSet bind_lvs binder
+ extendVarSet bind_lvs binder
else
- unitIdSet binder
+ unitVarSet binder
vars_bind :: StgLiveVars
-> FreeVarsInfo -- Free var info for body of binding
env_ext = map (mk_binding rec_bind_lvs) pairs
binders' = map fst env_ext
in
- extendVarEnv env_ext (
+ extendVarEnvLne env_ext (
fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
let
rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
let
fvs = unionFVInfos fvss
- escs = unionManyIdSets escss
+ escs = unionVarSets escss
in
returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
))
The std monad functions:
\begin{code}
initLne :: Bool -> LneM a -> a
-initLne want_LNEs m = m want_LNEs nullIdEnv emptyIdSet
+initLne want_LNEs m = m want_LNEs emptyVarEnv emptyVarSet
{-# INLINE thenLne #-}
{-# INLINE thenLne_ #-}
setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
= expr sw env new_lvs_cont
-extendVarEnv :: [(Id, HowBound)] -> LneM a -> LneM a
-extendVarEnv ids_w_howbound expr sw env lvs_cont
- = expr sw (growIdEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
+extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
+extendVarEnvLne ids_w_howbound expr sw env lvs_cont
+ = expr sw (extendVarEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
-lookupVarEnv :: Id -> LneM (Id, HowBound)
-lookupVarEnv v sw env lvs_cont
+lookupVarLne :: Id -> LneM (Id, HowBound)
+lookupVarLne v sw env lvs_cont
= returnLne (
- case (lookupIdEnv env v) of
+ case (lookupVarEnv env v) of
Just xx -> xx
Nothing -> --false:ASSERT(not (isLocallyDefined v))
(v, ImportBound)
lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
lookupLiveVarsForSet fvs sw env lvs_cont
- = returnLne (unionManyIdSets (map do_one (getFVs fvs)))
+ = returnLne (unionVarSets (map do_one (getFVs fvs)))
sw env lvs_cont
where
do_one v
= if isLocallyDefined v then
- case (lookupIdEnv env v) of
- Just (_, LetrecBound _ lvs) -> addOneToIdSet lvs v
- Just _ -> unitIdSet v
+ case (lookupVarEnv env v) of
+ Just (_, LetrecBound _ lvs) -> extendVarSet lvs v
+ Just _ -> unitVarSet v
Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
else
- emptyIdSet
+ emptyVarSet
\end{code}
\begin{code}
emptyFVInfo :: FreeVarsInfo
-emptyFVInfo = nullIdEnv
+emptyFVInfo = emptyVarEnv
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
-singletonFVInfo id ImportBound info = nullIdEnv
-singletonFVInfo id (LetrecBound top_level _) info = unitIdEnv id (id, top_level, info)
-singletonFVInfo id other info = unitIdEnv id (id, False, info)
+singletonFVInfo id ImportBound info = emptyVarEnv
+singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
+singletonFVInfo id other info = unitVarEnv id (id, False, info)
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
-unionFVInfo fv1 fv2 = combineIdEnvs plusFVInfo fv1 fv2
+unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
-minusFVBinders fv ids = fv `delManyFromIdEnv` ids
+minusFVBinders fv ids = fv `delVarEnvList` ids
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
-elementOfFVInfo id fvs = maybeToBool (lookupIdEnv fvs id)
+elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
-lookupFVInfo fvs id = case lookupIdEnv fvs id of
+lookupFVInfo fvs id = case lookupVarEnv fvs id of
Nothing -> NoStgBinderInfo
Just (_,_,info) -> info
getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
-getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs]
+getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
getFVSet :: FreeVarsInfo -> IdSet
-getFVSet fvs = mkIdSet (getFVs fvs)
+getFVSet fvs = mkVarSet (getFVs fvs)
plusFVInfo (id1,top1,info1) (id2,top2,info2)
= ASSERT (id1 == id2 && top1 == top2)
\begin{code}
rhsArity :: StgRhs -> Arity
rhsArity (StgRhsCon _ _ _) = 0
-rhsArity (StgRhsClosure _ _ _ _ args _) = length args
+rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
zapArity :: Id -> Id
-zapArity id = id `addIdArity` UnknownArity
+zapArity id = id `setIdArity` UnknownArity
\end{code}
\section{Update Avoidance Analyser}
(c) Simon Marlow, Andre Santos 1992-1993
-(c) The AQUA Project, Glasgow University, 1995-1996
+(c) The AQUA Project, Glasgow University, 1995-1998
%-----------------------------------------------------------------------------
\subsection{Module Interface}
import Prelude hiding ( lookup )
import StgSyn
-import MkId ( mkSysLocal )
-import Id ( IdEnv, growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv,
- unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv,
- IdSet,
- getIdUpdateInfo, addIdUpdateInfo, idType,
+import VarEnv
+import VarSet
+import Id ( mkSysLocal,
+ getIdUpdateInfo, setIdUpdateInfo, idType,
externallyVisibleId,
Id
)
import IdInfo ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe )
import Name ( isLocallyDefined )
import Type ( splitFunTys, splitSigmaTy )
-import UniqSet
import Unique ( getBuiltinUniques )
-import SrcLoc ( noSrcLoc )
import Util ( panic )
\end{code}
\begin{code}
type Refs = IdSet
-x `notInRefs` y = not (x `elementOfUniqSet` y)
+x `notInRefs` y = not (x `elemVarSet` y)
\end{code}
A closure value: environment of closures that are evaluated on entry,
-- backward-compat functions
null_IdEnv :: IdEnv (Id, a)
-null_IdEnv = nullIdEnv
+null_IdEnv = emptyVarEnv
unit_IdEnv :: Id -> a -> IdEnv (Id, a)
-unit_IdEnv k v = unitIdEnv k (k, v)
+unit_IdEnv k v = unitVarEnv k (k, v)
mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a)
-mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ]
+mk_IdEnv pairs = mkVarEnv [ (k, (k,v)) | (k,v) <- pairs ]
grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
-grow_IdEnv env1 env2 = growIdEnv env1 env2
+grow_IdEnv env1 env2 = plusVarEnv env1 env2
addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a)
-addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v)
+addOneTo_IdEnv env k v = extendVarEnv env k (k, v)
combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
-combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2
+combine_IdEnvs combiner env1 env2 = plusVarEnv_C new_combiner env1 env2
where
new_combiner (id, x) (_, y) = (id, combiner x y)
dom_IdEnv :: IdEnv (Id, a) -> Refs
-dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ]
+dom_IdEnv env = mkVarSet [ i | (i,_) <- rngVarEnv env ]
lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a
-lookup_IdEnv env key = case lookupIdEnv env key of
+lookup_IdEnv env key = case lookupVarEnv env key of
Nothing -> Nothing
Just (_,a) -> Just a
-- end backward compat stuff
-- partain: speeding-up stuff
type CaseBoundVars = IdSet
-noCaseBound = emptyUniqSet
-isCaseBound = elementOfUniqSet
+noCaseBound = emptyVarSet
+isCaseBound = elemVarSet
x `notCaseBound` y = not (isCaseBound x y)
moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars
-moreCaseBound old new = old `unionUniqSets` mkUniqSet new
+moreCaseBound old new = old `unionVarSet` mkVarSet new
-- end speeding-up
\end{code}
\begin{code}
mkRefs :: [Id] -> Refs
-mkRefs = mkUniqSet
+mkRefs = mkVarSet
noRefs :: Refs
-noRefs = emptyUniqSet
+noRefs = emptyVarSet
-elemRefs = elementOfUniqSet
+elemRefs = elemVarSet
merge :: [Refs] -> Refs
-merge xs = foldr merge2 emptyUniqSet xs
+merge xs = foldr merge2 emptyVarSet xs
merge2 :: Refs -> Refs -> Refs
-merge2 = unionUniqSets
+merge2 = unionVarSet
\end{code}
%-----------------------------------------------------------------------------
\subsection{Analysing an atom}
\begin{code}
-udAtom :: CaseBoundVars -> StgArg -> AbVal
-udAtom cvs (StgVarArg v)
- | v `isCaseBound` cvs = const unknownClosure
- | otherwise = lookup v
+udVar :: CaseBoundVars -> Id -> AbVal
+udVar cvs v | v `isCaseBound` cvs = const unknownClosure
+ | otherwise = lookup v
-udAtom cvs _ = const noClosure
+udAtom :: CaseBoundVars -> StgArg -> AbVal
+udAtom cvs (StgVarArg v) = udVar cvs v
+udAtom cvs _ = const noClosure
\end{code}
%-----------------------------------------------------------------------------
-> IdEnvClosure -- Current environment
-> (StgExpr, AbVal) -- (New expression, abstract value)
-ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs)
ud e@(StgCon _ vs _) cvs p = (e, udData vs cvs)
-ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) ->
- (StgSCC ty lab a', abval_a)
+ud e@(StgSCC lab a) cvs p = ud a cvs p =: \(a', abval_a) ->
+ (StgSCC lab a', abval_a)
\end{code}
Here is application. The first thing to do is analyse the head, and
I've left the type signature for doApp in to make things a bit clearer.
\begin{code}
-ud e@(StgApp a atoms lvs) cvs p
+ud e@(StgApp a atoms) cvs p
= (e, abval_app)
where
abval_atoms = map (udAtom cvs) atoms
- abval_a = udAtom cvs a
+ abval_a = udVar cvs a
abval_app = \p ->
let doApp :: Closure -> AbVal -> Closure
doApp (c, b, Fun f) abval_atom =
(combine_IdEnvs (+) c' c, b', f')
in foldl doApp (abval_a p) abval_atoms
-ud (StgCase expr lve lva uniq alts) cvs p
+ud (StgCase expr lve lva bndr srt alts) cvs p
= ud expr cvs p =: \(expr', abval_selector) ->
udAlt alts p =: \(alts', abval_alts) ->
let
let bs' = b `merge2` bs in
(combine_IdEnvs (+) c cs, bs', dont_know bs')
in
- (StgCase expr' lve lva uniq alts', abval_case)
+ (StgCase expr' lve lva bndr srt alts', abval_case)
where
+ alts_cvs = moreCaseBound cvs [bndr]
+
udAlt :: StgCaseAlts
-> IdEnvClosure
-> (StgCaseAlts, AbVal)
= udManyAlts alts def udPrimAlt (StgPrimAlts ty) p
udPrimAlt p (l, e)
- = ud e cvs p =: \(e', v) -> ((l, e'), v)
+ = ud e alts_cvs p =: \(e', v) -> ((l, e'), v)
udAlgAlt p (id, vs, use_mask, e)
- = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v)
+ = ud e (moreCaseBound alts_cvs vs) p
+ =: \(e', v) -> ((id, vs, use_mask, e'), v)
udDef :: StgCaseDefault
-> IdEnvClosure
udDef StgNoDefault p
= (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
- udDef (StgBindDefault v is_used expr) p
- = ud expr (moreCaseBound cvs [v]) p =: \(expr', abval) ->
- (StgBindDefault v is_used expr', abval)
+ udDef (StgBindDefault expr) p
+ = ud expr alts_cvs p =: \(expr', abval) ->
+ (StgBindDefault expr', abval)
udManyAlts alts def udalt stgalts p
= udDef def p =: \(def', abval_def) ->
abval p =: \(c, b, abfun) ->
(c, unit_IdEnv v (a, b, abfun))
a = case rhs of
- StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1
+ StgRhsClosure _ _ _ _ Updatable [] _ -> unit_IdEnv v 1
_ -> null_IdEnv
in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv)
= udRhs rhs cvs p =: \(rhs', abval) ->
(v,(v,rhs'), abval)
- collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv
+ collectfv (_, StgRhsClosure _ _ _ fv _ _ _) = fv
collectfv (_, StgRhsCon _ con args) = [ v | (StgVarArg v) <- args ]
\end{code}
\begin{code}
udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs)
-udRhs (StgRhsClosure cc bi fv u [] body) cvs p
+udRhs (StgRhsClosure cc bi srt fv u [] body) cvs p
= ud body cvs p =: \(body', abval_body) ->
- (StgRhsClosure cc bi fv u [] body', abval_body)
+ (StgRhsClosure cc bi srt fv u [] body', abval_body)
\end{code}
Here is the code for closures with arguments. A closure has a number
analyse each lambda expression.
\begin{code}
-udRhs (StgRhsClosure cc bi fv u args body) cvs p
+udRhs (StgRhsClosure cc bi srt fv u args body) cvs p
= ud body cvs p =: \(body', abval_body) ->
let
fv' = map lookup (filter (`notCaseBound` cvs) fv)
abval_rhs = \p ->
foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p
in
- (StgRhsClosure cc bi fv u args body', abval_rhs)
+ (StgRhsClosure cc bi srt fv u args body', abval_rhs)
where
doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
\begin{code}
tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
-tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body))
+tag b c r@(StgNonRec v (StgRhsClosure cc bi srt fv Updatable [] body))
= if (v `notInRefs` b) && (lookupc c v <= 1)
then -- trace "One!" (
- StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body)
+ StgNonRec v (StgRhsClosure cc bi srt fv SingleEntry [] body)
-- )
else r
tag b c other = other
where
(c,b,_) = foldl doApp f ids
ids = map mkid (getBuiltinUniques arity)
- mkid u = mkSysLocal SLIT("upd") u noType noSrcLoc
+ mkid u = mkSysLocal u noType
countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
noType = panic "UpdAnal: no type!"
where attachOne v
| externallyVisibleId v
= let c = lookup v p in
- addIdUpdateInfo v
+ setIdUpdateInfo v
(mkUpdateInfo (mkUpdateSpec v c))
| otherwise = v
\end{code}
--- /dev/null
+__interface SpecEnv 1 0 where
+__export SpecEnv SpecEnv ;
+1 data SpecEnv a;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[SpecEnv]{Specialisation info about an @Id@}
module SpecEnv (
SpecEnv,
emptySpecEnv, isEmptySpecEnv,
- specEnvValues, specEnvToList,
+ specEnvValues, specEnvToList, specEnvFromList,
addToSpecEnv, lookupSpecEnv, substSpecEnv
) where
#include "HsVersions.h"
-import Type ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars )
-import TyVar ( TyVar, GenTyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList )
-import Unify ( Subst, unifyTyListsX )
+import Var ( TyVar )
+import VarEnv
+import VarSet
+import Type ( Type, GenType, fullSubstTy, substTyVar )
+import Unify ( unifyTyListsX, matchTys )
import Outputable
import Maybes
import Util ( assertPanic )
%************************************************************************
\begin{code}
-type TemplateTyVar = GenTyVar Bool
-type TemplateType = GenType Bool
- -- The Bool is True for template type variables;
- -- that is, ones that can be bound
-
data SpecEnv value
= EmptySE
- | SpecEnv [([TemplateType], value)]
+ | SpecEnv [([TyVar], -- Really a set, but invariably small,
+ -- so kept as a list
+ [Type],
+ value)]
specEnvValues :: SpecEnv value -> [value]
specEnvValues EmptySE = []
-specEnvValues (SpecEnv alist) = map snd alist
+specEnvValues (SpecEnv alist) = [val | (_,_,val) <- alist]
-specEnvToList :: SpecEnv value -> [([TemplateTyVar], [TemplateType], value)]
+specEnvToList :: SpecEnv value -> [([TyVar], [Type], value)]
specEnvToList EmptySE = []
-specEnvToList (SpecEnv alist)
- = map do_item alist
- where
- do_item (tys, val) = (tyvars, tys, val)
- where
- tyvars = filter tyVarFlexi (tyVarSetToList (tyVarsOfTypes tys))
+specEnvToList (SpecEnv alist) = alist
+
+specEnvFromList :: [([TyVar], [Type], value)] -> SpecEnv value
+ -- Assumes the list is in appropriate order
+specEnvFromList [] = EmptySE
+specEnvFromList alist = SpecEnv alist
\end{code}
In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
= find alist
where
find [] = Nothing
- find ((tpl, val) : rest)
- = case matchTys tpl key of
+ find ((tpl_tyvars, tpl, val) : rest)
+ = case matchTys tpl_tyvars tpl key of
Nothing -> find rest
Just (subst, leftovers) -> ASSERT( null leftovers )
Just (subst, val)
addToSpecEnv :: Bool -- True <=> overlap permitted
-> SpecEnv value -- Envt
-> [TyVar] -> [Type] -> value -- New item
- -> MaybeErr (SpecEnv value) -- Success...
- ([TemplateType], value) -- Failure: Offending overlap
+ -> MaybeErr (SpecEnv value) -- Success...
+ ([Type], value) -- Failure: Offending overlap
-addToSpecEnv overlap_ok spec_env tvs tys value
+addToSpecEnv overlap_ok spec_env ins_tvs ins_tys value
= case spec_env of
EmptySE -> returnMaB (SpecEnv [ins_item])
SpecEnv alist -> insert alist `thenMaB` \ alist' ->
returnMaB (SpecEnv alist')
where
- ins_item = (ins_tys, value)
- ins_tys = map (applyToTyVars mk_tv) tys
-
- mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
- -- tvs identifies the template variables
+ ins_item = (ins_tvs, ins_tys, value)
insert [] = returnMaB [ins_item]
- insert alist@(cur_item@(cur_tys, _) : rest)
- | unifiable && not overlap_ok = failMaB cur_item
- | unifiable && ins_item_more_specific = returnMaB (ins_item : alist)
- | unifiable && not cur_item_more_specific = failMaB cur_item
- | otherwise = -- Less specific, or not unifiable... carry on
- insert rest `thenMaB` \ rest' ->
- returnMaB (cur_item : rest')
+ insert alist@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
+
+ -- FAIL if:
+ -- (a) they are the same, or
+ -- (b) they unify, and any sort of overlap is prohibited,
+ -- (c) they unify but neither is more specific than t'other
+ | identical
+ || (unifiable && not overlap_ok)
+ || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
+ = failMaB (tpl_tys, val)
+
+ -- New item is an instance of current item, so drop it here
+ | ins_item_more_specific = returnMaB (ins_item : alist)
+
+ -- Otherwise carry on
+ | otherwise = insert rest `thenMaB` \ rest' ->
+ returnMaB (cur_item : rest')
where
- unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
- ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
- cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
+ unifiable = maybeToBool (unifyTyListsX (ins_tvs ++ tpl_tvs) tpl_tys ins_tys)
+ ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
+ cur_item_more_specific = maybeToBool (matchTys ins_tvs ins_tys tpl_tys)
+ identical = ins_item_more_specific && cur_item_more_specific
\end{code}
Finally, during simplification we must apply the current substitution to
the SpecEnv.
\begin{code}
-substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val
-substSpecEnv ty_env val_fn EmptySE = EmptySE
-substSpecEnv ty_env val_fn (SpecEnv alist)
- = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
+substSpecEnv :: TyVarEnv Type -> IdOrTyVarSet
+ -> (TyVarEnv Type -> IdOrTyVarSet -> val -> val)
+ -> SpecEnv val -> SpecEnv val
+substSpecEnv ty_subst in_scope val_fn EmptySE = EmptySE
+substSpecEnv ty_subst in_scope val_fn (SpecEnv alist)
+ = SpecEnv (map subst alist)
where
- ty_fn = applyToTyVars tyvar_fn
-
- -- Apply the substitution; but if we ever substitute
- -- we need to convert a Type to a TemplateType
- tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
- | otherwise = case lookupTyVarEnv ty_env tv of
- Nothing -> mkTyVarTy tv
- Just ty -> applyToTyVars set_non_tpl ty
-
- set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)
+ subst (tpl_tyvars, tpl_tys, val)
+ = (tpl_tyvars',
+ map (fullSubstTy ty_subst' in_scope') tpl_tys,
+ val_fn ty_subst' in_scope' val)
+ where
+ (ty_subst', in_scope', tpl_tyvars') = go ty_subst in_scope [] tpl_tyvars
+
+ go s i acc [] = (s, i, reverse acc)
+ go s i acc (tv:tvs) = case substTyVar s i tv of
+ (s', i', tv') -> go s' i' (tv' : acc) tvs
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
-%
-\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
-
-\begin{code}
-module SpecUtils (
- specialiseCallTys,
- ConstraintVector,
- getIdOverloading,
- isUnboxedSpecialisation,
-
- specialiseConstrTys,
- mkSpecialisedCon,
-
- argTysMatchSpecTys_error,
-
- pprSpecErrs
- ) where
-
-#include "HsVersions.h"
-
-import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
- opt_SpecialiseAll
- )
-import Bag ( isEmptyBag, bagToList, Bag )
-import Class ( Class )
-import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
- lookupWithDefaultFM
- )
-import Id ( Id )
-import Maybes ( maybeToBool, catMaybes, firstJust )
-import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) )
-import Outputable
-import PprType ( pprParendType, pprMaybeTy, TyCon )
-import TyCon ( tyConTyVars )
-import Type ( mkSigmaTy, instantiateTauTy, instantiateThetaTy,
- splitSigmaTy, mkTyVarTy, mkForAllTys,
- isUnboxedType, Type
- )
-import TyVar ( TyVar, mkTyVarEnv )
-import Util ( equivClasses, zipWithEqual,
- assertPanic, panic{-ToDo:rm-}
- )
-
-
-cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)"
-getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)"
-mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)"
-\end{code}
-
-
-\begin{code}
-specialiseTy :: Type -- The type of the Id of which the SpecId
- -- is a specialised version
- -> [Maybe Type] -- The types at which it is specialised
- -> Int -- Number of leading dictionary args to ignore
- -> Type
-
-specialiseTy main_ty maybe_tys dicts_to_ignore
- = mkSigmaTy remaining_tyvars
- (instantiateThetaTy inst_env remaining_theta)
- (instantiateTauTy inst_env tau)
- where
- (tyvars, theta, tau) = splitSigmaTy main_ty -- A prefix of, but usually all,
- -- the theta is discarded!
- remaining_theta = drop dicts_to_ignore theta
- tyvars_and_maybe_tys = tyvars `zip` maybe_tys
- remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys]
- inst_env = mkTyVarEnv [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys]
-\end{code}
-
-
-@specialiseCallTys@ works out which type args don't need to be specialised on,
-based on flags, the overloading constraint vector, and the types.
-
-\begin{code}
-specialiseCallTys :: ConstraintVector -- Tells which type args are overloaded
- -> [Type] -- Type args
- -> [Maybe Type] -- Nothings replace non-specialised type args
-
-specialiseCallTys cvec tys
- | opt_SpecialiseAll = map Just tys
- | otherwise = zipWithEqual "specialiseCallTys" spec_ty_other cvec tys
- where
- spec_ty_other c ty | (opt_SpecialiseUnboxed && isUnboxedType ty) ||
- (opt_SpecialiseOverloaded && c)
- = Just ty
- | otherwise = Nothing
-
-\end{code}
-
-@getIdOverloading@ grabs the type of an Id, and returns a
-list of its polymorphic variables, and the initial segment of
-its ThetaType, in which the classes constrain only type variables.
-For example, if the Id's type is
-
- forall a,b,c. Eq a -> Ord [a] -> tau
-
-we'll return
-
- ([a,b,c], [(Eq,a)])
-
-This seems curious at first. For a start, the type above looks odd,
-because we usually only have dictionary args whose types are of
-the form (C a) where a is a type variable. But this doesn't hold for
-the functions arising from instance decls, which sometimes get
-arguements with types of form (C (T a)) for some type constructor T.
-
-Should we specialise wrt this compound-type dictionary? This is
-a heuristic judgement, as indeed is the fact that we specialise wrt
-only dictionaries. We choose *not* to specialise wrt compound dictionaries
-because at the moment the only place they show up is in instance decls,
-where they are simply plugged into a returned dictionary. So nothing is
-gained by specialising wrt them.
-
-\begin{code}
-getIdOverloading :: Id
- -> ([TyVar], [(Class,TyVar)])
-getIdOverloading = panic "getIdOverloading"
-
--- Looks suspicious to me; and I'm not sure what corresponds to
--- (Class,TyVar) pairs in the multi-param type class world.
-{-
-getIdOverloading id
- = (tyvars, tyvar_part_of theta)
- where
- (tyvars, theta, _) = splitSigmaTy (idType id)
-
- tyvar_part_of [] = []
- tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of
- Nothing -> []
- Just tv -> (c, tv) : tyvar_part_of theta
--}
-\end{code}
-
-\begin{code}
-type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
-\end{code}
-
-\begin{code}
-isUnboxedSpecialisation :: [Maybe Type] -> Bool
-isUnboxedSpecialisation tys
- = any is_unboxed tys
- where
- is_unboxed (Just ty) = isUnboxedType ty
- is_unboxed Nothing = False
-\end{code}
-
-@specialiseConstrTys@ works out which type args don't need to be
-specialised on. We only speciailise on unboxed types.
-
-\begin{code}
-specialiseConstrTys :: [Type]
- -> [Maybe Type]
-
-specialiseConstrTys tys
- = map maybe_unboxed_ty tys
- where
- maybe_unboxed_ty ty = case isUnboxedType ty of
- True -> Just ty
- False -> Nothing
-\end{code}
-
-\begin{code}
-mkSpecialisedCon :: Id -> [Type] -> Id
-mkSpecialisedCon con tys
- = if spec_reqd
- then mkSameSpecCon spec_tys con
- else con
- where
- spec_tys = specialiseConstrTys tys
- spec_reqd = maybeToBool (firstJust spec_tys)
-\end{code}
-
-@argTysMatchSpecTys@ checks if a list of argument types is consistent
-with a list of specialising types. An error message is returned if not.
-\begin{code}
-argTysMatchSpecTys_error :: [Maybe Type]
- -> [Type]
- -> Maybe SDoc
-argTysMatchSpecTys_error spec_tys arg_tys
- = if match spec_tys arg_tys
- then Nothing
- else Just (sep [ptext SLIT("Spec and Arg Types Inconsistent:"),
- ptext SLIT("spectys="), sep [pprMaybeTy ty | ty <- spec_tys],
- ptext SLIT("argtys="), sep [pprParendType ty | ty <- arg_tys]])
- where
- match (Nothing:spec_tys) (arg:arg_tys)
- = not (isUnboxedType arg) &&
- match spec_tys arg_tys
- match (Just spec:spec_tys) (arg:arg_tys)
- = case (cmpType True{-properly-} spec arg) of
- EQ -> match spec_tys arg_tys
- other -> False
- match [] [] = True
- match _ _ = False
-\end{code}
-
-@pprSpecErrs@ prints error and warning information
-about imported specialisations which do not exist.
-
-\begin{code}
-pprSpecErrs :: FAST_STRING -- module name
- -> (Bag (Id,[Maybe Type])) -- errors
- -> (Bag (Id,[Maybe Type])) -- warnings
- -> (Bag (TyCon,[Maybe Type])) -- errors
- -> SDoc
-
-pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
- | not any_errs && not any_warn
- = empty
-
- | otherwise
- = vcat [
- ptext SLIT("SPECIALISATION MESSAGES:"),
- vcat (map pp_module_specs use_modules)
- ]
- where
- any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
- any_warn = not (isEmptyBag spec_warn)
-
- mk_module_fm get_mod_data errs_bag
- = addListToFM_C (++) emptyFM errs_list
- where
- errs_list = map get_mod_data (bagToList errs_bag)
-
- tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
-
- iderrs_fm = mk_module_fm (get_id_data True) spec_errs
- idwarn_fm = mk_module_fm (get_id_data False) spec_warn
- idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
-
- get_id_data is_err (id, tys)
- = (mod_name, [(id_name, id, tys, is_err)])
- where
- (mod_name, id_name) = get_id_name id
-
-
- get_id_name id
-
-{- Don't understand this -- and looks TURGID. SLPJ 4 Nov 96
- | maybeToBool (isDefaultMethodId_maybe id)
- = (this_mod, _NIL_)
-
- | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
- = let get_mod = getInstIdModule id
- use_mod = get_mod
- in (use_mod, _NIL_)
-
- | otherwise
--}
- = modAndOcc id
-
- get_ty_data (ty, tys)
- = (mod_name, [(ty_name, ty, tys)])
- where
- (mod_name, ty_name) = modAndOcc ty
-
- module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
- mods = map head (equivClasses compare module_names)
-
- (unks, known) = if null mods
- then ([], [])
- else case head mods `compare` _NIL_ of
- EQ -> ([_NIL_], tail mods)
- other -> ([], mods)
-
- use_modules = unks ++ known
-
- pp_module_specs :: FAST_STRING -> SDoc
- pp_module_specs mod
- | mod == _NIL_
- = ASSERT (null mod_tyspecs)
- vcat (map (pp_idspec (ptext SLIT("UNKNOWN:"))) mod_idspecs)
-
- | have_specs
- = vcat [
- vcat (map (pp_tyspec (pp_module mod)) mod_tyspecs),
- vcat (map (pp_idspec (pp_module mod)) mod_idspecs)
- ]
-
- | otherwise
- = empty
-
- where
- mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
- mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
- have_specs = not (null mod_tyspecs && null mod_idspecs)
-
-pp_module mod
- = hcat [ptext mod, char ':']
-
-pp_tyspec :: SDoc -> (OccName, TyCon, [Maybe Type]) -> SDoc
-
-pp_tyspec pp_mod (_, tycon, tys)
- = hsep [pp_mod,
- text "{-# SPECIALIZE data",
- ppr tycon, hsep (map pprParendType spec_tys),
- text "-} {- Essential -}"
- ]
- where
- tvs = tyConTyVars tycon
- (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
- spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
-
- choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
- choose_ty (tv, Just ty) = (ty, Nothing)
-
-pp_idspec :: SDoc -> (OccName, Id, [Maybe Type], Bool) -> SDoc
-pp_idspec = error "pp_idspec"
-
-{- LATER
-
-pp_idspec pp_mod (_, id, tys, is_err)
- | isDictFunId id
- = hsep [pp_mod,
- text "{-# SPECIALIZE instance",
- pprGenType spec_ty,
- text "#-}", pp_essential ]
-
- | is_const_method_id
- = let
- Just (cls, clsty, clsop) = const_method_maybe
- in
- hsep [pp_mod,
- text "{-# SPECIALIZE",
- ppr clsop, text "::",
- pprGenType spec_ty,
- text "#-} {- IN instance",
- pprOccName (getOccName cls), pprParendType clsty,
- text "-}", pp_essential ]
-
- | is_default_method_id
- = let
- Just (cls, clsop, _) = default_method_maybe
- in
- hsep [pp_mod,
- text "{- instance",
- pprOccName (getOccName cls),
- ptext SLIT("EXPLICIT METHOD REQUIRED"),
- ppr clsop, text "::",
- pprGenType spec_ty,
- text "-}", pp_essential ]
-
- | otherwise
- = hsep [pp_mod,
- text "{-# SPECIALIZE",
- ppr id, ptext SLIT("::"),
- pprGenType spec_ty,
- text "#-}", pp_essential ]
- where
- spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
- pp_essential = if is_err then text "{- Essential -}" else empty
-
- const_method_maybe = isConstMethodId_maybe id
- is_const_method_id = maybeToBool const_method_maybe
-
- default_method_maybe = isDefaultMethodId_maybe id
- is_default_method_id = maybeToBool default_method_maybe
-
--}
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
#include "HsVersions.h"
-import MkId ( mkUserLocal )
-import Id ( Id, DictVar, idType, mkTemplateLocals,
-
- getIdSpecialisation, setIdSpecialisation, isSpecPragmaId,
-
- IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet,
- emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet,
-
- IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv, delOneFromIdEnv
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec )
+import Id ( Id, idType, mkTemplateLocals, mkUserLocal,
+ getIdSpecialisation, setIdSpecialisation,
+ isSpecPragmaId,
)
+import VarSet
+import VarEnv
-import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
- tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
- )
-import TyCon ( TyCon )
-import TyVar ( TyVar, mkTyVar, mkSysTyVar,
- TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
- elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
- minusTyVarSet,
- TyVarEnv, mkTyVarEnv, delFromTyVarEnv
+import Type ( Type, TyVarSubst, mkTyVarTy, splitSigmaTy, substTy,
+ fullSubstTy, tyVarsOfType, tyVarsOfTypes,
+ mkForAllTys, boxedTypeKind
)
-import Kind ( mkBoxedTypeKind )
+import Var ( TyVar, mkSysTyVar, setVarUnique )
+import VarSet
+import VarEnv
import CoreSyn
-import FreeVars ( exprFreeVars, exprFreeTyVars )
+import CoreUtils ( IdSubst, SubstCoreExpr(..), exprFreeVars,
+ substExpr, substId, substIds, coreExprType
+ )
+import CoreLint ( beginPass, endPass )
import PprCore () -- Instances
-import Name ( NamedThing(..), getSrcLoc, mkSysLocalName, isLocallyDefined )
-import SrcLoc ( noSrcLoc )
-import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues )
+import SpecEnv ( addToSpecEnv )
import UniqSupply ( UniqSupply,
- UniqSM, initUs, thenUs, returnUs, getUnique, mapUs
+ UniqSM, initUs, thenUs, thenUs_, returnUs, getUniqueUs,
+ getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
)
-import Unique ( mkAlphaTyVarUnique )
+import Name ( NamedThing(getOccName) )
import FiniteMap
-import Maybes ( MaybeErr(..), maybeToBool, catMaybes )
+import Maybes ( MaybeErr(..), catMaybes )
import Bag
import List ( partition )
-import Util ( zipEqual )
+import Util ( zipEqual, mapAccumL )
import Outputable
then I think it's unlikely. In any case, we simply don't accumulate such
partial applications.)
-There's a choice of whether to collect details of all *polymorphic* functions
-or simply all *overloaded* ones. How to sort this out?
- Pass in a predicate on the function to say if it is "interesting"?
- This is dependent on the user flags: SpecialiseOverloaded
- SpecialiseUnboxed
- SpecialiseAll
STEP 2: EQUIVALENCES
%************************************************************************
\begin{code}
-specProgram :: UniqSupply -> [CoreBinding] -> [CoreBinding]
+specProgram :: UniqSupply -> [CoreBind] -> IO [CoreBind]
specProgram us binds
- = initSM us (go binds `thenSM` \ (binds', uds') ->
- returnSM (dumpAllDictBinds uds' binds')
- )
+ = do
+ beginPass "Specialise"
+
+ let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
+ returnSM (dumpAllDictBinds uds' binds'))
+
+ endPass "Specialise" (opt_D_dump_spec || opt_D_verbose_core2core) binds'
+
where
go [] = returnSM ([], emptyUDs)
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
---------------- First the easy cases --------------------
+specExpr e@(Type _) = returnSM (e, emptyUDs)
specExpr e@(Var _) = returnSM (e, emptyUDs)
-specExpr e@(Lit _) = returnSM (e, emptyUDs)
-specExpr e@(Con _ _) = returnSM (e, emptyUDs)
-specExpr e@(Prim _ _) = returnSM (e, emptyUDs)
+
+specExpr e@(Con con args)
+ = mapAndCombineSM specExpr args `thenSM` \ (args', uds) ->
+ returnSM (Con con args', uds)
specExpr (Note note body)
= specExpr body `thenSM` \ (body', uds) ->
---------------- Applications might generate a call instance --------------------
-specExpr e@(App fun arg)
- = go fun [arg]
+specExpr expr@(App fun arg)
+ = go expr []
where
- go (App fun arg) args = go fun (arg:args)
- go (Var f) args = returnSM (e, mkCallUDs f args)
- go other args = specExpr other `thenSM` \ (e', uds) ->
- returnSM (foldl App e' args, uds)
+ go (App fun arg) args = specExpr arg `thenSM` \ (arg', uds_arg) ->
+ go fun (arg':args) `thenSM` \ (fun', uds_app) ->
+ returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
+
+ go (Var f) args = returnSM (Var f, mkCallUDs f args)
+ go other args = specExpr other
---------------- Lambda/case require dumping of usage details --------------------
specExpr e@(Lam _ _)
let
(filtered_uds, body'') = dumpUDs bndrs uds body'
in
- returnSM (foldr Lam body'' bndrs, filtered_uds)
+ returnSM (mkLams bndrs body'', filtered_uds)
where
(bndrs, body) = go [] e
-- More efficient to collect a group of binders together all at once
+ -- and we don't want to split a lambda group with dumped bindings
go bndrs (Lam bndr e) = go (bndr:bndrs) e
go bndrs e = (reverse bndrs, e)
-specExpr (Case scrut alts)
- = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
- spec_alts alts `thenSM` \ (alts', uds_alts) ->
- returnSM (Case scrut' alts', uds_scrut `plusUDs` uds_alts)
+specExpr (Case scrut case_bndr alts)
+ = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
+ mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
+ returnSM (Case scrut' case_bndr alts', uds_scrut `plusUDs` uds_alts)
where
- spec_alts (AlgAlts alts deflt)
- = mapAndCombineSM spec_alg_alt alts `thenSM` \ (alts', uds1) ->
- spec_deflt deflt `thenSM` \ (deflt', uds2) ->
- returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2)
-
- spec_alts (PrimAlts alts deflt)
- = mapAndCombineSM spec_prim_alt alts `thenSM` \ (alts', uds1) ->
- spec_deflt deflt `thenSM` \ (deflt', uds2) ->
- returnSM (PrimAlts alts' deflt', uds1 `plusUDs` uds2)
-
- spec_alg_alt (con, args, rhs)
+ spec_alt (con, args, rhs)
= specExpr rhs `thenSM` \ (rhs', uds) ->
let
- (uds', rhs'') = dumpUDs (map ValBinder args) uds rhs'
+ (uds', rhs'') = dumpUDs args uds rhs'
in
returnSM ((con, args, rhs''), uds')
- spec_prim_alt (lit, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- returnSM ((lit, rhs'), uds)
-
- spec_deflt NoDefault = returnSM (NoDefault, emptyUDs)
- spec_deflt (BindDefault arg rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- let
- (uds', rhs'') = dumpUDs [ValBinder arg] uds rhs'
- in
- returnSM (BindDefault arg rhs'', uds')
-
---------------- Finally, let is the interesting case --------------------
specExpr (Let bind body)
= -- Deal with the body
%************************************************************************
\begin{code}
-specBind :: CoreBinding
+specBind :: CoreBind
-> UsageDetails -- Info on how the scope of the binding
- -> SpecM ([CoreBinding], -- New bindings
+ -> SpecM ([CoreBind], -- New bindings
UsageDetails) -- And info to pass upstream
-specBind (NonRec bndr rhs) body_uds
- | isDictTy (idType bndr)
- = -- It's a dictionary binding
- -- Pick it up and float it outwards.
- specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- let
- all_uds = rhs_uds `plusUDs` addDictBind body_uds bndr rhs'
- in
- returnSM ([], all_uds)
-
- | isSpecPragmaId bndr
+specBind bind@(NonRec bndr rhs) body_uds
+ | isSpecPragmaId bndr -- Aha! A spec-pragma Id. Collect UDs from
+ -- its RHS and discard it!
= specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
returnSM ([], rhs_uds `plusUDs` body_uds)
- | otherwise
- = -- Deal with the RHS, specialising it according
- -- to the calls found in the body
- specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+
+specBind bind body_uds
+ = specBindItself bind (calls body_uds) `thenSM` \ (bind', bind_uds) ->
let
- (all_uds, (dict_binds, dump_calls))
- = splitUDs [ValBinder bndr]
- (body_uds `plusUDs` spec_uds)
+ bndrs = bindersOf bind
+ all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
-- It's important that the `plusUDs` is this way round,
-- because body_uds may bind dictionaries that are
-- used in the calls passed to specDefn. So the
- -- dictionary bindings in spec_uds may mention
+ -- dictionary bindings in bind_uds may mention
-- dictionaries bound in body_uds.
+ in
+ case splitUDs bndrs all_uds of
+
+ (_, ([],[])) -- This binding doesn't bind anything needed
+ -- in the UDs, so put the binding here
+ -- This is the case for most non-dict bindings, except
+ -- for the few that are mentioned in a dict binding
+ -- that is floating upwards in body_uds
+ -> returnSM ([bind'], all_uds)
+
+ (float_uds, (dict_binds, calls)) -- This binding is needed in the UDs, so float it out
+ -> returnSM ([], float_uds `plusUDs` mkBigUD bind' dict_binds calls)
+
+
+-- A truly gruesome function
+mkBigUD bind@(NonRec _ _) dbs calls
+ = -- Common case: non-recursive and no specialisations
+ -- (if there were any specialistions it would have been made recursive)
+ MkUD { dict_binds = listToBag (mkDB bind : dbs),
+ calls = listToCallDetails calls }
+
+mkBigUD bind dbs calls
+ = -- General case
+ MkUD { dict_binds = unitBag (mkDB (Rec (bind_prs bind ++ dbsToPairs dbs))),
+ -- Make a huge Rec
+ calls = listToCallDetails calls }
+ where
+ bind_prs (NonRec b r) = [(b,r)]
+ bind_prs (Rec prs) = prs
+
+ dbsToPairs [] = []
+ dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
- -- If we make specialisations then we Rec the whole lot together
- -- If not, leave it as a NonRec
+-- specBindItself deals with the RHS, specialising it according
+-- to the calls found in the body (if any)
+specBindItself (NonRec bndr rhs) call_info
+ = specDefn call_info (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+ let
new_bind | null spec_defns = NonRec bndr' rhs'
| otherwise = Rec ((bndr',rhs'):spec_defns)
+ -- bndr' mentions the spec_defns in its SpecEnv
+ -- Not sure why we couln't just put the spec_defns first
in
- returnSM ( new_bind : mkDictBinds dict_binds, all_uds )
+ returnSM (new_bind, spec_uds)
-specBind (Rec pairs) body_uds
- = mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff ->
+specBindItself (Rec pairs) call_info
+ = mapSM (specDefn call_info) pairs `thenSM` \ stuff ->
let
(pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
spec_defns = concat spec_defns_s
spec_uds = plusUDList spec_uds_s
-
- (all_uds, (dict_binds, dump_calls))
- = splitUDs (map (ValBinder . fst) pairs)
- (body_uds `plusUDs` spec_uds)
- -- See notes for non-rec case
-
- new_bind = Rec (spec_defns ++
- pairs' ++
- [(d,r) | (d,r,_,_) <- dict_binds])
- -- We need to Rec together the dict_binds too, because they
- -- can be recursive; this happens when an overloaded function
- -- is used as a method in an instance declaration.
- -- (The particular program that showed this up was
- -- docon/source/auxil/DInteger.hs)
+ new_bind = Rec (spec_defns ++ pairs')
in
- returnSM ( [new_bind], all_uds )
+ returnSM (new_bind, spec_uds)
+
specDefn :: CallDetails -- Info on how it is used in its scope
-> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
-> SpecM ((Id, CoreExpr), -- The thing and its processed RHS
(spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
fn' = addIdSpecialisations fn spec_env_stuff
- rhs' = foldr Lam (mkDictLets dict_binds body') rhs_bndrs
+ rhs' = mkLams rhs_bndrs (mkDictLets dict_binds body')
in
returnSM ((fn',rhs'),
spec_defns,
n_tyvars = length tyvars
n_dicts = length theta
- (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
+ (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
rhs_dicts = take n_dicts rhs_ids
- rhs_bndrs = map TyBinder rhs_tyvars ++ map ValBinder rhs_dicts
- body = mkValLam (drop n_dicts rhs_ids) rhs_body
+ rhs_bndrs = rhs_tyvars ++ rhs_dicts
+ body = mkLams (drop n_dicts rhs_ids) rhs_body
-- Glue back on the non-dict lambdas
calls_for_me = case lookupFM calls fn of
-- Specialise to one particular call pattern
spec_call :: ProtoUsageDetails -- From the original body, captured by
-- the dictionary lambdas
- -> ([Maybe Type], [DictVar]) -- Call instance
+ -> ([Maybe Type], ([DictExpr], IdOrTyVarSet)) -- Call instance
-> SpecM ((Id,CoreExpr), -- Specialised definition
UsageDetails, -- Usage details from specialised body
([TyVar], [Type], CoreExpr)) -- Info for the Id's SpecEnv
- spec_call bound_uds (call_ts, call_ds)
+ spec_call bound_uds (call_ts, (call_ds, _))
= ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
-- Calls are only recorded for properly-saturated applications
let
(maybe_spec_tyvars, spec_tys) = unzip stuff
spec_tyvars = catMaybes maybe_spec_tyvars
- spec_rhs = mkTyLam spec_tyvars $
- mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
- spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau)
- ty_env = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys)
+ spec_rhs = mkLams spec_tyvars $
+ mkApps rhs (map Type spec_tys ++ call_ds)
+ spec_id_ty = mkForAllTys spec_tyvars (substTy ty_env tau)
+ ty_env = zipVarEnv tyvars spec_tys
in
newIdSM fn spec_id_ty `thenSM` \ spec_f ->
-- In fact we use the standard template locals, so that the
-- they don't need to be "tidied" before putting in interface files
let
- arg_ds = mkTemplateLocals (map idType call_ds)
- spec_env_rhs = mkValLam arg_ds $
- mkTyApp (Var spec_f) $
+ arg_ds = mkTemplateLocals (map coreExprType call_ds)
+ spec_env_rhs = mkLams arg_ds $
+ mkTyApps (Var spec_f) $
map mkTyVarTy spec_tyvars
spec_env_info = (spec_tyvars, spec_tys, spec_env_rhs)
in
-- Specialise the UDs from f's RHS
let
-- Only the overloaded tyvars should be free in the uds
- ty_env = [ (rhs_tyvar,ty)
- | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
- ]
- dict_env = zipEqual "specUDs2" rhs_dicts call_ds
+ ty_env = mkVarEnv [ (rhs_tyvar, ty)
+ | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
+ ]
+ dict_env = zipVarEnv rhs_dicts (map Done call_ds)
in
specUDs ty_env dict_env bound_uds `thenSM` \ spec_uds ->
calls :: !CallDetails
}
-type DictBind = (DictVar, CoreExpr, TyVarSet, FreeDicts)
- -- The FreeDicts are the free dictionaries (only)
- -- of the RHS of the dictionary bindings
- -- Similarly the TyVarSet
+type DictBind = (CoreBind, IdOrTyVarSet)
+ -- The set is the free vars of the binding
+ -- both tyvars and dicts
+
+type DictExpr = CoreExpr
emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
type ProtoUsageDetails = ([DictBind],
- [(Id, [Maybe Type], [DictVar])]
+ [(Id, [Maybe Type], ([DictExpr], IdOrTyVarSet))]
)
------------------------------------------------------------
type CallDetails = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
- [DictVar] -- Dict args
+type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
+ ([DictExpr], IdSet) -- Dict args and the free dicts
+ -- free dicts does *not* include the main id itself
-- The finite maps eliminate duplicates
-- The list of types and dictionaries is guaranteed to
-- match the type of f
+unionCalls :: CallDetails -> CallDetails -> CallDetails
+unionCalls c1 c2 = plusFM_C plusFM c1 c2
+
+singleCall (id, tys, dicts)
+ = unitFM id (unitFM tys (dicts, dict_fvs))
+ where
+ dict_fvs = foldr (unionVarSet . exprFreeVars) emptyVarSet dicts
+ -- The type args (tys) are guaranteed to be part of the dictionary
+ -- types, because they are just the constrained types,
+ -- and the dictionary is therefore sure to be bound
+ -- inside the binding for any type variables free in the type;
+ -- hence it's safe to neglect tyvars free in tys when making
+ -- the free-var set for this call
+ --
+ -- We don't include the 'id' itself.
+
+listToCallDetails calls
+ = foldr (unionCalls . mk_call) emptyFM calls
+ where
+ mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs)
+ -- NB: the free vars of the call are provided
+
callDetailsToList calls = [ (id,tys,dicts)
| (id,fm) <- fmToList calls,
(tys,dicts) <- fmToList fm
]
-listToCallDetails calls = foldr (unionCalls . singleCall) emptyFM calls
-
-unionCalls :: CallDetails -> CallDetails -> CallDetails
-unionCalls c1 c2 = plusFM_C plusFM c1 c2
-
-singleCall (id, tys, dicts) = unitFM id (unitFM tys dicts)
-
mkCallUDs f args
| null theta
|| length spec_tys /= n_tyvars
| otherwise
= MkUD {dict_binds = emptyBag,
- calls = singleCall (f, spec_tys, dicts)
+ calls = singleCall (f, spec_tys, dicts)
}
where
(tyvars, theta, tau) = splitSigmaTy (idType f)
- constrained_tyvars = foldr (unionTyVarSets . tyVarsOfTypes . snd) emptyTyVarSet theta
+ constrained_tyvars = foldr (unionVarSet . tyVarsOfTypes . snd) emptyVarSet theta
n_tyvars = length tyvars
n_dicts = length theta
- spec_tys = [mk_spec_ty tv ty | (tv, TyArg ty) <- tyvars `zip` args]
- dicts = [d | (_, VarArg d) <- theta `zip` (drop n_tyvars args)]
+ spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
+ dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
- mk_spec_ty tyvar ty | tyvar `elementOfTyVarSet` constrained_tyvars
+ mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
= Just ty
| otherwise
= Nothing
plusUDList = foldr plusUDs emptyUDs
-mkDB dict rhs = (dict, rhs, db_ftvs, db_fvs)
- where
- db_ftvs = exprFreeTyVars rhs
- db_fvs = exprFreeVars isLocallyDefined rhs
+-- zapCalls deletes calls to ids from uds
+zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
+
+mkDB bind = (bind, bind_fvs bind)
-addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds }
+bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
+bind_fvs (Rec prs) = foldl delVarSet rhs_fvs (map fst prs)
+ where
+ rhs_fvs = foldr (unionVarSet . exprFreeVars . snd) emptyVarSet prs
+
+addDictBind uds bind = uds { dict_binds = mkDB bind `consBag` dict_binds uds }
dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
= foldrBag add binds dbs
where
- add (dict,rhs,_,_) binds = NonRec dict rhs : binds
+ add (bind,_) binds = bind : binds
-mkDictBinds :: [DictBind] -> [CoreBinding]
-mkDictBinds = map (\(d,r,_,_) -> NonRec d r)
+mkDictBinds :: [DictBind] -> [CoreBind]
+mkDictBinds = map fst
mkDictLets :: [DictBind] -> CoreExpr -> CoreExpr
mkDictLets dbs body = foldr mk body dbs
where
- mk (d,r,_,_) e = Let (NonRec d r) e
+ mk (bind,_) e = Let bind e
-dumpUDs :: [CoreBinder]
+dumpUDs :: [CoreBndr]
-> UsageDetails -> CoreExpr
-> (UsageDetails, CoreExpr)
dumpUDs bndrs uds body
where
(free_uds, (dict_binds, _)) = splitUDs bndrs uds
-splitUDs :: [CoreBinder]
+splitUDs :: [CoreBndr]
-> UsageDetails
-> (UsageDetails, -- These don't mention the binders
ProtoUsageDetails) -- These do
)
where
- tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs]
- id_set = mkIdSet [id | ValBinder id <- bndrs]
+ bndr_set = mkVarSet bndrs
(free_dbs, dump_dbs, dump_idset)
- = foldlBag dump_db (emptyBag, emptyBag, id_set) orig_dbs
+ = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
-- Important that it's foldl not foldr;
-- we're accumulating the set of dumped ids in dump_set
-- Filter out any calls that mention things that are being dumped
- -- Don't need to worry about the tyvars because the dicts will
- -- spot the captured ones; any fully polymorphic arguments will
- -- be Nothings in the call details
- orig_call_list = callDetailsToList orig_calls
- (dump_calls, free_calls) = partition captured orig_call_list
- captured (id,tys,dicts) = any (`elementOfIdSet` dump_idset) (id:dicts)
-
- dump_db (free_dbs, dump_dbs, dump_idset) db@(dict, rhs, ftvs, fvs)
- | isEmptyIdSet (dump_idset `intersectIdSets` fvs)
- && isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs)
- = (free_dbs `snocBag` db, dump_dbs, dump_idset)
+ orig_call_list = callDetailsToList orig_calls
+ (dump_calls, free_calls) = partition captured orig_call_list
+ captured (id,tys,(dicts, fvs)) = fvs `intersectsVarSet` dump_idset
+ || id `elemVarSet` dump_idset
- | otherwise -- Dump it
+ dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
+ | dump_idset `intersectsVarSet` fvs -- Dump it
= (free_dbs, dump_dbs `snocBag` db,
- dump_idset `addOneToIdSet` dict)
+ dump_idset `unionVarSet` mkVarSet (bindersOf bind))
+
+ | otherwise -- Don't dump it
+ = (free_dbs `snocBag` db, dump_dbs, dump_idset)
\end{code}
Given a type and value substitution, specUDs creates a specialised copy of
the given UDs
\begin{code}
-specUDs :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails
-specUDs tv_env_list dict_env_list (dbs, calls)
- = specDBs dict_env_list dbs `thenSM` \ (dict_env_list', dbs') ->
+specUDs :: TyVarSubst -> IdSubst -> ProtoUsageDetails -> SpecM UsageDetails
+specUDs tv_env dict_env (dbs, calls)
+ = getUniqSupplySM `thenSM` \ us ->
let
- dict_env = mkIdEnv dict_env_list'
+ ((us', dict_env'), dbs') = mapAccumL specDB (us, dict_env) dbs
in
- returnSM (MkUD { dict_binds = dbs',
- calls = listToCallDetails (map (inst_call dict_env) calls)
+ setUniqSupplySM us' `thenSM_`
+ returnSM (MkUD { dict_binds = listToBag dbs',
+ calls = foldr (unionCalls . singleCall . inst_call dict_env')
+ emptyFM calls
})
where
- bound_tyvars = mkTyVarSet (map fst tv_env_list)
- tv_env = mkTyVarEnv tv_env_list -- Doesn't change
-
- inst_call dict_env (id, tys, dicts) = (id, map inst_maybe_ty tys,
- map (lookupId dict_env) dicts)
-
- inst_maybe_ty Nothing = Nothing
- inst_maybe_ty (Just ty) = Just (instantiateTy tv_env ty)
-
- specDBs dict_env []
- = returnSM (dict_env, emptyBag)
- specDBs dict_env ((dict, rhs, ftvs, fvs) : dbs)
- = newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' ->
- let
- rhs' = foldl App (foldr Lam rhs (t_bndrs ++ d_bndrs)) (t_args ++ d_args)
- (t_bndrs, t_args) = unzip [(TyBinder tv, TyArg ty) | (tv,ty) <- tv_env_list,
- tv `elementOfTyVarSet` ftvs]
- (d_bndrs, d_args) = unzip [(ValBinder d, VarArg d') | (d,d') <- dict_env,
- d `elementOfIdSet` fvs]
- dict_env' = (dict,dict') : dict_env
- ftvs' = tyVarsOfTypes [ty | TyArg ty <- t_args] `unionTyVarSets`
- (ftvs `minusTyVarSet` bound_tyvars)
- fvs' = mkIdSet [d | VarArg d <- d_args] `unionIdSets`
- (fvs `minusIdSet` mkIdSet [d | ValBinder d <- d_bndrs])
- in
- specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') ->
- returnSM ( dict_env'', (dict', rhs', ftvs', fvs') `consBag` dbs' )
+ inst_call dict_env (id, tys, (dicts,fvs)) = (id, map (inst_maybe_ty fvs) tys,
+ map (substExpr tv_env dict_env fvs) dicts)
+
+ inst_maybe_ty fvs Nothing = Nothing
+ inst_maybe_ty fvs (Just ty) = Just (fullSubstTy tv_env fvs ty)
+
+ specDB (us, dict_env) (NonRec bndr rhs, fvs)
+ = ((us', dict_env'), mkDB (NonRec bndr' (substExpr tv_env dict_env fvs rhs)))
+ where
+ (dict_env', _, us', bndr') = substId clone_fn tv_env dict_env fvs us bndr
+ -- Fudge the in_scope set a bit by using the free vars of
+ -- the binding, and ignoring the one that comes back
+
+ specDB (us, dict_env) (Rec prs, fvs)
+ = ((us', dict_env'), mkDB (Rec (bndrs' `zip` rhss')))
+ where
+ (dict_env', _, us', bndrs') = substIds clone_fn tv_env dict_env fvs us (map fst prs)
+ rhss' = [substExpr tv_env dict_env' fvs rhs | (_, rhs) <- prs]
+
+ clone_fn _ us id = case splitUniqSupply us of
+ (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2))
\end{code}
%************************************************************************
\begin{code}
lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupIdEnv env id of
+lookupId env id = case lookupVarEnv env id of
Nothing -> id
Just id' -> id'
type SpecM a = UniqSM a
thenSM = thenUs
+thenSM_ = thenUs_
returnSM = returnUs
-getUniqSM = getUnique
+getUniqSM = getUniqueUs
+getUniqSupplySM = getUs
+setUniqSupplySM = setUs
mapSM = mapUs
initSM = initUs
returnSM (y:ys, uds1 `plusUDs` uds2)
newIdSM old_id new_ty
- = getUnique `thenSM` \ uniq ->
+ = getUniqSM `thenSM` \ uniq ->
returnSM (mkUserLocal (getOccName old_id)
uniq
new_ty
- (getSrcLoc old_id)
)
newTyVarSM
- = getUnique `thenSM` \ uniq ->
- returnSM (mkSysTyVar uniq mkBoxedTypeKind)
+ = getUniqSM `thenSM` \ uniq ->
+ returnSM (mkSysTyVar uniq boxedTypeKind)
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
import StgSyn -- output
import CoreUtils ( coreExprType )
-import CostCentre ( noCostCentre )
-import MkId ( mkSysLocal )
-import Id ( externallyVisibleId, mkIdWithNewUniq,
- nullIdEnv, addOneToIdEnv, lookupIdEnv,
- IdEnv, Id
+import SimplUtils ( findDefault )
+import CostCentre ( noCCS )
+import Id ( Id, mkUserLocal, idType,
+ externallyVisibleId, setIdUnique
)
-import SrcLoc ( noSrcLoc )
-import Type ( splitAlgTyConApp, Type )
-import UniqSupply ( UniqSupply, UniqSM,
- returnUs, thenUs, initUs,
- mapUs, getUnique
- )
-import PrimOp ( PrimOp(..) )
-
-import Outputable ( panic )
-
-isLeakFreeType x y = False -- safe option; ToDo
+import Name ( varOcc )
+import VarEnv
+import Const ( Con(..), isWHNFCon, Literal(..) )
+import PrimOp ( PrimOp(..) )
+import Type ( isUnLiftedType, isUnboxedTupleType, Type )
+import Unique ( Unique, Uniquable(..) )
+import UniqSupply -- all of it, really
+import Outputable
\end{code}
%* *
%************************************************************************
-Because we're going to come across ``boring'' bindings like
-\tr{let x = /\ tyvars -> y in ...}, we want to keep a small
-environment, so we can just replace all occurrences of \tr{x}
-with \tr{y}.
-
-March 98: We also use this environment to give all locally bound
+March 98: We keep a small environment to give all locally bound
Names new unique ids, since the code generator assumes that binders
are unique across a module. (Simplifier doesn't maintain this
invariant any longer.)
\begin{code}
-type StgEnv = IdEnv StgArg
+type StgEnv = IdEnv Id
\end{code}
No free/live variable information is pinned on in this pass; it's added
\begin{code}
topCoreBindsToStg :: UniqSupply -- name supply
- -> [CoreBinding] -- input
+ -> [CoreBind] -- input
-> [StgBinding] -- output
topCoreBindsToStg us core_binds
- = initUs us (coreBindsToStg nullIdEnv core_binds)
+ = initUs us (coreBindsToStg emptyVarEnv core_binds)
where
- coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
+ coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
coreBindsToStg env [] = returnUs []
coreBindsToStg env (b:bs)
\begin{code}
coreBindToStg :: StgEnv
- -> CoreBinding
+ -> CoreBind
-> UniqSM ([StgBinding], -- Empty or singleton
StgEnv) -- Floats
coreBindToStg env (NonRec binder rhs)
= coreRhsToStg env rhs `thenUs` \ stg_rhs ->
- let
- -- Binds to return if RHS is trivial
- triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it
- | otherwise = [] -- Discard it
- in
- case stg_rhs of
- StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
- -- Trivial RHS, so augment envt, and ditch the binding
- returnUs (triv_binds, new_env)
- where
- new_env = addOneToIdEnv env binder atom
-
- StgRhsCon cc con_id [] ->
- -- Trivial RHS, so augment envt, and ditch the binding
- returnUs (triv_binds, new_env)
- where
- new_env = addOneToIdEnv env binder (StgConArg con_id)
-
- other -> -- Non-trivial RHS
- mkUniqueBinder env binder `thenUs` \ (new_env, new_binder) ->
- returnUs ([StgNonRec new_binder stg_rhs], new_env)
- where
- mkUniqueBinder env binder
- | externallyVisibleId binder = returnUs (env, binder)
- | otherwise =
- -- local binder, give it a new unique Id.
- newUniqueLocalId binder `thenUs` \ binder' ->
- let
- new_env = addOneToIdEnv env binder (StgVarArg binder')
- in
- returnUs (new_env, binder')
-
+ newLocalId env binder `thenUs` \ (new_env, new_binder) ->
+ returnUs ([StgNonRec new_binder stg_rhs], new_env)
coreBindToStg env (Rec pairs)
- = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
- -- (possibly ToDo)
- let
- (binders, rhss) = unzip pairs
- in
- newLocalIds env True{-maybe externally visible-} binders `thenUs` \ (binders', env') ->
- mapUs (coreRhsToStg env') rhss `thenUs` \ stg_rhss ->
+ = newLocalIds env binders `thenUs` \ (env', binders') ->
+ mapUs (coreRhsToStg env') rhss `thenUs` \ stg_rhss ->
returnUs ([StgRec (binders' `zip` stg_rhss)], env')
+ where
+ (binders, rhss) = unzip pairs
\end{code}
coreRhsToStg env core_rhs
= coreExprToStg env core_rhs `thenUs` \ stg_expr ->
+ returnUs (exprToRhs stg_expr)
+
+exprToRhs (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
+ | var1 == var2
+ = rhs
+ -- This curious stuff is to unravel what a lambda turns into
+ -- We have to do it this way, rather than spot a lambda in the
+ -- incoming rhs. Why? Because trivial bindings might conceal
+ -- what the rhs is actually like.
+
+exprToRhs (StgCon (DataCon con) args _) = StgRhsCon noCCS con args
+
+exprToRhs expr
+ = StgRhsClosure noCCS -- No cost centre (ToDo?)
+ stgArgOcc -- safe
+ noSRT -- figure out later
+ bOGUS_FVs
+ Updatable -- Be pessimistic
+ []
+ expr
- let stg_rhs = case stg_expr of
- StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
- | var1 == var2 -> rhs
- -- This curious stuff is to unravel what a lambda turns into
- -- We have to do it this way, rather than spot a lambda in the
- -- incoming rhs. Why? Because trivial bindings might conceal
- -- what the rhs is actually like.
-
- StgCon con args _ -> StgRhsCon noCostCentre con args
-
- other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- Be pessimistic
- []
- stg_expr
- in
- returnUs stg_rhs
\end{code}
%************************************************************************
\begin{code}
-coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
+coreArgsToStg :: StgEnv -> [CoreArg]
+ -> UniqSM ([(Id,StgExpr)], [StgArg])
+
+coreArgsToStg env []
+ = returnUs ([], [])
+
+coreArgsToStg env (Type ty : as) -- Discard type arguments
+ = coreArgsToStg env as
-coreArgsToStg env [] = ([], [])
coreArgsToStg env (a:as)
- = case a of
- TyArg t -> (t:trest, vrest)
- VarArg v -> (trest, stgLookup env v : vrest)
- LitArg l -> (trest, StgLitArg l : vrest)
- where
- (trest,vrest) = coreArgsToStg env as
+ = coreArgToStg env a `thenUs` \ (bs1, a') ->
+ coreArgsToStg env as `thenUs` \ (bs2, as') ->
+ returnUs (bs1 ++ bs2, a' : as')
+
+-- This is where we arrange that a non-trivial argument is let-bound
+
+coreArgToStg :: StgEnv -> CoreArg -> UniqSM ([(Id,StgExpr)], StgArg)
+
+coreArgToStg env arg
+ = coreExprToStgFloat env arg `thenUs` \ (binds, arg') ->
+ case (binds, arg') of
+ ([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con)
+ ([], StgApp v []) -> returnUs ([], StgVarArg v)
+
+ -- A non-trivial argument: we must let (or case-bind)
+ -- We don't do the case part here... we leave that to mkStgLets
+
+ -- Further complication: if we're converting this binding into
+ -- a case, then try to avoid generating any case-of-case
+ -- expressions by pulling out the floats.
+ (_, other) ->
+ newStgVar ty `thenUs` \ v ->
+ if isUnLiftedType ty
+ then returnUs (binds ++ [(v,arg')], StgVarArg v)
+ else returnUs ([(v, mkStgLets binds arg')], StgVarArg v)
+ where
+ ty = coreExprType arg
+
\end{code}
\begin{code}
coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
-coreExprToStg env (Lit lit)
- = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
-
coreExprToStg env (Var var)
- = returnUs (mk_app (stgLookup env var) [])
-
-coreExprToStg env (Con con args)
- = let
- (types, stg_atoms) = coreArgsToStg env args
- in
- returnUs (StgCon con stg_atoms bOGUS_LVs)
-
-coreExprToStg env (Prim op args)
- = mkPrimOpUnique op `thenUs` \ op' ->
- let
- (types, stg_atoms) = coreArgsToStg env args
- in
- returnUs (StgPrim op' stg_atoms bOGUS_LVs)
- where
- mkPrimOpUnique (CCallOp (Right _) a b c d e) =
- getUnique `thenUs` \ u ->
- returnUs (CCallOp (Right u) a b c d e)
- mkPrimOpUnique op = returnUs op
+ = returnUs (StgApp (stgLookup env var) [])
\end{code}
\begin{code}
coreExprToStg env expr@(Lam _ _)
= let
- (_, binders, body) = collectBinders expr
+ (binders, body) = collectBinders expr
+ id_binders = filter isId binders
in
- newLocalIds env False{-all local-} binders `thenUs` \ (binders', env') ->
- coreExprToStg env' body `thenUs` \ stg_body ->
+ newLocalIds env id_binders `thenUs` \ (env', binders') ->
+ coreExprToStg env' body `thenUs` \ stg_body ->
- if null binders then -- it was all type/usage binders; tossed
+ if null id_binders then -- it was all type/usage binders; tossed
returnUs stg_body
else
+ case stg_body of
+
+ -- if the body reduced to a lambda too...
+ (StgLet (StgNonRec var (StgRhsClosure cc bi srt fvs uf args body))
+ (StgApp var' []))
+ | var == var' ->
+ returnUs (StgLet (StgNonRec var
+ (StgRhsClosure noCCS
+ stgArgOcc
+ noSRT
+ bOGUS_FVs
+ ReEntrant
+ (binders' ++ args)
+ body))
+ (StgApp var []))
+
+ other ->
+
+ -- We must let-bind the lambda
newStgVar (coreExprType expr) `thenUs` \ var ->
returnUs
- (StgLet (StgNonRec var
- (StgRhsClosure noCostCentre
+ (StgLet (StgNonRec var (StgRhsClosure noCCS
stgArgOcc
+ noSRT
bOGUS_FVs
ReEntrant -- binders is non-empty
binders'
stg_body))
- (StgApp (StgVarArg var) [] bOGUS_LVs))
+ (StgApp var []))
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+coreExprToStg env (Let bind body)
+ = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
+ coreExprToStg new_env body `thenUs` \ stg_body ->
+ returnUs (foldr StgLet stg_body stg_binds)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection[coreToStg-scc]{SCC expressions}
+%* *
+%************************************************************************
+
+Covert core @scc@ expression directly to STG @scc@ expression.
+\begin{code}
+coreExprToStg env (Note (SCC cc) expr)
+ = coreExprToStg env expr `thenUs` \ stg_expr ->
+ returnUs (StgSCC cc stg_expr)
+\end{code}
+
+\begin{code}
+coreExprToStg env (Note other_note expr) = coreExprToStg env expr
+\end{code}
+
+The rest are handled by coreExprStgFloat.
+
+\begin{code}
+coreExprToStg env expr
+ = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
+ returnUs (mkStgLets binds stg_expr)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-coreExprToStg env expr@(App _ _)
+coreExprToStgFloat env expr@(App _ _)
= let
(fun,args) = collect_args expr []
- (_, stg_args) = coreArgsToStg env args
in
+ coreArgsToStg env args `thenUs` \ (binds, stg_args) ->
+
-- Now deal with the function
- case (fun, args) of
+ case (fun, stg_args) of
(Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
- returnUs (mk_app (stgLookup env fun_id) stg_args)
+ returnUs (binds,
+ StgApp (stgLookup env fun_id) stg_args)
(non_var_fun, []) -> -- No value args, so recurse into the function
- coreExprToStg env non_var_fun
+ ASSERT( null binds )
+ coreExprToStg env non_var_fun `thenUs` \e ->
+ returnUs ([], e)
other -> -- A non-variable applied to things; better let-bind it.
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
coreExprToStg env fun `thenUs` \ (stg_fun) ->
let
- fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
+ fun_rhs = StgRhsClosure noCCS -- No cost centre (ToDo?)
stgArgOcc
+ noSRT
bOGUS_FVs
SingleEntry -- Only entered once
[]
stg_fun
in
- returnUs (StgLet (StgNonRec fun_id fun_rhs)
- (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
+ returnUs (binds,
+ StgLet (StgNonRec fun_id fun_rhs) $
+ StgApp fun_id stg_args)
where
- -- Collect arguments, discarding type/usage applications
- collect_args (App e (TyArg _)) args = collect_args e args
+ -- Collect arguments
collect_args (App fun arg) args = collect_args fun (arg:args)
collect_args (Note (Coerce _ _) expr) args = collect_args expr args
collect_args (Note InlineCall expr) args = collect_args expr args
%************************************************************************
%* *
-\subsubsection[coreToStg-cases]{Case expressions}
+\subsubsection[coreToStg-con]{Constructors}
%* *
%************************************************************************
+\begin{code}
+coreExprToStgFloat env expr@(Con (PrimOp (CCallOp (Right _) a b c)) args)
+ = getUniqueUs `thenUs` \ u ->
+ coreArgsToStg env args `thenUs` \ (binds, stg_atoms) ->
+ let con' = PrimOp (CCallOp (Right u) a b c) in
+ returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
+
+coreExprToStgFloat env expr@(Con con args)
+ = coreArgsToStg env args `thenUs` \ (binds, stg_atoms) ->
+ returnUs (binds, StgCon con stg_atoms (coreExprType expr))
+\end{code}
-******* TO DO TO DO: fix what follows
-
-Special case for
-
- case (op x1 ... xn) of
- y -> e
-
-where the type of the case scrutinee is a multi-constuctor algebraic type.
-Then we simply compile code for
-
- let y = op x1 ... xn
- in
- e
-
-In this case:
+%************************************************************************
+%* *
+\subsubsection[coreToStg-cases]{Case expressions}
+%* *
+%************************************************************************
- case (op x1 ... xn) of
- C a b -> ...
- y -> e
+\begin{code}
+coreExprToStgFloat env expr@(Case scrut bndr alts)
+ = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
+ newLocalId env bndr `thenUs` \ (env', bndr') ->
+ alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
+ returnUs (binds, mkStgCase scrut' bndr' alts')
+ where
+ scrut_ty = idType bndr
+ prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
-where the type of the case scrutinee is a multi-constuctor algebraic type.
-we just bomb out at the moment. It never happens in practice.
+ alts_to_stg env (alts, deflt)
+ | prim_case
+ = default_to_stg env deflt `thenUs` \ deflt' ->
+ mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
+ returnUs (StgPrimAlts scrut_ty alts' deflt')
-**** END OF TO DO TO DO
+ | otherwise
+ = default_to_stg env deflt `thenUs` \ deflt' ->
+ mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
+ returnUs (StgAlgAlts scrut_ty alts' deflt')
-\begin{code}
-coreExprToStg env (Case scrut@(Prim op args) (AlgAlts alts (BindDefault binder rhs)))
- = if not (null alts) then
- panic "cgCase: case on PrimOp with default *and* alts\n"
- -- For now, die if alts are non-empty
- else
- coreExprToStg env (Let (NonRec binder scrut) rhs)
-
-coreExprToStg env (Case discrim alts)
- = coreExprToStg env discrim `thenUs` \ stg_discrim ->
- alts_to_stg discrim alts `thenUs` \ stg_alts ->
- getUnique `thenUs` \ uniq ->
- returnUs (
- StgCase stg_discrim
- bOGUS_LVs
- bOGUS_LVs
- uniq
- stg_alts
- )
- where
- discrim_ty = coreExprType discrim
- (_, discrim_ty_args, _) = splitAlgTyConApp discrim_ty
-
- alts_to_stg discrim (AlgAlts alts deflt)
- = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
- mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts ->
- returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
- where
- boxed_alt_to_stg (con, bs, rhs)
+ alg_alt_to_stg env (DataCon con, bs, rhs)
= coreExprToStg env rhs `thenUs` \ stg_rhs ->
returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
- alts_to_stg discrim (PrimAlts alts deflt)
- = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
- mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts ->
- returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ prim_alt_to_stg env (Literal lit, args, rhs)
+ = ASSERT( null args )
+ coreExprToStg env rhs `thenUs` \ stg_rhs ->
returnUs (lit, stg_rhs)
- default_to_stg discrim NoDefault
+ default_to_stg env Nothing
= returnUs StgNoDefault
- default_to_stg discrim (BindDefault binder rhs)
+ default_to_stg env (Just rhs)
= coreExprToStg env rhs `thenUs` \ stg_rhs ->
- returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
+ returnUs (StgBindDefault stg_rhs)
+ -- The binder is used for prim cases and not otherwise
+ -- (hack for old code gen)
\end{code}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
-%* *
-%************************************************************************
-
\begin{code}
-coreExprToStg env (Let bind body)
- = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
- coreExprToStg new_env body `thenUs` \ stg_body ->
- returnUs (mkStgLets stg_binds stg_body)
+coreExprToStgFloat env expr
+ = coreExprToStg env expr `thenUs` \stg_expr ->
+ returnUs ([], stg_expr)
\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[coreToStg-scc]{SCC expressions}
-%* *
-%************************************************************************
-
-Covert core @scc@ expression directly to STG @scc@ expression.
-\begin{code}
-coreExprToStg env (Note (SCC cc) expr)
- = coreExprToStg env expr `thenUs` \ stg_expr ->
- returnUs (StgSCC (coreExprType expr) cc stg_expr)
-\end{code}
-
-\begin{code}
-coreExprToStg env (Note other_note expr) = coreExprToStg env expr
-\end{code}
-
-
%************************************************************************
%* *
\subsection[coreToStg-misc]{Miscellaneous helping functions}
isn't in the StgEnv. (WDP 94/06)
\begin{code}
-stgLookup :: StgEnv -> Id -> StgArg
-stgLookup env var = case (lookupIdEnv env var) of
- Nothing -> StgVarArg var
- Just atom -> atom
+stgLookup :: StgEnv -> Id -> Id
+stgLookup env var = case (lookupVarEnv env var) of
+ Nothing -> var
+ Just var -> var
\end{code}
Invent a fresh @Id@:
\begin{code}
newStgVar :: Type -> UniqSM Id
newStgVar ty
- = getUnique `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
+ = getUniqueUs `thenUs` \ uniq ->
+ returnUs (mkUserLocal (varOcc SLIT("stg")) uniq ty)
\end{code}
\begin{code}
-newUniqueLocalId :: Id -> UniqSM Id
-newUniqueLocalId i =
- getUnique `thenUs` \ uniq ->
- returnUs (mkIdWithNewUniq i uniq)
-
-newLocalIds :: StgEnv -> Bool -> [Id] -> UniqSM ([Id], StgEnv)
-newLocalIds env maybe_visible [] = returnUs ([], env)
-newLocalIds env maybe_visible (i:is)
- | maybe_visible && externallyVisibleId i =
- newLocalIds env maybe_visible is `thenUs` \ (is', env') ->
- returnUs (i:is', env')
- | otherwise =
- newUniqueLocalId i `thenUs` \ i' ->
- let
- new_env = addOneToIdEnv env i (StgVarArg i')
- in
- newLocalIds new_env maybe_visible is `thenUs` \ (is', env') ->
- returnUs (i':is', env')
+newLocalId env id
+ | externallyVisibleId id
+ = returnUs (env, id)
+
+ | otherwise
+ = -- Local binder, give it a new unique Id.
+ getUniqueUs `thenUs` \ uniq ->
+ let
+ id' = setIdUnique id uniq
+ new_env = extendVarEnv env id id'
+ in
+ returnUs (new_env, id')
+
+newLocalIds :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
+newLocalIds env []
+ = returnUs (env, [])
+newLocalIds env (b:bs)
+ = newLocalId env b `thenUs` \ (env', b') ->
+ newLocalIds env' bs `thenUs` \ (env'', bs') ->
+ returnUs (env'', b':bs')
\end{code}
\begin{code}
-mkStgLets :: [StgBinding]
- -> StgExpr -- body of let
- -> StgExpr
+mkStgLets :: [(Id,StgExpr)] -> StgExpr -> StgExpr
+mkStgLets binds body = foldr mkStgLet body binds
+
+mkStgLet (bndr, rhs) body
+ | isUnboxedTupleType bndr_ty
+ = panic "mkStgLets: unboxed tuple"
+ | isUnLiftedType bndr_ty
+ = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
-mkStgLets binds body = foldr StgLet body binds
+ | otherwise
+ = StgLet (StgNonRec bndr (exprToRhs rhs)) body
+ where
+ bndr_ty = idType bndr
--- mk_app spots an StgCon in a function position,
--- and turns it into an StgCon. See notes with
--- getArgAmode in CgBindery.
-mk_app (StgConArg con) args = StgCon con args bOGUS_LVs
-mk_app other_fun args = StgApp other_fun args bOGUS_LVs
+mkStgCase (StgLet bind expr) bndr alts
+ = StgLet bind (mkStgCase expr bndr alts)
+mkStgCase scrut bndr alts
+ = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[StgLint]{A ``lint'' pass to check for Stg correctness}
import StgSyn
import Bag ( Bag, emptyBag, isEmptyBag, snocBag, foldBag )
-import Id ( idType, isAlgCon, dataConArgTys,
- emptyIdSet, isEmptyIdSet, elementOfIdSet,
- mkIdSet, intersectIdSets,
- unionIdSets, idSetToList, IdSet,
- GenId{-instanced NamedThing-}, Id
- )
-import Literal ( literalType, Literal{-instance Outputable-} )
+import Id ( Id, idType )
+import VarSet
+import DataCon ( DataCon, dataConArgTys, dataConType )
+import Const ( literalType, conType, Literal )
import Maybes ( catMaybes )
import Name ( isLocallyDefined, getSrcLoc )
import ErrUtils ( ErrMsg )
-import PrimOp ( primOpType )
-import SrcLoc ( SrcLoc{-instance Outputable-} )
-import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe,
- isTyVarTy, Type
+import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe,
+ isUnLiftedType, isTyVarTy, Type
)
import TyCon ( TyCon, isDataTyCon )
import Util ( zipEqual, trace )
import Outputable
infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
-
-unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
\end{code}
Checks for
case (initL (lint_binds binds)) of
Nothing -> binds
Just msg -> pprPanic "" (vcat [
- ptext SLIT("*** Stg Lint ErrMsgs: in "),text whodunnit, ptext SLIT(" ***"),
+ ptext SLIT("*** Stg Lint ErrMsgs: in") <+> text whodunnit <+> ptext SLIT("***"),
msg,
ptext SLIT("*** Offending Program ***"),
pprStgBindings binds,
\begin{code}
lintStgArg :: StgArg -> LintM (Maybe Type)
+lintStgArg (StgConArg con) = returnL (Just (conType con))
+lintStgArg (StgVarArg v) = lintStgVar v
-lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
-lintStgArg (StgConArg con) = returnL (Just (idType con))
-lintStgArg a@(StgVarArg v)
- = checkInScope v `thenL_`
- returnL (Just (idType v))
+lintStgVar v = checkInScope v `thenL_`
+ returnL (Just (idType v))
\end{code}
\begin{code}
-- Check the rhs
lintStgRhs rhs `thenL` \ maybe_rhs_ty ->
+ -- Check binder doesn't have unlifted type
+ checkL (not (isUnLiftedType binder_ty))
+ (mkUnLiftedTyMsg binder rhs) `thenL_`
+
-- Check match to RHS type
(case maybe_rhs_ty of
Nothing -> returnL ()
- Just rhs_ty -> checkTys (idType binder)
+ Just rhs_ty -> checkTys binder_ty
rhs_ty
(mkRhsMsg binder rhs_ty)
) `thenL_`
returnL ()
)
+ where
+ binder_ty = idType binder
\end{code}
\begin{code}
lintStgRhs :: StgRhs -> LintM (Maybe Type)
-lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) (
addInScopeVars binders (
lintStgExpr expr `thenMaybeL` \ body_ty ->
Nothing -> returnL Nothing
Just arg_tys -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
where
- con_ty = idType con
+ con_ty = dataConType con
\end{code}
\begin{code}
lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found
-lintStgExpr e@(StgApp fun args _)
- = lintStgArg fun `thenMaybeL` \ fun_ty ->
+lintStgExpr e@(StgApp fun args)
+ = lintStgVar fun `thenMaybeL` \ fun_ty ->
mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
case maybe_arg_tys of
Nothing -> returnL Nothing
Nothing -> returnL Nothing
Just arg_tys -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
where
- con_ty = idType con
-
-lintStgExpr e@(StgPrim op args _)
- = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
- case maybe_arg_tys of
- Nothing -> returnL Nothing
- Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
- where
- op_ty = primOpType op
+ con_ty = conType con
lintStgExpr (StgLet binds body)
= lintStgBinds binds `thenL` \ binders ->
lintStgExpr body
))
-lintStgExpr (StgSCC _ _ expr) = lintStgExpr expr
+lintStgExpr (StgSCC _ expr) = lintStgExpr expr
-lintStgExpr e@(StgCase scrut _ _ _ alts)
+lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
= lintStgExpr scrut `thenMaybeL` \ _ ->
+ checkTys (idType bndr) scrut_ty (mkDefltMsg bndr) `thenL_`
-- Check that it is a data type
case (splitAlgTyConApp_maybe scrut_ty) of
Just (tycon, _, _) | isDataTyCon tycon
- -> lintStgAlts alts scrut_ty tycon
+ -> addInScopeVars [bndr] (lintStgAlts alts scrut_ty tycon)
other -> addErrL (mkCaseDataConMsg e) `thenL_`
returnL Nothing
where
lintStgExpr rhs
lintDeflt StgNoDefault scrut_ty = returnL Nothing
-lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
- = checkTys (idType binder) scrut_ty (mkDefltMsg deflt) `thenL_`
- addInScopeVars [binder] (
- lintStgExpr rhs
- )
+lintDeflt deflt@(StgBindDefault rhs) scrut_ty = lintStgExpr rhs
\end{code}
= hcat [ppr (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders [v], char ']']
ppr (LambdaBodyOf bs)
- = hcat [ppr (getSrcLoc (head bs)),
- ptext SLIT(": [in body of lambda with binders "), pp_binders bs, char ']']
+ = hcat [ptext SLIT(": [in body of lambda with binders "), pp_binders bs, char ']']
ppr (BodyOfLetRec bs)
= hcat [ppr (getSrcLoc (head bs)),
\begin{code}
initL :: LintM a -> Maybe ErrMsg
initL m
- = case (m [] emptyIdSet emptyBag) of { (_, errs) ->
+ = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
addErr errs_so_far msg locs
- = errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg)
+ = errs_so_far `snocBag` mk_msg locs
+ where
+ mk_msg (loc:_) = hang (ppr loc) 4 msg
+ mk_msg [] = msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
-- For now, it's just a "trace"; we may make
-- a real error out of it...
let
- new_set = mkIdSet ids
+ new_set = mkVarSet ids
- shadowed = scope `intersectIdSets` new_set
+ shadowed = scope `intersectVarSet` new_set
in
-- After adding -fliberate-case, Simon decided he likes shadowed
-- names after all. WDP 94/07
--- (if isEmptyIdSet shadowed
+-- (if isEmptyVarSet shadowed
-- then id
--- else pprTrace "Shadowed vars:" (ppr (idSetToList shadowed))) $
- m loc (scope `unionIdSets` new_set) errs
+-- else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $
+ m loc (scope `unionVarSet` new_set) errs
\end{code}
\begin{code}
| isTyVarTy res_ty
= (Just res_ty, errs)
| otherwise
- = case splitFunTys (unDictifyTy res_ty) of
+ = case splitFunTys res_ty of
([], _) -> (Nothing, addErr errs msg loc) -- Too many args
(new_expected, new_res) -> cfa new_res new_expected arg_tys
cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
- = if (sleazy_eq_ty expected_arg_ty arg_ty)
+ = if (expected_arg_ty == arg_ty)
then cfa res_ty expected_arg_tys arg_tys
else (Nothing, addErr errs msg loc) -- Arg mis-match
\end{code}
\begin{code}
checkInScope :: Id -> LintM ()
checkInScope id loc scope errs
- = if isLocallyDefined id && not (isAlgCon id) && not (id `elementOfIdSet` scope) then
+ = if isLocallyDefined id && not (id `elemVarSet` scope) then
((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
else
((), errs)
checkTys :: Type -> Type -> ErrMsg -> LintM ()
checkTys ty1 ty2 msg loc scope errs
- = if (sleazy_eq_ty ty1 ty2)
+ = if (ty1 == ty2)
then ((), errs)
else ((), addErr errs msg loc)
\end{code}
mkCaseDataConMsg :: StgExpr -> ErrMsg
mkCaseDataConMsg expr
= ($$) (ptext SLIT("A case scrutinee not a type-constructor type:"))
- (pp_expr expr)
+ (ppr expr)
mkCaseAbstractMsg :: TyCon -> ErrMsg
mkCaseAbstractMsg tycon
= ($$) (ptext SLIT("An algebraic case on an abstract type:"))
(ppr tycon)
-mkDefltMsg :: StgCaseDefault -> ErrMsg
-mkDefltMsg deflt
- = ($$) (ptext SLIT("Binder in default case of a case expression doesn't match type of scrutinee:"))
- --LATER: (ppr deflt)
+mkDefltMsg :: Id -> ErrMsg
+mkDefltMsg bndr
+ = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:"))
(panic "mkDefltMsg")
mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
= vcat [text "In a function application, function type doesn't match arg types:",
hang (ptext SLIT("Function type:")) 4 (ppr fun_ty),
hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)),
- hang (ptext SLIT("Expression:")) 4 (pp_expr expr)]
+ hang (ptext SLIT("Expression:")) 4 (ppr expr)]
mkRhsConMsg :: Type -> [Type] -> ErrMsg
mkRhsConMsg fun_ty arg_tys
= ($$) (text "In some case statement, type of scrutinee is not a data type:")
(ppr ty)
-mkAlgAltMsg2 :: Type -> Id -> ErrMsg
+mkAlgAltMsg2 :: Type -> DataCon -> ErrMsg
mkAlgAltMsg2 ty con
= vcat [
text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
ppr con
]
-mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
+mkAlgAltMsg3 :: DataCon -> [Id] -> ErrMsg
mkAlgAltMsg3 con alts
= vcat [
text "In some algebraic case alternative, number of arguments doesn't match constructor:",
mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
mkPrimAltMsg alt
- = ($$) (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
- (ppr alt)
+ = text "In a primitive case alternative, type of literal doesn't match type of scrutinee:"
+ $$ ppr alt
mkRhsMsg :: Id -> Type -> ErrMsg
mkRhsMsg binder ty
hsep [ptext SLIT("Rhs type:"), ppr ty]
]
-pp_expr :: StgExpr -> SDoc
-pp_expr expr = ppr expr
-
-sleazy_eq_ty ty1 ty2
- -- NB: probably severe overkill (WDP 95/04)
- = trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $
- case (splitFunTys ty1) of { (tyargs1,tyres1) ->
- case (splitFunTys ty2) of { (tyargs2,tyres2) ->
- let
- ty11 = mkFunTys tyargs1 tyres1
- ty22 = mkFunTys tyargs2 tyres2
- in
- ty11 == ty22 }}
+mkUnLiftedTyMsg binder rhs
+ = (ptext SLIT("Let(rec) binder") <+> quotes (ppr binder) <+>
+ ptext SLIT("has unlifted type") <+> quotes (ppr (idType binder)))
+ $$
+ (ptext SLIT("RHS:") <+> ppr rhs)
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
GenStgCaseAlts(..), GenStgCaseDefault(..),
- UpdateFlag(..),
+ UpdateFlag(..), isUpdatable,
StgBinderInfo(..),
stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc,
StgBinding, StgExpr, StgRhs,
StgCaseAlts, StgCaseDefault,
- pprStgBinding, pprStgBindings,
+ -- SRTs
+ SRT(..), noSRT,
+
+ pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
getArgPrimRep,
isLitLitArg,
stgArity,
collectFinalStgBinders
+
+#ifdef DEBUG
+ , pprStgLVs
+#endif
) where
#include "HsVersions.h"
-import CostCentre ( showCostCentre, CostCentre )
-import Id ( idPrimRep, DataCon,
- GenId{-instance NamedThing-}, Id )
-import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
+import CostCentre ( CostCentreStack, CostCentre )
+import Id ( idPrimRep, Id )
+import Const ( Con(..), DataCon, Literal,
+ conPrimRep, isLitLitLit )
+import PrimRep ( PrimRep(..) )
import Outputable
-import PrimOp ( PrimOp{-instance Outputable-} )
import Type ( Type )
-import Unique ( pprUnique, Unique )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
-import Util ( panic )
\end{code}
%************************************************************************
\begin{code}
data GenStgArg occ
= StgVarArg occ
- | StgLitArg Literal
- | StgConArg DataCon -- A nullary data constructor
+ | StgConArg Con -- A literal or nullary data constructor
\end{code}
\begin{code}
getArgPrimRep (StgVarArg local) = idPrimRep local
-getArgPrimRep (StgConArg con) = idPrimRep con
-getArgPrimRep (StgLitArg lit) = literalPrimRep lit
+getArgPrimRep (StgConArg con) = conPrimRep con
-isLitLitArg (StgLitArg x) = isLitLitLit x
-isLitLitArg _ = False
+isLitLitArg (StgConArg (Literal x)) = isLitLitLit x
+isLitLitArg _ = False
\end{code}
%************************************************************************
data GenStgExpr bndr occ
= StgApp
- (GenStgArg occ) -- function
+ occ -- function
[GenStgArg occ] -- arguments
- (GenStgLiveVars occ) -- Live vars in continuation; ie not
- -- including the function and args
-- NB: a literal is: StgApp <lit-atom> [] ...
\end{code}
%* *
%************************************************************************
-There are two specialised forms of application, for
-constructors and primitives.
+There are a specialised forms of application, for
+constructors, primitives, and literals.
\begin{code}
| StgCon -- always saturated
- Id -- data constructor
+ Con
[GenStgArg occ]
- (GenStgLiveVars occ) -- Live vars in continuation; ie not
- -- including the constr and args
- | StgPrim -- always saturated
- PrimOp
- [GenStgArg occ]
- (GenStgLiveVars occ) -- Live vars in continuation; ie not
- -- including the op and args
+ Type -- Result type; this is needed for primops, where
+ -- we need to know the result type so that we can
+ -- assign result registers.
+
\end{code}
These forms are to do ``inline versions,'' as it were.
An example might be: @f x = x:[]@.
-- binder-variables are NOT counted in the
-- free vars for the alt's RHS
- Unique -- Occasionally needed to compile case
- -- statements, as the uniq for a local
- -- variable to hold the tag of a primop with
- -- algebraic result
+ bndr -- binds the result of evaluating the scrutinee
+
+ SRT -- The SRT for the continuation
(GenStgCaseAlts bndr occ)
\end{code}
\begin{code}
| StgSCC
- Type -- the type of the body
CostCentre -- label of SCC expression
(GenStgExpr bndr occ) -- scc expression
-- end of GenStgExpr
\begin{code}
data GenStgRhs bndr occ
= StgRhsClosure
- CostCentre -- cost centre to be attached (default is CCC)
+ CostCentreStack -- CCS to be attached (default is CurrentCCS)
StgBinderInfo -- Info about how this binder is used (see below)
+ SRT -- The closures's SRT
[occ] -- non-global free vars; a list, rather than
-- a set, because order is important
UpdateFlag -- ReEntrant | Updatable | SingleEntry
[bndr] -- arguments; if empty, then not a function;
- -- as above, order is important
+ -- as above, order is important.
(GenStgExpr bndr occ) -- body
\end{code}
An example may be in order. Consider:
The second flavour of right-hand-side is for constructors (simple but important):
\begin{code}
| StgRhsCon
- CostCentre -- Cost centre to be attached (default is CCC).
+ CostCentreStack -- CCS to be attached (default is CurrentCCS).
-- Top-level (static) ones will end up with
- -- DontCareCC, because we don't count static
- -- data in heap profiles, and we don't set CCC
+ -- DontCareCCS, because we don't count static
+ -- data in heap profiles, and we don't set CCCS
-- from static closure.
- Id -- constructor
+ DataCon -- constructor
[GenStgArg occ] -- args
\end{code}
\begin{code}
data GenStgCaseAlts bndr occ
= StgAlgAlts Type -- so we can find out things about constructor family
- [(Id, -- alts: data constructor,
+ [(DataCon, -- alts: data constructor,
[bndr], -- constructor's parameters,
[Bool], -- "use mask", same length as
-- parameters; a True in a
data GenStgCaseDefault bndr occ
= StgNoDefault -- small con family: all
-- constructor accounted for
- | StgBindDefault bndr -- form: var -> expr
- Bool -- True <=> var is used in rhs
- -- i.e., False <=> "_ -> expr"
- (GenStgExpr bndr occ)
+ | StgBindDefault (GenStgExpr bndr occ)
\end{code}
%************************************************************************
instance Outputable UpdateFlag where
ppr u
= char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
+
+isUpdatable ReEntrant = False
+isUpdatable SingleEntry = False
+isUpdatable Updatable = True
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[Static Reference Tables]{@SRT@}
+%* *
+%************************************************************************
+
+There is one SRT per top-level function group. Each local binding and
+case expression within this binding group has a subrange of the whole
+SRT, expressed as an offset and length.
+
+\begin{code}
+data SRT = NoSRT
+ | SRT !Int{-offset-} !Int{-length-}
+
+noSRT :: SRT
+noSRT = NoSRT
+
+pprSRT (NoSRT) = ptext SLIT("_no_srt_")
+pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
\end{code}
%************************************************************************
pprStgBinding bind = pprGenStgBinding bind
pprStgBindings :: [StgBinding] -> SDoc
-pprStgBindings binds = vcat (map (pprGenStgBinding) binds)
+pprStgBindings binds = vcat (map pprGenStgBinding binds)
+
+pprGenStgBindingWithSRT
+ :: (Outputable bndr, Outputable bdee, Ord bdee)
+ => (GenStgBinding bndr bdee,[Id]) -> SDoc
+
+pprGenStgBindingWithSRT (bind,srt)
+ = vcat [ pprGenStgBinding bind,
+ ptext SLIT("SRT: ") <> ppr srt ]
+
+pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
+pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
\end{code}
\begin{code}
pprStgArg (StgVarArg var) = ppr var
pprStgArg (StgConArg con) = ppr con
-pprStgArg (StgLitArg lit) = ppr lit
\end{code}
\begin{code}
pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
=> GenStgExpr bndr bdee -> SDoc
-- special case
-pprStgExpr (StgApp func [] lvs)
- = (<>) (ppr func) (pprStgLVs lvs)
+pprStgExpr (StgApp func []) = ppr func
-- general case
-pprStgExpr (StgApp func args lvs)
- = hang ((<>) (ppr func) (pprStgLVs lvs))
+pprStgExpr (StgApp func args)
+ = hang (ppr func)
4 (sep (map (ppr) args))
\end{code}
\begin{code}
-pprStgExpr (StgCon con args lvs)
- = hcat [ (<>) (ppr con) (pprStgLVs lvs),
- ptext SLIT("! ["), interppSP args, char ']' ]
-
-pprStgExpr (StgPrim op args lvs)
- = hcat [ ppr op, char '#', pprStgLVs lvs,
- ptext SLIT(" ["), interppSP args, char ']' ]
+pprStgExpr (StgCon con args _)
+ = hsep [ ppr con, brackets (interppSP args)]
\end{code}
\begin{code}
--
-- Very special! Suspicious! (SLPJ)
-pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
expr@(StgLet _ _))
= ($$)
(hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
- text (showCostCentre True{-as string-} cc),
+ ppr cc,
pp_binder_info bi,
ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
ppr upd_flag, ptext SLIT(" ["),
\end{code}
\begin{code}
-pprStgExpr (StgSCC ty cc expr)
- = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre True{-as string-} cc)],
- pprStgExpr expr ]
+pprStgExpr (StgSCC cc expr)
+ = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
+ pprStgExpr expr ]
\end{code}
\begin{code}
-pprStgExpr (StgCase expr lvs_whole lvs_rhss uniq alts)
+pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
= sep [sep [ptext SLIT("case"),
nest 4 (hsep [pprStgExpr expr,
ifPprDebug (ptext SLIT("::") <> pp_ty alts)]),
- ptext SLIT("of {")],
+ ptext SLIT("of"), ppr bndr, char '{'],
ifPprDebug (
nest 4 (
hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
- ptext SLIT("]; uniq: "), pprUnique uniq])),
+ ptext SLIT("]; "),
+ pprMaybeSRT srt])),
nest 2 (ppr_alts alts),
char '}']
where
ppr_default StgNoDefault = empty
- ppr_default (StgBindDefault bndr used expr)
- = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr expr)
- where
- pp_binder = if used then ppr bndr else char '_'
+ ppr_default (StgBindDefault expr)
+ = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
pp_ty (StgAlgAlts ty _ _) = ppr ty
pp_ty (StgPrimAlts ty _ _) = ppr ty
=> GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
- = hcat [ text (showCostCentre True{-as String-} cc),
+pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
+ = hcat [ ppr cc,
pp_binder_info bi,
+ pprMaybeSRT srt,
brackets (ifPprDebug (ppr free_var)),
ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
-- general case
-pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
- = hang (hcat [text (showCostCentre True{-as String-} cc),
+pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
+ = hang (hcat [ppr cc,
pp_binder_info bi,
+ pprMaybeSRT srt,
brackets (ifPprDebug (interppSP free_vars)),
ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
4 (ppr body)
pprStgRhs (StgRhsCon cc con args)
- = hcat [ text (showCostCentre True{-as String-} cc),
+ = hcat [ ppr cc,
space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
+pprMaybeSRT (NoSRT) = empty
+pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
+
--------------
pp_binder_info NoStgBinderInfo = empty
stgArity :: StgRhs -> Int
stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
-stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
+stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
module SaAbsInt (
findStrictness,
- findDemand,
+ findDemand, findDemandAlts,
absEval,
widen,
fixpoint,
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
-import CoreUnfold ( Unfolding(..), FormSummary )
-import CoreUtils ( unTagBinders )
-import Id ( idType, getIdStrictness, getIdUnfolding,
- dataConTyCon, dataConArgTys, Id
- )
+import CoreUnfold ( Unfolding(..) )
+import Id ( Id, idType, getIdStrictness, getIdUnfolding )
+import Const ( Con(..) )
+import DataCon ( dataConTyCon, dataConArgTys )
import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwUnpackNew )
-import MagicUFs ( MagicUnfoldingFun )
-import Maybes ( maybeToBool )
-import PrimOp ( PrimOp(..) )
+import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData,
+ wwUnpackNew )
import SaLib
-import TyCon ( isProductTyCon, isEnumerationTyCon, isNewTyCon,
- TyCon{-instance Eq-}
- )
+import TyCon ( isProductTyCon, isEnumerationTyCon, isNewTyCon )
import BasicTypes ( NewOrData(..) )
import Type ( splitAlgTyConApp_maybe,
- isUnpointedType, Type )
-import TysWiredIn ( intTyCon, integerTyCon, doubleTyCon,
- floatTyCon, wordTyCon, addrTyCon
- )
-import Util ( isIn, isn'tIn, nOfThem, zipWithEqual, trace )
+ isUnLiftedType, Type )
+import TyCon ( tyConUnique )
+import PrelInfo ( numericTyKeys )
+import Util ( isIn, nOfThem, zipWithEqual )
import Outputable
returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)"
glb v1 AbsTop = v1
glb _ _ = AbsBot -- Be pessimistic
-
-
-
-combineCaseValues
- :: AnalysisKind
- -> AbsVal -- Value of scrutinee
- -> [AbsVal] -- Value of branches (at least one)
- -> AbsVal -- Result
-
--- For strictness analysis, see if the scrutinee is bottom; if so
--- return bottom; otherwise, the lub of the branches.
-
-combineCaseValues StrAnal AbsBot branches = AbsBot
-combineCaseValues StrAnal other_scrutinee branches
- -- Scrutinee can only be AbsBot, AbsProd or AbsTop
- = ASSERT(ok_scrutinee)
- foldr1 lub branches
- where
- ok_scrutinee
- = case other_scrutinee of {
- AbsTop -> True; -- i.e., cool
- AbsProd _ -> True; -- ditto
- _ -> False -- party over
- }
-
--- For absence analysis, check if the scrutinee is all poison (isBot)
--- If so, return poison (AbsBot); otherwise, any nested poison will come
--- out from looking at the branches, so just glb together the branches
--- to get the worst one.
-
-combineCaseValues AbsAnal AbsBot branches = AbsBot
-combineCaseValues AbsAnal other_scrutinee branches
- -- Scrutinee can only be AbsBot, AbsProd or AbsTop
- = ASSERT(ok_scrutinee)
- let
- result = foldr1 glb branches
-
- tracer = if at_least_one_AbsFun && at_least_one_AbsTop
- && no_AbsBots then
- pprTrace "combineCase:" (ppr branches)
- else
- id
- in
--- tracer (
- result
--- )
- where
- ok_scrutinee
- = case other_scrutinee of {
- AbsTop -> True; -- i.e., cool
- AbsProd _ -> True; -- ditto
- _ -> False -- party over
- }
-
- at_least_one_AbsFun = foldr ((||) . is_AbsFun) False branches
- at_least_one_AbsTop = foldr ((||) . is_AbsTop) False branches
- no_AbsBots = foldr ((&&) . is_not_AbsBot) True branches
-
- is_AbsFun x = case x of { AbsFun _ _ _ -> True; _ -> False }
- is_AbsTop x = case x of { AbsTop -> True; _ -> False }
- is_not_AbsBot x = case x of { AbsBot -> False; _ -> True }
\end{code}
@isBot@ returns True if its argument is (a representation of) bottom. The
\begin{code}
isBot :: AbsVal -> Bool
-isBot AbsBot = True
-isBot (AbsFun arg body env) = isBot (absEval StrAnal body env)
- -- Don't bother to extend the envt because
- -- unbound variables default to AbsTop anyway
-isBot other = False
+isBot AbsBot = True
+isBot other = False -- Functions aren't bottom any more
+
\end{code}
Used only in absence analysis:
anyBot AbsBot = True -- poisoned!
anyBot AbsTop = False
anyBot (AbsProd vals) = any anyBot vals
-anyBot (AbsFun arg body env) = anyBot (absEval AbsAnal body env)
-anyBot (AbsApproxFun _ _) = False
-
- -- AbsApproxFun can only arise in absence analysis from the Demand
- -- info of an imported value; whatever it is we're looking for is
- -- certainly not present over in the imported value.
+anyBot (AbsFun bndr body env) = anyBot (absEval AbsAnal body (addOneToAbsValEnv env bndr AbsTop))
+anyBot (AbsApproxFun _ val) = anyBot val
\end{code}
@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
\begin{code}
widen :: AnalysisKind -> AbsVal -> AbsVal
-widen StrAnal (AbsFun arg body env)
- = AbsApproxFun (findDemandStrOnly env body arg)
- (widen StrAnal abs_body)
+-- Widening is complicated by the fact that funtions are lifted
+widen StrAnal the_fn@(AbsFun bndr body env)
+ = case widened_body of
+ AbsApproxFun ds val -> AbsApproxFun (d : ds) val
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ str_fn val = foldl (absApply StrAnal) the_fn
+ (val : [AbsTop | d <- ds])
+
+ other -> AbsApproxFun [d] widened_body
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ str_fn val = absApply StrAnal the_fn val
where
- abs_body = absEval StrAnal body env
+ bndr_ty = idType bndr
+ widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop)
+ abs_fn val = AbsBot -- Always says poison; so it looks as if
+ -- nothing is absent; safe
{- OLD comment...
This stuff is now instead handled neatly by the fact that AbsApproxFun
widen StrAnal other_val = other_val
-widen AbsAnal (AbsFun arg body env)
- | anyBot abs_body = AbsBot
+widen AbsAnal the_fn@(AbsFun bndr body env)
+ | anyBot widened_body = AbsBot
-- In the absence-analysis case it's *essential* to check
-- that the function has no poison in its body. If it does,
-- anywhere, then the whole function is poisonous.
| otherwise
- = AbsApproxFun (findDemandAbsOnly env body arg)
- (widen AbsAnal abs_body)
+ = case widened_body of
+ AbsApproxFun ds val -> AbsApproxFun (d : ds) val
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ abs_fn val = foldl (absApply AbsAnal) the_fn
+ (val : [AbsTop | d <- ds])
+
+ other -> AbsApproxFun [d] widened_body
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ abs_fn val = absApply AbsAnal the_fn val
where
- abs_body = absEval AbsAnal body env
+ bndr_ty = idType bndr
+ widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop)
+ str_fn val = AbsBot -- Always says non-termination;
+ -- that'll make findRecDemand peer into the
+ -- structure of the value.
widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
AbsTop -> False
AbsBot -> True
AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
- _ -> trace "evalStrictness?" False
+ _ -> pprTrace "evalStrictness?" empty False
evalStrictness WwPrim val
= case val of
AbsTop -> False
+ AbsBot -> True -- Can happen: consider f (g x), where g is a
+ -- recursive function returning an Int# that diverges
- other -> -- A primitive value should be defined, never bottom;
- -- hence this paranoia check
- pprPanic "evalStrictness: WwPrim:" (ppr other)
+ other -> pprPanic "evalStrictness: WwPrim:" (ppr other)
\end{code}
For absence analysis, we're interested in whether "poison" in the
-- error's arg
absId anal var env
- = let
- result =
- case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
+ = case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
- absEval anal (unTagBinders unfolding) env
+ absEval anal unfolding env
-- Notice here that we only look in the unfolding if we don't
-- have strictness info (an unusual situation).
-- We could have chosen to look in the unfolding if it exists,
-- Includes MagicUnfolding, NoUnfolding
-- Try the strictness info
absValFromStrictness anal strictness_info
- in
- -- pprTrace "absId:" (hcat [ppr var, ptext SLIT("=:"), pp_anal anal, text SLIT(":="),ppr result]) $
- result
- where
- pp_anal StrAnal = ptext SLIT("STR")
- pp_anal AbsAnal = ptext SLIT("ABS")
-
-absEvalAtom anal (VarArg v) env = absId anal v env
-absEvalAtom anal (LitArg _) env = AbsTop
\end{code}
\begin{code}
absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
+absEval anal (Type ty) env = AbsTop
absEval anal (Var var) env = absId anal var env
-
-absEval anal (Lit _) env = AbsTop
- -- What if an unboxed literal? That's OK: it terminates, so its
- -- abstract value is AbsTop.
-
- -- For absence analysis, a literal certainly isn't the "poison" variable
\end{code}
-Discussion about \tr{error} (following/quoting Lennart): Any expression
-\tr{error e} is regarded as bottom (with HBC, with the
-\tr{-ffail-strict} flag, on with \tr{-O}).
+Discussion about error (following/quoting Lennart): Any expression
+'error e' is regarded as bottom (with HBC, with the -ffail-strict
+flag, on with -O).
Regarding it as bottom gives much better strictness properties for
some functions. E.g.
-\begin{verbatim}
+
f [x] y = x+y
f (x:xs) y = f xs (x+y)
i.e.
f [] _ = error "no match"
f [x] y = x+y
f (x:xs) y = f xs (x+y)
-\end{verbatim}
-is strict in \tr{y}, which you really want. But, it may lead to
+
+is strict in y, which you really want. But, it may lead to
transformations that turn a call to \tr{error} into non-termination.
(The odds of this happening aren't good.)
-
Things are a little different for absence analysis, because we want
to make sure that any poison (?????)
\begin{code}
-absEval StrAnal (Prim SeqOp [TyArg _, e]) env
- = ASSERT(isValArg e)
- if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
- -- This is a special case to ensure that seq# is strict in its argument.
- -- The comments below (for most normal PrimOps) do not apply.
-
-absEval StrAnal (Prim op es) env = AbsTop
- -- The arguments are all of unboxed type, so they will already
- -- have been eval'd. If the boxed version was bottom, we'll
- -- already have returned bottom.
-
- -- Actually, I believe we are saying that either (1) the
- -- primOp uses unboxed args and they've been eval'ed, so
- -- there's no need to force strictness here, _or_ the primOp
- -- uses boxed args and we don't know whether or not it's
- -- strict, so we assume laziness. (JSM)
-
-absEval AbsAnal (Prim op as) env
- = if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
+absEval anal (Con (Literal _) args) env
+ = -- Literals terminate (strictness) and are not poison (absence)
+ AbsTop
+
+absEval anal (Con (PrimOp _) args) env
+ = -- PrimOps evaluate all their arguments
+ if any anyBot [absEval anal arg env | arg <- args]
then AbsBot
else AbsTop
- -- For absence analysis, we want to see if the poison shows up...
-absEval anal (Con con as) env
+absEval anal (Con (DataCon con) args) env
| isProductTyCon (dataConTyCon con)
- = --pprTrace "absEval.Con" (cat[ text "con: ", (ppr con), text "args: ", interppSP as]) $
- AbsProd [absEvalAtom anal a env | a <- as, isValArg a]
+ = -- Products; filter out type arguments
+ AbsProd [absEval anal a env | a <- args, isValArg a]
| otherwise -- Not single-constructor
= case anal of
AbsAnal -> -- In the absence case we need to be more
-- careful: look to see if there's any
-- poison in the components
- if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
+ if any anyBot [absEval AbsAnal arg env | arg <- args]
then AbsBot
else AbsTop
\end{code}
\begin{code}
-absEval anal (Lam (ValBinder binder) body) env
- = AbsFun binder body env
-absEval anal (Lam other_binder expr) env
- = absEval anal expr env
-absEval anal (App f a) env | isValArg a
- = absApply anal (absEval anal f env) (absEvalAtom anal a env)
-absEval anal (App expr _) env
- = absEval anal expr env
+absEval anal (Lam bndr body) env
+ | isTyVar bndr = absEval anal body env -- Type lambda
+ | otherwise = AbsFun bndr body env -- Value lambda
+
+absEval anal (App expr (Type ty)) env
+ = absEval anal expr env -- Type appplication
+absEval anal (App f val_arg) env
+ = absApply anal (absEval anal f env) -- Value applicationn
+ (absEval anal val_arg env)
\end{code}
-For primitive cases, just GLB the branches, then LUB with the expr part.
-
\begin{code}
-absEval anal (Case expr (PrimAlts alts deflt)) env
- = let
- expr_val = absEval anal expr env
- abs_alts = [ absEval anal rhs env | (_, rhs) <- alts ]
- -- PrimAlts don't bind anything, so no need
- -- to extend the environment
-
- abs_deflt = absEvalDefault anal expr_val deflt env
- in
- combineCaseValues anal expr_val
- (abs_deflt ++ abs_alts)
-
-absEval anal (Case expr (AlgAlts alts deflt)) env
+absEval anal expr@(Case scrut case_bndr alts) env
= let
- expr_val = absEval anal expr env
- abs_alts = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ]
- abs_deflt = absEvalDefault anal expr_val deflt env
- in
- let
- result =
- combineCaseValues anal expr_val
- (abs_deflt ++ abs_alts)
+ scrut_val = absEval anal scrut env
+ alts_env = addOneToAbsValEnv env case_bndr scrut_val
in
-{-
- (case anal of
- StrAnal -> id
- _ -> pprTrace "absCase:ABS:" (($$) (hsep [ppr expr, ppr result, ppr expr_val, ppr abs_deflt, ppr abs_alts]) (ppr (keysFM env `zip` eltsFM env)))
- )
--}
- result
+ case (scrut_val, alts) of
+ (AbsBot, _) -> AbsBot
+
+ (AbsProd arg_vals, [(con, bndrs, rhs)])
+ | con /= DEFAULT ->
+ -- The scrutinee is a product value, so it must be of a single-constr
+ -- type; so the constructor in this alternative must be the right one
+ -- so we can go ahead and bind the constructor args to the components
+ -- of the product value.
+ ASSERT(length arg_vals == length val_bndrs)
+ absEval anal rhs rhs_env
+ where
+ val_bndrs = filter isId bndrs
+ rhs_env = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals)
+
+ other -> absEvalAlts anal alts alts_env
\end{code}
For @Lets@ we widen the value we get. This is nothing to
\end{code}
\begin{code}
-absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],CoreExpr) -> AbsValEnv -> AbsVal
-
-absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env
- = -- The scrutinee is a product value, so it must be of a single-constr
- -- type; so the constructor in this alternative must be the right one
- -- so we can go ahead and bind the constructor args to the components
- -- of the product value.
- ASSERT(length arg_vals == length args)
- let
- new_env = growAbsValEnvList env (args `zip` arg_vals)
- in
- absEval anal rhs new_env
-
-absEvalAlgAlt anal other_scrutinee (con, args, rhs) env
- = -- Scrutinised value is Top or Bot (it can't be a function!)
- -- So just evaluate the rhs with all constr args bound to Top.
- -- (If the scrutinee is Top we'll never evaluated this function
- -- call anyway!)
- ASSERT(ok_scrutinee)
- absEval anal rhs rhs_env
+absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal
+absEvalAlts anal alts env
+ = combine anal (map go alts)
where
- rhs_env = growAbsValEnvList env (args `zip` repeat AbsTop)
- -- We must extend the environment, because
- -- there might be shadowing
-
- ok_scrutinee
- = case other_scrutinee of {
- AbsTop -> True; -- i.e., OK
- AbsBot -> True; -- ditto
- _ -> False -- party over
- }
-
-
-absEvalDefault :: AnalysisKind
- -> AbsVal -- Value of scrutinee
- -> CoreCaseDefault
- -> AbsValEnv
- -> [AbsVal] -- Empty or singleton
-
-absEvalDefault anal scrut_val NoDefault env = []
-absEvalDefault anal scrut_val (BindDefault binder expr) env
- = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)]
+ combine StrAnal = foldr1 lub -- Diverge only if all diverge
+ combine AbsAnal = foldr1 glb -- Find any poison
+
+ go (con, bndrs, rhs)
+ = absEval anal rhs rhs_env
+ where
+ rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop)
\end{code}
%************************************************************************
\end{code}
\begin{code}
-absApply StrAnal (AbsApproxFun demand val) arg
- = if evalStrictness demand arg
- then AbsBot
- else val
+absApply StrAnal (AbsApproxFun (d:ds) val) arg
+ = case ds of
+ [] -> val'
+ other -> AbsApproxFun ds val' -- Result is non-bot if there are still args
+ where
+ val' | evalStrictness d arg = AbsBot
+ | otherwise = val
-absApply AbsAnal (AbsApproxFun demand val) arg
- = if evalAbsence demand arg
- then AbsBot
- else val
+absApply AbsAnal (AbsApproxFun (d:ds) val) arg
+ = if evalAbsence d arg
+ then AbsBot -- Poison in arg means poison in the application
+ else case ds of
+ [] -> val
+ other -> AbsApproxFun ds val
#ifdef DEBUG
absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
-> AbsVal -- Abstract absence value of function
-> [Demand] -- Resulting strictness annotation
-findStrictness [] str_val abs_val = []
+findStrictness tys str_val abs_val
+ = map find_str tys_w_index
+ where
+ tys_w_index = tys `zip` [1..]
-findStrictness (ty:tys) str_val abs_val
- = let
- demand = findRecDemand str_fn abs_fn ty
- str_fn val = absApply StrAnal str_val val
- abs_fn val = absApply AbsAnal abs_val val
+ find_str (ty,n) = findRecDemand str_fn abs_fn ty
+ where
+ str_fn val = foldl (absApply StrAnal) str_val
+ (map (mk_arg val n) tys_w_index)
- demands = findStrictness tys
- (absApply StrAnal str_val AbsTop)
- (absApply AbsAnal abs_val AbsTop)
- in
- demand : demands
+ abs_fn val = foldl (absApply AbsAnal) abs_val
+ (map (mk_arg val n) tys_w_index)
+
+ mk_arg val n (_,m) | m==n = val
+ | otherwise = AbsTop
\end{code}
\begin{code}
-findDemandStrOnly str_env expr binder -- Only strictness environment available
+findDemand str_env abs_env expr binder
= findRecDemand str_fn abs_fn (idType binder)
where
str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
- abs_fn val = AbsBot -- Always says poison; so it looks as if
- -- nothing is absent; safe
-
-findDemandAbsOnly abs_env expr binder -- Only absence environment available
- = findRecDemand str_fn abs_fn (idType binder)
- where
- str_fn val = AbsBot -- Always says non-termination;
- -- that'll make findRecDemand peer into the
- -- structure of the value.
abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
-
-findDemand str_env abs_env expr binder
+findDemandAlts str_env abs_env alts binder
= findRecDemand str_fn abs_fn (idType binder)
where
- str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
- abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
+ str_fn val = absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val)
+ abs_fn val = absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)
\end{code}
@findRecDemand@ is where we finally convert strictness/absence info
-> Demand
findRecDemand str_fn abs_fn ty
- = if isUnpointedType ty then -- It's a primitive type!
+ = if isUnLiftedType ty then -- It's a primitive type!
wwPrim
else if not (anyBot (abs_fn AbsBot)) then -- It's absent
let
demand = findRecDemand str_fn abs_fn (head cmpnt_tys)
in
- case demand of -- No point in unpacking unless there is more to see inside
- WwUnpack _ _ _ -> wwUnpackNew demand
- other -> wwStrict
-
+ wwUnpackNew demand
else -- A data type!
let
compt_strict_infos
= case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above
Nothing -> False
Just (tycon, _, _)
- | tycon `is_elem`
- [intTyCon, integerTyCon,
- doubleTyCon, floatTyCon,
- wordTyCon, addrTyCon]
+ | tyConUnique tycon `is_elem` numericTyKeys
-> True
_{-something else-} -> False
where
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[SaLib]{Basic datatypes, functions for the strictness analyser}
AbsVal(..),
AnalysisKind(..),
AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv,
+ mkAbsApproxFun,
nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
lookupAbsValEnv,
absValFromStrictness
#include "HsVersions.h"
+import Id ( Id )
import CoreSyn ( CoreExpr )
-import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList,
- lookupIdEnv, IdEnv,
- Id
- )
+import VarEnv
import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand{-instance Outputable-} )
+import Demand ( Demand, pprDemands )
import Outputable
\end{code}
AbsValEnv -- and environment
| AbsApproxFun -- This is used to represent a coarse
- Demand -- approximation to a function value. It's an
+ [Demand] -- approximation to a function value. It's an
AbsVal -- abstract function which is strict in its
- -- argument if the Demand so indicates.
+ -- arguments if the Demand so indicates.
+
+ -- AbsApproxFun has to take a *list* of demands, no just one,
+ -- because function spaces are now lifted. Hence, (f bot top)
+ -- might be bot, but the partial application (f bot) is a *function*,
+ -- not bot.
+
+mkAbsApproxFun :: Demand -> AbsVal -> AbsVal
+mkAbsApproxFun d (AbsApproxFun ds val) = AbsApproxFun (d:ds) val
+mkAbsApproxFun d val = AbsApproxFun [d] val
instance Outputable AbsVal where
ppr AbsTop = ptext SLIT("AbsTop")
= hsep [ptext SLIT("AbsFun{"), ppr arg,
ptext SLIT("???"), -- text "}{env:", ppr (keysFM env `zip` eltsFM env),
char '}' ]
- ppr (AbsApproxFun demand val)
- = hsep [ptext SLIT("AbsApprox "), ppr demand, ppr val]
+ ppr (AbsApproxFun demands val)
+ = hsep [ptext SLIT("AbsApprox "), pprDemands demands, ppr val]
\end{code}
%-----------
type AbsenceEnv = AbsValEnv -- Environment for absence analysis
nullAbsValEnv -- this is the one and only way to create AbsValEnvs
- = AbsValEnv nullIdEnv
+ = AbsValEnv emptyVarEnv
-addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (addOneToIdEnv idenv y z)
-growAbsValEnvList (AbsValEnv idenv) ys = AbsValEnv (growIdEnvList idenv ys)
+addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (extendVarEnv idenv y z)
+growAbsValEnvList (AbsValEnv idenv) ys = AbsValEnv (extendVarEnvList idenv ys)
lookupAbsValEnv (AbsValEnv idenv) y
- = lookupIdEnv idenv y
+ = lookupVarEnv idenv y
\end{code}
\begin{code}
absValFromStrictness StrAnal BottomGuaranteed = AbsBot -- Guaranteed bottom
absValFromStrictness AbsAnal BottomGuaranteed = AbsTop -- Check for poison in
-- arguments (if any)
-absValFromStrictness anal (StrictnessInfo args_info _) = foldr AbsApproxFun AbsTop args_info
+absValFromStrictness anal (StrictnessInfo args_info _) = AbsApproxFun args_info AbsTop
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats
- )
+import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats, opt_D_verbose_core2core )
import CoreSyn
-import Id ( idType, addIdStrictness,
- getIdDemandInfo, addIdDemandInfo,
+import Id ( idType, setIdStrictness,
+ getIdDemandInfo, setIdDemandInfo,
Id
)
-import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
- mkDemandInfo, willBeDemanded, DemandInfo
- )
-import PprCore ( pprCoreBinding )
+import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo )
+import CoreLint ( beginPass, endPass )
+import ErrUtils ( dumpIfSet )
import SaAbsInt
import SaLib
+import Demand ( isStrict )
import WorkWrap -- "back-end" of strictness analyser
-import Unique ( Unique{-instance Eq -} )
import UniqSupply ( UniqSupply )
import Util ( zipWith4Equal )
import Outputable
\begin{code}
saWwTopBinds :: UniqSupply
- -> [CoreBinding]
- -> [CoreBinding]
+ -> [CoreBind]
+ -> IO [CoreBind]
saWwTopBinds us binds
- = let
+ = do {
+ beginPass "Strictness analysis";
- -- mark each binder with its strictness
+ -- Mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
- (binds_w_strictness, sa_stats)
- = saTopBinds binds nullSaStats
+ let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
+ dumpIfSet opt_D_simplifier_stats "Strictness analysis statistics"
+ (pp_stats sa_stats);
#else
- binds_w_strictness
- = saTopBindsBinds binds
-#endif
- in
- -- possibly show what we decided about strictness...
- (if opt_D_dump_stranal
- then pprTrace "Strictness:\n" (vcat (
- map (pprCoreBinding) binds_w_strictness))
- else id
- )
- -- possibly show how many things we marked as demanded...
- ((if opt_D_simplifier_stats
-#ifndef OMIT_STRANAL_STATS
- then pp_stats sa_stats
-#else
- then id
-#endif
- else id
- )
- -- create worker/wrappers, and mark binders with their
- -- "strictness info" [which encodes their
- -- worker/wrapper-ness]
- (workersAndWrappers binds_w_strictness us))
-#ifndef OMIT_STRANAL_STATS
- where
- pp_stats (SaStats tlam dlam tc dc tlet dlet)
- = pprTrace "Binders marked demanded: "
- (hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
- ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
- ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet)
- ])
+ let { binds_w_strictness = saTopBindsBinds binds };
#endif
+
+ -- Create worker/wrappers, and mark binders with their
+ -- "strictness info" [which encodes their worker/wrapper-ness]
+ let { binds' = workersAndWrappers us binds_w_strictness };
+
+ endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds'
+ }
\end{code}
%************************************************************************
@AbsValEnv@ maps an @Id@ to its @AbsVal@).
\begin{code}
-saTopBinds :: [CoreBinding] -> SaM [CoreBinding] -- not exported
+saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
saTopBinds binds
= let
\begin{code}
saTopBind :: StrictEnv -> AbsenceEnv
- -> CoreBinding
- -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
+ -> CoreBind
+ -> SaM (StrictEnv, AbsenceEnv, CoreBind)
saTopBind str_env abs_env (NonRec binder rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
saExpr _ _ e@(Var _) = returnSa e
-saExpr _ _ e@(Lit _) = returnSa e
saExpr _ _ e@(Con _ _) = returnSa e
-saExpr _ _ e@(Prim _ _) = returnSa e
+saExpr _ _ e@(Type _) = returnSa e
-saExpr str_env abs_env (Lam (ValBinder arg) body)
- = saExpr str_env abs_env body `thenSa` \ new_body ->
- let
- new_arg = addDemandInfoToId str_env abs_env body arg
- in
- tickLambda new_arg `thenSa_` -- stats
- returnSa (Lam (ValBinder new_arg) new_body)
-
-saExpr str_env abs_env (Lam other_binder expr)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (Lam other_binder new_expr)
+saExpr str_env abs_env (Lam bndr body)
+ = -- Don't bother to set the demand-info on a lambda binder
+ -- We do that only for let(rec)-bound functions
+ saExpr str_env abs_env body `thenSa` \ new_body ->
+ returnSa (Lam bndr new_body)
saExpr str_env abs_env (App fun arg)
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
- returnSa (App new_fun arg)
+ saExpr str_env abs_env arg `thenSa` \ new_arg ->
+ returnSa (App new_fun new_arg)
saExpr str_env abs_env (Note note expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
returnSa (Note note new_expr)
-saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
- mapSa sa_alt alts `thenSa` \ new_alts ->
- returnSa (Case new_expr (AlgAlts new_alts new_deflt))
+saExpr str_env abs_env (Case expr case_bndr alts)
+ = saExpr str_env abs_env expr `thenSa` \ new_expr ->
+ mapSa sa_alt alts `thenSa` \ new_alts ->
+ let
+ new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr
+ in
+ returnSa (Case new_expr new_case_bndr new_alts)
where
sa_alt (con, binders, rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
- new_binders = addDemandInfoToIds str_env abs_env rhs binders
+ new_binders = map add_demand_info binders
+ add_demand_info bndr | isTyVar bndr = bndr
+ | otherwise = addDemandInfoToId str_env abs_env rhs bndr
in
tickCases new_binders `thenSa_` -- stats
returnSa (con, new_binders, new_rhs)
-saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
- mapSa sa_alt alts `thenSa` \ new_alts ->
- returnSa (Case new_expr (PrimAlts new_alts new_deflt))
- where
- sa_alt (lit, rhs)
- = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
- returnSa (lit, new_rhs)
-
saExpr str_env abs_env (Let (NonRec binder rhs) body)
= -- Analyse the RHS in the environment at hand
saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
str_vals abs_vals binders rhss
- whiter_than_white_binders = launder improved_binders
-
- new_pairs = whiter_than_white_binders `zip` new_rhss
+ new_pairs = improved_binders `zip` new_rhss
in
returnSa (Let (Rec new_pairs) new_body)
- where
- launder me = {-still-} me
-\end{code}
-
-\begin{code}
-saDefault str_env abs_env NoDefault = returnSa NoDefault
-
-saDefault str_env abs_env (BindDefault bdr rhs)
- = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
- let
- new_bdr = addDemandInfoToId str_env abs_env rhs bdr
- in
- tickCases [new_bdr] `thenSa_` -- stats
- returnSa (BindDefault new_bdr new_rhs)
\end{code}
addStrictnessInfoToId str_val abs_val binder body
| isBot str_val
- = binder `addIdStrictness` mkBottomStrictnessInfo
+ = binder `setIdStrictness` mkBottomStrictnessInfo
| otherwise
- = case (collectBinders body) of
+ = case (collectTyAndValBinders body) of
(_, [], rhs) -> binder
- (_, lambda_bounds, rhs) -> binder `addIdStrictness`
+ (_, lambda_bounds, rhs) -> binder `setIdStrictness`
mkStrictnessInfo strictness False
where
tys = map idType lambda_bounds
-> Id -- Id augmented with Demand info
addDemandInfoToId str_env abs_env expr binder
- = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
+ = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder)
+
+addDemandInfoToCaseBndr str_env abs_env alts binder
+ = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder)
addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
{-# INLINE returnSa #-}
tickLambda :: Id -> SaM ()
-tickCases :: [Id] -> SaM ()
+tickCases :: [CoreBndr] -> SaM ()
tickLet :: Id -> SaM ()
#ifndef OMIT_STRANAL_STATS
((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
tick_demanded var (tot, demanded)
+ | isTyVar var = (tot, demanded)
+ | otherwise
= (tot + 1,
- if (willBeDemanded (getIdDemandInfo var))
+ if (isStrict (getIdDemandInfo var))
then demanded + 1
else demanded)
+pp_stats (SaStats tlam dlam tc dc tlet dlet)
+ = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
+ ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
+ ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet)
+ ]
+
#else {-OMIT_STRANAL_STATS-}
-- identity monad
type SaM a = a
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
import CmdLineOpts ( opt_UnfoldingCreationThreshold )
import CoreUtils ( coreExprType )
+import Const ( Con(..) )
+import DataCon ( DataCon )
import MkId ( mkWorkerId )
-import Id ( getInlinePragma, getIdStrictness,
- addIdStrictness, addInlinePragma, idWantsToBeINLINEd,
- IdSet, emptyIdSet, addOneToIdSet, unionIdSets,
- GenId, Id
+import Id ( Id, getIdStrictness,
+ setIdStrictness, setInlinePragma, idWantsToBeINLINEd,
)
+import VarSet
import Type ( splitAlgTyConApp_maybe )
-import IdInfo ( noIdInfo, mkStrictnessInfo, setStrictnessInfo, StrictnessInfo(..) )
+import IdInfo ( mkStrictnessInfo, StrictnessInfo(..),
+ InlinePragInfo(..) )
import SaLib
-import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM )
+import UniqSupply ( UniqSupply, initUs, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import UniqSet
import WwLib
import Outputable
\end{code}
\end{enumerate}
\begin{code}
-workersAndWrappers :: [CoreBinding] -> UniqSM [CoreBinding]
+workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
-workersAndWrappers top_binds
- = mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 ->
+workersAndWrappers us top_binds
+ = initUs us $
+ mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 ->
let
top_binds3 = map make_top_binding top_binds2
in
returnUs (concat top_binds3)
where
- make_top_binding :: WwBinding -> [CoreBinding]
+ make_top_binding :: WwBinding -> [CoreBind]
make_top_binding (WwLet binds) = binds
\end{code}
\begin{code}
wwBind :: Bool -- True <=> top-level binding
- -> CoreBinding
+ -> CoreBind
-> UniqSM WwBinding -- returns a WwBinding intermediate form;
-- the caller will convert to Expr/Binding,
-- as appropriate.
wwBind top_level (NonRec binder rhs)
- = wwExpr rhs `thenUs` \ new_rhs ->
- tryWW binder new_rhs `thenUs` \ new_pairs ->
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ tryWW True {- non-recursive -} binder new_rhs `thenUs` \ new_pairs ->
returnUs (WwLet [NonRec b e | (b,e) <- new_pairs])
-- Generated bindings must be non-recursive
-- because the original binding was.
returnUs (WwLet [Rec (concat new_pairs)])
where
do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs ->
- tryWW binder new_rhs
+ tryWW False {- recursive -} binder new_rhs
\end{code}
@wwExpr@ basically just walks the tree, looking for appropriate
\begin{code}
wwExpr :: CoreExpr -> UniqSM CoreExpr
+wwExpr e@(Type _) = returnUs e
wwExpr e@(Var _) = returnUs e
-wwExpr e@(Lit _) = returnUs e
-wwExpr e@(Con _ _) = returnUs e
-wwExpr e@(Prim _ _) = returnUs e
+
+wwExpr e@(Con con args)
+ = mapUs wwExpr args `thenUs` \ args' ->
+ returnUs (Con con args')
wwExpr (Lam binder expr)
= wwExpr expr `thenUs` \ new_expr ->
wwExpr (App f a)
= wwExpr f `thenUs` \ new_f ->
- returnUs (App new_f a)
+ wwExpr a `thenUs` \ new_a ->
+ returnUs (App new_f new_a)
wwExpr (Note note expr)
= wwExpr expr `thenUs` \ new_expr ->
wwExpr expr `thenUs` \ new_expr ->
returnUs (mash_ww_bind intermediate_bind new_expr)
where
- mash_ww_bind (WwLet binds) body = mkCoLetsNoUnboxed binds body
+ mash_ww_bind (WwLet binds) body = mkLets binds body
mash_ww_bind (WwCase case_fn) body = case_fn body
-wwExpr (Case expr alts)
+wwExpr (Case expr binder alts)
= wwExpr expr `thenUs` \ new_expr ->
- ww_alts alts `thenUs` \ new_alts ->
- returnUs (Case new_expr new_alts)
+ mapUs ww_alt alts `thenUs` \ new_alts ->
+ returnUs (Case new_expr binder new_alts)
where
- ww_alts (AlgAlts alts deflt)
- = mapUs ww_alg_alt alts `thenUs` \ new_alts ->
- ww_deflt deflt `thenUs` \ new_deflt ->
- returnUs (AlgAlts new_alts new_deflt)
-
- ww_alts (PrimAlts alts deflt)
- = mapUs ww_prim_alt alts `thenUs` \ new_alts ->
- ww_deflt deflt `thenUs` \ new_deflt ->
- returnUs (PrimAlts new_alts new_deflt)
-
- ww_alg_alt (con, binders, rhs)
+ ww_alt (con, binders, rhs)
= wwExpr rhs `thenUs` \ new_rhs ->
returnUs (con, binders, new_rhs)
-
- ww_prim_alt (lit, rhs)
- = wwExpr rhs `thenUs` \ new_rhs ->
- returnUs (lit, new_rhs)
-
- ww_deflt NoDefault
- = returnUs NoDefault
-
- ww_deflt (BindDefault binder rhs)
- = wwExpr rhs `thenUs` \ new_rhs ->
- returnUs (BindDefault binder new_rhs)
\end{code}
%************************************************************************
The only reason this is monadised is for the unique supply.
\begin{code}
-tryWW :: Id -- The fn binder
+tryWW :: Bool -- True <=> a non-recursive binding
+ -> Id -- The fn binder
-> CoreExpr -- The bound rhs; its innards
-- are already ww'd
-> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
-- the orig "wrapper" lives on);
-- if two, then a worker and a
-- wrapper.
-tryWW fn_id rhs
+tryWW non_rec fn_id rhs
| idWantsToBeINLINEd fn_id
- || (certainlySmallEnoughToInline fn_id $
- calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
+ || (non_rec && -- Don't split if its non-recursive and small
+ certainlySmallEnoughToInline fn_id unfold_guidance
)
-- No point in worker/wrappering something that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
| otherwise -- Do w/w split
= let
- (tyvars, wrap_args, body) = collectBinders rhs
+ (tyvars, wrap_args, body) = collectTyAndValBinders rhs
in
mkWwBodies tyvars wrap_args
(coreExprType body)
revised_wrap_args_info `thenUs` \ (wrap_fn, work_fn, work_demands) ->
- getUnique `thenUs` \ work_uniq ->
+ getUniqueUs `thenUs` \ work_uniq ->
let
work_rhs = work_fn body
- work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) work_info
- work_info = mkStrictnessInfo work_demands False `setStrictnessInfo` noIdInfo
+ work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
+ mkStrictnessInfo work_demands False
wrap_rhs = wrap_fn work_id
- wrap_id = addInlinePragma (fn_id `addIdStrictness`
- mkStrictnessInfo revised_wrap_args_info True)
+ wrap_id = fn_id `setIdStrictness` mkStrictnessInfo revised_wrap_args_info True
+ `setInlinePragma` IWantToBeINLINEd
-- Add info to the wrapper:
-- (a) we want to inline it everywhere
-- (b) we want to pin on its revised stricteness info
StrictnessInfo args_info _ -> args_info
revised_wrap_args_info = setUnpackStrategy wrap_args_info
+ unfold_guidance = calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
+
-- This rather (nay! extremely!) crude function looks at a wrapper function, and
-- snaffles out (a) the worker Id and (b) constructors needed to
-- make the wrapper.
-- These are needed when we write an interface file.
+getWorkerIdAndCons :: Id -> CoreExpr -> (Id, UniqSet DataCon)
getWorkerIdAndCons wrap_id wrapper_fn
= (get_work_id wrapper_fn, get_cons wrapper_fn)
where
get_work_id (Lam _ body) = get_work_id body
- get_work_id (Case _ (AlgAlts [(_,_,rhs)] _)) = get_work_id rhs
+ get_work_id (Case _ _ [(_,_,rhs)]) = get_work_id rhs
get_work_id (Note _ body) = get_work_id body
get_work_id (Let _ body) = get_work_id body
get_work_id (App fn _) = get_work_id fn
get_cons (Lam _ body) = get_cons body
- get_cons (Let (NonRec _ rhs) body) = get_cons rhs `unionIdSets` get_cons body
+ get_cons (Let (NonRec _ rhs) body) = get_cons rhs `unionUniqSets` get_cons body
- get_cons (Case e (AlgAlts [(con,_,rhs)] _)) = (get_cons e `unionIdSets` get_cons rhs)
- `addOneToIdSet` con
+ get_cons (Case e _ [(DataCon dc,_,rhs)]) = (get_cons e `unionUniqSets` get_cons rhs)
+ `addOneToUniqSet` dc
-- Coercions don't mention the construtor now,
-- but we must still put the constructor in the interface
-- file so that the RHS of the newtype decl is imported
get_cons (Note (Coerce to_ty from_ty) body)
- = get_cons body `addOneToIdSet` con
+ = get_cons body `addOneToUniqSet` con
where
con = case splitAlgTyConApp_maybe from_ty of
Just (_, _, [con]) -> con
other -> pprPanic "getWorkerIdAndCons" (ppr to_ty)
- get_cons other = emptyIdSet
+ get_cons other = emptyUniqSet
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
#include "HsVersions.h"
import CoreSyn
-import MkId ( mkSysLocal )
-import Id ( idType, dataConArgTys, isDataCon, isNewCon, Id )
-import IdInfo ( Demand(..) )
-import PrelVals ( aBSENT_ERROR_ID, voidId )
-import TysPrim ( voidTy )
-import SrcLoc ( noSrcLoc )
-import Type ( isUnpointedType, mkTyVarTys, mkFunTys,
+import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo )
+import Const ( Con(..) )
+import DataCon ( dataConArgTys )
+import Demand ( Demand(..) )
+import PrelVals ( aBSENT_ERROR_ID )
+import TysWiredIn ( unitTy, unitDataCon )
+import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
splitForAllTys, splitFunTys,
splitAlgTyConApp_maybe,
Type
)
-import TyCon ( isNewTyCon, isDataTyCon )
import BasicTypes ( NewOrData(..) )
-import TyVar ( TyVar )
-import UniqSupply ( returnUs, thenUs, getUniques, getUnique, UniqSM )
-import Util ( zipEqual, zipWithEqual )
+import Var ( TyVar )
+import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM )
+import Util ( zipWithEqual )
import Outputable
\end{code}
\begin{code}
data WwBinding
- = WwLet [CoreBinding]
+ = WwLet [CoreBind]
| WwCase (CoreExpr -> CoreExpr)
-- the "case" will be a "strict let" of the form:
--
nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
worthSplitting :: [Demand] -> Bool -- True <=> the wrapper would not be an identity function
-worthSplitting [] = False
-worthSplitting (WwLazy True : ds) = True -- Absent arg
-worthSplitting (WwUnpack _ True _ : ds) = True -- Arg to unpack
-worthSplitting (d : ds) = worthSplitting ds
+worthSplitting ds = any worth_it ds
+ where
+ worth_it (WwLazy True) = True -- Absent arg
+ worth_it (WwUnpack _ True _) = True -- Arg to unpack
+ worth_it WwStrict = True
+ worth_it other = False
allAbsent :: [Demand] -> Bool
-allAbsent (WwLazy True : ds) = allAbsent ds
-allAbsent (WwUnpack _ True cs : ds) = allAbsent cs && allAbsent ds
-allAbsent (d : ds) = False
-allAbsent [] = True
+allAbsent ds = all absent ds
+ where
+ absent (WwLazy is_absent) = is_absent
+ absent (WwUnpack _ True cs) = allAbsent cs
+ absent other = False
\end{code}
= let
n_wrap_args = length demands
in
- getUniques n_wrap_args `thenUs` \ wrap_uniqs ->
+ getUniquesUs n_wrap_args `thenUs` \ wrap_uniqs ->
let
(tyvars, tau_ty) = splitForAllTys fun_ty
(arg_tys, body_ty) = splitFunTys tau_ty
mkWwBodies tyvars args body_ty demands
| allAbsent demands &&
- isUnpointedType body_ty
+ isUnLiftedType body_ty
= -- Horrid special case. If the worker would have no arguments, and the
-- function returns a primitive type value, that would make the worker into
-- an unboxed value. We box it by passing a dummy void argument, thus:
-- f = /\abc. \xyz. fw abc void
-- fw = /\abc. \v. body
--
- getUnique `thenUs` \ void_arg_uniq ->
+ getUniqueUs `thenUs` \ void_arg_uniq ->
let
- void_arg = mk_ww_local void_arg_uniq voidTy
+ void_arg = mk_ww_local void_arg_uniq unitTy
in
- returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)),
- \ body -> mkLam tyvars [void_arg] body,
+ returnUs (\ work_id -> mkLams tyvars $ mkLams args $
+ mkApps (Var work_id)
+ (map (Type . mkTyVarTy) tyvars ++ [mkConApp unitDataCon []]),
+ \ body -> mkLams (tyvars ++ [void_arg]) body,
[WwLazy True])
-mkWwBodies tyvars args body_ty demands
+mkWwBodies tyvars wrap_args body_ty demands
| otherwise
= let
- args_w_demands = zipEqual "mkWwBodies" args demands
- in
- mkWW args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
- let
- (work_args, work_demands) = unzip work_args_w_demands
+ wrap_args_w_demands = zipWithEqual "mkWwBodies" setIdDemandInfo wrap_args demands
in
- returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))),
- \ body -> mkLam tyvars work_args (work_fn body),
- work_demands)
+ mkWW wrap_args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
+ returnUs (\ work_id -> mkLams tyvars $ mkLams wrap_args_w_demands $
+ wrap_fn (mkTyApps (Var work_id) (mkTyVarTys tyvars)),
+
+ \ body -> mkLams tyvars $ mkLams work_args_w_demands $
+ work_fn body,
+
+ map getIdDemandInfo work_args_w_demands)
\end{code}
\begin{code}
-mkWW :: [(Id,Demand)]
+mkWW :: [Id] -- Wrapper args; have their demand info on them
-> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
-- and without its lambdas
- [(Id,Demand)], -- Worker args and their demand infos
+ [Id], -- Worker args; have their demand info on them
CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function
\ worker_body -> worker_body)
+mkWW (arg : ds)
+ = case getIdDemandInfo arg of
+
-- Absent case
-mkWW ((arg,WwLazy True) : ds)
- = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
- returnUs (\ wrapper_body -> wrap_fn wrapper_body,
- worker_args,
- \ worker_body -> mk_absent_let arg (work_fn worker_body))
+ WwLazy True ->
+ mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> wrap_fn wrapper_body,
+ worker_args,
+ \ worker_body -> mk_absent_let arg (work_fn worker_body))
-- Unpack case
-mkWW ((arg,WwUnpack new_or_data True cs) : ds)
- = getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
- let
- unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
- unpk_args_w_ds = zipEqual "mkWW" unpk_args cs
- in
- mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
- returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon
- (wrap_fn wrapper_body),
- worker_args,
- \ worker_body -> work_fn (mk_pk_let new_or_data arg data_con
- tycon_arg_tys unpk_args worker_body))
- where
- inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
- (arg_tycon, tycon_arg_tys, data_con)
- = case (splitAlgTyConApp_maybe (idType arg)) of
-
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
- (arg_tycon, tycon_arg_tys, data_con)
-
- Just (_, _, data_cons) -> pprPanic "mk_ww_arg_processing: not one constr (interface files not consistent/up to date ?)" ((ppr arg) <+> (ppr (idType arg)))
- Nothing -> panic "mk_ww_arg_processing: not datatype"
+ WwUnpack new_or_data True cs ->
+ getUniquesUs (length inst_con_arg_tys) `thenUs` \ uniqs ->
+ let
+ unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
+ unpk_args_w_ds = zipWithEqual "mkWW" setIdDemandInfo unpk_args cs
+ in
+ mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon
+ (wrap_fn wrapper_body),
+ worker_args,
+ \ worker_body -> work_fn (mk_pk_let new_or_data arg data_con
+ tycon_arg_tys unpk_args worker_body))
+ where
+ inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
+ (arg_tycon, tycon_arg_tys, data_con)
+ = case (splitAlgTyConApp_maybe (idType arg)) of
+
+ Just (arg_tycon, tycon_arg_tys, [data_con]) ->
+ -- The main event: a single-constructor data type
+ (arg_tycon, tycon_arg_tys, data_con)
+
+ Just (_, _, data_cons) ->
+ pprPanic "mk_ww_arg_processing:"
+ (text "not one constr (interface files not consistent/up to date?)"
+ $$ (ppr arg <+> ppr (idType arg)))
+
+ Nothing ->
+ panic "mk_ww_arg_processing: not datatype"
-- Other cases
-mkWW ((arg,other_demand) : ds)
- = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
- returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (VarArg arg)),
- (arg,other_demand) : worker_args,
- work_fn)
+ other_demand ->
+ mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (Var arg)),
+ arg : worker_args,
+ work_fn)
\end{code}
\begin{code}
mk_absent_let arg body
- | not (isUnpointedType arg_ty)
- = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
+ | not (isUnLiftedType arg_ty)
+ = Let (NonRec arg (mkTyApps (Var aBSENT_ERROR_ID) [arg_ty])) body
| otherwise
= panic "WwLib: haven't done mk_absent_let for primitives yet"
where
mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body
-- A newtype! Use a coercion not a case
- = ASSERT( null other_args && isNewTyCon boxing_tycon )
- Let (NonRec unpk_arg (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg)))
- body
+ = ASSERT( null other_args )
+ Case (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg))
+ unpk_arg
+ [(DEFAULT,[],body)]
where
(unpk_arg:other_args) = unpk_args
mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body
-- A data type
- = ASSERT( isDataTyCon boxing_tycon )
- Case (Var arg)
- (AlgAlts [(boxing_con, unpk_args, body)]
- NoDefault
- )
+ = Case (Var arg) arg [(DataCon boxing_con, unpk_args, body)]
mk_pk_let NewType arg boxing_con con_tys unpk_args body
- = ASSERT( null other_args && isNewCon boxing_con )
+ = ASSERT( null other_args )
Let (NonRec arg (Note (Coerce (idType arg) (idType unpk_arg)) (Var unpk_arg))) body
where
(unpk_arg:other_args) = unpk_args
mk_pk_let DataType arg boxing_con con_tys unpk_args body
- = ASSERT( isDataCon boxing_con )
- Let (NonRec arg (Con boxing_con con_args)) body
+ = Let (NonRec arg (Con (DataCon boxing_con) con_args)) body
where
- con_args = map TyArg con_tys ++ map VarArg unpk_args
+ con_args = map Type con_tys ++ map Var unpk_args
-mk_ww_local uniq ty
- = mkSysLocal SLIT("ww") uniq ty noSrcLoc
+mk_ww_local uniq ty = mkSysLocal uniq ty
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Inst]{The @Inst@ type: dictionaries or method instances}
\begin{code}
module Inst (
- LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE,
- pprInsts, pprInstsInFull,
+ LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
+ plusLIEs, mkLIE, isEmptyLIE,
- Inst, OverloadedLit(..), pprInst,
+ Inst, OverloadedLit(..),
+ pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
InstanceMapper,
isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor,
instBindingRequired, instCanBeGeneralised,
- zonkInst, instToId,
+ zonkInst, instToId, instToIdBndr,
InstOrigin(..), pprOrigin
) where
#include "HsVersions.h"
-import CmdLineOpts ( opt_AllowOverlappingInstances )
-import HsSyn ( HsLit(..), HsExpr(..), MonoBinds )
-import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr )
+import HsSyn ( HsLit(..), HsExpr(..) )
+import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId
)
import TcMonad
-import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
+import TcEnv ( TcIdSet, tcLookupGlobalValueByKey, tcLookupTyConByKey,
+ tidyType, tidyTypes
+ )
import TcType ( TcThetaType,
- TcType, TcTauType, TcMaybe, TcTyVarSet,
- tcInstType, zonkTcType, zonkTcTypes, tcSplitForAllTy,
+ TcType, TcTauType, TcTyVarSet,
+ zonkTcType, zonkTcTypes,
zonkTcThetaType
)
-import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
- listToBag, consBag, Bag )
+import Bag
import Class ( classInstEnv,
Class, ClassInstEnv
)
-import MkId ( mkUserLocal, mkSysLocal )
-import Id ( Id, idType, mkId,
- GenIdSet, elementOfIdSet
- )
+import Id ( Id, idType, mkUserLocal, mkSysLocal )
+import VarSet ( elemVarSet )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( OccName(..), Name, occNameString, getOccName )
-import PprType ( TyCon, pprConstraint )
+import PprType ( pprConstraint )
import SpecEnv ( SpecEnv, lookupSpecEnv )
import SrcLoc ( SrcLoc )
-import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy,
+import Type ( Type, ThetaType, substTy,
isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
splitRhoTy, tyVarsOfType, tyVarsOfTypes,
- mkSynTy
+ mkSynTy, substFlexiTy, substFlexiTheta
)
-import TyVar ( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets )
+import TyCon ( TyCon )
+import VarEnv ( zipVarEnv, lookupVarEnv )
+import VarSet ( unionVarSet )
import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
-import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange,
- floatDataCon, isFloatTy,
- doubleDataCon, isDoubleTy )
+import TysWiredIn ( intDataCon, isIntTy, inIntRange,
+ floatDataCon, isFloatTy,
+ doubleDataCon, isDoubleTy,
+ integerTy, isIntegerTy
+ )
import Unique ( fromRationalClassOpKey, rationalTyConKey,
fromIntClassOpKey, fromIntegerClassOpKey, Unique
)
-import Maybes ( MaybeErr, expectJust )
-import Util ( thenCmp, zipWithEqual )
+import Maybes ( expectJust )
+import Util ( thenCmp, zipWithEqual, mapAccumL )
import Outputable
\end{code}
\begin{code}
type LIE s = Bag (Inst s)
+isEmptyLIE = isEmptyBag
emptyLIE = emptyBag
unitLIE inst = unitBag inst
mkLIE insts = listToBag insts
tyVarsOfInst :: Inst s -> TcTyVarSet s
tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys
-tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
+tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` tcIdTyVars id
-- The id might not be a RealId; in the case of
-- locally-overloaded class methods, for example
tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
isDict (Dict _ _ _ _ _) = True
isDict other = False
-isMethodFor :: GenIdSet (TcType s) -> Inst s -> Bool
+isMethodFor :: TcIdSet s -> Inst s -> Bool
isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc)
- = id `elementOfIdSet` ids
+ = id `elemVarSet` ids
isMethodFor ids inst
= False
newMethod orig id tys
= -- Get the Id type and instantiate it at the specified types
(case id of
- RealId id -> let (tyvars, rho) = splitForAllTys (idType id)
+ RealId id -> let
+ (tyvars, rho) = splitForAllTys (idType id)
in
ASSERT( length tyvars == length tys)
- tcInstType (zipTyVarEnv tyvars tys) rho
+ returnNF_Tc (substFlexiTy (zipVarEnv tyvars tys) rho)
- TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) ->
- returnNF_Tc (instantiateTy (zipTyVarEnv tyvars tys) rho)
+ TcId id -> let
+ (tyvars, rho) = splitForAllTys (idType id)
+ in
+ returnNF_Tc (substTy (zipVarEnv tyvars tys) rho)
) `thenNF_Tc` \ rho_ty ->
let
(theta, tau) = splitRhoTy rho_ty
in
- -- Our friend does the rest
- newMethodWithGivenTy orig id tys theta tau
+ newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
+ returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
newMethodWithGivenTy orig id tys theta tau
let
meth_inst = Method new_uniq id tys theta tau orig loc
in
- returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
+ returnNF_Tc meth_inst
newMethodAtLoc :: InstOrigin s -> SrcLoc
-> Id -> [TcType s]
newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
-- slightly different interface
= -- Get the Id type and instantiate it at the specified types
- let
- (tyvars,rho) = splitForAllTys (idType real_id)
- in
- tcInstType (zipTyVarEnv tyvars tys) rho `thenNF_Tc` \ rho_ty ->
tcGetUnique `thenNF_Tc` \ new_uniq ->
let
- (theta, tau) = splitRhoTy rho_ty
- meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
+ (tyvars,rho) = splitForAllTys (idType real_id)
+ rho_ty = ASSERT( length tyvars == length tys )
+ substFlexiTy (zipVarEnv tyvars tys) rho
+ (theta, tau) = splitRhoTy rho_ty
+ meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
in
returnNF_Tc (meth_inst, instToId meth_inst)
\end{code}
where
intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
integer_lit = HsLitOut (HsInt i) integerTy
- int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
-
+ int_lit = HsCon intDataCon [] [intprim_lit]
+
newOverloadedLit orig lit ty -- The general case
= tcGetSrcLoc `thenNF_Tc` \ loc ->
tcGetUnique `thenNF_Tc` \ new_uniq ->
\begin{code}
instToId :: Inst s -> TcIdOcc s
-instToId (Dict u clas ty orig loc)
- = TcId (mkUserLocal occ u (mkDictTy clas ty) loc)
+instToId inst = TcId (instToIdBndr inst)
+
+instToIdBndr :: Inst s -> TcIdBndr s
+instToIdBndr (Dict u clas ty orig loc)
+ = mkUserLocal occ u (mkDictTy clas ty)
where
occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
-instToId (Method u id tys theta tau orig loc)
- = TcId (mkUserLocal (getOccName id) u tau loc)
+instToIdBndr (Method u id tys theta tau orig loc)
+ = mkUserLocal (getOccName id) u tau
-instToId (LitInst u list ty orig loc)
- = TcId (mkSysLocal SLIT("lit") u ty loc)
+instToIdBndr (LitInst u list ty orig loc)
+ = mkSysLocal u ty
\end{code}
pprInst (Method u id tys _ _ orig loc)
= hsep [ppr id, ptext SLIT("at"),
- interppSP tys,
+ brackets (interppSP tys),
show_uniq u]
+tidyInst :: TidyTypeEnv s -> Inst s -> (TidyTypeEnv s, Inst s)
+tidyInst env (LitInst u lit ty orig loc)
+ = (env', LitInst u lit ty' orig loc)
+ where
+ (env', ty') = tidyType env ty
+
+tidyInst env (Dict u clas tys orig loc)
+ = (env', Dict u clas tys' orig loc)
+ where
+ (env', tys') = tidyTypes env tys
+
+tidyInst env (Method u id tys theta tau orig loc)
+ = (env', Method u id tys' theta tau orig loc)
+ -- Leave theta, tau alone cos we don't print them
+ where
+ (env', tys') = tidyTypes env tys
+
+tidyInsts env insts = mapAccumL tidyInst env insts
+
show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
\end{code}
= NoInstance
| SimpleInst (TcExpr s) -- Just a variable, type application, or literal
| GenInst [Inst s] (TcExpr s) -- The expression and its needed insts
+
lookupInst :: Inst s
-> NF_TcM s (LookupInstResult s)
Just (tenv, dfun_id)
-> let
(tyvars, rho) = splitForAllTys (idType dfun_id)
- ty_args = map (expectJust "Inst" . lookupTyVarEnv tenv) tyvars
+ ty_args = map (expectJust "Inst" . lookupVarEnv tenv) tyvars
-- tenv should bind all the tyvars
- in
- tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
- let
- (theta, tau) = splitRhoTy dfun_rho
- ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
+ dfun_rho = substFlexiTy tenv rho
+ (theta, tau) = splitRhoTy dfun_rho
+ ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
in
if null theta then
returnNF_Tc (SimpleInst ty_app)
in_int_range = inIntRange i
intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
integer_lit = HsLitOut (HsInt i) integerTy
- int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
+ int_lit = HsCon intDataCon [] [intprim_lit]
-- similar idea for overloaded floating point literals: if the literal is
-- *definitely* a float or a double, generate the real thing here.
where
floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy
- float_lit = HsApp (HsVar (RealId floatDataCon)) floatprim_lit
+ float_lit = HsCon floatDataCon [] [floatprim_lit]
doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
- double_lit = HsApp (HsVar (RealId doubleDataCon)) doubleprim_lit
+ double_lit = HsCon doubleDataCon [] [doubleprim_lit]
\end{code}
Nothing -> returnNF_Tc Nothing
Just (tenv, dfun)
- -> returnNF_Tc (Just (instantiateThetaTy tenv theta))
+ -> returnNF_Tc (Just (substFlexiTheta tenv theta))
where
(_, theta, _) = splitSigmaTy (idType dfun)
\end{code}
| LiteralOrigin HsLit -- Occurrence of a literal
+ | PatOrigin RenamedPat
+
| ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
| SignatureOrigin -- A dict created from a type signature
= hsep [ptext SLIT("use of"), quotes (ppr id)]
pp_orig (LiteralOrigin lit)
= hsep [ptext SLIT("the literal"), quotes (ppr lit)]
+ pp_orig (PatOrigin pat)
+ = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
pp_orig (InstanceDeclOrigin)
= ptext SLIT("an instance declaration")
pp_orig (ArithSeqOrigin seq)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, bindInstsOfLocalFuns,
- tcPragmaSigs, checkSigTyVars, tcBindWithSigs,
- sigCtxt, TcSigInfo(..) ) where
+module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
+ tcPragmaSigs, tcBindWithSigs ) where
#include "HsVersions.h"
import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
import {-# SOURCE #-} TcExpr ( tcExpr )
-import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..),
- collectMonoBinders, andMonoBinds
+import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
+ collectMonoBinders, andMonoBindList, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcHsBinds, TcMonoBinds,
TcIdOcc(..), TcIdBndr,
- tcIdType
+ tcIdType, zonkId
)
import TcMonad
-import Inst ( Inst, LIE, emptyLIE, plusLIE, plusLIEs, InstOrigin(..),
- newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy,
- zonkInst, pprInsts
+import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
+ newDicts, tyVarsOfInst, instToId,
)
-import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK,
- newLocalId, newSpecPragmaId,
+import TcEnv ( tcExtendLocalValEnv, tcExtendEnvWithPat,
+ tcLookupLocalValueOK,
+ newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcMatches ( tcMatchesFun )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
-import TcMonoType ( tcHsType )
-import TcPat ( tcPat )
-import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( TcType, TcThetaType, TcTauType,
- TcTyVarSet, TcTyVar,
- newTyVarTy, newTcTyVar, tcInstSigType, tcInstSigTcType,
- zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVar
+import TcMonoType ( tcHsTcType, checkSigTyVars,
+ TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
-import Unify ( unifyTauTy, unifyTauTyLists )
-
-import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
-import MkId ( mkUserId )
-import Id ( idType, idName, idInfo, replaceIdInfo )
+import TcPat ( tcVarPat, tcPat )
+import TcSimplify ( bindInstsOfLocalFuns )
+import TcType ( TcType, TcThetaType,
+ TcTyVar,
+ newTyVarTy, newTcTyVar, tcInstTcType,
+ zonkTcType, zonkTcTypes, zonkTcThetaType )
+import TcUnify ( unifyTauTy, unifyTauTyLists )
+
+import Id ( mkUserId )
+import Var ( idType, idName, setIdInfo )
import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
-import Maybes ( maybeToBool, assocMaybe )
-import Name ( getOccName, getSrcLoc, Name )
-import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes,
- splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
- splitRhoTy, mkForAllTy, splitForAllTys
+import Name ( Name )
+import Type ( mkTyVarTy, tyVarsOfTypes,
+ splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
+ mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
+ isUnboxedType, openTypeKind,
+ unboxedTypeKind, boxedTypeKind
)
-import TyVar ( TyVar, tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
- elementOfTyVarSet, unionTyVarSets, tyVarSetToList
- )
-import Bag ( bagToList, foldrBag, )
-import Util ( isIn, hasNoDups, assoc )
-import Unique ( Unique )
+import Var ( TyVar, tyVarKind )
+import VarSet
+import Bag
+import Util ( isIn )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import SrcLoc ( SrcLoc )
import Outputable
\begin{code}
tcTopBindsAndThen, tcBindsAndThen
- :: (RecFlag -> TcMonoBinds s -> this -> that) -- Combinator
+ :: (RecFlag -> TcMonoBinds s -> thing -> thing) -- Combinator
-> RenamedHsBinds
- -> TcM s (this, LIE s)
- -> TcM s (that, LIE s)
+ -> TcM s (thing, LIE s)
+ -> TcM s (thing, LIE s)
tcTopBindsAndThen = tc_binds_and_then TopLevel
tcBindsAndThen = tc_binds_and_then NotTopLevel
-tc_binds_and_then top_lvl combiner binds do_next
- = tcBinds top_lvl binds `thenTc` \ (mbinds1, binds_lie, env, ids) ->
- tcSetEnv env $
-
- -- Now do whatever happens next, in the augmented envt
- do_next `thenTc` \ (thing, thing_lie) ->
+tc_binds_and_then top_lvl combiner EmptyBinds do_next
+ = do_next
+tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
+ = do_next
- -- Create specialisations of functions bound here
- -- Nota Bene: we glom the bindings all together in a single
- -- recursive group ("recursive" passed to combiner, below)
- -- so that we can do thsi bindInsts thing once for all the bindings
- -- and the thing inside. This saves a quadratic-cost algorithm
- -- when there's a long sequence of bindings.
- bindInstsOfLocalFuns (binds_lie `plusLIE` thing_lie) ids `thenTc` \ (final_lie, mbinds2) ->
-
- -- All done
- let
- final_mbinds = mbinds1 `AndMonoBinds` mbinds2
- in
- returnTc (combiner Recursive final_mbinds thing, final_lie)
+tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
+ = tc_binds_and_then top_lvl combiner b1 $
+ tc_binds_and_then top_lvl combiner b2 $
+ do_next
-tcBinds :: TopLevelFlag
- -> RenamedHsBinds
- -> TcM s (TcMonoBinds s, LIE s, TcEnv s, [TcIdBndr s])
- -- The envt is the envt with binders in scope
- -- The binders are those bound by this group of bindings
-
-tcBinds top_lvl EmptyBinds
- = tcGetEnv `thenNF_Tc` \ env ->
- returnTc (EmptyMonoBinds, emptyLIE, env, [])
-
- -- Short-cut for the rather common case of an empty bunch of bindings
-tcBinds top_lvl (MonoBind EmptyMonoBinds sigs is_rec)
- = tcGetEnv `thenNF_Tc` \ env ->
- returnTc (EmptyMonoBinds, emptyLIE, env, [])
-
-tcBinds top_lvl (ThenBinds binds1 binds2)
- = tcBinds top_lvl binds1 `thenTc` \ (mbinds1, lie1, env1, ids1) ->
- tcSetEnv env1 $
- tcBinds top_lvl binds2 `thenTc` \ (mbinds2, lie2, env2, ids2) ->
- returnTc (mbinds1 `AndMonoBinds` mbinds2, lie1 `plusLIE` lie2, env2, ids1++ids2)
-
-tcBinds top_lvl (MonoBind bind sigs is_rec)
- = fixTc (\ ~(prag_info_fn, _) ->
+tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
+ = fixTc (\ ~(prag_info_fn, _, _) ->
-- This is the usual prag_info fix; the PragmaInfo field of an Id
-- is not inspected till ages later in the compiler, so there
-- should be no black-hole problems here.
-- TYPECHECK THE SIGNATURES
- mapTc tcTySig ty_sigs `thenTc` \ tc_ty_sigs ->
+ mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
- tcBindWithSigs top_lvl binder_names bind
+ tcBindWithSigs top_lvl bind
tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
-- Extend the environment to bind the new polymorphic Ids
- tcExtendLocalValEnv binder_names poly_ids $
+ tcExtendLocalValEnv (map idName poly_ids) poly_ids $
-- Build bindings and IdInfos corresponding to user pragmas
- tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
-
- -- Catch the environment and return
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc (prag_info_fn, (poly_binds `AndMonoBinds` prag_binds,
- poly_lie `plusLIE` prag_lie,
- env, poly_ids)
- ) ) `thenTc` \ (_, result) ->
- returnTc result
- where
- binder_names = map fst (bagToList (collectMonoBinders bind))
- ty_sigs = [sig | sig@(Sig name _ _) <- sigs]
+ tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
+
+ -- Now do whatever happens next, in the augmented envt
+ do_next `thenTc` \ (thing, thing_lie) ->
+
+ -- Create specialisations of functions bound here
+ -- We want to keep non-recursive things non-recursive
+ -- so that we desugar unboxed bindings correctly
+ case (top_lvl, is_rec) of
+
+ -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
+ -- All the top level things are rec'd together anyway, so it's fine to
+ -- leave them to the tcSimplifyTop, and quite a bit faster too
+ (TopLevel, _)
+ -> returnTc (prag_info_fn,
+ combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
+ thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
+
+ (NotTopLevel, NonRecursive)
+ -> bindInstsOfLocalFuns
+ (thing_lie `plusLIE` prag_lie)
+ poly_ids `thenTc` \ (thing_lie', lie_binds) ->
+
+ returnTc (
+ prag_info_fn,
+ combiner NonRecursive poly_binds $
+ combiner NonRecursive prag_binds $
+ combiner Recursive lie_binds $
+ -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
+ -- aren't guaranteed in dependency order (though we could change
+ -- that); hence the Recursive marker.
+ thing,
+
+ thing_lie' `plusLIE` poly_lie
+ )
+
+ (NotTopLevel, Recursive)
+ -> bindInstsOfLocalFuns
+ (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie)
+ poly_ids `thenTc` \ (final_lie, lie_binds) ->
+
+ returnTc (
+ prag_info_fn,
+ combiner Recursive (
+ poly_binds `andMonoBinds`
+ lie_binds `andMonoBinds`
+ prag_binds) thing,
+ final_lie
+ )
+ ) `thenTc` \ (_, thing, lie) ->
+ returnTc (thing, lie)
\end{code}
An aside. The original version of @tcBindsAndThen@ which lacks a
examples of this, which is why I thought it worth preserving! [SLPJ]
\begin{pseudocode}
-tcBindsAndThen
- :: RenamedHsBinds
- -> TcM s (thing, LIE s, thing_ty))
- -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
-
-tcBindsAndThen EmptyBinds do_next
- = do_next `thenTc` \ (thing, lie, thing_ty) ->
- returnTc ((EmptyBinds, thing), lie, thing_ty)
-
-tcBindsAndThen (ThenBinds binds1 binds2) do_next
- = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
- `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
-
- returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
-
-tcBindsAndThen (MonoBind bind sigs is_rec) do_next
- = tcBindAndThen bind sigs do_next
+% tcBindsAndThen
+% :: RenamedHsBinds
+% -> TcM s (thing, LIE s, thing_ty))
+% -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
+%
+% tcBindsAndThen EmptyBinds do_next
+% = do_next `thenTc` \ (thing, lie, thing_ty) ->
+% returnTc ((EmptyBinds, thing), lie, thing_ty)
+%
+% tcBindsAndThen (ThenBinds binds1 binds2) do_next
+% = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
+% `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
+%
+% returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
+%
+% tcBindsAndThen (MonoBind bind sigs is_rec) do_next
+% = tcBindAndThen bind sigs do_next
\end{pseudocode}
\begin{code}
tcBindWithSigs
:: TopLevelFlag
- -> [Name]
-> RenamedMonoBinds
-> [TcSigInfo s]
-> RecFlag
-> (Name -> IdInfo)
-> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
-tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn
+tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
= recoverTc (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
-- error messages
- newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
+ newTcTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
let
- forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
- poly_ids = map mk_dummy binder_names
+ forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
+ binder_names = map fst (bagToList (collectMonoBinders mbind))
+ poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
- Just (TySigInfo _ poly_id _ _ _ _) -> poly_id -- Signature
+ Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
Nothing -> mkUserId name forall_a_a -- No signature
in
returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
) $
- -- Create a new identifier for each binder, with each being given
- -- a fresh unique, and a type-variable type.
- -- For "mono_lies" see comments about polymorphic recursion at the
- -- end of the function.
- mapAndUnzipNF_Tc mk_mono_id binder_names `thenNF_Tc` \ (mono_lies, mono_ids) ->
+ -- TYPECHECK THE BINDINGS
+ tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
+
let
- mono_lie = plusLIEs mono_lies
mono_id_tys = map idType mono_ids
in
- -- TYPECHECK THE BINDINGS
- tcMonoBinds mbind binder_names mono_ids tc_ty_sigs `thenTc` \ (mbind', lie) ->
-
-- CHECK THAT THE SIGNATURES MATCH
-- (must do this before getTyVarsToGen)
- checkSigMatch tc_ty_sigs `thenTc` \ sig_theta ->
-
+ checkSigMatch tc_ty_sigs `thenTc` \ (sig_theta, lie_avail) ->
+
-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-- The tyvars_not_to_gen are free in the environment, and hence
-- candidates for generalisation, but sometimes the monomorphism
-- restriction means we can't generalise them nevertheless
- getTyVarsToGen is_unrestricted mono_id_tys lie `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
+ getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-- DEAL WITH TYPE VARIABLE KINDS
-- **** This step can do unification => keep other zonking after this ****
- mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
+ mapTc defaultUncommittedTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
let
- real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
+ real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
-- It's important that the final list
-- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
-- zonked, *including boxity*, because they'll be included in the forall types of
in
-- SIMPLIFY THE LIE
- tcExtendGlobalTyVars (tyVarSetToList tyvars_not_to_gen) (
+ tcExtendGlobalTyVars tyvars_not_to_gen (
+ if null real_tyvars_to_gen_list then
+ -- No polymorphism, so no need to simplify context
+ returnTc (lie_req, EmptyMonoBinds, [])
+ else
if null tc_ty_sigs then
-- No signatures, so just simplify the lie
-- NB: no signatures => no polymorphic recursion, so no
- -- need to use mono_lies (which will be empty anyway)
+ -- need to use lie_avail (which will be empty anyway)
tcSimplify (text "tcBinds1" <+> ppr binder_names)
- top_lvl real_tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) ->
+ top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
else
let
-- The "givens" is the stuff available. We get that from
- -- the context of the type signature, BUT ALSO the mono_lie
+ -- the context of the type signature, BUT ALSO the lie_avail
-- so that polymorphic recursion works right (see comments at end of fn)
- givens = dicts_sig `plusLIE` mono_lie
+ givens = dicts_sig `plusLIE` lie_avail
in
-- Check that the needed dicts can be expressed in
-- terms of the signature ones
tcAddErrCtxt (bindSigsCtxt tysig_names) $
tcSimplifyAndCheck
- (ptext SLIT("type signature for") <+>
- hsep (punctuate comma (map (quotes . ppr) binder_names)))
- real_tyvars_to_gen givens lie `thenTc` \ (lie_free, dict_binds) ->
+ (ptext SLIT("type signature for") <+> pprQuotedList binder_names)
+ real_tyvars_to_gen givens lie_req `thenTc` \ (lie_free, dict_binds) ->
returnTc (lie_free, dict_binds, dict_ids)
) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
- ASSERT( not (any (isUnboxedTypeKind . tyVarKind) real_tyvars_to_gen_list) )
+ -- GET THE FINAL MONO_ID_TYS
+ zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
+
+
+ -- CHECK FOR BOGUS UNPOINTED BINDINGS
+ (if any isUnLiftedType zonked_mono_id_types then
+ -- Unlifted bindings must be non-recursive,
+ -- not top level, and non-polymorphic
+ checkTc (case top_lvl of {TopLevel -> False; NotTopLevel -> True})
+ (unliftedBindErr "Top-level" mbind) `thenTc_`
+ checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
+ (unliftedBindErr "Recursive" mbind) `thenTc_`
+ checkTc (null real_tyvars_to_gen_list)
+ (unliftedBindErr "Polymorphic" mbind)
+ else
+ returnTc ()
+ ) `thenTc_`
+
+ ASSERT( not (any ((== unboxedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
-- The instCantBeGeneralised stuff in tcSimplify should have
- -- already raised an error if we're trying to generalise an unboxed tyvar
- -- (NB: unboxed tyvars are always introduced along with a class constraint)
- -- and it's better done there because we have more precise origin information.
+ -- already raised an error if we're trying to generalise an
+ -- unboxed tyvar (NB: unboxed tyvars are always introduced
+ -- along with a class constraint) and it's better done there
+ -- because we have more precise origin information.
-- That's why we just use an ASSERT here.
+
-- BUILD THE POLYMORPHIC RESULT IDs
- zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
+ mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
let
- exports = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types
+ exports = zipWith mk_export binder_names zonked_mono_ids
dict_tys = map tcIdType dicts_bound
- mk_export binder_name mono_id zonked_mono_id_ty
- = (tyvars, TcId (replaceIdInfo poly_id (prag_info_fn binder_name)), TcId mono_id)
+ mk_export binder_name zonked_mono_id
+ = (tyvars,
+ TcId (setIdInfo poly_id (prag_info_fn binder_name)),
+ TcId zonked_mono_id)
where
(tyvars, poly_id) =
- case maybeSig tc_ty_sigs binder_name of
- Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) -> (sig_tyvars, sig_poly_id)
- Nothing -> (real_tyvars_to_gen_list, new_poly_id)
+ case maybeSig tc_ty_sigs binder_name of
+ Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
+ (sig_tyvars, sig_poly_id)
+ Nothing -> (real_tyvars_to_gen_list, new_poly_id)
new_poly_id = mkUserId binder_name poly_ty
- poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys zonked_mono_id_ty
- -- It's important to build a fully-zonked poly_ty, because
- -- we'll slurp out its free type variables when extending the
- -- local environment (tcExtendLocalValEnv); if it's not zonked
- -- it appears to have free tyvars that aren't actually free at all.
+ poly_ty = mkForAllTys real_tyvars_to_gen_list
+ $ mkFunTys dict_tys
+ $ idType (zonked_mono_id)
+ -- It's important to build a fully-zonked poly_ty, because
+ -- we'll slurp out its free type variables when extending the
+ -- local environment (tcExtendLocalValEnv); if it's not zonked
+ -- it appears to have free tyvars that aren't actually free
+ -- at all.
+
+ pat_binders :: [Name]
+ pat_binders = map fst $ bagToList $ collectMonoBinders $
+ (justPatBindings mbind EmptyMonoBinds)
in
+ -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
+ mapTc (\id -> checkTc (not (idName id `elem` pat_binders
+ && isUnboxedType (idType id)))
+ (unboxedPatBindErr id)) zonked_mono_ids
+ `thenTc_`
-- BUILD RESULTS
returnTc (
AbsBinds real_tyvars_to_gen_list
dicts_bound
exports
- (dict_binds `AndMonoBinds` mbind'),
+ (dict_binds `andMonoBinds` mbind'),
lie_free,
[poly_id | (_, TcId poly_id, _) <- exports]
)
where
- no_of_binders = length binder_names
-
- mk_mono_id binder_name
- | theres_a_signature -- There's a signature; and it's overloaded,
- && not (null sig_theta) -- so make a Method
- = tcAddSrcLoc sig_loc $
- newMethodWithGivenTy SignatureOrigin
- (TcId poly_id) (mkTyVarTys sig_tyvars)
- sig_theta sig_tau `thenNF_Tc` \ (mono_lie, TcId mono_id) ->
- -- A bit turgid to have to strip the TcId
- returnNF_Tc (mono_lie, mono_id)
-
- | otherwise -- No signature or not overloaded;
- = tcAddSrcLoc (getSrcLoc binder_name) $
- (if theres_a_signature then
- returnNF_Tc sig_tau -- Non-overloaded signature; use its type
- else
- newTyVarTy kind -- No signature; use a new type variable
- ) `thenNF_Tc` \ mono_id_ty ->
-
- newLocalId (getOccName binder_name) mono_id_ty `thenNF_Tc` \ mono_id ->
- returnNF_Tc (emptyLIE, mono_id)
- where
- maybe_sig = maybeSig tc_ty_sigs binder_name
- theres_a_signature = maybeToBool maybe_sig
- Just (TySigInfo name poly_id sig_tyvars sig_theta sig_tau sig_loc) = maybe_sig
-
- tysig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
+ tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
is_unrestricted = isUnRestrictedGroup tysig_names mbind
- kind = case is_rec of
- Recursive -> mkBoxedTypeKind -- Recursive, so no unboxed types
- NonRecursive -> mkTypeKind -- Non-recursive, so we permit unboxed types
+justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
+justPatBindings (AndMonoBinds b1 b2) binds =
+ justPatBindings b1 (justPatBindings b2 binds)
+justPatBindings other_bind binds = binds
\end{code}
Polymorphic recursion
Notice the the stupid construction of (f a d), which is of course
identical to the function we're executing. In this case, the
-polymorphic recursion ins't being used (but that's a very common case).
+polymorphic recursion isn't being used (but that's a very common case).
+We'd prefer
+
+ f = /\a -> \d::Eq a -> letrec
+ fm = \ys:[a] -> ...fm...
+ in
+ fm
-This can lead to a massive space leak, from the following top-level defn:
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
ff :: [Int] -> [Int]
- ff = f dEqInt
+ ff = f Int dEqInt
Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
f' is another thunk which evaluates to the same thing... and you end
up with a chain of identical values all hung onto by the CAF ff.
+ ff = f Int dEqInt
+
+ = let f' = f Int dEqInt in \ys. ...f'...
+
+ = let f' = let f' = f Int dEqInt in \ys. ...f'...
+ in \ys. ...f'...
+
+Etc.
Solution: when typechecking the RHSs we always have in hand the
*monomorphic* Ids for each binding. So we just need to make sure that
if (Method f a d) shows up in the constraints emerging from (...f...)
we just use the monomorphic Id. We achieve this by adding monomorphic Ids
-to the "givens" when simplifying constraints. Thats' what the "mono_lies"
+to the "givens" when simplifying constraints. That's what the "lies_avail"
is doing.
= tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
let
- tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusTyVarSet` free_tyvars
+ tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
in
if is_unrestricted
then
- returnNF_Tc (emptyTyVarSet, tyvars_to_gen)
+ returnNF_Tc (emptyVarSet, tyvars_to_gen)
else
-- This recover and discard-errs is to avoid duplicate error
-- messages; this, after all, is an "extra" call to tcSimplify
- recoverNF_Tc (returnNF_Tc (emptyTyVarSet, tyvars_to_gen)) $
+ recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen)) $
discardErrsTc $
tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
let
-- ASSERT: dicts_sig is already zonked!
- constrained_tyvars = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts
- reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
+ constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
+ reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
in
returnTc (constrained_tyvars, reduced_tyvars_to_gen)
\end{code}
\begin{code}
defaultUncommittedTyVar tyvar
- | isTypeKind (tyVarKind tyvar)
- = newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
- unifyTauTy (mkTyVarTy boxed_tyvar) (mkTyVarTy tyvar) `thenTc_`
+ | tyVarKind tyvar == openTypeKind
+ = newTcTyVar boxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
+ unifyTauTy (mkTyVarTy tyvar) (mkTyVarTy boxed_tyvar) `thenTc_`
returnTc boxed_tyvar
| otherwise
\begin{code}
tcMonoBinds :: RenamedMonoBinds
- -> [Name] -> [TcIdBndr s]
-> [TcSigInfo s]
- -> TcM s (TcMonoBinds s, LIE s)
-
-tcMonoBinds mbind binder_names mono_ids tc_ty_sigs
- = tcExtendLocalValEnv binder_names mono_ids (
- tc_mono_binds mbind
- )
+ -> RecFlag
+ -> TcM s (TcMonoBinds s,
+ LIE s, -- LIE required
+ [Name], -- Bound names
+ [TcIdBndr s]) -- Corresponding monomorphic bound things
+
+tcMonoBinds mbinds tc_ty_sigs is_rec
+ = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
+ let
+ tv_list = bagToList tvs
+ (names, mono_ids) = unzip (bagToList ids)
+ in
+ -- Don't know how to deal with pattern-bound existentials yet
+ checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
+ (existentialExplode mbinds) `thenTc_`
+
+ -- *Before* checking the RHSs, but *after* checking *all* the patterns,
+ -- extend the envt with bindings for all the bound ids;
+ -- and *then* override with the polymorphic Ids from the signatures
+ -- That is the whole point of the "complete_it" stuff.
+ tcExtendEnvWithPat ids (tcExtendEnvWithPat sig_ids
+ complete_it
+ ) `thenTc` \ (mbinds', lie_req_rhss) ->
+ returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
where
- sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
- sig_ids = [id | (TySigInfo _ id _ _ _ _) <- tc_ty_sigs]
-
- tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
-
- tc_mono_binds (AndMonoBinds mb1 mb2)
- = tc_mono_binds mb1 `thenTc` \ (mb1a, lie1) ->
- tc_mono_binds mb2 `thenTc` \ (mb2a, lie2) ->
- returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
-
- tc_mono_binds (FunMonoBind name inf matches locn)
- = tcAddSrcLoc locn $
- tcLookupLocalValueOK "tc_mono_binds" name `thenNF_Tc` \ id ->
-
- -- Before checking the RHS, extend the envt with
- -- bindings for the *polymorphic* Ids from any type signatures
- tcExtendLocalValEnv sig_names sig_ids $
- tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
-
- returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
-
- tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
- = tcAddSrcLoc locn $
- tcAddErrCtxt (patMonoBindsCtxt bind) $
- tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
-
- -- Before checking the RHS, but after the pattern, extend the envt with
- -- bindings for the *polymorphic* Ids from any type signatures
- tcExtendLocalValEnv sig_names sig_ids $
- tcGRHSsAndBinds pat_ty grhss_and_binds `thenTc` \ (grhss_and_binds2, lie) ->
- returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
- plusLIE lie_pat lie)
+ sig_fn name = case maybeSig tc_ty_sigs name of
+ Nothing -> Nothing
+ Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id
+
+ sig_ids = listToBag [(name,poly_id) | TySigInfo name poly_id _ _ _ _ _ _ <- tc_ty_sigs]
+
+ kind = case is_rec of
+ Recursive -> boxedTypeKind -- Recursive, so no unboxed types
+ NonRecursive -> openTypeKind -- Non-recursive, so we permit unboxed types
+
+ tc_mb_pats EmptyMonoBinds
+ = returnTc (returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+ tc_mb_pats (AndMonoBinds mb1 mb2)
+ = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
+ tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
+ let
+ complete_it = complete_it1 `thenTc` \ (mb1', lie1) ->
+ complete_it2 `thenTc` \ (mb2', lie2) ->
+ returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
+ in
+ returnTc (complete_it,
+ lie_req1 `plusLIE` lie_req2,
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2,
+ lie_avail1 `plusLIE` lie_avail2)
+
+ tc_mb_pats (FunMonoBind name inf matches locn)
+ = newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
+ tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
+ let
+ complete_it = tcAddSrcLoc locn $
+ tcMatchesFun name pat_ty matches `thenTc` \ (matches', lie) ->
+ returnTc (FunMonoBind (TcId bndr_id) inf matches' locn, lie)
+ in
+ returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
+
+ tc_mb_pats bind@(PatMonoBind pat grhss_and_binds locn)
+ = tcAddSrcLoc locn $
+ newTyVarTy kind `thenNF_Tc` \ pat_ty ->
+ tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+ let
+ complete_it = tcAddSrcLoc locn $
+ tcAddErrCtxt (patMonoBindsCtxt bind) $
+ tcGRHSsAndBinds grhss_and_binds pat_ty PatBindRhs `thenTc` \ (grhss_and_binds', lie) ->
+ returnTc (PatMonoBind pat' grhss_and_binds' locn, lie)
+ in
+ returnTc (complete_it, lie_req, tvs, ids, lie_avail)
\end{code}
%************************************************************************
%* *
%************************************************************************
-@tcSigs@ checks the signatures for validity, and returns a list of
-{\em freshly-instantiated} signatures. That is, the types are already
-split up, and have fresh type variables installed. All non-type-signature
-"RenamedSigs" are ignored.
-
-The @TcSigInfo@ contains @TcTypes@ because they are unified with
-the variable's type, and after that checked to see whether they've
-been instantiated.
-
-\begin{code}
-data TcSigInfo s
- = TySigInfo
- Name -- N, the Name in corresponding binding
- (TcIdBndr s) -- *Polymorphic* binder for this value...
- -- Usually has name = N, but doesn't have to.
- [TcTyVar s]
- (TcThetaType s)
- (TcTauType s)
- SrcLoc
-
-
-maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
- -- Search for a particular signature
-maybeSig [] name = Nothing
-maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name
- | name == sig_name = Just sig
- | otherwise = maybeSig sigs name
-\end{code}
-
-
-\begin{code}
-tcTySig :: RenamedSig
- -> TcM s (TcSigInfo s)
-
-tcTySig (Sig v ty src_loc)
- = tcAddSrcLoc src_loc $
- tcHsType ty `thenTc` \ sigma_ty ->
-
- -- Convert from Type to TcType
- tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty ->
- let
- poly_id = mkUserId v sigma_tc_ty
- in
- -- Instantiate this type
- -- It's important to do this even though in the error-free case
- -- we could just split the sigma_tc_ty (since the tyvars don't
- -- unified with anything). But in the case of an error, when
- -- the tyvars *do* get unified with something, we want to carry on
- -- typechecking the rest of the program with the function bound
- -- to a pristine type, namely sigma_tc_ty
- tcInstSigTcType sigma_tc_ty `thenNF_Tc` \ (tyvars, rho) ->
- let
- (theta, tau) = splitRhoTy rho
- -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
- -- wherever possible, which can improve interface files.
- in
- returnTc (TySigInfo v poly_id tyvars theta tau src_loc)
-\end{code}
-
@checkSigMatch@ does the next step in checking signature matching.
The tau-type part has already been unified. What we do here is to
check that this unification has not over-constrained the (polymorphic)
\begin{code}
checkSigMatch []
- = returnTc (error "checkSigMatch")
+ = returnTc (error "checkSigMatch", emptyLIE)
-checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _) : all_sigs_but_first )
+checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_but_first )
= -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
-- Doesn't affect substitution
mapTc check_one_sig tc_ty_sigs `thenTc_`
-- ToDo: amplify
mapTc check_one_cxt all_sigs_but_first `thenTc_`
- returnTc theta1
+ returnTc (theta1, sig_lie)
where
sig1_dict_tys = mk_dict_tys theta1
n_sig1_dict_tys = length sig1_dict_tys
+ sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- tc_ty_sigs]
- check_one_cxt sig@(TySigInfo _ id _ theta _ src_loc)
+ check_one_cxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (sigContextsCtxt id1 id) $
checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
where
this_sig_dict_tys = mk_dict_tys theta
- check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (sigCtxt id) $
- checkSigTyVars sig_tyvars sig_tau
+ check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxtM (sigCtxt (quotes (ppr id)) sig_tau) $
+ checkSigTyVars sig_tyvars
mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
\end{code}
-@checkSigTyVars@ is used after the type in a type signature has been unified with
-the actual type found. It then checks that the type variables of the type signature
-are
- (a) still all type variables
- eg matching signature [a] against inferred type [(p,q)]
- [then a will be unified to a non-type variable]
-
- (b) still all distinct
- eg matching signature [(a,b)] against inferred type [(p,p)]
- [then a and b will be unified together]
-
- (c) not mentioned in the environment
- eg the signature for f in this:
-
- g x = ... where
- f :: a->[a]
- f y = [x,y]
-
- Here, f is forced to be monorphic by the free occurence of x.
-
-Before doing this, the substitution is applied to the signature type variable.
-
-We used to have the notion of a "DontBind" type variable, which would
-only be bound to itself or nothing. Then points (a) and (b) were
-self-checking. But it gave rise to bogus consequential error messages.
-For example:
-
- f = (*) -- Monomorphic
-
- g :: Num a => a -> a
- g x = f x x
-
-Here, we get a complaint when checking the type signature for g,
-that g isn't polymorphic enough; but then we get another one when
-dealing with the (Num x) context arising from f's definition;
-we try to unify x with Int (to default it), but find that x has already
-been unified with the DontBind variable "a" from g's signature.
-This is really a problem with side-effecting unification; we'd like to
-undo g's effects when its type signature fails, but unification is done
-by side effect, so we can't (easily).
-
-So we revert to ordinary type variables for signatures, and try to
-give a helpful message in checkSigTyVars.
-
-\begin{code}
-checkSigTyVars :: [TcTyVar s] -- The original signature type variables
- -> TcType s -- signature type (for err msg)
- -> TcM s [TcTyVar s] -- Zonked signature type variables
-
-checkSigTyVars sig_tyvars sig_tau
- = mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys ->
- let
- sig_tyvars' = map (getTyVar "checkSigTyVars") sig_tys
- in
-
- -- Check points (a) and (b)
- checkTcM (all isTyVarTy sig_tys && hasNoDups sig_tyvars')
- (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' ->
- failWithTc (badMatchErr sig_tau sig_tau')
- ) `thenTc_`
-
- -- Check point (c)
- -- We want to report errors in terms of the original signature tyvars,
- -- ie sig_tyvars, NOT sig_tyvars'. sig_tyvars' correspond
- -- 1-1 with sig_tyvars, so we can just map back.
- tcGetGlobalTyVars `thenNF_Tc` \ globals ->
- let
- mono_tyvars' = [sig_tv' | sig_tv' <- sig_tyvars',
- sig_tv' `elementOfTyVarSet` globals]
-
- mono_tyvars = map (assoc "checkSigTyVars" (sig_tyvars' `zip` sig_tyvars)) mono_tyvars'
- in
- checkTcM (null mono_tyvars')
- (failWithTc (notAsPolyAsSigErr sig_tau mono_tyvars)) `thenTc_`
-
- returnTc sig_tyvars'
-\end{code}
-
-
%************************************************************************
%* *
\subsection{SPECIALIZE pragmas}
let
prag_fn name = foldr ($) noIdInfo [f | Just (n,f) <- maybe_info_modifiers, n==name]
in
- returnTc (prag_fn, andMonoBinds binds, plusLIEs lies)
+ returnTc (prag_fn, andMonoBindList binds, plusLIEs lies)
\end{code}
The interesting case is for SPECIALISE pragmas. There are two forms.
= returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
tcPragmaSig (NoInlineSig name loc)
- = returnTc (Just (name, setInlinePragInfo IDontWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
+ = returnTc (Just (name, setInlinePragInfo IMustNotBeINLINEd), EmptyMonoBinds, emptyLIE)
tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
= -- SPECIALISE f :: forall b. theta => tau = g
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsType poly_ty `thenTc` \ sig_sigma ->
- tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
+ tcHsTcType poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
-- Get the type of f, and find out what types
-- f has to be instantiated at to give the signature type
tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ f_id ->
- tcInstSigTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
+ tcInstTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
let
(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
(f_theta, f_tau) = splitRhoTy f_rho
- sig_tyvar_set = mkTyVarSet sig_tyvars
+ sig_tyvar_set = mkVarSet sig_tyvars
in
unifyTauTy sig_tau f_tau `thenTc_`
])
-----------------------------------------------
-sigCtxt id
- = sep [ptext SLIT("When checking the type signature for"), quotes (ppr id)]
+unboxedPatBindErr id
+ = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
+ <+> quotes (ppr id)
+-----------------------------------------------
bindSigsCtxt ids
= ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
-----------------------------------------------
-specGroundnessCtxt
- = panic "specGroundnessCtxt"
-
---------------------------------------------
-specContextGroundnessCtxt -- err_ctxt dicts
- = panic "specContextGroundnessCtxt"
-{-
- = hang (
- sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr name],
- hcat [ptext SLIT(" specialised to the type"), ppr spec_ty],
- pp_spec_id,
- ptext SLIT("... not all overloaded type variables were instantiated"),
- ptext SLIT("to ground types:")])
- 4 (vcat [hsep [ppr c, ppr t]
- | (c,t) <- map getDictClassAndType dicts])
- where
- (name, spec_ty, locn, pp_spec_id)
- = case err_ctxt of
- ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> empty)
- ValSpecSpecIdCtxt n ty spec loc ->
- (n, ty, loc,
- hsep [ptext SLIT("... type of explicit id"), ppr spec])
--}
+unliftedBindErr flavour mbind
+ = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))
+ 4 (ppr mbind)
+
+existentialExplode mbinds
+ = hang (vcat [text "My brain just exploded.",
+ text "I can't handle pattern bindings for existentially-quantified constructors.",
+ text "In the binding group"])
+ 4 (ppr mbinds)
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcClassDcl]{Typechecking class declarations}
#include "HsVersions.h"
import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
- InPat(..), HsBinds(..), GRHSsAndBinds(..), GRHS(..),
+ InPat(..), HsBinds(..), GRHSsAndBinds(..),
HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
- unguardedRHS, andMonoBinds, getTyVarName
+ unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName
)
import HsPragmas ( ClassPragmas(..) )
-import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
+import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
import RnHsSyn ( RenamedClassDecl, RenamedClassPragmas,
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedHsDecl, RenamedSig
tcLookupClass, tcLookupTyVar,
tcExtendGlobalTyVars, tcExtendLocalValEnv
)
-import TcBinds ( tcBindWithSigs, bindInstsOfLocalFuns,
- checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..)
- )
-import TcKind ( unifyKinds, TcKind )
+import TcBinds ( tcBindWithSigs, tcPragmaSigs )
+import TcUnify ( unifyKinds )
import TcMonad
-import TcMonoType ( tcHsType, tcContext )
-import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
- zonkSigTyVar, tcInstSigTcType
- )
+import TcMonoType ( tcHsType, tcContext, checkSigTyVars, sigCtxt, mkTcSig )
+import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
+import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr )
import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
import FieldLabel ( firstFieldLabelTag )
import Bag ( unionManyBags )
import Class ( mkClass, classBigSig, Class )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
-import MkId ( mkDataCon, mkSuperDictSelId,
+import MkId ( mkSuperDictSelId, mkDataConId,
mkMethodSelId, mkDefaultMethodId
)
-import Id ( Id, StrictnessMark(..),
+import DataCon ( mkDataCon )
+import Id ( Id,
getIdUnfolding, idType, idName
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
-import Name ( Name, isLocallyDefined, OccName, nameOccName,
- NamedThing(..) )
+import Name ( Name, isLocallyDefined, NamedThing(..) )
import Outputable
-import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
- mkSigmaTy, mkForAllTys, Type, ThetaType
+import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+ mkSigmaTy, mkForAllTys, Type, ThetaType,
+ boxedTypeKind, mkArrowKind
)
-import TyVar ( mkTyVarSet, tyVarKind, TyVar )
-import TyCon ( mkDataTyCon )
-import Kind ( mkBoxedTypeKind, mkArrowKind )
+import Var ( tyVarKind, TyVar )
+import VarSet ( mkVarSet )
+import TyCon ( mkAlgTyCon )
import Unique ( Unique, Uniquable(..) )
import Util
-import Maybes ( assocMaybe, maybeToBool, seqMaybe )
+import Maybes ( seqMaybe )
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
[_] -> NewType
other -> DataType
- dict_con_id = mkDataCon datacon_name
+ dict_con = mkDataCon datacon_name
[NotMarkedStrict | _ <- dict_component_tys]
[{- No labelled fields -}]
rec_tyvars
[{-No context-}]
[{-No existential tyvars-}] [{-Or context-}]
dict_component_tys
- tycon
+ tycon dict_con_id
+ dict_con_id = mkDataConId dict_con
- tycon = mkDataTyCon tycon_name
- (foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars)
+ tycon = mkAlgTyCon tycon_name
+ (foldr (mkArrowKind . tyVarKind) boxedTypeKind rec_tyvars)
rec_tyvars
[] -- No context
- [dict_con_id] -- Constructors
+ [dict_con] -- Constructors
[] -- No derivings
(Just clas) -- Yes! It's a dictionary
new_or_data
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
-- The selector binds are already in the selector Id's unfoldings
- sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
- | sel_id <- sc_sel_ids ++ op_sel_ids,
- isLocallyDefined sel_id
- ]
-
- final_sel_binds = andMonoBinds sel_binds
+-- sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
+-- | sel_id <- sc_sel_ids ++ op_sel_ids,
+-- isLocallyDefined sel_id
+-- ]
+--
+-- final_sel_binds = andMonoBindList sel_binds
in
-- Generate bindings for the default methods
tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
- returnTc (const_insts,
- final_sel_binds `AndMonoBinds` meth_binds)
+ returnTc (const_insts, meth_binds)
+-- final_sel_binds `AndMonoBinds` meth_binds)
+-- Leave 'em out for now. They always get inlined anyway. SLPJ June '98
\end{code}
%************************************************************************
tcDefaultMethodBinds clas default_binds
= -- Construct suitable signatures
- tcInstSigTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
+ tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
-- Typecheck the default bindings
let
avail_insts = this_dict
in
tcAddErrCtxt (classDeclCtxt clas) $
- mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
+
+ -- tcMethodBind has checked that the class_tyvars havn't
+ -- been unified with each other or another type, but we must
+ -- still zonk them
+ mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
+
tcSimplifyAndCheck
(ptext SLIT("class") <+> ppr clas)
- (mkTyVarSet clas_tyvars')
+ (mkVarSet clas_tyvars')
avail_insts
(unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
clas_tyvars'
[this_dict_id]
abs_bind_stuff
- (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
+ (dict_binds `andMonoBinds` andMonoBindList defm_binds)
in
returnTc (const_lie, full_binds)
tcMethodBind clas origin inst_tys inst_tyvars
meth_binds prags supply_default_bind
(sel_id, maybe_dm_id)
- | no_user_bind && not supply_default_bind
- = pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
-
- | otherwise
= tcGetSrcLoc `thenNF_Tc` \ loc ->
- -- Warn if no method binding, only if -fwarn-missing-methods
- warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
- (omittedMethodWarn sel_id clas) `thenNF_Tc_`
-
newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId meth_id) ->
- tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
+ mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
+
let
- (theta', tau') = splitRhoTy rho_ty'
+ meth_name = idName meth_id
+ maybe_user_bind = find_bind meth_name meth_binds
+
+ no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False}
+ no_user_default = case maybe_dm_id of {Nothing -> True; other -> False}
+
+ meth_bind = case maybe_user_bind of
+ Just bind -> bind
+ Nothing -> mk_default_bind meth_name loc
- meth_name = idName meth_id
- sig_info = TySigInfo meth_name meth_id tyvars' theta' tau' loc
- meth_bind = mk_meth_bind meth_name loc
meth_prags = find_prags meth_name prags
in
+
+ -- Warn if no method binding, only if -fwarn-missing-methods
+ if no_user_bind && not supply_default_bind then
+ pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
+ else
+ warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
+ (omittedMethodWarn sel_id clas) `thenNF_Tc_`
+
+ -- Check the pragmas
tcExtendLocalValEnv [meth_name] [meth_id] (
tcPragmaSigs meth_prags
) `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
- -- Check that the signatures match
- tcExtendGlobalTyVars inst_tyvars (
+ -- Check the bindings
+ tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
tcAddErrCtxt (methodCtxt sel_id) $
- tcBindWithSigs NotTopLevel [meth_name] meth_bind [sig_info]
+ tcBindWithSigs NotTopLevel meth_bind [sig_info]
NonRecursive prag_info_fn
) `thenTc` \ (binds, insts, _) ->
+
-- The prag_lie for a SPECIALISE pragma will mention the function
-- itself, so we have to simplify them away right now lest they float
-- outwards!
bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) ->
+
-- Now check that the instance type variables
-- (or, in the case of a class decl, the class tyvars)
-- have not been unified with anything in the environment
- tcAddErrCtxt (monoCtxt sel_id) (
- tcAddErrCtxt (sigCtxt sel_id) $
- checkSigTyVars inst_tyvars (idType meth_id)
- ) `thenTc_`
+ tcAddErrCtxtM (sigCtxt (quotes (ppr sel_id)) (idType meth_id)) (
+ checkSigTyVars inst_tyvars `thenTc_`
returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
insts `plusLIE` prag_lie',
- meth)
+ meth))
+
where
sel_name = idName sel_id
- maybe_user_bind = find meth_binds
-
- no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False}
- no_user_default = case maybe_dm_id of {Nothing -> True; other -> False}
-
- find EmptyMonoBinds = Nothing
- find (AndMonoBinds b1 b2) = find b1 `seqMaybe` find b2
- find b@(FunMonoBind op_name _ _ _) = if op_name == sel_name then Just b else Nothing
- find b@(PatMonoBind (VarPatIn op_name) _ _) = if op_name == sel_name then Just b else Nothing
- find other = panic "Urk! Bad instance method binding"
-
-- The renamer just puts the selector ID as the binder in the method binding
-- but we must use the method name; so we substitute it here. Crude but simple.
- mk_meth_bind meth_name loc
- = case maybe_user_bind of
- Just (FunMonoBind _ fix matches loc) -> FunMonoBind meth_name fix matches loc
- Just (PatMonoBind (VarPatIn _) rhs loc) -> PatMonoBind (VarPatIn meth_name) rhs loc
- Nothing -> mk_default_bind meth_name loc
+ find_bind meth_name (FunMonoBind op_name fix matches loc)
+ | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
+ find_bind meth_name (PatMonoBind (VarPatIn op_name) rhs loc)
+ | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) rhs loc)
+ find_bind meth_name (AndMonoBinds b1 b2)
+ = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
+ find_bind meth_name other = Nothing -- Default case
+
-- Find the prags for this method, and replace the
-- selector name with the method name
methodCtxt sel_id
= ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
-monoCtxt sel_id
- = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
- nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
- ]
-
badMethodErr bndr clas
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr bndr)]
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[TcDefaults]{Typechecking \tr{default} declarations}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcDeriv]{Deriving}
import TcMonad
import Inst ( InstanceMapper )
-import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
-import TcKind ( TcKind )
+import TcEnv ( getEnv_TyCons )
import TcGenDeriv -- Deriv stuff
-import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
+import TcInstUtil ( InstInfo(..), buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
import RnEnv ( newDfunName, bindLocatedLocalsRn )
-import RnMonad ( RnM, RnDown, SDown, RnNameSupply,
+import RnMonad ( RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
import ErrUtils ( ErrMsg )
import MkId ( mkDictFunId )
-import Id ( dataConArgTys, isNullaryDataCon )
+import Id ( mkVanillaId )
+import DataCon ( dataConArgTys, isNullaryDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
-import Name ( isLocallyDefined, getSrcLoc, Provenance,
- Name{--O only-}, Module, NamedThing(..),
+import Name ( isLocallyDefined, getSrcLoc,
+ Name, Module, NamedThing(..),
OccName, nameOccName
)
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
mkSigmaTy, mkDictTy, isUnboxedType,
splitAlgTyConApp
)
-import TysPrim ( voidTy )
-import TyVar ( GenTyVar, TyVar )
+import TysWiredIn ( voidTy )
+import Var ( TyVar )
import Unique -- Keys stuff
import Bag ( bagToList )
import Util ( zipWithEqual, sortLt, removeDups, assoc, thenCmp )
ddump_deriving inst_infos extra_binds
= vcat ((map pp_info inst_infos) ++ [ppr extra_binds])
where
- pp_info (InstInfo clas tvs [ty] inst_decl_theta _ _ mbinds _ _)
+ pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _)
= ($$) (ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty])))
(ppr mbinds)
\end{code}
let
local_data_tycons = filter (\tc -> isLocallyDefined tc && isAlgTyCon tc)
(getEnv_TyCons env)
- in
- if null local_data_tycons then
- -- Bale out now; evalClass may not be loaded if there aren't any
- returnTc []
- else
- tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
- let
- think_about_deriving = need_deriving eval_clas local_data_tycons
+
+ think_about_deriving = need_deriving local_data_tycons
(derive_these, _) = removeDups cmp_deriv think_about_deriving
eqns = map mk_eqn derive_these
in
+ if null local_data_tycons then
+ returnTc [] -- Bale out now
+ else
mapTc chk_out think_about_deriving `thenTc_`
returnTc eqns
where
------------------------------------------------------------------
- need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
+ need_deriving :: [TyCon] -> [(Class, TyCon)]
-- find the tycons that have `deriving' clauses;
- -- we handle the "every datatype in Eval" by
- -- doing a dummy "deriving" for it.
-
- need_deriving eval_clas tycons_to_consider
- = foldr ( \ tycon acc ->
- let
- acc_plus = if isLocallyDefined tycon
- then (eval_clas, tycon) : acc
- else acc
- in
- case (tyConDerivings tycon) of
- [] -> acc_plus
- cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
- )
+
+ need_deriving tycons_to_consider
+ = foldr (\ tycon acc -> [(clas,tycon) | clas <- tyConDerivings tycon] ++ acc)
[]
tycons_to_consider
-- to make the rest of the equation
mk_eqn (clas, tycon)
- = (clas, tycon, tyvars, if_not_Eval constraints)
+ = (clas, tycon, tyvars, constraints)
where
clas_key = classKey clas
tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
tyvar_tys = mkTyVarTys tyvars
data_cons = tyConDataCons tycon
- if_not_Eval cs = if clas_key == evalClassKey then [] else cs
-
constraints = extra_constraints ++ concat (map mk_constraints data_cons)
-- "extra_constraints": see notes above about contexts on data decls
mk_deriv_inst_info (clas, tycon, tyvars, _) theta
= InstInfo clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)]
theta
- (my_panic "dfun_theta")
-
dummy_dfun_id
-
(my_panic "binds") (getSrcLoc tycon)
(my_panic "upragmas")
where
dummy_dfun_id
- = mkDictFunId (getName tycon) dummy_dfun_ty bottom bottom
+ = mkVanillaId (getName tycon) dummy_dfun_ty
-- The name is getSrcLoc'd in an error message
- where
- bottom = panic "dummy_dfun_id"
dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
-- All we need from the dfun is its "theta" part, used during
-- (paired with class name, as we need that when generating dict
-- names.)
gen_bind :: InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
-gen_bind (InstInfo clas _ [ty] _ _ _ _ _ _)
+gen_bind (InstInfo clas _ [ty] _ _ _ _ _)
| not from_here
= (clas_nm, tycon_nm, EmptyMonoBinds)
| otherwise
[(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
- ,(evalClassKey, gen_Eval_binds)
,(boundedClassKey, gen_Bounded_binds)
,(showClassKey, gen_Show_binds)
,(readClassKey, gen_Read_binds)
-> InstInfo -- the gen'd (filled-in) "instance decl"
gen_inst_info modname
- (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds))
+ (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, (dfun_name, meth_binds))
=
-- Generate the various instance-related Ids
InstInfo clas tyvars tys inst_decl_theta
- dfun_theta dfun_id
+ dfun_id
meth_binds
locn []
where
- (dfun_id, dfun_theta) = mkInstanceRelatedIds
- dfun_name
- clas tyvars tys
- inst_decl_theta
+ dfun_id = mkDictFunId dfun_name clas tyvars tys inst_decl_theta
from_here = isLocallyDefined tycon
(tycon,_,_) = splitAlgTyConApp ty
foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
foldlTc do_tag2con names_so_far tycons_of_interest
where
- all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _ _) <- inst_infos ]
+ all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _) <- inst_infos ]
get_tycon ty = case splitAlgTyConApp ty of { (tc, _, _) -> tc }
--- /dev/null
+__interface TcEnv 1 0 where
+__export TcEnv TcEnv;
+1 data TcEnv a;
\begin{code}
module TcEnv(
- TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
+ TcIdOcc(..), TcIdBndr, TcIdSet, tcIdType, tcIdTyVars, tcInstId,
+ tcLookupDataCon,
TcEnv, GlobalValueEnv,
- initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
+ initEnv, getEnv_TyCons, getEnv_Classes,
- tcExtendTyVarEnv, tcLookupTyVar,
+ tcExtendTyVarEnv, tcLookupTyVar, tcLookupTyVarBndrs,
tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey,
tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
tcGetTyConsAndClasses,
- tcExtendGlobalValEnv, tcExtendLocalValEnv, tcGetGlobalValEnv, tcSetGlobalValEnv,
+ tcExtendGlobalValEnv, tcExtendLocalValEnv, tcExtendEnvWithPat,
+ tcGetGlobalValEnv, tcSetGlobalValEnv, lookupGlobalByKey,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
tcAddImportedIdInfo, tcExplicitLookupGlobal,
tcLookupGlobalValueByKeyMaybe,
- newMonoIds, newLocalIds, newLocalId, newSpecPragmaId,
- tcGetGlobalTyVars, tcExtendGlobalTyVars
+ newLocalIds, newLocalId, newSpecPragmaId,
+ tcGetGlobalTyVars, tcExtendGlobalTyVars,
+
+ tidyType, tidyTypes, tidyTyVar,
+
+ badCon, badPrimOp
) where
#include "HsVersions.h"
-import MkId ( mkUserLocal, mkUserId, mkSpecPragmaId )
-import Id ( Id, GenId, idType, replaceIdInfo, idInfo )
-import TcKind ( TcKind, kindToTcKind, Kind )
-import TcType ( TcType, TcMaybe, TcTyVar, TcTyVarSet, TcThetaType,
- newTyVarTys, tcInstTyVars, zonkTcTyVars, tcInstType
+import HsTypes ( getTyVarName )
+import Id ( mkUserLocal, isDataConId_maybe )
+import MkId ( mkSpecPragmaId )
+import Var ( TyVar, Id, GenId, setVarName,
+ idType, setIdInfo, idInfo
+ )
+import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType, TcBox,
+ tcInstTyVars, zonkTcTyVars,
+ TcKind, kindToTcKind
)
-import TyVar ( mkTyVarSet, unionTyVarSets, emptyTyVarSet, TyVar )
-import Type ( tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy )
-import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon, Arity )
+import VarEnv
+import VarSet
+import Type ( Kind,
+ tyVarsOfType, tyVarsOfTypes, mkTyVarTy, substTy,
+ splitForAllTys, splitRhoTy, splitFunTys, substFlexiTy,
+ splitAlgTyConApp_maybe, getTyVar
+ )
+import DataCon ( DataCon )
+import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
import Class ( Class )
import TcMonad
+import BasicTypes ( Arity )
import IdInfo ( noIdInfo )
-import Name ( Name, OccName(..), nameOccName,
+import Name ( Name, OccName(..), nameOccName, occNameString, mkLocalName,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
+ isSysLocalName,
NamedThing(..)
)
-import Unique ( pprUnique10{-, pprUnique ToDo:rm-}, Unique, Uniquable(..) )
-import UniqFM
-import Util ( zipEqual, zipWithEqual, zipWith3Equal )
+import Unique ( pprUnique10, Unique, Uniquable(..) )
+import FiniteMap ( lookupFM, addToFM )
+import UniqFM
+import Unique ( Uniquable(..) )
+import Util ( zipEqual, zipWith3Equal, mapAccumL )
+import Bag ( bagToList )
import Maybes ( maybeToBool )
import Outputable
\end{code}
\begin{code}
-type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes
+type TcIdBndr s = GenId (TcBox s) -- Binders are all TcTypes
data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either
| RealId Id
+type TcIdSet s = GenIdSet (TcBox s)
+
instance Eq (TcIdOcc s) where
(TcId id1) == (TcId id2) = id1 == id2
(RealId id1) == (RealId id2) = id1 == id2
tcIdType (RealId id) = pprPanic "tcIdType:" (ppr id)
tcIdTyVars (TcId id) = tyVarsOfType (idType id)
-tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables
+tcIdTyVars (RealId _) = emptyVarSet -- Top level Ids have no free type variables
+tcLookupDataCon :: Name -> TcM s (DataCon, [TcType s], TcType s)
+tcLookupDataCon con_name
+ = tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
+ case isDataConId_maybe con_id of {
+ Nothing -> failWithTc (badCon con_id);
+ Just data_con ->
+
+ tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
+ -- Ignore the con_theta; overloaded constructors only
+ -- behave differently when called, not when used for
+ -- matching.
+ let
+ (arg_tys, result_ty) = splitFunTys con_tau
+ in
+ ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
+ returnTc (data_con, arg_tys, result_ty) }
+
-- A useful function that takes an occurrence of a global thing
-- and instantiates its type with fresh type variables
tcInstId :: Id
(tyvars, rho) = splitForAllTys (idType id)
in
tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
- tcInstType tenv rho `thenNF_Tc` \ rho' ->
let
- (theta', tau') = splitRhoTy rho'
+ rho' = substFlexiTy tenv rho
+ (theta', tau') = splitRhoTy rho'
in
returnNF_Tc (tyvars', theta', tau')
\end{code}
+tidyTy tidies up a type for printing in an error message.
+
+\begin{code}
+tidyType :: TidyTypeEnv s -> TcType s -> (TidyTypeEnv s, TcType s)
+tidyType env ty
+ = (env', substTy subst' ty)
+ where
+ env'@(_, subst') = foldl go env (varSetElems (tyVarsOfType ty))
+ go env tyvar = fst (tidyTyVar env tyvar)
+
+tidyTypes :: TidyTypeEnv s -> [TcType s] -> (TidyTypeEnv s, [TcType s])
+tidyTypes env tys = mapAccumL tidyType env tys
+
+tidyTyVar :: TidyTypeEnv s -> TcTyVar s -> (TidyTypeEnv s, TcTyVar s)
+tidyTyVar (supply,subst) tyvar
+ = case lookupVarEnv subst tyvar of
+ Just ty -> -- Already substituted
+ ((supply,subst), getTyVar "tidyTyVar" ty)
+ Nothing -> -- Make a new nice name for it
+ ((addToFM supply str next,
+ extendVarEnv subst tyvar (mkTyVarTy new_tyvar)),
+ new_tyvar)
+ where
+ tyvar_name = getName tyvar
+ is_sys = isSysLocalName tyvar_name
+
+ str | is_sys = SLIT("$")
+ | otherwise = occNameString (nameOccName tyvar_name)
+
+ next = case lookupFM supply str of
+ Nothing -> 0
+ Just n -> n+1
+
+ new_tyvar = mkNewTv str is_sys next tyvar
+
+mkNewTv :: FastString -> Bool -> Int -> TcTyVar s -> TcTyVar s
+mkNewTv str False 0 tv = tv -- Leave first non-sys thing alone
+mkNewTv str is_sys n tv = setVarName tv (mkLocalName (getUnique tv)
+ (TvOcc (_PK_ ((_UNPK_ str) ++ show n))))
+\end{code}
+
%************************************************************************
%* *
\begin{code}
data TcEnv s = TcEnv
- (TyVarEnv s)
+ (TcTyVarEnv s)
(TyConEnv s)
(ClassEnv s)
GlobalValueEnv
(TcRef s (TcTyVarSet s)) -- Free type variables of locals
-- ...why mutable? see notes with tcGetGlobalTyVars
-type TyVarEnv s = UniqFM (TcKind s, TyVar)
-type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Synonyms only
-type ClassEnv s = UniqFM ([TcKind s], Class) -- The kinds are the kinds of the args
+type TcTyVarEnv s = UniqFM (TcKind s, TyVar)
+type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Synonyms only
+type ClassEnv s = UniqFM ([TcKind s], Class) -- The kinds are the kinds of the args
-- to the class
type ValueEnv id = UniqFM id
type GlobalValueEnv = ValueEnv Id -- Globals
initEnv :: TcRef s (TcTyVarSet s) -> TcEnv s
initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
-getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls
getEnv_TyCons (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
getEnv_Classes (TcEnv _ _ cs _ _ _) = [clas | (_, clas) <- eltsUFM cs]
\end{code}
Looking up in the environments.
\begin{code}
+tcLookupTyVarBndrs tyvar_bndrs -- [HsTyVar name]
+ = mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_bndrs
+
tcLookupTyVar name
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr name)) name)
tcExtendGlobalValEnv ids scope
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
- gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
+ gve' = addListToUFM_Directly gve [(getUnique id, id) | id <- ids]
in
tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
let
lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
extra_global_tyvars = tyVarsOfTypes (map idType ids)
- new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tyvars
+ new_global_tyvars = global_tvs `unionVarSet` extra_global_tyvars
+ in
+ tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
+
+ tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
+
+tcExtendEnvWithPat names_w_ids scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
+ let
+ names_w_ids_list = bagToList names_w_ids
+ lve' = addListToUFM lve names_w_ids_list
+ extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids_list)
+ new_global_tyvars = global_tvs `unionVarSet` extra_global_tyvars
in
tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
\begin{code}
tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
tcGetGlobalTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
- zonkTcTyVars global_tvs `thenNF_Tc` \ global_tvs' ->
- tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
+ zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
+ let
+ global_tvs' = (tyVarsOfTypes global_tys')
+ in
+ tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
returnNF_Tc global_tvs'
tcExtendGlobalTyVars extra_global_tvs scope
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
let
- new_global_tyvars = global_tvs `unionTyVarSets` mkTyVarSet extra_global_tvs
+ new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
in
tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
tcLookupGlobalValueByKey uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
+ returnNF_Tc (lookupGlobalByKey gve uniq)
+
+lookupGlobalByKey :: GlobalValueEnv -> Unique -> Id
+lookupGlobalByKey gve uniq
+ = lookupWithDefaultUFM_Directly gve def uniq
where
#ifdef DEBUG
def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq)
-- have explicit local definitions, so we get a black hole!
= id
| otherwise
- = id `replaceIdInfo` new_info
+ = id `setIdInfo` new_info
-- The Id must be returned without a data dependency on maybe_id
where
new_info = -- pprTrace "tcAdd" (ppr id) $
~~~~~~~~~~~~~~~~~~~~
\begin{code}
--- Uses the Name as the Name of the Id
-newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
-
-newMonoIds names kind m
- = newTyVarTys no_of_names kind `thenNF_Tc` \ tys ->
- let
- new_ids = zipWithEqual "newMonoIds" mk_id names tys
- mk_id name ty = mkUserId name ty
- in
- tcExtendLocalValEnv names new_ids (m new_ids)
- where
- no_of_names = length names
-
newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
newLocalId name ty
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkUserLocal name uniq ty loc)
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (mkUserLocal name uniq ty)
newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
newLocalIds names tys
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
+ = tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
let
new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys
- mk_id name uniq ty = mkUserLocal name uniq ty loc
+ mk_id name uniq ty = mkUserLocal name uniq ty
in
returnNF_Tc new_ids
newSpecPragmaId :: Name -> TcType s -> NF_TcM s (TcIdBndr s)
newSpecPragmaId name ty
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty loc)
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty)
\end{code}
tyConAsClassErr name
= ptext SLIT("Type constructor used as a class:") <+> ppr name
+
+badCon con_id
+ = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
+badPrimOp op
+ = quotes (ppr op) <+> ptext SLIT("is not a primop")
\end{code}
_declarations_
1 tcExpr _:_ _forall_ [s] =>
RnHsSyn.RenamedHsExpr
- -> TcType.TcType s
+ -> TcMonad.TcType s
-> TcMonad.TcM s (TcHsSyn.TcExpr s, Inst.LIE s) ;;
--- /dev/null
+__interface TcExpr 1 0 where
+__export TcExpr tcExpr ;
+1 tcExpr :: __forall [_s] =>
+ RnHsSyn.RenamedHsExpr
+ -> TcMonad.TcType _s
+ -> TcMonad.TcM _s (TcHsSyn.TcExpr _s, Inst.LIE _s) ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcExpr]{Typecheck an expression}
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), DoOrListComp(..),
- failureFreePat, collectPatBinders
+ HsBinds(..), Stmt(..), StmtCtxt(..),
+ failureFreePat
)
-import RnHsSyn ( RenamedHsExpr,
- RenamedStmt, RenamedRecordBinds
- )
-import TcHsSyn ( TcExpr, TcStmt,
- TcRecordBinds,
+import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
+import TcHsSyn ( TcExpr, TcRecordBinds,
mkHsTyApp
)
import BasicTypes ( RecFlag(..) )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
- LIE, emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
- newMethod, newMethodWithGivenTy, newDicts )
-import TcBinds ( tcBindsAndThen, checkSigTyVars )
-import TcEnv ( TcIdOcc(..), tcInstId,
+ LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
+ newMethod, newMethodWithGivenTy, newDicts, instToId )
+import TcBinds ( tcBindsAndThen )
+import TcEnv ( TcIdOcc(..), tcInstId, tidyType,
tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
- tcLookupGlobalValueByKey, newMonoIds,
+ tcLookupGlobalValueByKey,
tcExtendGlobalTyVars, tcLookupGlobalValueMaybe,
- tcLookupTyCon
+ tcLookupTyCon, tcLookupDataCon
)
import TcMatches ( tcMatchesCase, tcMatchExpected )
-import TcGRHSs ( tcStmt )
-import TcMonoType ( tcHsType )
-import TcPat ( tcPat, badFieldsCon )
+import TcGRHSs ( tcStmts )
+import TcMonoType ( tcHsTcType, checkSigTyVars, sigCtxt )
+import TcPat ( badFieldCon )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( TcType, TcTauType, TcMaybe(..),
- tcInstType, tcInstSigTcType, tcInstTyVars,
- tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy,
- newTyVarTy, newTyVarTys, zonkTcType )
-import TcKind ( TcKind )
+ tcInstTyVars,
+ tcInstTcType, tcSplitRhoTy,
+ newTyVarTy, zonkTcType )
import Class ( Class )
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
-import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
+import Id ( idType, recordSelectorFieldLabel,
isRecordSelector,
Id
)
-import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
-import Name ( Name{-instance Eq-} )
+import DataCon ( dataConFieldLabels, dataConSig, dataConId )
+import Name ( Name )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
splitFunTy_maybe, splitFunTys,
mkTyConApp,
- splitForAllTys, splitRhoTy, splitSigmaTy,
+ splitForAllTys, splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
- isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe
- )
-import TyVar ( emptyTyVarEnv, zipTyVarEnv,
- elementOfTyVarSet, mkTyVarSet, tyVarSetToList
+ isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
+ boxedTypeKind, openTypeKind, mkArrowKind,
+ substFlexiTheta
)
+import VarEnv ( zipVarEnv )
+import VarSet ( elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
floatPrimTy, addrPrimTy
)
import TysWiredIn ( boolTy, charTy, stringTy )
import PrelInfo ( ioTyCon_NAME )
-import Unify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
-import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
+import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
+ unifyUnboxedTupleTy )
+import Unique ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
-- To ensure that the forall'd type variables don't get unified with each
-- other or any other types, we make fresh copy of the alleged type
- tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
+ tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
let
(sig_theta, sig_tau) = splitRhoTy sig_rho
in
-- Type-check the arg and unify with expected type
- tcExtendGlobalTyVars sig_tyvars (
+ tcExtendGlobalTyVars (mkVarSet sig_tyvars) (
tcMonoExpr arg sig_tau
) `thenTc` \ (arg', lie_arg) ->
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
- tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
+ tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
+ tcAddErrCtxtM (sigCtxt (text "an expression") sig_tau) $
+
+ checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars ->
- checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars ->
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
-- ToDo: better origin
-
tcSimplifyAndCheck
(text "tcPolyExpr")
- (mkTyVarSet zonked_sig_tyvars)
- sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
+ (mkVarSet zonked_sig_tyvars)
+ sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
let
-- This HsLet binds any Insts which came out of the simplification.
= tcMonoExpr (HsApp neg expr) res_ty
tcMonoExpr (HsLam match) res_ty
- = tcMatchExpected [] res_ty match `thenTc` \ (match',lie) ->
+ = tcMatchExpected match res_ty LambdaBody `thenTc` \ (match',lie) ->
returnTc (HsLam match', lie)
tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
-
let
new_arg_dict (arg, arg_ty)
= newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
in
-- Arguments
- mapNF_Tc (\ _ -> newTyVarTy mkTypeKind) [1..(length args)] `thenNF_Tc` \ ty_vars ->
- tcMonoExprs args ty_vars `thenTc` \ (args', args_lie) ->
+ mapNF_Tc (\ _ -> newTyVarTy openTypeKind)
+ [1..(length args)] `thenNF_Tc` \ ty_vars ->
+ tcMonoExprs args ty_vars `thenTc` \ (args', args_lie) ->
-- The argument types can be unboxed or boxed; the result
-- type must, however, be boxed since it's an argument to the IO
-- type constructor.
- newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
let
io_result_ty = mkTyConApp ioTyCon [result_ty]
+ [ioDataCon] = tyConDataCons ioTyCon
in
unifyTauTy res_ty io_result_ty `thenTc_`
mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
- case tyConDataCons ioTyCon of { [ioDataCon] ->
- returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty])
- (CCall lbl args' may_gc is_asm io_result_ty),
+ returnTc (HsApp (HsVar (RealId (dataConId ioDataCon)) `TyApp` [result_ty])
+ (CCall lbl args' may_gc is_asm result_ty),
-- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
- }
\end{code}
\begin{code}
= tcAddErrCtxt (listCtxt expr) $
tcMonoExpr expr elt_ty
-tcMonoExpr (ExplicitTuple exprs) res_ty
- = unifyTupleTy (length exprs) res_ty `thenTc` \ arg_tys ->
+tcMonoExpr (ExplicitTuple exprs boxed) res_ty
+ = (if boxed
+ then unifyTupleTy (length exprs) res_ty
+ else unifyUnboxedTupleTy (length exprs) res_ty
+ ) `thenTc` \ arg_tys ->
mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
(exprs `zip` arg_tys) -- we know they're of equal length.
- `thenTc` \ (exprs', lies) ->
- returnTc (ExplicitTuple exprs', plusLIEs lies)
+ `thenTc` \ (exprs', lies) ->
+ returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
-tcMonoExpr (RecordCon con_name _ rbinds) res_ty
- = tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
- tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
+tcMonoExpr (RecordCon con_name rbinds) res_ty
+ = tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
(_, record_ty) = splitFunTys con_tau
in
unifyTauTy res_ty record_ty `thenTc_`
-- Check that the record bindings match the constructor
+ tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
let
- bad_fields = badFields rbinds con_id
+ bad_fields = badFields rbinds data_con
in
- checkTc (null bad_fields) (badFieldsCon con_name bad_fields) `thenTc_`
+ mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
-- Typecheck the record bindings
-- (Do this after checkRecordFields in case there's a field that
-- doesn't match the constructor.)
tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
- returnTc (RecordCon (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie)
+ returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
-- The main complication with RecordUpd is that we need to explicitly
common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
mk_inst_ty (tyvar, result_inst_ty)
- | tyvar `elementOfTyVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
- | otherwise = newTyVarTy mkBoxedTypeKind -- Fresh type
+ | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
+ | otherwise = newTyVarTy boxedTypeKind -- Fresh type
in
mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
-- union the ones that could participate in the update.
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
- inst_env = zipTyVarEnv tyvars result_inst_tys
+ inst_env = zipVarEnv tyvars result_inst_tys
+ theta' = substFlexiTheta inst_env theta
in
- tcInstTheta inst_env theta `thenNF_Tc` \ theta' ->
newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
-- Phew!
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
= tcSetErrCtxt (exprSigCtxt in_expr) $
- tcHsType poly_ty `thenTc` \ sig_ty ->
- tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty ->
+ tcHsTcType poly_ty `thenTc` \ sig_tc_ty ->
if not (isForAllTy sig_tc_ty) then
-- Easy case
= case id_expr of
HsVar name -> tcId name `thenNF_Tc` \ stuff ->
returnTc stuff
- other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty ->
+ other -> newTyVarTy openTypeKind `thenNF_Tc` \ id_ty ->
tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
returnTc (id_expr', lie_id, id_ty)
\end{code}
-- If an error happens we try to figure out whether the
-- function has been given too many or too few arguments,
-- and say so
-checkArgsCtxt fun args expected_res_ty actual_res_ty
+checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
= zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
let
- (exp_args, _) = splitFunTys exp_ty'
- (act_args, _) = splitFunTys act_ty'
+ (env1, exp_ty'') = tidyType tidy_env exp_ty'
+ (env2, act_ty'') = tidyType env1 act_ty'
+ (exp_args, _) = splitFunTys exp_ty''
+ (act_args, _) = splitFunTys act_ty''
+
message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
| length exp_args > length act_args = wrongArgsCtxt "too many" fun args
| otherwise = appCtxt fun args
in
- returnNF_Tc message
+ returnNF_Tc (env2, message)
split_fun_ty :: TcType s -- The type of the function
case maybe_local of
Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
- Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
- tcInstType emptyTyVarEnv (idType id) `thenNF_Tc` \ inst_ty ->
- let
- (tyvars, rho) = splitForAllTys inst_ty
- in
- instantiate_it2 (RealId id) tyvars rho
+ Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
+ instantiate_it2 (RealId id) tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
-- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
instantiate_it tc_id_occ ty
= tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
- instantiate_it2 tc_id_occ tyvars rho
+ tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
+ instantiate_it2 tc_id_occ tyvars theta tau
- instantiate_it2 tc_id_occ tyvars rho
- = tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
- if null theta then -- Is it overloaded?
+ instantiate_it2 tc_id_occ tyvars theta tau
+ = if null theta then -- Is it overloaded?
returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
else
-- Yes, it's overloaded
newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys theta tau `thenNF_Tc` \ (lie1, meth_id) ->
- instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
- returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
+ tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
+ instantiate_it (instToId inst) tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
where
arg_tys = mkTyVarTys tyvars
-- create type consisting of a fresh monad tyvar
ASSERT( not (null stmts) )
tcAddSrcLoc src_loc $
- newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
- let
- tc_stmts [] = returnTc (([], error "tc_stmts"), emptyLIE)
- tc_stmts (stmt:stmts) = tcStmt do_or_lc (mkAppTy m) combine_stmts stmt $
- tc_stmts stmts
-
- combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
- combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
- combine_stmts stmt _ ([], _) = panic "Bad last stmt tcDoStmts"
- combine_stmts stmt _ (stmts, ty) = (stmt:stmts, ty)
- in
- tc_stmts stmts `thenTc` \ ((stmts', result_ty), final_lie) ->
- unifyTauTy res_ty result_ty `thenTc_`
+ newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
+ unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
+
+ tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
failure_free other_stmt = True
in
returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
- final_lie `plusLIE` monad_lie)
-
+ stmts_lie `plusLIE` monad_lie)
\end{code}
4 (quotes (ppr arg))
wrongArgsCtxt too_many_or_few fun args
- = hang (ptext SLIT("Probable cause:") <+> ppr fun
+ = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
<+> ptext SLIT("is applied to") <+> text too_many_or_few
<+> ptext SLIT("arguments in the call"))
4 (parens (ppr the_app))
import TcMonad
import TcEnv ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue )
-import TcType ( tcInstTcType, tcInstSigType, tcSplitRhoTy, zonkTcTypeToType )
+import TcType ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
import TcMonoType ( tcHsType )
import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..),
TcForeignExportDecl )
import CoreSyn
import ErrUtils ( Message )
-import Id ( Id, idName )
+import Id ( Id, idName, mkUserId )
import Name ( nameOccName )
-import MkId ( mkUserId )
-import Type ( isUnpointedType
- , splitFunTys
+import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
, splitRhoTy
, isForAllTy
, mkForAllTys
)
-import TyVar ( emptyTyVarEnv )
-
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
isFFIExternalTy, isAddrTy
)
import Type ( Type )
import Unique
-import Unify ( unifyTauTy )
import Outputable
import Util
import CmdLineOpts ( opt_GlasgowExts )
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsType hs_ty `thenTc` \ sig_ty ->
- tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty ->
- tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
+ tcHsType hs_ty `thenTc` \ sig_ty ->
+ let sig_tc_ty = typeToTcType sig_ty in
+ tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
let
-- drop the foralls before inspecting the structure
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
-- Check that the type has the form
--- (IO t) and that t satisfies the given predicate.
+-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignRes :: (Type -> Bool) -> Type -> TcM s ()
checkForeignRes pred_res_ty ty =
case (splitTyConApp_maybe ty) of
Just (io, [res_ty])
- | (uniqueOf io) == ioTyConKey &&
- pred_res_ty res_ty
+ | (getUnique io) == ioTyConKey && pred_res_ty res_ty
-> returnTc ()
- _ | pred_res_ty ty -> returnTc ()
- | otherwise -> check False (illegalForeignTyErr False{-Res-} ty)
+ _
+ | pred_res_ty ty -> returnTc ()
+ | otherwise -> check False (illegalForeignTyErr False{-Res-} ty)
\end{code}
\begin{code}
illegalForeignTyErr isArg ty
- = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")])
- 4 (hsep [ ptext SLIT("type:"), ppr ty])
+ = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
+ 4 (hsep [ppr ty])
where
arg_or_res
| isArg = ptext SLIT("argument")
| otherwise = ptext SLIT("result")
foreignDeclCtxt fo =
- hang (ptext SLIT("When checking a foreign declaration:"))
+ hang (ptext SLIT("When checking declaration:"))
4 (ppr fo)
\end{code}
TcGRHSs tcGRHSsAndBinds;
_declarations_
2 tcGRHSsAndBinds _:_ _forall_ [s] =>
- TcType.TcType s
- -> RnHsSyn.RenamedGRHSsAndBinds
+ RnHsSyn.RenamedGRHSsAndBinds
+ -> TcMonad.TcType s
+ -> HsExpr.StmtCtxt
-> TcMonad.TcM s (TcHsSyn.TcGRHSsAndBinds s, Inst.LIE s) ;;
--- /dev/null
+__interface TcGRHSs 2 0 where
+__export TcGRHSs tcGRHSsAndBinds;
+2 tcGRHSsAndBinds :: __forall [_s] =>
+ RnHsSyn.RenamedGRHSsAndBinds
+ -> TcMonad.TcType _s
+ -> HsExpr.StmtCtxt
+ -> TcMonad.TcM _s (TcHsSyn.TcGRHSsAndBinds _s, Inst.LIE _s) ;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcGRHSs]{Typecheck guarded right-hand-sides}
\begin{code}
-module TcGRHSs ( tcGRHSsAndBinds, tcStmt ) where
+module TcGRHSs ( tcGRHSsAndBinds, tcStmts ) where
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcExpr )
-import HsSyn ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..),
- Stmt(..),
- collectPatBinders
+import HsSyn ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), StmtCtxt(..),
+ Stmt(..)
)
import RnHsSyn ( RenamedGRHSsAndBinds, RenamedGRHS, RenamedStmt )
import TcHsSyn ( TcGRHSsAndBinds, TcGRHS, TcStmt )
+import TcEnv ( tcExtendGlobalTyVars, tcExtendEnvWithPat )
import TcMonad
-import Inst ( Inst, LIE, plusLIE )
+import Inst ( LIE, plusLIE )
import TcBinds ( tcBindsAndThen )
+import TcSimplify ( tcSimplifyAndCheck )
import TcPat ( tcPat )
+import TcMonoType ( checkSigTyVars, noSigs, existentialPatCtxt )
import TcType ( TcType, newTyVarTy )
-import TcEnv ( newMonoIds )
import TysWiredIn ( boolTy )
-import Kind ( mkTypeKind, mkBoxedTypeKind )
+import Type ( tyVarsOfType, openTypeKind, boxedTypeKind )
+import BasicTypes ( RecFlag(..) )
+import VarSet
+import Bag
import Outputable
\end{code}
%************************************************************************
\begin{code}
-tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
+tcGRHSs :: [RenamedGRHS] -> TcType s -> StmtCtxt -> TcM s ([TcGRHS s], LIE s)
-tcGRHSs expected_ty [grhs]
- = tcGRHS expected_ty grhs `thenTc` \ (grhs', lie) ->
+tcGRHSs [grhs] expected_ty ctxt
+ = tcGRHS grhs expected_ty ctxt `thenTc` \ (grhs', lie) ->
returnTc ([grhs'], lie)
-tcGRHSs expected_ty (grhs:grhss)
- = tcGRHS expected_ty grhs `thenTc` \ (grhs', lie1) ->
- tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie2) ->
+tcGRHSs (grhs:grhss) expected_ty ctxt
+ = tcGRHS grhs expected_ty ctxt `thenTc` \ (grhs', lie1) ->
+ tcGRHSs grhss expected_ty ctxt `thenTc` \ (grhss', lie2) ->
returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
-tcGRHS expected_ty (GRHS guard expr locn)
- = tcAddSrcLoc locn $
- tcStmts guard `thenTc` \ ((guard', expr'), lie) ->
- returnTc (GRHS guard' expr' locn, lie)
- where
- tcStmts [] = tcExpr expr expected_ty `thenTc` \ (expr2, expr_lie) ->
- returnTc (([], expr2), expr_lie)
- tcStmts (stmt:stmts) = tcStmt Guard (\x->x) combine stmt $
- tcStmts stmts
-
- combine stmt _ (stmts, expr) = (stmt:stmts, expr)
+tcGRHS (GRHS guarded locn) expected_ty ctxt
+ = tcAddSrcLoc locn $
+ tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
+ returnTc (GRHS guarded' locn, lie)
\end{code}
pieces.
\begin{code}
-tcGRHSsAndBinds :: TcType s -- Expected type of RHSs
- -> RenamedGRHSsAndBinds
+tcGRHSsAndBinds :: RenamedGRHSsAndBinds
+ -> TcType s -- Expected type of RHSs
+ -> StmtCtxt
-> TcM s (TcGRHSsAndBinds s, LIE s)
--- Shortcut for common case
-tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss EmptyBinds)
- = tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie) ->
- returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
-
-tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
+tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds) expected_ty ctxt
= tcBindsAndThen
combiner binds
- (tcGRHSs expected_ty grhss)
+ (tcGRHSs grhss expected_ty ctxt `thenTc` \ (grhss, lie) ->
+ returnTc (GRHSsAndBindsOut grhss EmptyBinds expected_ty, lie))
where
- combiner is_rec binds grhss
- = GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty
+ combiner is_rec mbinds (GRHSsAndBindsOut grhss binds expected_ty)
+ = GRHSsAndBindsOut grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) expected_ty
\end{code}
\begin{code}
-tcStmt :: DoOrListComp
- -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
- -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
- -> RenamedStmt
- -> TcM s (thing, LIE s)
- -> TcM s (thing, LIE s)
-
-tcStmt do_or_lc m combine stmt@(ReturnStmt exp) do_next
- = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
- tcExpr exp exp_ty `thenTc` \ (exp', exp_lie) ->
- returnTc (ReturnStmt exp', exp_lie, m exp_ty)
- ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' (Just stmt_ty) thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
- = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
- newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
+tcStmts :: StmtCtxt
+ -> (TcType s -> TcType s) -- m, the relationship type of pat and rhs in pat <- rhs
+ -> [RenamedStmt]
+ -> TcType s -- elt_ty, where type of the comprehension is (m elt_ty)
+ -> TcM s ([TcStmt s], LIE s)
+
+tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
+ = ASSERT( null stmts )
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
+ returnTc ([ReturnStmt exp'], exp_lie)
+
+ -- ExprStmt at the end
+tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
+ = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
+ returnTc ([ExprStmt exp' src_loc], exp_lie)
+
+ -- ExprStmt not at the end
+tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
+ = ASSERT( isDoStmt do_or_lc )
tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- tcExpr exp boolTy `thenTc` \ (exp', exp_lie) ->
- returnTc (GuardStmt exp' src_loc, exp_lie)
- )) `thenTc` \ (stmt', stmt_lie) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' Nothing thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
- = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
- newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
- let
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
-- exp has type (m tau) for some tau (doesn't matter what)
- exp_ty = m tau
- in
- tcExpr exp exp_ty `thenTc` \ (exp', exp_lie) ->
- returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
- )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' (Just stmt_ty) thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
- = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
- tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
-
- -- NB: the environment has been extended with the new binders
- -- which the rhs can't "see", but the renamer should have made
- -- sure that everything is distinct by now, so there's no problem.
- -- Putting the tcExpr before the newMonoIds messes up the nesting
- -- of error contexts, so I didn't bother
-
- returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
- )) `thenTc` \ (stmt', stmt_lie) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' Nothing thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt do_or_lc m combine (LetStmt binds) do_next
+ newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
+ tcExpr exp (m any_ty)
+ ) `thenTc` \ (exp', exp_lie) ->
+ tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ returnTc (ExprStmt exp' src_loc : stmts',
+ exp_lie `plusLIE` stmts_lie)
+
+tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
+ = ASSERT( not (isDoStmt do_or_lc) )
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ tcAddSrcLoc src_loc $
+ tcExpr exp boolTy
+ ) `thenTc` \ (exp', exp_lie) ->
+ tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ returnTc (GuardStmt exp' src_loc : stmts',
+ exp_lie `plusLIE` stmts_lie)
+
+tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
+ tcPat noSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
+ tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
+ returnTc (pat', exp',
+ pat_lie `plusLIE` exp_lie,
+ pat_tvs, pat_ids, avail)
+ ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_ids, lie_avail) ->
+
+ -- Do the rest; we don't need to add the pat_tvs to the envt
+ -- because they all appear in the pat_ids's types
+ tcExtendEnvWithPat pat_ids (
+ tcStmts do_or_lc m stmts elt_ty
+ ) `thenTc` \ (stmts', stmts_lie) ->
+
+
+ -- Reinstate context for existential checks
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
+ tcAddErrCtxtM (existentialPatCtxt pat_tvs pat_ids) $
+
+ checkSigTyVars (bagToList pat_tvs) `thenTc` \ zonked_pat_tvs ->
+
+ tcSimplifyAndCheck
+ (text ("the existential context of a data constructor"))
+ (mkVarSet zonked_pat_tvs)
+ lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
+
+ returnTc (BindStmt pat' exp' src_loc :
+ LetStmt (MonoBind dict_binds [] Recursive) :
+ stmts',
+ lie_req `plusLIE` final_lie)
+
+tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
= tcBindsAndThen -- No error context, but a binding group is
- combine' -- rather a large thing for an error context anyway
+ combine -- rather a large thing for an error context anyway
binds
- do_next
+ (tcStmts do_or_lc m stmts elt_ty)
where
- combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
+ combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
+
+isDoStmt DoStmt = True
+isDoStmt other = False
stmtCtxt do_or_lc stmt
- = hang (ptext SLIT("In a") <+> whatever <> colon)
+ = hang (ptext SLIT("In") <+> what <> colon)
4 (ppr stmt)
where
- whatever = case do_or_lc of
- ListComp -> ptext SLIT("list-comprehension qualifier")
- DoStmt -> ptext SLIT("do statement")
- Guard -> ptext SLIT("guard")
+ what = case do_or_lc of
+ ListComp -> ptext SLIT("a list-comprehension qualifier")
+ DoStmt -> ptext SLIT("a do statement:")
+ PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
+ FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
+ CaseAlt -> thing <+> ptext SLIT("a case alternative")
+ LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
+ thing = case stmt of
+ BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
+ GuardStmt _ _ -> ptext SLIT("a guard for")
+ ExprStmt _ _ -> ptext SLIT("the right-hand side of")
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcGenDeriv]{Generating derived instance declarations}
module TcGenDeriv (
gen_Bounded_binds,
gen_Enum_binds,
- gen_Eval_binds,
gen_Eq_binds,
gen_Ix_binds,
gen_Ord_binds,
#include "HsVersions.h"
-import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), GRHS(..),
+import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), Stmt(..), HsLit(..),
- HsBinds(..), DoOrListComp(..),
+ HsBinds(..), StmtCtxt(..),
unguardedRHS
)
import RdrHsSyn ( RdrName(..), varUnqual, mkOpApp,
)
import BasicTypes ( IfaceFlavour(..), RecFlag(..) )
import FieldLabel ( fieldLabelName )
-import Id ( GenId, isNullaryDataCon, dataConTag,
+import DataCon ( isNullaryDataCon, dataConTag,
dataConRawArgTys, fIRST_TAG,
- isDataCon, DataCon, ConTag,
- dataConFieldLabels, Id )
-import Maybes ( maybeToBool )
+ DataCon, ConTag,
+ dataConFieldLabels )
import Name ( getOccString, getOccName, getSrcLoc, occNameString,
modAndOcc, OccName, Name )
import PrimOp ( PrimOp(..) )
import PrelInfo -- Lots of RdrNames
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
-import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
-import Type ( isUnpointedType, isUnboxedType, Type )
+import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
+ maybeTyConSingleCon
+ )
+import Type ( isUnLiftedType, isUnboxedType, Type )
import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
floatPrimTy, doublePrimTy
)
import Util ( mapAccumL, zipEqual, zipWithEqual,
zipWith3Equal, nOfThem, panic, assertPanic )
-
+import Maybes ( maybeToBool )
import List ( partition, intersperse )
\end{code}
%************************************************************************
%* *
-\subsubsection{Generating @Eval@ instance declarations}
-%* *
-%************************************************************************
-
-\begin{code}
-gen_Eval_binds tycon = EmptyMonoBinds
-\end{code}
-
-%************************************************************************
-%* *
\subsubsection{Generating @Bounded@ instance declarations}
%* *
%************************************************************************
enum_index `AndMonoBinds` enum_inRange
enum_range
- = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
+ = mk_easy_FunMonoBind tycon_loc range_RDR
+ [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
(mk_easy_App mkInt_RDR [bh_RDR]))
enum_index
- = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
+ = mk_easy_FunMonoBind tycon_loc index_RDR
+ [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat] True{-boxed-}),
+ d_Pat] [] (
HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
tycon_loc)
enum_inRange
- = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
+ = mk_easy_FunMonoBind tycon_loc inRange_RDR
+ [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
data_con
= case maybeTyConSingleCon tycon of -- just checking...
Nothing -> panic "get_Ix_binds"
- Just dc -> if (any isUnpointedType (dataConRawArgTys dc)) then
+ Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
else
dc
--------------------------------------------------------------
single_con_range
- = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
+ = mk_easy_FunMonoBind tycon_loc range_RDR
+ [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
HsDo ListComp stmts tycon_loc
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
[ReturnStmt con_expr]
mk_qual a b c = BindStmt (VarPatIn c)
- (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
+ (HsApp (HsVar range_RDR)
+ (ExplicitTuple [HsVar a, HsVar b] True))
tycon_loc
----------------
single_con_index
- = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
+ = mk_easy_FunMonoBind tycon_loc index_RDR
+ [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
+ con_pat cs_needed] [range_size] (
foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
= genOpApp (
- (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
+ (HsApp (HsApp (HsVar index_RDR)
+ (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
) plus_RDR (
genOpApp (
- (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
+ (HsApp (HsVar rangeSize_RDR)
+ (ExplicitTuple [HsVar l, HsVar u] True))
) times_RDR multiply_by
)
range_size
- = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
+ = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
+ [TuplePatIn [a_Pat, b_Pat] True] [] (
genOpApp (
- (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
+ (HsApp (HsApp (HsVar index_RDR)
+ (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
) plus_RDR (HsLit (HsInt 1)))
------------------
single_con_inRange
= mk_easy_FunMonoBind tycon_loc inRange_RDR
- [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
+ [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
+ con_pat cs_needed]
[] (
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
where
- in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
+ in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
+ (ExplicitTuple [HsVar a, HsVar b] True))
+ (HsVar c)
\end{code}
%************************************************************************
-- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
con_qual
= BindStmt
- (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
+ (TuplePatIn [LitPatIn (HsString data_con_str),
+ d_Pat] True)
(HsApp (HsVar lex_RDR) c_Expr)
tycon_loc
str_qual str res draw_from
= BindStmt
- (TuplePatIn [LitPatIn (HsString str), VarPatIn res])
+ (TuplePatIn [LitPatIn (HsString str), VarPatIn res] True)
(HsApp (HsVar lex_RDR) draw_from)
tycon_loc
mk_read_qual con_field res draw_from =
BindStmt
- (TuplePatIn [VarPatIn con_field, VarPatIn res])
+ (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
(HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
tycon_loc
result_expr = ExplicitTuple [con_expr, if null bs_needed
then d_Expr
- else HsVar (last bs_needed)]
+ else HsVar (last bs_needed)] True
stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
mk_stuff var
- = ASSERT(isDataCon var)
- ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
+ = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
var_RDR = qual_orig_name var
[([WildPatIn], impossible_Expr)])
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
-
- mk_stuff var
- = ASSERT(isDataCon var)
- ([lit_pat], HsVar var_RDR)
+ mk_stuff var = ([lit_pat], HsVar var_RDR)
where
lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
var_RDR = qual_orig_name var
\end{code}
\begin{code}
-argFieldCount :: Id -> Int -- Works on data and newtype constructors
+argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
argFieldCount con = length (dataConRawArgTys con)
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
maybeBoxedPrimType,
- zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId,
+ zonkTopBinds, zonkTcId, zonkId,
zonkForeignExports
) where
-- friends:
import HsSyn -- oodles of it
-import Id ( idType, dataConArgTys, mkIdWithNewType, Id
- )
-- others:
+import Id ( idType, setIdType, Id )
+import DataCon ( DataCon, dataConArgTys )
import Name ( NamedThing(..) )
-import BasicTypes ( IfaceFlavour, Unused )
+import BasicTypes ( Unused )
import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv,
TcIdOcc(..), TcIdBndr, GlobalValueEnv,
tcIdType, tcIdTyVars, tcInstId
)
import TcMonad
-import TcType ( TcType, TcMaybe, TcTyVar, TcBox,
+import TcType ( TcType, TcTyVar, TcBox,
zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType
)
import TyCon ( isDataTyCon )
-import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnpointedType, Type )
-import TyVar ( TyVar, TyVarEnv, emptyTyVarEnv, growTyVarEnvList )
-import TysPrim ( voidTy )
-import CoreSyn ( GenCoreExpr )
-import Unique ( Unique ) -- instances
+import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
+import Var ( TyVar )
+import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
+import TysWiredIn ( voidTy )
+import CoreSyn ( Expr )
import Bag
import UniqFM
import Outputable
type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
-type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s)
+type TcCoreExpr s = Expr (TcIdOcc s) (TcBox s)
type TcForeignExportDecl s = ForeignDecl (TcIdOcc s)
type TypecheckedPat = OutPat Unused Id
DsCCall.lhs.
\begin{code}
-maybeBoxedPrimType :: Type -> Maybe (Id, Type)
+maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
maybeBoxedPrimType ty
= case splitAlgTyConApp_maybe ty of -- Data type,
Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
-> case (dataConArgTys data_con tys_applied) of
[data_con_arg_ty] -- Applied to exactly one type,
- | isUnpointedType data_con_arg_ty -- which is primitive
+ | isUnLiftedType data_con_arg_ty -- which is primitive
-> Just (data_con, data_con_arg_ty)
other_cases -> Nothing
other_cases -> Nothing
zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s)
zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id
zonkTcId (TcId id)
- = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
- returnNF_Tc (TcId (mkIdWithNewType id ty'))
+ = zonkId id `thenNF_Tc` \id ->
+ returnNF_Tc (TcId id)
+
+zonkId :: TcIdBndr s -> NF_TcM s (TcIdBndr s)
+zonkId id
+ = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
+ returnNF_Tc (setIdType id ty')
\end{code}
+
This zonking pass runs over the bindings
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
Actually, since this is all in the Tc monad, it's convenient to keep the
mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds
-were previously in the LVE of the Tc monad.)
+were previously in the LVE of the Tc monad.) The type variables, though,
+we carry round in a separate environment.
It's all pretty boring stuff, because HsSyn is such a large type, and
the environment manipulation is tiresome.
\begin{code}
-extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
+extend_te te tyvars = extendVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
zonkIdBndr te (RealId id) = returnNF_Tc id
zonkIdBndr te (TcId id)
= zonkTcTypeToType te (idType id) `thenNF_Tc` \ ty' ->
- returnNF_Tc (mkIdWithNewType id ty')
+ returnNF_Tc (setIdType id ty')
zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
new_id = case maybe_id' of
Just id' -> id'
Nothing -> pprTrace "zonkIdOcc: " (ppr id) $
- mkIdWithNewType id voidTy
+ setIdType id voidTy
in
returnNF_Tc new_id
\end{code}
zonkTopBinds binds -- Top level is implicitly recursive
= fixNF_Tc (\ ~(_, new_ids) ->
tcExtendGlobalValEnv (bagToList new_ids) $
- zonkMonoBinds emptyTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) ->
+ zonkMonoBinds emptyVarEnv binds `thenNF_Tc` \ (binds', _, new_ids) ->
+ -- No top-level existential type variables
tcGetGlobalValEnv `thenNF_Tc` \ env ->
returnNF_Tc ((binds', env), new_ids)
) `thenNF_Tc` \ (stuff, _) ->
zonkBinds :: TyVarEnv Type
- -> TcHsBinds s
- -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
+ -> TcHsBinds s
+ -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
zonkBinds te binds
- = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
+ = go binds te (\ binds' te' -> tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc (binds', te', env))
where
- -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
- -- -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
- go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
- go b2 $ \ b2' ->
- thing_inside (b1' `ThenBinds` b2')
-
- go EmptyBinds thing_inside = thing_inside EmptyBinds
-
- go (MonoBind bind sigs is_rec) thing_inside
+ -- go :: TcHsBinds s
+ -- -> (TypecheckedHsBinds
+ -- -> TyVarEnv Type
+ -- -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
+ -- )
+ -- -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
+ go (ThenBinds b1 b2) te thing_inside = go b1 te $ \ b1' te1 ->
+ go b2 te1 $ \ b2' te2 ->
+ thing_inside (b1' `ThenBinds` b2') te2
+
+ go EmptyBinds te thing_inside = thing_inside EmptyBinds te
+
+ go (MonoBind bind sigs is_rec) te thing_inside
= ASSERT( null sigs )
- fixNF_Tc (\ ~(_, new_ids) ->
- tcExtendGlobalValEnv (bagToList new_ids) $
- zonkMonoBinds te bind `thenNF_Tc` \ (new_bind, new_ids) ->
- thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
- returnNF_Tc (stuff, new_ids)
- ) `thenNF_Tc` \ (stuff, _) ->
+ fixNF_Tc (\ ~(_, new_tvs, new_ids) ->
+ let
+ new_te = extend_te te (bagToList new_tvs)
+ in
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkMonoBinds new_te bind `thenNF_Tc` \ (new_bind, new_tvs, new_ids) ->
+ thing_inside (MonoBind new_bind [] is_rec) new_te `thenNF_Tc` \ stuff ->
+ returnNF_Tc (stuff, new_tvs, new_ids)
+ ) `thenNF_Tc` \ (stuff, _, _) ->
returnNF_Tc stuff
\end{code}
-------------------------------------------------------------------------
zonkMonoBinds :: TyVarEnv Type
-> TcMonoBinds s
- -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
+ -> NF_TcM s (TypecheckedMonoBinds, Bag TyVar, Bag Id)
-zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
+zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag, emptyBag)
zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
- = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', ids1) ->
- zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', ids2) ->
- returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
+ = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', tvs1, ids1) ->
+ zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', tvs2, ids2) ->
+ returnNF_Tc (b1' `AndMonoBinds` b2',
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2)
zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
- returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
+ returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, tvs, ids)
zonkMonoBinds te (VarMonoBind var expr)
= zonkIdBndr te var `thenNF_Tc` \ new_var ->
zonkExpr te expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
+ returnNF_Tc (VarMonoBind new_var new_expr, emptyBag, unitBag new_var)
zonkMonoBinds te (CoreMonoBind var core_expr)
= zonkIdBndr te var `thenNF_Tc` \ new_var ->
- returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
+ returnNF_Tc (CoreMonoBind new_var core_expr, emptyBag, unitBag new_var)
zonkMonoBinds te (FunMonoBind var inf ms locn)
= zonkIdBndr te var `thenNF_Tc` \ new_var ->
mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
+ returnNF_Tc (FunMonoBind new_var inf new_ms locn, emptyBag, unitBag new_var)
zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
tcExtendGlobalValEnv new_dicts $
- fixNF_Tc (\ ~(_, _, val_bind_ids) ->
+ fixNF_Tc (\ ~(_, _, val_bind_tvs, val_bind_ids) ->
+ let
+ new_te2 = extend_te new_te (bagToList val_bind_tvs)
+ in
tcExtendGlobalValEnv (bagToList val_bind_ids) $
- zonkMonoBinds new_te val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
- mapNF_Tc (zonkExport new_te) exports `thenNF_Tc` \ new_exports ->
- returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
- ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
+ zonkMonoBinds new_te2 val_bind `thenNF_Tc` \ (new_val_bind, val_bind_tvs, val_bind_ids) ->
+ mapNF_Tc (zonkExport new_te2) exports `thenNF_Tc` \ new_exports ->
+ returnNF_Tc (new_val_bind, new_exports, val_bind_tvs, val_bind_ids)
+ ) `thenNF_Tc ` \ (new_val_bind, new_exports, _, _) ->
let
new_globals = listToBag [global | (_, global, local) <- new_exports]
in
returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
+ emptyBag, -- For now.
new_globals)
where
zonkExport te (tyvars, global, local)
-> TcMatch s -> NF_TcM s TypecheckedMatch
zonkMatch te (PatMatch pat match)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
- tcExtendGlobalValEnv (bagToList ids) $
- zonkMatch te match `thenNF_Tc` \ new_match ->
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
+ let
+ new_te = extend_te te (bagToList new_tvs)
+ in
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkMatch new_te match `thenNF_Tc` \ new_match ->
returnNF_Tc (PatMatch new_pat new_match)
zonkMatch te (GRHSMatch grhss_w_binds)
-> NF_TcM s TypecheckedGRHSsAndBinds
zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
- = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
+ = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) ->
tcSetEnv new_env $
let
- zonk_grhs (GRHS guard expr locn)
- = zonkStmts te guard `thenNF_Tc` \ (new_guard, new_env) ->
- tcSetEnv new_env $
- zonkExpr te expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (GRHS new_guard new_expr locn)
+ zonk_grhs (GRHS guarded locn)
+ = zonkStmts new_te guarded `thenNF_Tc` \ new_guarded ->
+ returnNF_Tc (GRHS new_guarded locn)
in
mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
- zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+ zonkTcTypeToType new_te ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
\end{code}
returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
zonkExpr te (HsLet binds expr)
- = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
+ = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) ->
tcSetEnv new_env $
- zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkExpr new_te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
- = zonkStmts te stmts `thenNF_Tc` \ (new_stmts, _) ->
+ = zonkStmts te stmts `thenNF_Tc` \ new_stmts ->
zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
returnNF_Tc (ExplicitListOut new_ty new_exprs)
-zonkExpr te (ExplicitTuple exprs)
+zonkExpr te (ExplicitTuple exprs boxed)
= mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitTuple new_exprs)
+ returnNF_Tc (ExplicitTuple new_exprs boxed)
-zonkExpr te (HsCon con_id tys exprs)
+zonkExpr te (HsCon data_con tys exprs)
= mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (HsCon con_id new_tys new_exprs)
+ returnNF_Tc (HsCon data_con new_tys new_exprs)
-zonkExpr te (RecordCon con_id con_expr rbinds)
- = zonkIdOcc con_id `thenNF_Tc` \ new_con_id ->
- zonkExpr te con_expr `thenNF_Tc` \ new_con_expr ->
+zonkExpr te (RecordConOut data_con con_expr rbinds)
+ = zonkExpr te con_expr `thenNF_Tc` \ new_con_expr ->
zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
- returnNF_Tc (RecordCon new_con_id new_con_expr new_rbinds)
+ returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
-------------------------------------------------------------------------
zonkStmts :: TyVarEnv Type
- -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
+ -> [TcStmt s]
+ -> NF_TcM s [TypecheckedStmt]
-zonkStmts te [] = tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc ([], env)
+zonkStmts te [] = returnNF_Tc []
zonkStmts te [ReturnStmt expr]
= zonkExpr te expr `thenNF_Tc` \ new_expr ->
- tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc ([ReturnStmt new_expr], env)
+ returnNF_Tc [ReturnStmt new_expr]
zonkStmts te (ExprStmt expr locn : stmts)
= zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
- returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
+ zonkStmts te stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ExprStmt new_expr locn : new_stmts)
zonkStmts te (GuardStmt expr locn : stmts)
= zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
- returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
+ zonkStmts te stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (GuardStmt new_expr locn : new_stmts)
zonkStmts te (LetStmt binds : stmts)
- = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
+ = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) ->
tcSetEnv new_env $
- zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env2) ->
- returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
+ zonkStmts new_te stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (LetStmt new_binds : new_stmts)
zonkStmts te (BindStmt pat expr locn : stmts)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkExpr te expr `thenNF_Tc` \ new_expr ->
- tcExtendGlobalValEnv (bagToList ids) $
- zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
- returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkPat te pat `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
+ let
+ new_te = extend_te te (bagToList new_tvs)
+ in
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkStmts new_te stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
\begin{code}
zonkPat :: TyVarEnv Type
- -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
+ -> TcPat s -> NF_TcM s (TypecheckedPat, Bag TyVar, Bag Id)
zonkPat te (WildPat ty)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty, emptyBag)
+ returnNF_Tc (WildPat new_ty, emptyBag, emptyBag)
zonkPat te (VarPat v)
= zonkIdBndr te v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v, unitBag new_v)
+ returnNF_Tc (VarPat new_v, emptyBag, unitBag new_v)
zonkPat te (LazyPat pat)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
- returnNF_Tc (LazyPat new_pat, ids)
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
+ returnNF_Tc (LazyPat new_pat, tvs, ids)
zonkPat te (AsPat n pat)
= zonkIdBndr te n `thenNF_Tc` \ new_n ->
- zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
- returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
+ zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
+ returnNF_Tc (AsPat new_n new_pat, tvs, new_n `consBag` ids)
-zonkPat te (ConPat n ty pats)
+zonkPat te (ListPat ty pats)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (ConPat n new_ty new_pats, ids)
+ zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
+ returnNF_Tc (ListPat new_ty new_pats, tvs, ids)
-zonkPat te (ConOpPat pat1 op pat2 ty)
- = zonkPat te pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
- zonkPat te pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
- zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
+zonkPat te (TuplePat pats boxed)
+ = zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
+ returnNF_Tc (TuplePat new_pats boxed, tvs, ids)
-zonkPat te (ListPat ty pats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (ListPat new_ty new_pats, ids)
+zonkPat te (ConPat n ty tvs dicts pats)
+ = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
+ let
+ new_te = extend_te te new_tvs
+ in
+ mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
+ tcExtendGlobalValEnv new_dicts $
+
+ zonkPats new_te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
-zonkPat te (TuplePat pats)
- = zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (TuplePat new_pats, ids)
+ returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
+ listToBag new_tvs `unionBags` tvs,
+ listToBag new_dicts `unionBags` ids)
-zonkPat te (RecPat n ty rpats)
+zonkPat te (RecPat n ty tvs dicts rpats)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
- returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
+ mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
+ let
+ new_te = extend_te te new_tvs
+ in
+ mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
+ tcExtendGlobalValEnv new_dicts $
+ mapNF_Tc (zonk_rpat new_te) rpats `thenNF_Tc` \ stuff ->
+ let
+ (new_rpats, tvs_s, ids_s) = unzip3 stuff
+ in
+ returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
+ listToBag new_tvs `unionBags` unionManyBags tvs_s,
+ listToBag new_dicts `unionBags` unionManyBags ids_s)
where
- zonk_rpat (f, pat, pun)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
- returnNF_Tc ((f, new_pat, pun), ids)
+ zonk_rpat te (f, pat, pun)
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
+ returnNF_Tc ((f, new_pat, pun), tvs, ids)
zonkPat te (LitPat lit ty)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (LitPat lit new_ty, emptyBag)
+ returnNF_Tc (LitPat lit new_ty, emptyBag, emptyBag)
zonkPat te (NPat lit ty expr)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
zonkExpr te expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
+ returnNF_Tc (NPat lit new_ty new_expr, emptyBag, emptyBag)
zonkPat te (NPlusKPat n k ty e1 e2)
= zonkIdBndr te n `thenNF_Tc` \ new_n ->
zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
+ returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, emptyBag, unitBag new_n)
zonkPat te (DictPat ds ms)
= mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds ->
mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (DictPat new_ds new_ms,
+ returnNF_Tc (DictPat new_ds new_ms, emptyBag,
listToBag new_ds `unionBags` listToBag new_ms)
-zonkPats te []
- = returnNF_Tc ([], emptyBag)
+zonkPats te []
+ = returnNF_Tc ([], emptyBag, emptyBag)
+
zonkPats te (pat:pats)
- = zonkPat te pat `thenNF_Tc` \ (pat', ids1) ->
- zonkPats te pats `thenNF_Tc` \ (pats', ids2) ->
- returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
+ = zonkPat te pat `thenNF_Tc` \ (pat', tvs1, ids1) ->
+ zonkPats te pats `thenNF_Tc` \ (pats', tvs2, ids2) ->
+ returnNF_Tc (pat':pats', tvs1 `unionBags` tvs2, ids1 `unionBags` ids2)
\end{code}
%************************************************************************
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcIfaceSig]{Type checking of type signatures in interface files}
import TcMonoType ( tcHsType, tcHsTypeKind, tcTyVarScope )
import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetGlobalValEnv,
tcLookupTyConByKey, tcLookupGlobalValueMaybe,
- tcExplicitLookupGlobal,
+ tcExplicitLookupGlobal, badCon, badPrimOp,
GlobalValueEnv
)
-import TcKind ( TcKind, kindToTcKind )
+import TcType ( TcKind, kindToTcKind )
import RnHsSyn ( RenamedHsDecl )
import HsCore
import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
-import Literal ( Literal(..) )
+import CallConv ( cCallConv )
+import Const ( Con(..), Literal(..) )
import CoreSyn
import CoreUtils ( coreExprType )
import CoreUnfold
-import MagicUFs ( MagicUnfoldingFun )
import WwLib ( mkWrapper )
import PrimOp ( PrimOp(..) )
-import CallConv ( cCallConv )
-import MkId ( mkImportedId, mkUserId )
-import Id ( Id, addInlinePragma, isPrimitiveId_maybe, dataConArgTys )
+import Id ( Id, mkImportedId, mkUserId,
+ isPrimitiveId_maybe, isDataConId_maybe
+ )
import IdInfo
+import DataCon ( dataConSig, dataConArgTys )
import SpecEnv ( addToSpecEnv )
-import Type ( mkSynTy, splitAlgTyConApp )
-import TyVar ( mkSysTyVar )
-import Name ( Name )
-import Unique ( rationalTyConKey, uniqueOf )
-import TysWiredIn ( integerTy )
+import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
+import Var ( mkTyVar, tyVarKind )
+import VarEnv
+import Name ( Name, NamedThing(..) )
+import Unique ( rationalTyConKey )
+import TysWiredIn ( integerTy, stringTy )
import ErrUtils ( pprBagOfErrors )
import Maybes ( maybeToBool, MaybeErr(..) )
import Outputable
import Util ( zipWithEqual )
-
\end{code}
Ultimately, type signatures in interfaces will have pragmatic
where
tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info)
- tcPrag info (HsFBType fb) = returnTc (fb `setFBTypeInfo` info)
- tcPrag info (HsArgUsage au) = returnTc (au `setArgUsageInfo` info)
+ tcPrag info (HsNoCafRefs) = returnTc (NoCafRefs `setCafInfo` info)
- tcPrag info (HsUnfold inline expr)
- = tcPragExpr unf_env name expr `thenNF_Tc` \ maybe_expr' ->
+ tcPrag info (HsUnfold inline_prag maybe_expr)
+ = (case maybe_expr of
+ Just expr -> tcPragExpr unf_env name expr
+ Nothing -> returnNF_Tc Nothing
+ ) `thenNF_Tc` \ maybe_expr' ->
let
-- maybe_expr doesn't get looked at if the unfolding
-- is never inspected; so the typecheck doesn't even happen
Just expr' -> mkUnfolding expr'
info1 = unfold_info `setUnfoldingInfo` info
- info2 | inline = IWantToBeINLINEd `setInlinePragInfo` info1
- | otherwise = info1
+ info2 = inline_prag `setInlinePragInfo` info1
in
returnTc info2
an unfolding that isn't going to be looked at.
\begin{code}
+tcPragExpr :: GlobalValueEnv -> Name -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
tcPragExpr unf_env name core_expr
= forkNF_Tc (
recoverNF_Tc no_unfolding (
\begin{code}
tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
+tcCoreExpr (UfType ty)
+ = tcHsTypeKind ty `thenTc` \ (_, ty') ->
+ -- It might not be of kind type
+ returnTc (Type ty')
+
tcCoreExpr (UfVar name)
= tcVar name `thenTc` \ id ->
returnTc (Var id)
--- rationalTy isn't built in so we have to construct it
--- (the "ty" part of the incoming literal is simply bottom)
-tcCoreExpr (UfLit (NoRepRational lit _))
- = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
- let
- rational_ty = mkSynTy rational_tycon []
- in
- returnTc (Lit (NoRepRational lit rational_ty))
-
--- Similarly for integers, except that it is wired in
-tcCoreExpr (UfLit (NoRepInteger lit _))
- = returnTc (Lit (NoRepInteger lit integerTy))
-
-tcCoreExpr (UfLit other_lit)
- = returnTc (Lit other_lit)
-
tcCoreExpr (UfCon con args)
- = tcVar con `thenTc` \ con_id ->
- mapTc tcCoreArg args `thenTc` \ args' ->
- returnTc (Con con_id args')
+ = tcUfCon con `thenTc` \ con' ->
+ mapTc tcCoreExpr args `thenTc` \ args' ->
+ returnTc (Con con' args')
-tcCoreExpr (UfPrim prim args)
- = tcCorePrim prim `thenTc` \ primop ->
- mapTc tcCoreArg args `thenTc` \ args' ->
- returnTc (Prim primop args')
+tcCoreExpr (UfTuple name args)
+ = tcUfDataCon name `thenTc` \ con ->
+ mapTc tcCoreExpr args `thenTc` \ args' ->
+ let
+ -- Put the missing type arguments back in
+ con_args = map (Type . coreExprType) args' ++ args'
+ in
+ returnTc (Con con con_args)
tcCoreExpr (UfLam bndr body)
= tcCoreLamBndr bndr $ \ bndr' ->
tcCoreExpr (UfApp fun arg)
= tcCoreExpr fun `thenTc` \ fun' ->
- tcCoreArg arg `thenTc` \ arg' ->
+ tcCoreExpr arg `thenTc` \ arg' ->
returnTc (App fun' arg')
-tcCoreExpr (UfCase scrut alts)
- = tcCoreExpr scrut `thenTc` \ scrut' ->
- tcCoreAlts (coreExprType scrut') alts `thenTc` \ alts' ->
- returnTc (Case scrut' alts')
+tcCoreExpr (UfCase scrut case_bndr alts)
+ = tcCoreExpr scrut `thenTc` \ scrut' ->
+ let
+ scrut_ty = coreExprType scrut'
+ case_bndr' = mkUserId case_bndr scrut_ty
+ in
+ tcExtendGlobalValEnv [case_bndr'] $
+ mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
+ returnTc (Case scrut' case_bndr' alts')
tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
= tcCoreExpr rhs `thenTc` \ rhs' ->
tcCoreNote (UfSCC cc) = returnTc (SCC cc)
tcCoreNote UfInlineCall = returnTc InlineCall
+
+
+-- rationalTy isn't built in so, we have to construct it
+-- (the "ty" part of the incoming literal is simply bottom)
+tcUfCon (UfLitCon (NoRepRational lit _))
+ = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
+ let
+ rational_ty = mkSynTy rational_tycon []
+ in
+ returnTc (Literal (NoRepRational lit rational_ty))
+
+-- Similarly for integers and strings, except that they are wired in
+tcUfCon (UfLitCon (NoRepInteger lit _))
+ = returnTc (Literal (NoRepInteger lit integerTy))
+tcUfCon (UfLitCon (NoRepStr lit _))
+ = returnTc (Literal (NoRepStr lit stringTy))
+
+tcUfCon (UfLitCon other_lit)
+ = returnTc (Literal other_lit)
+
+-- The dreaded lit-lits are also similar, except here the type
+-- is read in explicitly rather than being implicit
+tcUfCon (UfLitLitCon lit ty)
+ = tcHsType ty `thenTc` \ ty' ->
+ returnTc (Literal (MachLitLit lit ty'))
+
+tcUfCon (UfDataCon name) = tcUfDataCon name
+
+tcUfCon (UfPrimOp name)
+ = tcVar name `thenTc` \ op_id ->
+ case isPrimitiveId_maybe op_id of
+ Just op -> returnTc (PrimOp op)
+ Nothing -> failWithTc (badPrimOp name)
+
+tcUfCon (UfCCallOp str casm gc)
+ = returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
+
+tcUfDataCon name
+ = tcVar name `thenTc` \ con_id ->
+ case isDataConId_maybe con_id of
+ Just con -> returnTc (DataCon con)
+ Nothing -> failWithTc (badCon name)
\end{code}
\begin{code}
id = mkUserId name ty'
in
tcExtendGlobalValEnv [id] $
- thing_inside (ValBinder id)
+ thing_inside id
tcCoreLamBndr (UfTyBinder name kind) thing_inside
= let
- tyvar = mkSysTyVar (uniqueOf name) kind
+ tyvar = mkTyVar name kind
in
tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
- thing_inside (TyBinder tyvar)
+ thing_inside tyvar
tcCoreValBndr (UfValBinder name ty) thing_inside
= tcHsType ty `thenTc` \ ty' ->
tcExtendGlobalValEnv ids $
thing_inside ids
where
- names = map (\ (UfValBinder name _) -> name) bndrs
- tys = map (\ (UfValBinder _ ty) -> ty) bndrs
+ names = [name | UfValBinder name _ <- bndrs]
+ tys = [ty | UfValBinder _ ty <- bndrs]
\end{code}
\begin{code}
-tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v')
-tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty')
-tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
-
-tcCoreAlts scrut_ty (UfAlgAlts alts deflt)
- = mapTc tc_alt alts `thenTc` \ alts' ->
- tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
- returnTc (AlgAlts alts' deflt')
- where
- tc_alt (con, names, rhs)
- = tcVar con `thenTc` \ con' ->
- let
- arg_tys = dataConArgTys con' inst_tys
- (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
- arg_ids = zipWithEqual "tcCoreAlts" mkUserId names arg_tys
- in
- tcExtendGlobalValEnv arg_ids $
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (con', arg_ids, rhs')
-
-tcCoreAlts scrut_ty (UfPrimAlts alts deflt)
- = mapTc tc_alt alts `thenTc` \ alts' ->
- tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
- returnTc (PrimAlts alts' deflt')
- where
- tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (lit, rhs')
-
-tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault
-tcCoreDefault scrut_ty (UfBindDefault name rhs)
- = let
- deflt_id = mkUserId name scrut_ty
+tcCoreAlt scrut_ty (UfDefault, names, rhs)
+ = ASSERT( null names )
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (DEFAULT, [], rhs')
+
+tcCoreAlt scrut_ty (UfLitCon lit, names, rhs)
+ = ASSERT( null names )
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (Literal lit, [], rhs')
+
+tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs)
+ = ASSERT( null names )
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ tcHsType ty `thenTc` \ ty' ->
+ returnTc (Literal (MachLitLit str ty'), [], rhs')
+
+-- A case alternative is made quite a bit more complicated
+-- by the fact that we omit type annotations because we can
+-- work them out. True enough, but its not that easy!
+tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
+ = tcVar con_name `thenTc` \ con_id ->
+ let
+ con = case isDataConId_maybe con_id of
+ Just con -> con
+ Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
+
+ (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
+
+ (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
+ ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
+ ex_tys' = mkTyVarTys ex_tyvars'
+ arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
+ id_names = drop (length ex_tyvars) names
+ arg_ids
+#ifdef DEBUG
+ | length id_names /= length arg_tys
+ = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
+ (ppr main_tyvars <+> ppr ex_tyvars) $$
+ ppr arg_tys)
+ | otherwise
+#endif
+ = zipWithEqual "tcCoreAlts" mkUserId id_names arg_tys
in
- tcExtendGlobalValEnv [deflt_id] $
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (BindDefault deflt_id rhs')
-
-
-tcCorePrim (UfOtherOp op)
- = tcVar op `thenTc` \ op_id ->
- case isPrimitiveId_maybe op_id of
- Just prim_op -> returnTc prim_op
- Nothing -> pprPanic "tcCorePrim" (ppr op_id)
-
-tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
- = mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
- tcHsType res_ty `thenTc` \ res_ty' ->
- returnTc (CCallOp (Left str) casm gc cCallConv arg_tys' res_ty')
+ ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
+ tcExtendTyVarEnv (map getName ex_tyvars')
+ [ (kindToTcKind (tyVarKind tv), tv)
+ | tv <- ex_tyvars'] $
+ tcExtendGlobalValEnv arg_ids $
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
\end{code}
\begin{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcInstDecls]{Typechecking instance declarations}
#include "HsVersions.h"
import HsSyn ( HsDecl(..), InstDecl(..),
- HsBinds(..), MonoBinds(..), GRHSsAndBinds(..), GRHS(..),
+ HsBinds(..), MonoBinds(..), GRHSsAndBinds(..),
HsExpr(..), InPat(..), HsLit(..), Sig(..),
- unguardedRHS,
- collectMonoBinders, andMonoBinds
+ collectMonoBinders, andMonoBindList
)
-import HsBinds ( sigsForMe )
-import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds,
- RenamedInstDecl, RenamedHsExpr,
- RenamedSig, RenamedHsDecl
- )
-import TcHsSyn ( TcMonoBinds, TcIdOcc(..), TcIdBndr,
+import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
+import TcHsSyn ( TcMonoBinds, TcIdOcc(..),
maybeBoxedPrimType, tcIdType
)
import Inst ( Inst, InstOrigin(..),
newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
-import TcEnv ( GlobalValueEnv, tcExtendGlobalValEnv, tcAddImportedIdInfo )
-import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, classDataCon )
-import TcKind ( TcKind, unifyKind )
+import TcEnv ( GlobalValueEnv, tcExtendGlobalValEnv, tcAddImportedIdInfo, tcInstId )
+import TcInstUtil ( InstInfo(..), classDataCon )
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType, TcTyVar, TcTyVarSet,
- zonkSigTyVar, tcInstSigType, tcInstTheta
- )
+import TcType ( TcTyVar, zonkTcTyVarBndr )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
foldBag, bagToList, Bag
)
-import CmdLineOpts ( opt_GlasgowExts )
+import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
-import Id ( isNullaryDataCon, dataConArgTys, replaceIdInfo, idName, idType, Id )
-import Maybes ( maybeToBool, seqMaybe, catMaybes, expectJust )
-import Name ( nameOccName, mkLocalName,
- isLocallyDefined, Module,
+import Var ( setIdInfo, idName, Id, TyVar )
+import DataCon ( isNullaryDataCon, dataConArgTys, dataConId )
+import Maybes ( maybeToBool, catMaybes, expectJust )
+import MkId ( mkDictFunId )
+import Name ( nameOccName, isLocallyDefined, Module,
NamedThing(..)
)
import PrelVals ( eRROR_ID )
-import PprType ( pprParendType, pprConstraint )
-import SrcLoc ( SrcLoc, noSrcLoc )
+import PprType ( pprConstraint )
+import SrcLoc ( SrcLoc )
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
-import Type ( Type, ThetaType, isUnpointedType,
- splitSigmaTy, isTyVarTy, mkSigmaTy,
+import Type ( Type, isUnLiftedType, mkTyVarTys,
+ splitSigmaTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy_maybe,
- splitAlgTyConApp_maybe, splitRhoTy,
- tyVarsOfTypes, mkTyVarTys,
+ splitAlgTyConApp_maybe,
+ tyVarsOfTypes, substFlexiTheta
)
-import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
+import VarEnv ( zipVarEnv )
+import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
-- Make the dfun id and constant-method ids
let
- (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
- clas tyvars inst_tys theta
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
+
-- Add info from interface file
final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
in
returnTc (unitBag (InstInfo clas tyvars inst_tys theta
- dfun_theta final_dfun_id
+ final_dfun_id
binds src_loc uprags))
\end{code}
tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
- inst_decl_theta dfun_theta
+ inst_decl_theta
dfun_id monobinds
locn uprags)
| not (isLocallyDefined dfun_id)
tcAddSrcLoc locn $
-- Instantiate the instance decl with tc-style type variables
- tcInstSigType (idType dfun_id) `thenNF_Tc` \ dfun_ty' ->
+ tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
- (inst_tyvars',
- dfun_theta', dict_ty') = splitSigmaTy dfun_ty'
-
(clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
+ origin = InstanceDeclOrigin
+
(class_tyvars,
sc_theta, sc_sel_ids,
op_sel_ids, defm_ids) = classBigSig clas
- origin = InstanceDeclOrigin
- in
-- Instantiate the theta found in the original instance decl
- tcInstTheta (zipTyVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
-
- -- Instantiate the super-class context with the instance types
- tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
+ inst_decl_theta' = substFlexiTheta (zipVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta
+ -- Instantiate the super-class context with inst_tys
+ sc_theta' = substFlexiTheta (zipVarEnv class_tyvars inst_tys') sc_theta
+ in
-- Create dictionary Ids from the specified instance contexts.
newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
-- Check the overloading constraints of the methods and superclasses
- mapNF_Tc zonkSigTyVar inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
+ -- tcMethodBind has checked that the class_tyvars havn't
+ -- been unified with each other or another type, but we must
+ -- still zonk them
+ mapNF_Tc zonkTcTyVarBndr inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
let
- inst_tyvars_set = mkTyVarSet zonked_inst_tyvars
+ inst_tyvars_set = mkVarSet zonked_inst_tyvars
(meth_lies, meth_ids) = unzip meth_lies_w_ids
inst_tyvars_set -- Local tyvars
inst_decl_dicts -- The instance dictionaries available
sc_dicts -- The superclass dicationaries reqd
- ) `thenTc_`
+ ) `thenTc` \ _ ->
-- Ignore the result; we're only doing
-- this to make sure it can be done.
(HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
- = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
+ = foldl HsApp (TyApp (HsVar (RealId (dataConId dict_constr))) inst_tys')
(map HsVar (sc_dict_ids ++ meth_ids))
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
dict_bind = VarMonoBind this_dict_id dict_rhs
- method_binds = andMonoBinds method_binds_s
+ method_binds = andMonoBindList method_binds_s
- final_dfun_id = replaceIdInfo dfun_id (prag_info_fn (idName dfun_id))
+ final_dfun_id = setIdInfo dfun_id (prag_info_fn (idName dfun_id))
-- Pretty truesome
main_bind
= AbsBinds
\begin{code}
scrutiniseInstanceConstraint (clas, tys)
- | all isTyVarTy tys = returnNF_Tc ()
- | otherwise = addErrTc (instConstraintErr clas tys)
+ | all isTyVarTy tys
+ || opt_AllowUndecidableInstances = returnNF_Tc ()
+ | otherwise = addErrTc (instConstraintErr clas tys)
scrutiniseInstanceHead clas inst_taus
| -- CCALL CHECK (a).... urgh!
--
-- We flag this separately to give a more precise error msg.
--
- (uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey)
+ (getUnique clas == cCallableClassKey || getUnique clas == cReturnableClassKey)
&& is_alg_tycon_app && not constructors_visible
= addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
| -- CCALL CHECK (b)
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
- (uniqueOf clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
- (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
+ (getUnique clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
+ (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
= addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
-- DERIVING CHECK
= addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
-- Kind check will have ensured inst_taus is of length 1
+ -- Allow anything for AllowUndecidableInstances
+ | opt_AllowUndecidableInstances
+ = returnNF_Tc ()
+
+ -- If GlasgowExts then check at least one isn't a type variable
+ | opt_GlasgowExts
+ = if all isTyVarTy inst_taus then
+ addErrTc (instTypeErr clas inst_taus (text "There must be at least one non-type-variable in the instance head"))
+ else
+ returnNF_Tc ()
+
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
- | not opt_GlasgowExts
- && not (length inst_taus == 1 &&
+ | not (length inst_taus == 1 &&
maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
not (isSynTyCon tycon) && -- ...but not a synonym
all isTyVarTy arg_tys && -- Applied to type variables
- length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
+ length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
-- This last condition checks that all the type variables are distinct
)
= addErrTc (instTypeErr clas inst_taus
-- These conditions come directly from what the DsCCall is capable of.
-- Totally grotesque. Green card should solve this.
-ccallable_type ty = isUnpointedType ty || -- Allow CCallable Int# etc
+ccallable_type ty = isUnLiftedType ty || -- Allow CCallable Int# etc
maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
ty == stringTy ||
byte_arr_thing
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcInstUtil]{Utilities for typechecking instance declarations}
\begin{code}
module TcInstUtil (
InstInfo(..),
- mkInstanceRelatedIds,
buildInstanceEnvs,
classDataCon
) where
import Inst ( InstanceMapper )
import Bag ( bagToList, Bag )
-import Class ( ClassInstEnv, Class, classBigSig )
-import MkId ( mkDictFunId )
-import Id ( Id )
+import Class ( ClassInstEnv, Class )
+import Var ( TyVar, Id )
import SpecEnv ( emptySpecEnv, addToSpecEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
-import Name ( getSrcLoc, Name )
+import Name ( getSrcLoc )
import SrcLoc ( SrcLoc )
-import Type ( mkSigmaTy, mkDictTy, instantiateThetaTy,
- ThetaType, Type
- )
+import Type ( ThetaType, Type )
import PprType ( pprConstraint )
import Class ( classTyCon )
+import DataCon ( DataCon )
import TyCon ( tyConDataCons )
-import TyVar ( TyVar, zipTyVarEnv )
-import Unique ( Unique )
-import Util ( equivClasses, panic, assertPanic )
+import Util ( equivClasses, assertPanic )
import Outputable
-import List ( nub )
\end{code}
instance c => k (t tvs) where b
ThetaType -- inst_decl_theta: the original context, c, from the
-- instance declaration. It constrains (some of)
-- the TyVars above
- ThetaType -- dfun_theta: the inst_decl_theta, plus one
- -- element for each superclass; the "Mark
- -- Jones optimisation"
Id -- The dfun id
RenamedMonoBinds -- Bindings, b
SrcLoc -- Source location assoc'd with this instance's defn
It makes a nasty mutual-recursion knot if you put it in Class.
\begin{code}
-classDataCon :: Class -> Id
+classDataCon :: Class -> DataCon
classDataCon clas = case tyConDataCons (classTyCon clas) of
(dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
\end{code}
%************************************************************************
%* *
-\subsection{Creating instance related Ids}
-%* *
-%************************************************************************
-
-\begin{code}
-mkInstanceRelatedIds :: Name -- Name to use for the dict fun;
- -> Class
- -> [TyVar]
- -> [Type]
- -> ThetaType
- -> (Id, ThetaType)
-
-mkInstanceRelatedIds dfun_name clas inst_tyvars inst_tys inst_decl_theta
- = (dfun_id, dfun_theta)
- where
- (class_tyvars, sc_theta, _, _, _) = classBigSig clas
- sc_theta' = instantiateThetaTy (zipTyVarEnv class_tyvars inst_tys) sc_theta
-
- dfun_theta = case inst_decl_theta of
- [] -> [] -- If inst_decl_theta is empty, then we don't
- -- want to have any dict arguments, so that we can
- -- expose the constant methods.
-
- other -> nub (inst_decl_theta ++ sc_theta')
- -- Otherwise we pass the superclass dictionaries to
- -- the dictionary function; the Mark Jones optimisation.
- --
- -- NOTE the "nub". I got caught by this one:
- -- class Monad m => MonadT t m where ...
- -- instance Monad m => MonadT (EnvT env) m where ...
- -- Here, the inst_decl_theta has (Monad m); but so
- -- does the sc_theta'!
-
- dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
-
- dfun_id = mkDictFunId dfun_name dfun_ty clas inst_tys
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Converting instance info into suitable InstEnvs}
%* *
%************************************************************************
buildInstanceEnvs info
= let
icmp :: InstInfo -> InstInfo -> Ordering
- (InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
+ (InstInfo c1 _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _)
= c1 `compare` c2
info_by_class = equivClasses icmp (bagToList info)
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
-> NF_TcM s (Class, ClassInstEnv)
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
+buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
= foldrNF_Tc addClassInstance
emptySpecEnv
inst_infos `thenNF_Tc` \ class_inst_env ->
-> NF_TcM s ClassInstEnv
addClassInstance
- (InstInfo clas inst_tyvars inst_tys _ _
+ (InstInfo clas inst_tyvars inst_tys _
dfun_id _ src_loc _)
class_inst_env
= -- Add the instance to the class's instance environment
+++ /dev/null
-\begin{code}
-module TcKind (
-
- Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind,
- hasMoreBoxityInfo, -- Kind -> Kind -> Bool
- resultKind, -- Kind -> Kind
-
- TcKind,
- newKindVar, -- NF_TcM s (TcKind s)
- newKindVars, -- Int -> NF_TcM s [TcKind s]
- unifyKind, -- TcKind s -> TcKind s -> TcM s ()
- unifyKinds, -- [TcKind s] -> [TcKind s] -> TcM s ()
-
- kindToTcKind, -- Kind -> TcKind s
- tcDefaultKind -- TcKind s -> NF_TcM s Kind
- ) where
-
-#include "HsVersions.h"
-
-import Kind
-import TcMonad
-
-import Unique ( Unique )
-import Util ( nOfThem, panic )
-import Outputable
-\end{code}
-
-
-\begin{code}
-type TcKind s = GenKind (TcRef s (TcMaybe s))
-data TcMaybe s = Unbound
- | BoundTo (TcKind s) -- Always ArrowKind or BoxedTypeKind
-
-newKindVar :: NF_TcM s (TcKind s)
-newKindVar = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutVar Unbound `thenNF_Tc` \ box ->
- returnNF_Tc (VarKind uniq box)
-
-newKindVars :: Int -> NF_TcM s [TcKind s]
-newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ())
-\end{code}
-
-
-Kind unification
-~~~~~~~~~~~~~~~~
-\begin{code}
-unifyKinds :: [TcKind s] -> [TcKind s] -> TcM s ()
-unifyKinds [] [] = returnTc ()
-unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_`
- unifyKinds ks1 ks2
-unifyKinds _ _ = panic "unifyKinds: length mis-match"
-
-unifyKind :: TcKind s -- Expected
- -> TcKind s -- Actual
- -> TcM s ()
-
-unifyKind kind1 kind2
- = tcAddErrCtxtM ctxt (unify_kind kind1 kind2)
- where
- ctxt = zonkTcKind kind1 `thenNF_Tc` \ kind1' ->
- zonkTcKind kind2 `thenNF_Tc` \ kind2' ->
- returnNF_Tc (unifyKindCtxt kind1' kind2')
-
-
--- TypeKind expected => the actual can be boxed or unboxed
-unify_kind TypeKind TypeKind = returnTc ()
-unify_kind TypeKind BoxedTypeKind = returnTc ()
-unify_kind TypeKind UnboxedTypeKind = returnTc ()
-
-unify_kind BoxedTypeKind BoxedTypeKind = returnTc ()
-unify_kind UnboxedTypeKind UnboxedTypeKind = returnTc ()
-
-unify_kind (ArrowKind fun1 arg1)
- (ArrowKind fun2 arg2)
-
- = unify_kind fun1 fun2 `thenTc_`
- unify_kind arg1 arg2
-
-unify_kind kind1@(VarKind uniq box) kind2 = unify_var False kind1 uniq box kind2
-unify_kind kind1 kind2@(VarKind uniq box) = unify_var True kind2 uniq box kind1
-
-unify_kind kind1 kind2
- = failWithTc (kindMisMatchErr kind1 kind2)
-\end{code}
-
-We could probably do some "shorting out" in unifyVarKind, but
-I'm not convinced it would save time, and it's a little tricky to get right.
-
-\begin{code}
-unify_var swap_vars kind1 uniq1 box1 kind2
- = tcReadMutVar box1 `thenNF_Tc` \ maybe_kind1 ->
- case maybe_kind1 of
- Unbound -> unify_unbound_var False kind1 uniq1 box1 kind2
- BoundTo TypeKind -> unify_unbound_var True kind1 uniq1 box1 kind2
- -- *** NB: BoundTo TypeKind is a kind of un-bound
- -- It can get refined to BoundTo UnboxedTypeKind or BoxedTypeKind
-
- BoundTo kind1' | swap_vars -> unify_kind kind2 kind1'
- | otherwise -> unify_kind kind1' kind2
- -- Keep them the right way round, so that
- -- the asymettric boxed/unboxed stuff works
-
-
-unify_unbound_var type_kind kind1 uniq1 box1 kind2@(VarKind uniq2 box2)
- | uniq1 == uniq2 -- Binding to self is a no-op
- = returnTc ()
-
- | otherwise -- Distinct variables
- = tcReadMutVar box2 `thenNF_Tc` \ maybe_kind2 ->
- case maybe_kind2 of
- BoundTo kind2' -> unify_unbound_var type_kind kind1 uniq1 box1 kind2'
- Unbound -> tcWriteMutVar box2 (BoundTo kind1) `thenNF_Tc_`
- -- No need for occurs check here
- -- Kind1 is an unbound variable, or BoundToTypeKind
- returnTc ()
-
--- If the variable was originally bound to TypeKind, we succeed
--- unless the thing its bound to is an arrow.
-unify_unbound_var True kind1 uniq1 box1 kind2@(ArrowKind k1 k2)
- = failWithTc (kindMisMatchErr kind1 kind2)
-
-unify_unbound_var type_kind kind1 uniq1 box1 non_var_or_arrow_kind2
- = occur_check non_var_or_arrow_kind2 `thenTc_`
- tcWriteMutVar box1 (BoundTo non_var_or_arrow_kind2) `thenNF_Tc_`
- returnTc ()
- where
- occur_check TypeKind = returnTc ()
- occur_check UnboxedTypeKind = returnTc ()
- occur_check BoxedTypeKind = returnTc ()
- occur_check (ArrowKind fun arg) = occur_check fun `thenTc_` occur_check arg
- occur_check kind@(VarKind uniq' box)
- | uniq1 == uniq'
- = failWithTc (kindOccurCheck kind non_var_or_arrow_kind2)
-
- | otherwise -- Different variable
- = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
- case maybe_kind of
- Unbound -> returnTc ()
- BoundTo kind' -> occur_check kind'
-\end{code}
-
-The "occurs check" is necessary to catch situation like
-
- type T k = k k
-
-
-Kind flattening
-~~~~~~~~~~~~~~~
-Coercions between TcKind and Kind.
-
-\begin{code}
--- This strange function is forced on us by the type system
-kindToTcKind :: Kind -> TcKind s
-kindToTcKind TypeKind = TypeKind
-kindToTcKind BoxedTypeKind = BoxedTypeKind
-kindToTcKind UnboxedTypeKind = UnboxedTypeKind
-kindToTcKind (ArrowKind k1 k2) = ArrowKind (kindToTcKind k1) (kindToTcKind k2)
-
-
--- Default all unbound kinds to TcTypeKind, and return the
--- corresponding Kind as well.
-tcDefaultKind :: TcKind s -> NF_TcM s Kind
-
-tcDefaultKind TypeKind = returnNF_Tc TypeKind
-tcDefaultKind BoxedTypeKind = returnNF_Tc BoxedTypeKind
-tcDefaultKind UnboxedTypeKind = returnNF_Tc UnboxedTypeKind
-
-tcDefaultKind (ArrowKind kind1 kind2)
- = tcDefaultKind kind1 `thenNF_Tc` \ k1 ->
- tcDefaultKind kind2 `thenNF_Tc` \ k2 ->
- returnNF_Tc (ArrowKind k1 k2)
-
- -- Here's where we "default" unbound kinds to BoxedTypeKind
-tcDefaultKind (VarKind uniq box)
- = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
- case maybe_kind of
- BoundTo TypeKind -> bind_to_boxed
- Unbound -> bind_to_boxed
- BoundTo kind -> tcDefaultKind kind
- where
- -- Default unbound variables to kind BoxedTypeKind
- bind_to_boxed = tcWriteMutVar box (BoundTo BoxedTypeKind) `thenNF_Tc_`
- returnNF_Tc BoxedTypeKind
-
-
-
-zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
--- Removes variables that have now been bound.
--- Mainly used just before an error message is printed,
--- so that we don't need to follow through bound variables
--- during error message construction.
-
-zonkTcKind TypeKind = returnNF_Tc TypeKind
-zonkTcKind BoxedTypeKind = returnNF_Tc BoxedTypeKind
-zonkTcKind UnboxedTypeKind = returnNF_Tc UnboxedTypeKind
-
-zonkTcKind (ArrowKind kind1 kind2)
- = zonkTcKind kind1 `thenNF_Tc` \ k1 ->
- zonkTcKind kind2 `thenNF_Tc` \ k2 ->
- returnNF_Tc (ArrowKind k1 k2)
-
-zonkTcKind kind@(VarKind uniq box)
- = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
- case maybe_kind of
- Unbound -> returnNF_Tc kind
- BoundTo kind' -> zonkTcKind kind'
-\end{code}
-
-
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
-\begin{code}
-unifyKindCtxt kind1 kind2
- = vcat [ptext SLIT("Expected:") <+> ppr kind1,
- ptext SLIT("Found: ") <+> ppr kind2]
-
-kindOccurCheck kind1 kind2
- = hang (ptext SLIT("Cannot construct the infinite kind:")) 4
- (sep [ppr kind1, equals, ppr kind1, ptext SLIT("(\"occurs check\")")])
-
-kindMisMatchErr kind1 kind2
- = hang (ptext SLIT("Couldn't match the kind")) 4
- (sep [ppr kind1,
- ptext SLIT("against"),
- ppr kind2]
- )
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMatches]{Typecheck some @Matches@}
import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
-import HsSyn ( HsBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..),
- HsExpr, MonoBinds(..),
- collectPatBinders, pprMatch, getMatchLoc
+import HsSyn ( HsBinds(..), Match(..), GRHSsAndBinds(..),
+ MonoBinds(..), StmtCtxt(..),
+ pprMatch, getMatchLoc
)
import RnHsSyn ( RenamedMatch )
-import TcHsSyn ( TcIdBndr, TcMatch )
+import TcHsSyn ( TcMatch )
import TcMonad
-import Inst ( Inst, LIE, plusLIE )
-import TcEnv ( TcIdOcc(..), newMonoIds )
+import TcMonoType ( checkSigTyVars, noSigs, existentialPatCtxt )
+import Inst ( Inst, LIE, plusLIE, emptyLIE )
+import TcEnv ( tcExtendEnvWithPat, tcExtendGlobalTyVars )
import TcPat ( tcPat )
-import TcType ( TcType, TcMaybe, zonkTcType, newTyVarTy )
-import TcSimplify ( bindInstsOfLocalFuns )
-import Unify ( unifyTauTy, unifyFunTy )
-import Name ( Name {- instance Outputable -} )
+import TcType ( TcType, newTyVarTy )
+import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
+import TcUnify ( unifyFunTy )
+import Name ( Name )
-import Kind ( Kind, mkTypeKind )
import BasicTypes ( RecFlag(..) )
-import Type ( isTauTy, mkFunTy )
+import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, openTypeKind )
+import VarSet
import Util
+import Bag
import Outputable
import SrcLoc (SrcLoc)
\end{code}
-- because inconsistency between branches
-- may show up as something wrong with the (non-existent) type signature
- -- We need to substitute so that we can see as much about the type as possible
- zonkTcType expected_ty `thenNF_Tc` \ expected_ty' ->
- tcMatchesExpected expected_ty' (MFun fun_name) matches
+ -- No need to zonk expected_ty, because unifyFunTy does that on the fly
+ tcMatchesExpected matches expected_ty (FunRhs fun_name)
)
where
LIE s)
tcMatchesCase expr_ty matches
- = newTyVarTy mkTypeKind `thenNF_Tc` \ scrut_ty ->
- tcMatchesExpected (mkFunTy scrut_ty expr_ty) MCase matches `thenTc` \ (matches', lie) ->
+ = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
+ tcMatchesExpected matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
returnTc (scrut_ty, matches', lie)
\end{code}
\begin{code}
-data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss;
- -- used to produced better error messages
-
-tcMatchesExpected :: TcType s
- -> FunOrCase
- -> [RenamedMatch]
+tcMatchesExpected :: [RenamedMatch]
+ -> TcType s
+ -> StmtCtxt
-> TcM s ([TcMatch s], LIE s)
-tcMatchesExpected expected_ty fun_or_case [match]
+tcMatchesExpected [match] expected_ty fun_or_case
= tcAddSrcLoc (getMatchLoc match) $
tcAddErrCtxt (matchCtxt fun_or_case match) $
- tcMatchExpected [] expected_ty match `thenTc` \ (match', lie) ->
+ tcMatchExpected match expected_ty fun_or_case `thenTc` \ (match', lie) ->
returnTc ([match'], lie)
-tcMatchesExpected expected_ty fun_or_case (match1 : matches)
+tcMatchesExpected (match1 : matches) expected_ty fun_or_case
= tcAddSrcLoc (getMatchLoc match1) (
tcAddErrCtxt (matchCtxt fun_or_case match1) $
- tcMatchExpected [] expected_ty match1
+ tcMatchExpected match1 expected_ty fun_or_case
) `thenTc` \ (match1', lie1) ->
- tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) ->
+ tcMatchesExpected matches expected_ty fun_or_case `thenTc` \ (matches', lie2) ->
returnTc (match1' : matches', plusLIE lie1 lie2)
\end{code}
\begin{code}
tcMatchExpected
- :: [TcIdBndr s] -- Ids bound by enclosing matches
- -> TcType s -- This gives the expected
- -- result-type of the Match. Early unification
- -- with this guy gives better error messages
- -> RenamedMatch
- -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed
- -- in instead!
-
-tcMatchExpected matched_ids expected_ty the_match@(PatMatch pat match)
- = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
-
- let binders = collectPatBinders pat
- in
- newMonoIds binders mkTypeKind (\ mono_ids ->
- tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
- unifyTauTy pat_ty arg_ty `thenTc_`
+ :: RenamedMatch
+ -> TcType s -- Expected result-type of the Match.
+ -- Early unification with this guy gives better error messages
+ -> StmtCtxt
+ -> TcM s (TcMatch s,LIE s)
- tcMatchExpected (mono_ids ++ matched_ids)
- rest_ty match `thenTc` \ (match', lie_match) ->
+tcMatchExpected match expected_ty ctxt
+ = tcMatchExpected_help emptyBag emptyBag emptyLIE match expected_ty ctxt
- returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match)
- )
-tcMatchExpected matched_ids expected_ty (GRHSMatch grhss_and_binds)
+tcMatchExpected_help bound_tvs bound_ids bound_lie
+ the_match@(PatMatch pat match) expected_ty ctxt
+ = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+
+ tcPat noSigs pat arg_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail_lie) ->
+
+ tcMatchExpected_help
+ (bound_tvs `unionBags` pat_tvs)
+ (bound_ids `unionBags` pat_ids)
+ (bound_lie `plusLIE` avail_lie)
+ match rest_ty ctxt `thenTc` \ (match', lie_match) ->
+
+ returnTc (PatMatch pat' match', pat_lie `plusLIE` lie_match)
+
+
+tcMatchExpected_help bound_tvs bound_ids bound_lie
+ (GRHSMatch grhss_and_binds) expected_ty ctxt
= -- Check that the remaining "expected type" is not a rank-2 type
-- If it is it'll mess up the unifier when checking the RHS
checkTc (isTauTy expected_ty)
lurkingRank2SigErr `thenTc_`
- tcGRHSsAndBinds expected_ty grhss_and_binds `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) ->
+ tcExtendEnvWithPat bound_ids (
+ tcGRHSsAndBinds grhss_and_binds expected_ty ctxt
+ ) `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) ->
+
+
+ -- Check for existentially bound type variables
+ tcExtendGlobalTyVars (tyVarsOfType expected_ty) (
+ tcAddErrCtxtM (existentialPatCtxt bound_tvs bound_ids) $
+ checkSigTyVars (bagToList bound_tvs) `thenTc` \ zonked_pat_tvs ->
+ tcSimplifyAndCheck
+ (text ("the existential context of a data constructor"))
+ (mkVarSet zonked_pat_tvs)
+ bound_lie lie
+ ) `thenTc` \ (ex_lie, ex_binds) ->
-- In case there are any polymorpic, overloaded binders in the pattern
-- (which can happen in the case of rank-2 type signatures, or data constructors
-- with polymorphic arguments), we must do a bindInstsOfLocalFns here
- bindInstsOfLocalFuns lie matched_ids `thenTc` \ (lie', inst_mbinds) ->
+ bindInstsOfLocalFuns ex_lie bound_id_list `thenTc` \ (inst_lie, inst_binds) ->
+
let
- binds' = case inst_mbinds of
- EmptyMonoBinds -> binds -- The common case
- other -> MonoBind inst_mbinds [] Recursive `ThenBinds` binds
+ binds' = ex_binds `glue_on` (inst_binds `glue_on` binds)
in
- returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), lie')
+ returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), inst_lie)
+ where
+ bound_id_list = map snd (bagToList bound_ids)
+
+ -- glue_on just avoids stupid dross
+ glue_on EmptyMonoBinds binds = binds -- The common case
+ glue_on mbinds binds = MonoBind mbinds [] Recursive `ThenBinds` binds
\end{code}
Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
-matchCtxt MCase match
+matchCtxt CaseAlt match
= hang (ptext SLIT("In a \"case\" branch:"))
4 (pprMatch True{-is_case-} match)
-matchCtxt (MFun fun) match
+matchCtxt (FunRhs fun) match
= hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr fun), char ':'])
4 (hcat [ppr fun, space, pprMatch False{-not case-} match])
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
import TcDefaults ( tcDefaults )
import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv,
getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
- tcLookupTyCon, initEnv, tcSetGlobalValEnv )
+ lookupGlobalByKey, tcSetGlobalValEnv,
+ tcLookupTyCon, initEnv, GlobalValueEnv
+ )
import TcExpr ( tcId )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls1 )
import TcTyDecls ( mkDataBinds )
-import TcType ( TcType, tcInstType )
-import TcKind ( TcKind, kindToTcKind )
+import TcType ( TcType, typeToTcType,
+ TcKind, kindToTcKind
+ )
import RnMonad ( RnNameSupply )
import Bag ( isEmptyBag )
-import ErrUtils ( WarnMsg, ErrMsg,
+import ErrUtils ( ErrMsg,
pprBagOfErrors, dumpIfSet
)
-import Id ( idType, GenId )
-import Name ( Name, isLocallyDefined, pprModule, NamedThing(..) )
+import Id ( Id, idType )
+import Name ( Name, nameUnique, isLocallyDefined, pprModule, NamedThing(..) )
import TyCon ( TyCon, tyConKind )
+import DataCon ( dataConId )
import Class ( Class, classSelIds, classTyCon )
import Type ( mkTyConApp, Type )
-import TyVar ( emptyTyVarEnv )
import TysWiredIn ( unitTy )
import PrelMods ( mAIN )
-import PrelInfo ( main_NAME, ioTyCon_NAME )
-import Unify ( unifyTauTy )
+import PrelInfo ( main_NAME, ioTyCon_NAME,
+ thinAirIdNames, setThinAirIds
+ )
+import TcUnify ( unifyTauTy )
import Unique ( Unique )
import UniqSupply ( UniqSupply )
import Util
import Bag ( Bag, isEmptyBag )
-import FiniteMap ( FiniteMap )
import Outputable
+
+import IOExts
\end{code}
Outside-world interface:
type TcResults
= (TypecheckedMonoBinds,
[TyCon], [Class],
- Bag InstInfo, -- Instance declaration information
+ Bag InstInfo, -- Instance declaration information
[TypecheckedForeignDecl], -- foreign import & exports.
- TcDDumpDeriv)
+ TcDDumpDeriv,
+ GlobalValueEnv,
+ [Id] -- The thin-air Ids
+ )
type TcDDumpDeriv = SDoc
dumpIfSet opt_D_dump_tc "Typechecked"
(case maybe_result of
- Just (binds, _, _, _, ds, _) -> ppr binds $$ ppr ds
- Nothing -> text "Typecheck failed") >>
+ Just (binds, _, _, _, _, _, _, _) -> ppr binds
+ Nothing -> text "Typecheck failed") >>
dumpIfSet opt_D_dump_deriv "Derived instances"
(case maybe_result of
- Just (_, _, _, _, _, dump_deriv) -> dump_deriv
- Nothing -> empty) >>
+ Just (_, _, _, _, _, dump_deriv, _, _) -> dump_deriv
+ Nothing -> empty) >>
+
+ -- write the thin-air Id map
+ (case maybe_result of
+ Just (_, _, _, _, _, _, _, thin_air_ids) -> setThinAirIds thin_air_ids
+ Nothing -> return ()
+ ) >>
return (if isEmptyBag errs then
maybe_result
-- the classes, and the global value environment with the
-- corresponding data cons.
-- They are mentioned in types in interface files.
- tcExtendGlobalValEnv (map classDataCon classes) $
+ tcExtendGlobalValEnv (map (dataConId . classDataCon) classes) $
tcExtendTyConEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, tycon))
| clas <- classes,
let tycon = classTyCon clas
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
- -- trace "tcBinds:" $
+-- trace "tc6" $
tcTopBindsAndThen
(\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
(get_val_decls decls `ThenBinds` deriv_binds)
( tcGetEnv `thenNF_Tc` \ env ->
+-- tcGetUnique `thenNF_Tc` \ uniq ->
+-- pprTrace "tc7" (ppr uniq) $
returnTc ((EmptyMonoBinds, env), emptyLIE)
) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
tcSetEnv final_env $
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
- -- trace "tc8" $
+-- pprTrace "tc8" emtpy $
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
-- restriction, and no subsequent decl instantiates its
-- type. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
- -- trace "tc9" $
let
lie_alldecls = lie_valdecls `plusLIE`
lie_instdecls `plusLIE`
tcSetGlobalValEnv really_final_env $
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
+ let
+ thin_air_ids = map (lookupGlobalByKey really_final_env . nameUnique) thinAirIdNames
+ -- When looking up the thin-air names we must use
+ -- a global env that includes the zonked locally-defined Ids too
+ -- Hence using really_final_env
+ in
returnTc (really_final_env,
- (all_binds',local_tycons, local_classes,
- inst_info, foi_decls ++ foe_decls', ddump_deriv))
+ (all_binds', local_tycons, local_classes, inst_info,
+ foi_decls ++ foe_decls',
+ ddump_deriv, really_final_env, thin_air_ids))
-- End of outer fix loop
) `thenTc` \ (final_env, stuff) ->
-- Check that it has the right type (or a more general one)
let
- expected_ty = mkTyConApp ioTyCon [unitTy]
+ expected_tau = typeToTcType (mkTyConApp ioTyCon [unitTy])
in
- tcInstType emptyTyVarEnv expected_ty `thenNF_Tc` \ expected_tau ->
tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) ->
tcSetErrCtxt mainTyCheckCtxt $
unifyTauTy expected_tau
main_tau `thenTc_`
- checkTc (isEmptyBag lie) (mainTyMisMatch expected_ty (idType main_id))
+ checkTc (isEmptyBag lie) (mainTyMisMatch expected_tau (idType main_id))
}
= hsep [ptext SLIT("Module"), quotes (pprModule mAIN),
ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
-mainTyMisMatch :: Type -> TcType s -> ErrMsg
+mainTyMisMatch :: TcType s -> TcType s -> ErrMsg
mainTyMisMatch expected actual
= hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")])
4 (vcat [
\begin{code}
module TcMonad(
+ TcType, TcMaybe(..), TcBox,
+ TcTauType, TcThetaType, TcRhoType,
+ TcTyVar, TcTyVarSet,
+ TcKind,
+
TcM, NF_TcM, TcDown, TcEnv,
SST_R, FSST_R,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ addErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
- TcError, TcWarning,
+ TcError, TcWarning, TidyTypeEnv, emptyTidyEnv,
arityErr
) where
import Type ( Type, GenType )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-import CmdLineOpts ( opt_PprStyle_All )
+import CmdLineOpts ( opt_PprStyle_Debug )
import SST
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
+import Class ( Class )
+import Var ( GenTyVar )
+import VarEnv ( TyVarEnv, emptyVarEnv )
+import VarSet ( GenTyVarSet )
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+ UniqSM, initUs )
import SrcLoc ( SrcLoc, noSrcLoc )
+import FiniteMap ( FiniteMap, emptyFM )
import UniqFM ( UniqFM, emptyUFM )
-import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
- UniqSM, initUs )
import Unique ( Unique )
import Util
import Outputable
\end{code}
+Types
+~~~~~
+\begin{code}
+type TcType s = GenType (TcBox s) -- Used during typechecker
+ -- Invariant on ForAllTy in TcTypes:
+ -- forall a. T
+ -- a cannot occur inside a MutTyVar in T; that is,
+ -- T is "flattened" before quantifying over a
+
+type TcKind s = TcType s
+
+type TcThetaType s = [(Class, [TcType s])]
+type TcRhoType s = TcType s -- No ForAllTys
+type TcTauType s = TcType s -- No DictTys or ForAllTys
+
+type TcBox s = TcRef s (TcMaybe s)
+
+data TcMaybe s = UnBound
+ | BoundTo (TcType s)
+
+-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
+-- because you get a synonym loop if you do!
+
+type TcTyVar s = GenTyVar (TcBox s)
+type TcTyVarSet s = GenTyVarSet (TcBox s)
+\end{code}
+
+
\section{TcM, NF_TcM: the type checker monads}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
failTc down env
= failFSST ()
-failWithTc :: Message -> TcM s a -- Add an error message and fail
-failWithTc err_msg
- = addErrTc err_msg `thenNF_Tc_`
+failWithTc :: Message -> TcM s a -- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
+
+addErrTc :: Message -> NF_TcM s ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+
+-- The 'M' variants do the TidyTypeEnv bit
+failWithTcM :: (TidyTypeEnv s, Message) -> TcM s a -- Add an error message and fail
+failWithTcM env_and_msg
+ = addErrTcM env_and_msg `thenNF_Tc_`
failTc
-addErrTc :: Message -> NF_TcM s () -- Add an error message but don't fail
-addErrTc err_msg down env
- = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
+addErrTcM :: (TidyTypeEnv s, Message) -> NF_TcM s () -- Add an error message but don't fail
+addErrTcM (tidy_env, err_msg) down env
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ do_ctxt tidy_env ctxt down env `thenSST` \ ctxt_msgs ->
let
err = addShortErrLocLine loc $
vcat (err_msg : ctxt_to_use ctxt_msgs)
ctxt = getErrCtxt down
loc = getLoc down
+do_ctxt tidy_env [] down env
+ = returnSST []
+do_ctxt tidy_env (c:cs) down env
+ = c tidy_env down env `thenSST` \ (tidy_env', m) ->
+ do_ctxt tidy_env' cs down env `thenSST` \ ms ->
+ returnSST (m:ms)
+
+-- warnings don't have an 'M' variant
warnTc :: Bool -> Message -> NF_TcM s ()
warnTc warn_if_true warn_msg down env
= if warn_if_true then
- readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
+ readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ do_ctxt emptyTidyEnv ctxt down env `thenSST` \ ctxt_msgs ->
let
warn = addShortWarnLocLine loc $
vcat (warn_msg : ctxt_to_use ctxt_msgs)
tcGetSrcLoc :: NF_TcM s SrcLoc
tcGetSrcLoc down env = returnSST (getLoc down)
-tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message))
+ -> TcM s a -> TcM s a
tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
-> (TcDown s -> TcEnv s -> State# s -> b)
-> TcDown s -> TcEnv s -> State# s -> b
-- Usual thing
-tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
-tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
+tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
+tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
\end{code}
= readMutVarSST u_var `thenSST` \ uniq_supply ->
let
(new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniq = getUnique uniq_s
+ uniq = uniqFromSupply uniq_s
in
writeMutVarSST u_var new_uniq_supply `thenSST_`
returnSST uniq
= readMutVarSST u_var `thenSST` \ uniq_supply ->
let
(new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = getUniques n uniq_s
+ uniqs = uniqsFromSupply n uniq_s
in
writeMutVarSST u_var new_uniq_supply `thenSST_`
returnSST uniqs
(TcRef s (Bag WarnMsg,
Bag ErrMsg))
-type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
- -- to deal with bound type variables just before error
- -- message construction
+-- The TidyTypeEnv gives us a chance to tidy up the type,
+-- so it prints nicely in error messages
+type TidyTypeEnv s = (FiniteMap FastString Int, -- Says what the 'next' unique to use
+ -- for this occname is
+ TyVarEnv (TcType s)) -- Current mapping
+
+emptyTidyEnv :: TidyTypeEnv s
+emptyTidyEnv = (emptyFM, emptyVarEnv)
+
+type ErrCtxt s = [TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message)]
+ -- Innermost first. Monadic so that we have a chance
+ -- to deal with bound type variables just before error
+ -- message construction
\end{code}
-- These selectors are *local* to TcMonad.lhs
type TcError = Message
type TcWarning = Message
-ctxt_to_use ctxt | opt_PprStyle_All = ctxt
- | otherwise = takeAtMost 3 ctxt
+ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
+ | otherwise = takeAtMost 3 ctxt
where
takeAtMost :: Int -> [a] -> [a]
takeAtMost 0 ls = []
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where
+module TcMonoType ( tcHsType, tcHsTcType, tcHsTypeKind, tcContext,
+ tcTyVarScope,
+ TcSigInfo(..), tcTySig, mkTcSig, noSigs, maybeSig,
+ checkSigTyVars, sigCtxt, existentialPatCtxt
+ ) where
#include "HsVersions.h"
-import HsSyn ( HsType(..), HsTyVar(..), pprContext )
-import RnHsSyn ( RenamedHsType, RenamedContext )
+import HsSyn ( HsType(..), HsTyVar(..), Sig(..), pprContext )
+import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig )
+import TcHsSyn ( TcIdBndr, TcIdOcc(..) )
import TcMonad
-import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv )
-import TcKind ( TcKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind,
- unifyKind, unifyKinds, newKindVar,
- kindToTcKind, tcDefaultKind
+import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv,
+ tcGetGlobalTyVars, tidyTypes, tidyTyVar
)
+import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
+ typeToTcType, tcInstTcType, kindToTcKind,
+ newKindVar,
+ zonkTcKindToKind, zonkTcTyVars, zonkTcType
+ )
+import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
+import TcUnify ( unifyKind, unifyKinds )
import Type ( Type, ThetaType,
- mkTyVarTy, mkFunTy, mkSynTy,
- mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys
+ mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
+ mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitRhoTy,
+ boxedTypeKind, unboxedTypeKind, openTypeKind,
+ mkArrowKind, getTyVar_maybe, getTyVar
)
-import TyVar ( TyVar, mkTyVar )
+import Id ( mkUserId, idName, idType, idFreeTyVars )
+import Var ( TyVar, mkTyVar )
+import VarEnv
+import VarSet
+import Bag ( bagToList )
import PrelInfo ( cCallishClassKeys )
import TyCon ( TyCon )
import Name ( Name, OccName, isTvOcc, getOccName )
-import TysWiredIn ( mkListTy, mkTupleTy )
+import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
+import SrcLoc ( SrcLoc )
import Unique ( Unique, Uniquable(..) )
-import Util ( zipWithEqual, zipLazy )
+import Util ( zipWithEqual, zipLazy, mapAccumL )
import Outputable
\end{code}
+%************************************************************************
+%* *
+\subsection{Checking types}
+%* *
+%************************************************************************
+
tcHsType and tcHsTypeKind
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tcHsType :: RenamedHsType -> TcM s Type
-
tcHsType ty
= tcAddErrCtxt (typeCtxt ty) $
tc_hs_type ty
+-- Version for when we need a TcType returned
+tcHsTcType :: RenamedHsType -> TcM s (TcType s)
+tcHsTcType ty
+ = tcHsType ty `thenTc` \ ty' ->
+ returnTc (typeToTcType ty')
+
tc_hs_type ty
= tc_hs_type_kind ty `thenTc` \ (kind,ty) ->
-- Check that it really is a type
- unifyKind mkTypeKind kind `thenTc_`
+ unifyKind openTypeKind kind `thenTc_`
returnTc ty
\end{code}
tc_hs_type_kind ty@(MonoTyVar name)
= tcFunType ty []
-tc_hs_type_kind (MonoListTy _ ty)
+tc_hs_type_kind (MonoListTy ty)
= tc_hs_type ty `thenTc` \ tau_ty ->
- returnTc (mkBoxedTypeKind, mkListTy tau_ty)
+ returnTc (boxedTypeKind, mkListTy tau_ty)
-tc_hs_type_kind (MonoTupleTy _ tys)
+tc_hs_type_kind (MonoTupleTy tys True{-boxed-})
= mapTc tc_hs_type tys `thenTc` \ tau_tys ->
- returnTc (mkBoxedTypeKind, mkTupleTy (length tys) tau_tys)
+ returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys)
+
+tc_hs_type_kind (MonoTupleTy tys False{-unboxed-})
+ = mapTc tc_hs_type tys `thenTc` \ tau_tys ->
+ returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys)
tc_hs_type_kind (MonoFunTy ty1 ty2)
= tc_hs_type ty1 `thenTc` \ tau_ty1 ->
tc_hs_type ty2 `thenTc` \ tau_ty2 ->
- returnTc (mkBoxedTypeKind, mkFunTy tau_ty1 tau_ty2)
+ returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2)
tc_hs_type_kind (MonoTyApp ty1 ty2)
= tcTyApp ty1 [ty2]
tcContext context `thenTc` \ theta ->
tc_hs_type ty `thenTc` \ tau ->
-- For-all's are of kind type!
- returnTc (mkBoxedTypeKind, mkSigmaTy tyvars theta tau)
+ returnTc (boxedTypeKind, mkSigmaTy tyvars theta tau)
-- for unfoldings, and instance decls, only:
tc_hs_type_kind (MonoDictTy class_name tys)
= tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
- returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys)
+ returnTc (boxedTypeKind, mkDictTy clas arg_tys)
\end{code}
Help functions for type applications
where
check_naughty (class_name, _)
- = checkTc (not (uniqueOf class_name `elem` cCallishClassKeys))
+ = checkTc (not (getUnique class_name `elem` cCallishClassKeys))
(naughtyCCallContextErr class_name)
tcClassAssertion (class_name, tys)
\end{code}
-Type variables, with knot tying!
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Type variables, with knot tying!}
+%* *
+%************************************************************************
+
\begin{code}
tcTyVarScope
:: [HsTyVar Name] -- Names of some type variables
(thing_inside rec_tyvars) `thenTc` \ result ->
-- Get the tyvar's Kinds from their TcKinds
- mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
+ mapNF_Tc zonkTcKindToKind kinds `thenNF_Tc` \ kinds' ->
-- Construct the real TyVars
let
= returnNF_Tc (name, kindToTcKind kind)
\end{code}
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
+
+%************************************************************************
+%* *
+\subsection{Signatures}
+%* *
+%************************************************************************
+
+@tcSigs@ checks the signatures for validity, and returns a list of
+{\em freshly-instantiated} signatures. That is, the types are already
+split up, and have fresh type variables installed. All non-type-signature
+"RenamedSigs" are ignored.
+
+The @TcSigInfo@ contains @TcTypes@ because they are unified with
+the variable's type, and after that checked to see whether they've
+been instantiated.
+
+\begin{code}
+data TcSigInfo s
+ = TySigInfo
+ Name -- N, the Name in corresponding binding
+
+ (TcIdBndr s) -- *Polymorphic* binder for this value...
+ -- Has name = N
+
+ [TcTyVar s] -- tyvars
+ (TcThetaType s) -- theta
+ (TcTauType s) -- tau
+
+ (TcIdBndr s) -- *Monomorphic* binder for this value
+ -- Does *not* have name = N
+ -- Has type tau
+
+ (Inst s) -- Empty if theta is null, or
+ -- (method mono_id) otherwise
+
+ SrcLoc -- Of the signature
+
+
+maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
+ -- Search for a particular signature
+maybeSig [] name = Nothing
+maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
+ | name == sig_name = Just sig
+ | otherwise = maybeSig sigs name
+
+-- This little helper is useful to pass to tcPat
+noSigs :: Name -> Maybe (TcIdBndr s)
+noSigs name = Nothing
+\end{code}
+
+
+\begin{code}
+tcTySig :: RenamedSig
+ -> TcM s (TcSigInfo s)
+
+tcTySig (Sig v ty src_loc)
+ = tcAddSrcLoc src_loc $
+ tcHsTcType ty `thenTc` \ sigma_tc_ty ->
+ mkTcSig (mkUserId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
+ returnTc sig
+
+mkTcSig :: TcIdBndr s -> SrcLoc -> NF_TcM s (TcSigInfo s)
+mkTcSig poly_id src_loc
+ = -- Instantiate this type
+ -- It's important to do this even though in the error-free case
+ -- we could just split the sigma_tc_ty (since the tyvars don't
+ -- unified with anything). But in the case of an error, when
+ -- the tyvars *do* get unified with something, we want to carry on
+ -- typechecking the rest of the program with the function bound
+ -- to a pristine type, namely sigma_tc_ty
+ tcInstTcType (idType poly_id) `thenNF_Tc` \ (tyvars, rho) ->
+ let
+ (theta, tau) = splitRhoTy rho
+ -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
+ -- wherever possible, which can improve interface files.
+ in
+ newMethodWithGivenTy SignatureOrigin
+ (TcId poly_id)
+ (mkTyVarTys tyvars)
+ theta tau `thenNF_Tc` \ inst ->
+ -- We make a Method even if it's not overloaded; no harm
+
+ returnNF_Tc (TySigInfo name poly_id tyvars theta tau (instToIdBndr inst) inst src_loc)
+ where
+ name = idName poly_id
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Checking signature type variables}
+%* *
+%************************************************************************
+
+@checkSigTyVars@ is used after the type in a type signature has been unified with
+the actual type found. It then checks that the type variables of the type signature
+are
+ (a) still all type variables
+ eg matching signature [a] against inferred type [(p,q)]
+ [then a will be unified to a non-type variable]
+
+ (b) still all distinct
+ eg matching signature [(a,b)] against inferred type [(p,p)]
+ [then a and b will be unified together]
+
+ (c) not mentioned in the environment
+ eg the signature for f in this:
+
+ g x = ... where
+ f :: a->[a]
+ f y = [x,y]
+
+ Here, f is forced to be monorphic by the free occurence of x.
+
+Before doing this, the substitution is applied to the signature type variable.
+
+We used to have the notion of a "DontBind" type variable, which would
+only be bound to itself or nothing. Then points (a) and (b) were
+self-checking. But it gave rise to bogus consequential error messages.
+For example:
+
+ f = (*) -- Monomorphic
+
+ g :: Num a => a -> a
+ g x = f x x
+
+Here, we get a complaint when checking the type signature for g,
+that g isn't polymorphic enough; but then we get another one when
+dealing with the (Num x) context arising from f's definition;
+we try to unify x with Int (to default it), but find that x has already
+been unified with the DontBind variable "a" from g's signature.
+This is really a problem with side-effecting unification; we'd like to
+undo g's effects when its type signature fails, but unification is done
+by side effect, so we can't (easily).
+
+So we revert to ordinary type variables for signatures, and try to
+give a helpful message in checkSigTyVars.
+
+\begin{code}
+checkSigTyVars :: [TcTyVar s] -- The original signature type variables
+ -> TcM s [TcTyVar s] -- Zonked signature type variables
+
+checkSigTyVars [] = returnTc []
+
+checkSigTyVars sig_tyvars
+ = zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys ->
+ tcGetGlobalTyVars `thenNF_Tc` \ globals ->
+ checkTcM (all_ok sig_tys globals)
+ (complain sig_tys globals) `thenTc_`
+
+ returnTc (map (getTyVar "checkSigTyVars") sig_tys)
+
+ where
+ all_ok [] acc = True
+ all_ok (ty:tys) acc = case getTyVar_maybe ty of
+ Nothing -> False -- Point (a)
+ Just tv | tv `elemVarSet` acc -> False -- Point (b) or (c)
+ | otherwise -> all_ok tys (acc `extendVarSet` tv)
+
+
+ complain sig_tys globals
+ = failWithTcM (env2, main_msg)
+ where
+ (env1, tidy_tys) = tidyTypes emptyTidyEnv sig_tys
+ (env2, tidy_tvs) = mapAccumL tidyTyVar env1 sig_tyvars
+
+ msgs = check (tidy_tvs `zip` tidy_tys) emptyVarEnv
+
+ main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
+ $$
+ nest 4 (vcat msgs)
+
+ check [] acc = []
+ check ((sig_tyvar,ty):prs) acc
+ = case getTyVar_maybe ty of
+ Nothing -- Error (a)!
+ -> unify_msg sig_tyvar (ppr ty) : check prs acc
+
+ Just tv
+ | tv `elemVarSet` globals -- Error (c)! Type variable escapes
+ -> escape_msg tv : check prs acc
+
+ | otherwise
+ -> case lookupVarEnv acc tv of
+ Nothing -- All OK
+ -> check prs (extendVarEnv acc tv sig_tyvar) -- All OK
+ Just sig_tyvar' -- Error (b)!
+ -> unify_msg sig_tyvar (ppr sig_tyvar') : check prs acc
+
+
+escape_msg tv = mk_msg tv <+> ptext SLIT("escapes; i.e. unifies with something more global")
+unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> quotes thing
+mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv)
+\end{code}
+
+These two context are used with checkSigTyVars
+
+\begin{code}
+sigCtxt thing sig_tau tidy_env
+ = zonkTcType sig_tau `thenNF_Tc` \ zonked_sig_tau ->
+ let
+ (env1, [tidy_tau, tidy_zonked_tau]) = tidyTypes tidy_env [sig_tau, zonked_sig_tau]
+
+ msg = vcat [ptext SLIT("When checking the type signature for") <+> thing,
+ nest 4 (ptext SLIT("Signature:") <+> ppr tidy_tau),
+ nest 4 (ptext SLIT("Inferred: ") <+> ppr tidy_zonked_tau)]
+ in
+ returnNF_Tc (env1, msg)
+
+existentialPatCtxt bound_tvs bound_ids tidy_env
+ = returnNF_Tc (env1,
+ sep [ptext SLIT("When checking an existential pattern that binds"),
+ nest 4 (vcat (zipWith ppr_id show_ids tidy_tys))])
+ where
+ tv_list = bagToList bound_tvs
+ show_ids = filter is_interesting (map snd (bagToList bound_ids))
+ is_interesting id = any (`elemVarSet` idFreeTyVars id) tv_list
+
+ (env1, tidy_tys) = tidyTypes tidy_env (map idType show_ids)
+ ppr_id id ty = ppr id <+> ptext SLIT("::") <+> ppr ty
+ -- Don't zonk the types so we get the separate, un-unified versions
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
+
\begin{code}
naughtyCCallContextErr clas_name
= sep [ptext SLIT("Can't use class"), quotes (ppr clas_name), ptext SLIT("in a context")]
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat, badFieldsCon ) where
+module TcPat ( tcPat, tcVarPat, badFieldCon ) where
#include "HsVersions.h"
-import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..) )
+import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) )
import RnHsSyn ( RenamedPat )
-import TcHsSyn ( TcPat )
+import TcHsSyn ( TcPat, TcIdBndr )
import TcMonad
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
- emptyLIE, plusLIE, plusLIEs, LIE,
- newMethod, newOverloadedLit
+ emptyLIE, plusLIE, LIE,
+ newMethod, newMethodWithGivenTy, newOverloadedLit,
+ newDicts, instToIdBndr
)
-import Name ( Name {- instance Outputable -} )
-import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey,
- tcLookupLocalValueOK, tcInstId
- )
-import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys )
+import Name ( Name, getOccName, getSrcLoc )
import FieldLabel ( fieldLabelName )
-import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
+import TcEnv ( TcIdOcc(..), tcLookupGlobalValue,
+ tcLookupGlobalValueByKey, newLocalId, badCon
+ )
+import TcType ( TcType, TcTyVar, tcInstTyVars )
+import TcUnify ( unifyTauTy, unifyListTy,
+ unifyTupleTy, unifyUnboxedTupleTy
+ )
-import Maybes ( maybeToBool )
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
-import Id ( GenId, idType, Id, dataConFieldLabels )
-import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-import Type ( splitFunTys, splitRhoTy,
- splitFunTy_maybe, splitAlgTyConApp_maybe,
- Type
- )
+import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity )
+import Id ( Id, idType, isDataConId_maybe )
+import Type ( Type, substFlexiTy, substFlexiTheta, mkTyConApp )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
-import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, intTy )
-import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
-import Util ( assertPanic, panic )
+import TysWiredIn ( charTy, stringTy, intTy )
+import SrcLoc ( SrcLoc )
+import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey )
+import Bag
+import Util ( zipEqual )
import Outputable
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Variable patterns}
+%* *
+%************************************************************************
+
+\begin{code}
+tcVarPat :: (Name -> Maybe (TcIdBndr s)) -- Info about signatures
+ -> Name
+ -> TcType s -- Expected type
+ -> TcM s (TcIdBndr s) -- The monomorphic Id; this is put in the pattern itself
+
+tcVarPat sig_fn binder_name pat_ty
+ = case sig_fn binder_name of
+ Nothing -> newLocalId (getOccName binder_name) pat_ty `thenNF_Tc` \ bndr_id ->
+ returnTc bndr_id
+
+ Just bndr_id -> tcAddSrcLoc (getSrcLoc binder_name) $
+ unifyTauTy pat_ty (idType bndr_id) `thenTc_`
+ returnTc bndr_id
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Typechecking patterns}
+%* *
+%************************************************************************
+
\begin{code}
-tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
+tcPat :: (Name -> Maybe (TcIdBndr s)) -- Info about signatures
+ -> RenamedPat
+ -> TcType s -- Expected type
+ -> TcM s (TcPat s,
+ LIE s, -- Required by n+k and literal pats
+ Bag (TcTyVar s), -- TyVars bound by the pattern
+ Bag (Name, TcIdBndr s), -- Ids bound by the pattern, along with the Name under
+ -- which it occurs in the pattern
+ -- The two aren't the same because we conjure up a new
+ -- local name for each variable.
+ LIE s) -- Dicts or methods [see below] bound by the pattern
\end{code}
+
%************************************************************************
%* *
\subsection{Variables, wildcards, lazy pats, as-pats}
%************************************************************************
\begin{code}
-tcPat (VarPatIn name)
- = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id ->
- returnTc (VarPat (TcId id), emptyLIE, idType id)
+tcPat sig_fn (VarPatIn name) pat_ty
+ = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
+ returnTc (VarPat (TcId bndr_id), emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
-tcPat (LazyPatIn pat)
- = tcPat pat `thenTc` \ (pat', lie, ty) ->
- returnTc (LazyPat pat', lie, ty)
+tcPat sig_fn (LazyPatIn pat) pat_ty
+ = tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+ returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
-tcPat pat_in@(AsPatIn name pat)
- = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
- tcPat pat `thenTc` \ (pat', lie, ty) ->
+tcPat sig_fn pat_in@(AsPatIn name pat) pat_ty
+ = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
+ tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
tcAddErrCtxt (patCtxt pat_in) $
- unifyTauTy (idType id) ty `thenTc_`
- returnTc (AsPat (TcId id) pat', lie, ty)
+ returnTc (AsPat (TcId bndr_id) pat', lie_req,
+ tvs, (name, bndr_id) `consBag` ids,
+ lie_avail)
-tcPat WildPatIn
- = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
- returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
+tcPat sig_fn WildPatIn pat_ty
+ = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
-tcPat (NegPatIn pat)
- = tcPat (negate_lit pat)
+tcPat sig_fn (NegPatIn pat) pat_ty
+ = tcPat sig_fn (negate_lit pat) pat_ty
where
negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
negate_lit _ = panic "TcPat:negate_pat"
-tcPat (ParPatIn parend_pat)
- = tcPat parend_pat
+tcPat sig_fn (ParPatIn parend_pat) pat_ty
+ = tcPat sig_fn parend_pat pat_ty
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat pat_in@(ListPatIn pats)
- = tcPats pats `thenTc` \ (pats', lie, tys) ->
- newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
- tcAddErrCtxt (patCtxt pat_in) $
- unifyTauTyList (tyvar_ty:tys) `thenTc_`
+tcPat sig_fn pat_in@(ListPatIn pats) pat_ty
+ = tcAddErrCtxt (patCtxt pat_in) $
+ unifyListTy pat_ty `thenTc` \ elem_ty ->
+ tcPats sig_fn pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+ returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
- returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
+tcPat sig_fn pat_in@(TuplePatIn pats boxed) pat_ty
+ = tcAddErrCtxt (patCtxt pat_in) $
-tcPat pat_in@(TuplePatIn pats)
- = let
- arity = length pats
- in
- tcPats pats `thenTc` \ (pats', lie, tys) ->
-
- -- Make sure we record that the tuples can only contain boxed types
- newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
+ (if boxed
+ then unifyTupleTy arity pat_ty
+ else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_tys ->
- tcAddErrCtxt (patCtxt pat_in) $
- unifyTauTyLists tyvar_tys tys `thenTc_`
+ tcPats sig_fn pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
-- possibly do the "make all tuple-pats irrefutable" test:
let
- unmangled_result = TuplePat pats'
+ unmangled_result = TuplePat pats' boxed
-- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
-- so that we can experiment with lazy tuple-matching.
-- it was easy to do.
possibly_mangled_result
- = if opt_IrrefutableTuples
- then LazyPat unmangled_result
- else unmangled_result
-
- -- ToDo: IrrefutableEverything
+ | opt_IrrefutableTuples && boxed = LazyPat unmangled_result
+ | otherwise = unmangled_result
in
- returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
+ returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
+ where
+ arity = length pats
\end{code}
%************************************************************************
%* *
\subsection{Other constructors}
%* *
-%************************************************************************
-Constructor patterns are a little fun:
-\begin{itemize}
-\item
-typecheck the arguments
-\item
-look up the constructor
-\item
-specialise its type (ignore the translation this produces)
-\item
-check that the context produced by this specialisation is empty
-\item
-get the arguments out of the function type produced from specialising
-\item
-unify them with the types of the patterns
-\item
-back substitute with the type of the result of the constructor
-\end{itemize}
-
-ToDo: exploit new representation of constructors to make this more
-efficient?
+%************************************************************************
\begin{code}
-tcPat pat_in@(ConPatIn name pats)
- = tcPats pats `thenTc` \ (pats', lie, tys) ->
-
- tcAddErrCtxt (patCtxt pat_in) $
- matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
-
- returnTc (ConPat con_id data_ty pats',
- lie,
- data_ty)
-
-tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form...
- = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
- tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
-
- tcAddErrCtxt (patCtxt pat_in) $
- matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
+tcPat sig_fn pat@(ConPatIn name arg_pats) pat_ty
+ = tcConPat sig_fn pat name arg_pats pat_ty
- returnTc (ConOpPat pat1' con_id pat2' data_ty,
- lie1 `plusLIE` lie2,
- data_ty)
+tcPat sig_fn pat@(ConOpPatIn pat1 op _ pat2) pat_ty
+ = tcConPat sig_fn pat op [pat1, pat2] pat_ty
\end{code}
+
%************************************************************************
%* *
\subsection{Records}
%************************************************************************
\begin{code}
-tcPat pat_in@(RecPatIn name rpats)
- = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
- tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
- let
- -- Ignore the con_theta; overloaded constructors only
- -- behave differently when called, not when used for
- -- matching.
- (_, record_ty) = splitFunTys con_tau
+tcPat sig_fn pat@(RecPatIn name rpats) pat_ty
+ = tcAddErrCtxt (patCtxt pat) $
- field_names = map fieldLabelName (dataConFieldLabels con_id)
- bad_fields = [f | (f,_,_) <- rpats, not (f `elem` field_names)]
+ -- Check the constructor itself
+ tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
+ let
+ field_tys = zipEqual "tcPat"
+ (map fieldLabelName (dataConFieldLabels data_con))
+ arg_tys
in
- -- Check that all the fields are from this constructor
- checkTc (null bad_fields) (badFieldsCon name bad_fields) `thenTc_`
-
- -- Con is syntactically constrained to be a data constructor
- ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
- mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
+ -- Check the fields
+ tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
- returnTc (RecPat con_id record_ty rpats',
- plusLIEs lies,
- record_ty)
+ returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
+ lie_req,
+ listToBag ex_tvs `unionBags` tvs,
+ ids,
+ lie_avail1 `plusLIE` lie_avail2)
where
- do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
- = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
- tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
-
- -- Record selectors all have type
- -- forall a1..an. T a1 .. an -> tau
- ASSERT( maybeToBool (splitFunTy_maybe tau) )
- let
- -- Selector must have type RecordType -> FieldType
- Just (record_ty, field_ty) = splitFunTy_maybe tau
- in
- tcAddErrCtxt (recordLabel field_label) (
- unifyTauTy expected_record_ty record_ty
- ) `thenTc_`
- tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
- tcAddErrCtxt (recordRhs field_label rhs_pat) (
- unifyTauTy field_ty rhs_ty
- ) `thenTc_`
- returnTc ((sel_id, rhs_pat', pun_flag), lie)
+ tc_fields field_tys []
+ = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+ tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
+ | null matching_fields
+ = addErrTc (badFieldCon name field_label) `thenNF_Tc_`
+ tc_fields field_tys rpats
+
+ | otherwise
+ = ASSERT( null extras )
+ tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
+
+ tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
+ tcPat sig_fn rhs_pat rhs_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
+
+ returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
+ lie_req1 `plusLIE` lie_req2,
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2,
+ lie_avail1 `plusLIE` lie_avail2)
+ where
+ matching_fields = [ty | (f,ty) <- field_tys, f == field_label]
+ (rhs_ty : extras) = matching_fields
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat (LitPatIn lit@(HsChar str))
- = returnTc (LitPat lit charTy, emptyLIE, charTy)
-
-tcPat (LitPatIn lit@(HsString str))
- = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
- newMethod (LiteralOrigin lit)
- (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
- let
- comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
- in
- returnTc (NPat lit stringTy comp_op, lie, stringTy)
-
-tcPat (LitPatIn lit@(HsIntPrim _))
- = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
-tcPat (LitPatIn lit@(HsCharPrim _))
- = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
-tcPat (LitPatIn lit@(HsStringPrim _))
- = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
-tcPat (LitPatIn lit@(HsFloatPrim _))
- = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
-tcPat (LitPatIn lit@(HsDoublePrim _))
- = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
+tcPat sig_fn (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty
+tcPat sig_fn (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty
+tcPat sig_fn (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty
+tcPat sig_fn (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty
+tcPat sig_fn (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty
+tcPat sig_fn (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
+
+tcPat sig_fn (LitPatIn lit@(HsLitLit s)) pat_ty = tcSimpleLitPat lit intTy pat_ty
+ -- This one looks weird!
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat (LitPatIn lit@(HsInt i))
- = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
- newOverloadedLit origin
- (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
-
- tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
- newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
-
- returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
- over_lit_expr),
- lie1 `plusLIE` lie2,
- tyvar_ty)
- where
- origin = LiteralOrigin lit
+tcPat sig_fn pat@(LitPatIn lit@(HsString str)) pat_ty
+ = unifyTauTy pat_ty stringTy `thenTc_`
+ tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
+ newMethod (PatOrigin pat)
+ (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
+ let
+ comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
+ in
+ returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
-tcPat (LitPatIn lit@(HsFrac f))
- = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
- newOverloadedLit origin
- (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
- tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
- newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
+tcPat sig_fn pat@(LitPatIn lit@(HsInt i)) pat_ty
+ = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
- returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
- over_lit_expr),
- lie1 `plusLIE` lie2,
- tyvar_ty)
- where
- origin = LiteralOrigin lit
+tcPat sig_fn pat@(LitPatIn lit@(HsFrac f)) pat_ty
+ = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
-tcPat (LitPatIn lit@(HsLitLit s))
--- = error "tcPat: can't handle ``literal-literal'' patterns"
- = returnTc (LitPat lit intTy, emptyLIE, intTy)
-tcPat (NPlusKPatIn name lit@(HsInt i))
- = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local ->
- let
- local_ty = idType local
- in
+tcPat sig_fn pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
+ = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
newOverloadedLit origin
- (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+ (OverloadedIntegral i) pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
- newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) ->
- newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) ->
+ newMethod origin (RealId ge_sel_id) [pat_ty] `thenNF_Tc` \ (lie2, ge_id) ->
+ newMethod origin (RealId minus_sel_id) [pat_ty] `thenNF_Tc` \ (lie3, minus_id) ->
- returnTc (NPlusKPat (TcId local) lit local_ty
+ returnTc (NPlusKPat (TcId bndr_id) lit pat_ty
(SectionR (HsVar ge_id) over_lit_expr)
(SectionR (HsVar minus_id) over_lit_expr),
lie1 `plusLIE` lie2 `plusLIE` lie3,
- local_ty)
+ emptyBag, unitBag (name, bndr_id), emptyLIE)
where
- origin = LiteralOrigin lit -- Not very good!
+ origin = PatOrigin pat
-tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal"
+tcPat sig_fn (NPlusKPatIn pat other) pat_ty
+ = panic "TcPat:NPlusKPat: not an HsInt literal"
\end{code}
%************************************************************************
%* *
%************************************************************************
+Helper functions
+
\begin{code}
-tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
+tcPats :: (Name -> Maybe (TcIdBndr s)) -- Info about signatures
+ -> [RenamedPat] -> [TcType s] -- Excess 'expected types' discarded
+ -> TcM s ([TcPat s],
+ LIE s, -- Required by n+k and literal pats
+ Bag (TcTyVar s),
+ Bag (Name, TcIdBndr s), -- Ids bound by the pattern
+ LIE s) -- Dicts bound by the pattern
+
+tcPats sig_fn [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+tcPats sig_fn (ty:tys) (pat:pats)
+ = tcPat sig_fn ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) ->
+ tcPats sig_fn tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
+
+ returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
+ tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
+ lie_avail1 `plusLIE` lie_avail2)
+\end{code}
-tcPats [] = returnTc ([], emptyLIE, [])
+------------------------------------------------------
+\begin{code}
+tcSimpleLitPat lit lit_ty pat_ty
+ = unifyTauTy pat_ty lit_ty `thenTc_`
+ returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
-tcPats (pat:pats)
- = tcPat pat `thenTc` \ (pat', lie, ty) ->
- tcPats pats `thenTc` \ (pats', lie', tys) ->
- returnTc (pat':pats', plusLIE lie lie', ty:tys)
-\end{code}
+tcOverloadedLitPat pat lit over_lit pat_ty
+ = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+ tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
+ newMethod origin (RealId eq_sel_id) [pat_ty] `thenNF_Tc` \ (lie2, eq_id) ->
-@matchConArgTys@ grabs the signature of the data constructor, and
-unifies the actual args against the expected ones.
+ returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
+ over_lit_expr),
+ lie1 `plusLIE` lie2,
+ emptyBag, emptyBag, emptyLIE)
+ where
+ origin = PatOrigin pat
+\end{code}
+------------------------------------------------------
\begin{code}
-matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
-
-matchConArgTys con arg_tys
- = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
- tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
- -- Ignore the con_theta; overloaded constructors only
+tcConstructor pat con_name pat_ty
+ = -- Check that it's a constructor
+ tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
+ case isDataConId_maybe con_id of {
+ Nothing -> failWithTc (badCon con_id);
+ Just data_con ->
+
+ -- Instantiate it
+ let
+ (tvs, theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
+ -- Ignore the theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
+ in
+ tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
+ let
+ ex_theta' = substFlexiTheta tenv ex_theta
+ arg_tys' = map (substFlexiTy tenv) arg_tys
+
+ n_ex_tvs = length ex_tvs
+ ex_tvs' = take n_ex_tvs all_tvs'
+ result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
+ in
+ newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) ->
+
+ -- Check overall type matches
+ unifyTauTy pat_ty result_ty `thenTc_`
+
+ returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys')
+ }
+\end{code}
+
+------------------------------------------------------
+\begin{code}
+tcConPat sig_fn pat con_name arg_pats pat_ty
+ = tcAddErrCtxt (patCtxt pat) $
+
+ -- Check the constructor itself
+ tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->
+
+ -- Check correct arity
let
- (con_args, con_result) = splitFunTys con_tau
- con_arity = length con_args
- no_of_args = length arg_tys
+ con_arity = dataConSourceArity data_con
+ no_of_args = length arg_pats
in
checkTc (con_arity == no_of_args)
- (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
+ (arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
+
+ -- Check arguments
+ tcPats sig_fn arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
- unifyTauTyLists con_args arg_tys `thenTc_`
- returnTc (con_id, con_result)
+ returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
+ lie_req,
+ listToBag ex_tvs' `unionBags` tvs,
+ ids,
+ lie_avail1 `plusLIE` lie_avail2)
\end{code}
-% =================================================
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
+
\begin{code}
patCtxt pat = hang (ptext SLIT("In the pattern:"))
4 (ppr pat)
= hang (ptext SLIT("In the record field pattern"))
4 (sep [ppr field_label, char '=', ppr pat])
-badFieldsCon :: Name -> [Name] -> SDoc
-badFieldsCon con fields
+badFieldCon :: Name -> Name -> SDoc
+badFieldCon con field
= hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
- ptext SLIT("does not have field(s):"), pprQuotedList fields]
+ ptext SLIT("does not have field"), quotes (ppr field)]
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcSimplify]{TcSimplify}
#include "HsVersions.h"
-import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds )
+import CmdLineOpts ( opt_MaxContextReductionDepth )
+import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
TcMonoBinds, TcDictBinds
)
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld,
instLoc, getDictClassTys,
- pprInst, zonkInst,
- Inst, LIE, pprInsts, pprInstsInFull, mkLIE,
- InstOrigin, pprOrigin
+ pprInst, zonkInst, tidyInst, tidyInsts,
+ Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
+ plusLIE, pprOrigin
)
import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars )
-import TcType ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta )
-import Unify ( unifyTauTy )
-import Id ( mkIdSet )
+import TcType ( TcType, TcTyVarSet, typeToTcType )
+import TcUnify ( unifyTauTy )
+import Id ( idType )
+import VarSet ( mkVarSet )
-import Bag ( Bag, bagToList, snocBag )
+import Bag ( bagToList )
import Class ( Class, ClassInstEnv, classBigSig, classInstEnv )
import PrelInfo ( isNumericClass, isCreturnableClass )
-import Maybes ( maybeToBool )
import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
- isTyVarTy, instantiateThetaTy
+ isTyVarTy, substFlexiTheta, splitSigmaTy,
+ tyVarsOfTypes
)
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
-import TyVar ( intersectTyVarSets, unionManyTyVarSets, minusTyVarSet,
- isEmptyTyVarSet, tyVarSetToList, unionTyVarSets,
- zipTyVarEnv, emptyTyVarEnv
- )
+import VarSet
+import VarEnv ( zipVarEnv )
import FiniteMap
import BasicTypes ( TopLevelFlag(..) )
-import Unique ( Unique )
+import CmdLineOpts ( opt_GlasgowExts )
import Outputable
import Util
import List ( partition )
LIE s) -- Remaining wanteds; no dups
tcSimplify str top_lvl local_tvs wanted_lie
+ | isEmptyVarSet local_tvs
+ = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
+
+ | otherwise
= reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
-- Check for non-generalisable insts
-- But we can get stuck with
-- C a b
-- where "a" is one of the local_tvs, but "b" is unconstrained.
- -- Then we must yell about the ambiguous b.
+ -- Then we must yell about the ambiguous b
-- But we must only do so if "b" really is unconstrained; so
-- we must grab the global tyvars to answer that question
tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
let
- avail_tvs = local_tvs `unionTyVarSets` global_tvs
- (irreds', bad_guys) = partition (isEmptyTyVarSet . ambig_tv_fn) irreds
- ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` avail_tvs
+ avail_tvs = local_tvs `unionVarSet` global_tvs
+ (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
+ ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
in
addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
try_me inst
-- Does not constrain a local tyvar
- | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
+ | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
= -- if is_top_level then
-- FreeIfTautological -- Special case for inference on
-- -- top-level defns
TcDictBinds s) -- Bindings
tcSimplifyAndCheck str local_tvs given_lie wanted_lie
+ | isEmptyVarSet local_tvs
+ -- This can happen quite legitimately; for example in
+ -- instance Num Int where ...
+ = returnTc (wanted_lie, EmptyMonoBinds)
+
+ | otherwise
= reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
-- Complain about any irreducible ones
try_me inst
-- Does not constrain a local tyvar
- | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
+ | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
= Free
-- When checking against a given signature we always reduce
foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
-- Do the real work
- reduce try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
+ reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
-- Extract the bindings from avails
let
| otherwise = binds
in
{-
- pprTrace ("reduceContext1") (vcat [
+ pprTrace ("reduceContext end") (vcat [
text "----------------------",
str,
text "given" <+> ppr givens,
text "wanted" <+> ppr wanteds,
text "----",
text "avails" <+> pprAvails avails,
- text "free" <+> ppr frees,
- text "irreds" <+> ppr irreds,
+ text "irreds" <+> ppr irreds,
text "----------------------"
]) $
-}
The main context-reduction function is @reduce@. Here's its game plan.
\begin{code}
-reduce :: (Inst s -> WhatToDo)
- -> [Inst s]
- -> RedState s
- -> TcM s (RedState s)
+reduceList :: (Int,[Inst s])
+ -> (Inst s -> WhatToDo)
+ -> [Inst s]
+ -> RedState s
+ -> TcM s (RedState s)
\end{code}
@reduce@ is passed
wanteds: The list of insts to reduce
state: An accumulating parameter of type RedState
that contains the state of the algorithm
-
+
It returns a RedState.
\begin{code}
- -- Base case: we're done!
-reduce try_me [] state = returnTc state
+reduceList (n,stack) try_me wanteds state
+ | n > opt_MaxContextReductionDepth
+ = failWithTc (reduceDepthErr n stack)
-reduce try_me (wanted:wanteds) state@(avails, frees, irreds)
+ | otherwise
+ =
+#ifdef DEBUG
+ (if n > 4 then
+ pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
+ else (\x->x))
+#endif
+ go wanteds state
+ where
+ go [] state = returnTc state
+ go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
+ go ws state'
+
+ -- Base case: we're done!
+reduce stack try_me wanted state@(avails, frees, irreds)
-- It's the same as an existing inst, or a superclass thereof
| wanted `elemFM` avails
- = reduce try_me wanteds (activate avails wanted, frees, irreds)
+ = returnTc (activate avails wanted, frees, irreds)
-- It should be reduced
| case try_me_result of { ReduceMe _ -> True; _ -> False }
returnTc (avails', frees, wanted:irreds))
-- If tautology succeeds, just add to frees
- (reduce try_me_taut [wanted] (avails, [], []) `thenTc_`
+ (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
returnTc (avails, wanted:frees, irreds))
- `thenTc` \ state' ->
- reduce try_me wanteds state'
-- It's irreducible (or at least should not be reduced)
where
-- The three main actions
- add_to_frees = reduce try_me wanteds (avails, wanted:frees, irreds)
+ add_to_frees = let
+ avails' = addFree avails wanted
+ -- Add the thing to the avails set so any identical Insts
+ -- will be commoned up with it right here
+ in
+ returnTc (avails', wanted:frees, irreds)
add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
- reduce try_me wanteds (avails', frees, wanted:irreds)
+ returnTc (avails', frees, wanted:irreds)
use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
- reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds)
-
+ reduceList stack try_me wanteds' (avails', frees, irreds)
try_me_result = try_me wanted
ReduceMe no_instance_action = try_me_result
rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
| otherwise = NoRhs
+addFree :: Avails s -> Inst s -> (Avails s)
+ -- When an Inst is tossed upstairs as 'free' we nevertheless add it
+ -- to avails, so that any other equal Insts will be commoned up right
+ -- here rather than also being tossed upstairs.
+addFree avails free
+ | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
+ | otherwise = avails
+
addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
addGiven avails given
= -- ASSERT( not (given `elemFM` avails) )
- -- This assertion isn' necessarily true. It's permitted
+ -- This assertion isn't necessarily true. It's permitted
-- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
-- and when typechecking instance decls we generate redundant "givens" too.
addAvail avails given avail
= returnNF_Tc avails
| otherwise -- It is a dictionary
- = tcInstTheta env sc_theta `thenNF_Tc` \ sc_theta' ->
- foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
+ = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
- env = zipTyVarEnv tyvars tys
+ sc_theta' = substFlexiTheta (zipVarEnv tyvars tys) sc_theta
add_sc avails ((super_clas, super_tys), sc_sel)
= newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
= reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
let
-- Check that the returned dictionaries are of the form (C a b c)
- bad_guys = [ct | ct@(clas,tys) <- irreds, not (all isTyVarTy tys)]
+ bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
+ isEmptyVarSet (tyVarsOfTypes tys)]
+ | otherwise = [ct | ct@(clas,tys) <- irreds,
+ not (all isTyVarTy tys)]
+
in
if null bad_guys then
returnTc irreds
-> NF_TcM s ThetaType -- Irreducible
reduceSimple inst_mapper givens wanteds
- = reduce_simple inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
+ = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
where
givens_fm = foldl addNonIrred emptyFM givens
-reduce_simple :: (Class -> ClassInstEnv)
+reduce_simple :: (Int,ThetaType) -- Stack
+ -> (Class -> ClassInstEnv)
-> AvailsSimple
-> ThetaType
-> NF_TcM s AvailsSimple
-reduce_simple inst_mapper givens []
- = -- Finished, so pull out the needed ones
- returnNF_Tc givens
+reduce_simple (n,stack) inst_mapper avails wanteds
+ = go avails wanteds
+ where
+ go avails [] = returnNF_Tc avails
+ go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
+ go avails' ws
-reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds)
+reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
| wanted `elemFM` givens
- = reduce_simple inst_mapper givens wanteds
+ = returnNF_Tc givens
| otherwise
= lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
case maybe_theta of
- Nothing -> reduce_simple inst_mapper (addIrred givens wanted) wanteds
- Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds)
+ Nothing -> returnNF_Tc (addIrred givens wanted)
+ Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
addIrred givens ct
= foldl add givens sc_theta
where
(tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
- sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl
+ sc_theta = substFlexiTheta (zipVarEnv tyvars tys) sc_theta_tmpl
add givens ct = case lookupFM givens ct of
Nothing -> -- Add it and its superclasses
bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
bindInstsOfLocalFuns init_lie local_ids
+ | null overloaded_ids || null lie_for_here
+ -- Common case
+ = returnTc (init_lie, EmptyMonoBinds)
+
+ | otherwise
= reduceContext (text "bindInsts" <+> ppr local_ids)
- try_me [] (bagToList init_lie) `thenTc` \ (binds, frees, irreds) ->
+ try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
ASSERT( null irreds )
- returnTc (mkLIE frees, binds)
+ returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
where
- local_id_set = mkIdSet local_ids -- There can occasionally be a lot of them
- -- so it's worth building a set, so that
- -- lookup (in isMethodFor) is faster
- try_me inst | isMethodFor local_id_set inst = ReduceMe AddToIrreds
- | otherwise = Free
+ overloaded_ids = filter is_overloaded local_ids
+ is_overloaded id = case splitSigmaTy (idType id) of
+ (_, theta, _) -> not (null theta)
+
+ overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
+ -- so it's worth building a set, so that
+ -- lookup (in isMethodFor) is faster
+
+ -- No sense in repeatedly zonking lots of
+ -- constant constraints so filter them out here
+ (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
+ (bagToList init_lie)
+ try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
+ | otherwise = Free
\end{code}
-- Have a try at disambiguation
-- if the type variable isn't bound
-- up with one of the non-standard classes
- worth_a_try group@(d:_) = isEmptyTyVarSet (tyVarsOfInst d `intersectTyVarSets` non_std_tyvars)
- non_std_tyvars = unionManyTyVarSets (map tyVarsOfInst non_stds)
+ worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
+ non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
-- Collect together all the bad guys
bad_guys = non_stds ++ concat std_bads
-- And complain about the ones that don't
mapNF_Tc complain bad_guys `thenNF_Tc_`
- returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig)
+ returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
where
wanteds = bagToList wanted_lie
try_me inst = ReduceMe AddToIrreds
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
- complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d
+ complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
| otherwise = addAmbigErr tyVarsOfInst d
get_tv d = case getDictClassTys d of
try_default default_tys `thenTc` \ chosen_default_ty ->
-- Bind the type variable and reduce the context, for real this time
- tcInstType emptyTyVarEnv chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
+ let
+ chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
+ in
unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
reduceContext (text "disambig" <+> ppr dicts)
try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
addAmbigErr ambig_tv_fn dict
= tcAddSrcLoc (instLoc dict) $
- addErrTc (sep [text "Ambiguous type variable(s)",
- hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
- nest 4 (text "in the constraint" <+> quotes (pprInst dict)),
+ addErrTcM (tidy_env,
+ sep [text "Ambiguous type variable(s)" <+>
+ hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
+ nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)),
nest 4 (pprOrigin dict)])
where
- ambig_tvs = tyVarSetToList (ambig_tv_fn dict)
+ ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
-- Used for top-level irreducibles
addTopInstanceErr dict
= tcAddSrcLoc (instLoc dict) $
- addErrTc (sep [ptext SLIT("No instance for") <+> quotes (pprInst dict),
- nest 4 $ parens $ pprOrigin dict])
+ addErrTcM (tidy_env,
+ sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict),
+ nest 4 $ pprOrigin dict])
+ where
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
addNoInstanceErr str givens dict
= tcAddSrcLoc (instLoc dict) $
- addErrTc (sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst dict),
+ addErrTcM (tidy_env,
+ sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
nest 4 $ parens $ pprOrigin dict],
- nest 4 $ ptext SLIT("from the context") <+> pprInsts givens]
+ nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens]
$$
ptext SLIT("Probable cause:") <+>
- vcat [ptext SLIT("missing") <+> quotes (pprInst dict) <+> ptext SLIT("in") <+> str,
+ vcat [ptext SLIT("missing") <+> quotes (pprInst tidy_dict) <+> ptext SLIT("in") <+> str,
if all_tyvars then empty else
- ptext SLIT("or missing instance declaration for") <+> quotes (pprInst dict)]
+ ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
)
where
all_tyvars = all isTyVarTy tys
(_, tys) = getDictClassTys dict
+ (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
-- Used for the ...Thetas variants; all top level
addNoInstErr (c,ts)
= addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
+
+reduceDepthErr n stack
+ = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
+ ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
+ nest 4 (pprInstsInFull stack)]
+
+reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[TcTyClsDecls]{Typecheck type and class declarations}
Sig(..),
hsDeclName
)
-import RnHsSyn ( RenamedTyDecl, RenamedClassDecl, RenamedHsDecl )
-import TcHsSyn ( TcHsBinds )
-import BasicTypes ( RecFlag(..) )
+import RnHsSyn ( RenamedHsDecl )
+import RnEnv ( listTyCon_name, tupleTyCon_name ) -- ToDo: move these
+import BasicTypes ( RecFlag(..), Arity )
import TcMonad
import Inst ( InstanceMapper )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv )
-import TcKind ( TcKind, newKindVar, newKindVars, tcDefaultKind, kindToTcKind )
-import TcTyDecls ( tcTyDecl, mkDataBinds )
+import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind )
+import TcTyDecls ( tcTyDecl )
import TcMonoType ( tcTyVarScope )
import TyCon ( tyConKind, tyConArity, isSynTyCon )
import Class ( Class, classBigSig )
-import TyVar ( tyVarKind )
+import Var ( tyVarKind )
import Bag
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon, Arity )
+import TyCon ( TyCon )
import Unique ( Unique, Uniquable(..) )
import Util ( panic{-, pprTrace-} )
\begin{code}
sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl]
sortByDependency decls
- = let -- CHECK FOR SYNONYM CYCLES
+ = let -- CHECK FOR CLASS CYCLES
+ cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges decls)
+ cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
+ in
+ checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
+
+ let -- CHECK FOR SYNONYM CYCLES
syn_sccs = stronglyConnComp (filter is_syn_decl edges)
syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
in
checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
- let -- CHECK FOR CLASS CYCLES
- cls_sccs = stronglyConnComp (filter is_cls_decl edges)
- cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
-
- in
- checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
-
- -- DO THE MAIN DEPENDENCY ANALYSIS
+ -- DO THE MAIN DEPENDENCY ANALYSIS
let
- decl_sccs = stronglyConnComp (filter is_ty_cls_decl edges)
+ decl_sccs = stronglyConnComp edges
in
returnTc decl_sccs
-
where
edges = mapMaybe mk_edges decls
-bag_acyclic (AcyclicSCC scc) = unitBag scc
-bag_acyclic (CyclicSCC sccs) = listToBag sccs
-
is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
is_syn_decl _ = False
-is_ty_cls_decl (TyD _, _, _) = True
-is_ty_cls_decl (ClD _, _, _) = True
-is_ty_cls_decl other = False
-
is_cls_decl (ClD _, _, _) = True
is_cls_decl other = False
\end{code}
Edges in Type/Class decls
~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+-- mk_cls_edges looks only at the context of class decls
+-- Its used when we are figuring out if there's a cycle in the
+-- superclass hierarchy
+
+mk_cls_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
+
+mk_cls_edges decl@(ClD (ClassDecl ctxt name _ _ _ _ _ _ _))
+ = Just (decl, getUnique name, map (getUnique . fst) ctxt)
+mk_cls_edges other_decl
+ = Nothing
+
+
+mk_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
+
mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
- = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+ = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_cons condecls `unionUniqSets`
get_deriv derivs))
mk_edges decl@(TyD (TySynonym name _ rhs _))
- = Just (decl, uniqueOf name, uniqSetToList (get_ty rhs))
+ = Just (decl, getUnique name, uniqSetToList (get_ty rhs))
mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _))
- = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+ = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_sigs sigs))
mk_edges other_decl = Nothing
get_cons cons = unionManyUniqSets (map get_con cons)
-get_con (ConDecl _ ctxt details _)
+get_con (ConDecl _ _ ctxt details _)
= get_ctxt ctxt `unionUniqSets` get_con_details details
get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
= unionUniqSets (get_ty ty1) (get_ty ty2)
get_ty (MonoFunTy ty1 ty2)
= unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoListTy tc ty)
- = set_name tc `unionUniqSets` get_ty ty
-get_ty (MonoTupleTy tc tys)
- = set_name tc `unionUniqSets` get_tys tys
+get_ty (MonoListTy ty)
+ = set_name listTyCon_name `unionUniqSets` get_ty ty
+get_ty (MonoTupleTy tys boxed)
+ = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
get_ty (HsForAllTy _ ctxt mty)
= get_ctxt ctxt `unionUniqSets` get_ty mty
get_ty other = panic "TcTyClsDecls:get_ty"
get_sig (ClassOpSig _ _ ty _) = get_ty ty
get_sig other = panic "TcTyClsDecls:get_sig"
-set_name name = unitUniqSet (uniqueOf name)
+set_name name = unitUniqSet (getUnique name)
set_to_bag set = listToBag (uniqSetToList set)
\end{code}
get_binders
~~~~~~~~~~~
Extract *binding* names from type and class decls. Type variables are
-bound in type, data, newtype and class declarations and the polytypes
-in the class op sigs.
+bound in type, data, newtype and class declarations,
+ *and* the polytypes in the class op sigs.
+ *and* the existentially quantified contexts in datacon decls
Why do we need to grab all these type variables at once, including
those locally-quantified type variables in class op signatures?
+
+ [Incidentally, this only works because the names are all unique by now.]
+
Because we can only commit to the final kind of a type variable when
we've completed the mutually recursive group. For example:
union3 (a1,a2,a3) (b1,b2,b3)
= (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
-get_binders1 (TyD (TyData _ _ name tyvars _ _ _ _))
- = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
get_binders1 (TyD (TySynonym name tyvars _ _))
= (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
+get_binders1 (TyD (TyData _ _ name tyvars condecls _ _ _))
+ = (listToBag tyvars `unionBags` cons_tvs condecls,
+ unitBag (name,Nothing), emptyBag)
get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _))
= (listToBag tyvars `unionBags` sigs_tvs sigs,
emptyBag, unitBag (name, length tyvars))
+cons_tvs condecls = unionManyBags (map con_tvs condecls)
+ where
+ con_tvs (ConDecl _ tvs _ _ _) = listToBag tvs
+
sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
where
sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[TcTyDecls]{Typecheck type declarations}
import HsSyn ( MonoBinds(..),
TyDecl(..), ConDecl(..), ConDetails(..), BangType(..),
- andMonoBinds
+ andMonoBindList
)
-import HsTypes ( getTyVarName )
import RnHsSyn ( RenamedTyDecl, RenamedConDecl )
-import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
- TcHsBinds, TcMonoBinds
- )
-import BasicTypes ( RecFlag(..), NewOrData(..) )
+import TcHsSyn ( TcMonoBinds )
+import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
-import Inst ( newDicts, InstOrigin(..), Inst )
+import Inst ( InstOrigin(..) )
import TcMonoType ( tcHsTypeKind, tcHsType, tcContext )
-import TcSimplify ( tcSimplifyCheckThetas )
-import TcType ( tcInstTyVars )
-import TcEnv ( TcIdOcc(..), tcInstId,
- tcLookupTyCon, tcLookupTyVar, tcLookupClass,
- newLocalId, newLocalIds, tcLookupClassByKey
+import TcEnv ( TcIdOcc(..),
+ tcLookupTyCon, tcLookupClass,
+ tcLookupTyVarBndrs
)
import TcMonad
-import TcKind ( TcKind, unifyKind, mkArrowKind, mkBoxedTypeKind )
-
-import Class ( classInstEnv, Class )
-import MkId ( mkDataCon, mkRecordSelId )
-import Id ( dataConSig, idType,
- dataConFieldLabels, dataConStrictMarks,
- StrictnessMark(..), getIdUnfolding,
- Id
+import TcUnify ( unifyKind )
+
+import Class ( Class )
+import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
+ dataConFieldLabels, dataConId
)
+import MkId ( mkDataConId, mkRecordSelId )
+import Id ( getIdUnfolding )
import CoreUnfold ( getUnfoldingTemplate )
import FieldLabel
-import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
-import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc,
- OccName(..),
- NamedThing(..)
- )
+import Var ( Id, TyVar )
+import Name ( isLocallyDefined, OccName(..), NamedThing(..) )
import Outputable
-import TyCon ( TyCon, mkSynTyCon, mkDataTyCon, isAlgTyCon,
+import TyCon ( TyCon, mkSynTyCon, mkAlgTyCon, isAlgTyCon,
isSynTyCon, tyConDataCons
)
-import Type ( typeKind, getTyVar, tyVarsOfTypes, splitSigmaTy,
+import Type ( typeKind, getTyVar, tyVarsOfTypes,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
- splitFunTys, mkTyVarTy, getTyVar_maybe,
+ mkTyVarTy,
+ mkArrowKind, mkArrowKinds, boxedTypeKind,
isUnboxedType, Type, ThetaType
)
-import TyVar ( tyVarKind, elementOfTyVarSet, intersectTyVarSets, isEmptyTyVarSet,
- TyVar )
-import Unique ( evalClassKey )
-import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet )
-import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
+import Var ( tyVarKind )
+import VarSet ( intersectVarSet, isEmptyVarSet )
+import Util ( equivClasses, panic, assertPanic )
\end{code}
\begin{code}
-- Look up the pieces
tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
- mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
- `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+ tcLookupTyVarBndrs tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
-- Look at the rhs
tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
-- Unify tycon kind with (k1->...->kn->rhs)
- unifyKind tycon_kind
- (foldr mkArrowKind rhs_kind tyvar_kinds)
- `thenTc_`
+ unifyKind tycon_kind (mkArrowKinds tyvar_kinds rhs_kind) `thenTc_`
let
- -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
- -- because that's a TcKind and may not yet be fully unified with other kinds.
- -- We could have augmented the tycon environment with a knot-tied kind,
- -- but the simplest thing to do seems to be to get the Kind by (lazily)
- -- looking at the tyvars and rhs_ty.
- result_kind, final_tycon_kind :: Kind -- NB not TcKind!
- result_kind = typeKind rhs_ty
- final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
-
-- Construct the tycon
+ kind = mkArrowKinds (map tyVarKind rec_tyvars) (typeKind rhs_ty)
tycon = mkSynTyCon (getName tycon_name)
- final_tycon_kind
+ kind
(length tyvar_names)
rec_tyvars
rhs_ty
-- Lookup the pieces
tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
- mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
- tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+ tcLookupTyVarBndrs tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
tc_derivs derivings `thenTc` \ derived_classes ->
-- Typecheck the context
tcContext context `thenTc` \ ctxt ->
-- Unify tycon kind with (k1->...->kn->Type)
- unifyKind tycon_kind
- (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds)
- `thenTc_`
+ unifyKind tycon_kind (mkArrowKinds tyvar_kinds boxedTypeKind) `thenTc_`
-- Walk the condecls
mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
- `thenTc` \ con_ids ->
+ `thenTc` \ data_cons ->
let
-- Construct the tycon
- final_tycon_kind :: Kind -- NB not TcKind!
- final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
-
- tycon = mkDataTyCon (getName tycon_name)
- final_tycon_kind
- rec_tyvars
- ctxt
- con_ids
- derived_classes
- Nothing -- Not a dictionary
- data_or_new
- is_rec
+ real_data_or_new = case data_or_new of
+ NewType -> NewType
+ DataType -> if all isNullaryDataCon data_cons then
+ EnumType
+ else
+ DataType
+
+ kind = foldr (mkArrowKind . tyVarKind) boxedTypeKind rec_tyvars
+ tycon = mkAlgTyCon (getName tycon_name)
+ kind
+ rec_tyvars
+ ctxt
+ data_cons
+ derived_classes
+ Nothing -- Not a dictionary
+ real_data_or_new
+ is_rec
in
returnTc tycon
mkDataBinds_one tycon
= ASSERT( isAlgTyCon tycon )
- mapTc checkConstructorContext data_cons `thenTc_`
mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
let
- data_ids = data_cons ++ sel_ids
+ data_ids = map dataConId data_cons ++ sel_ids
-- For the locally-defined things
-- we need to turn the unfoldings inside the Ids into bindings,
| data_id <- data_ids, isLocallyDefined data_id
]
in
- returnTc (data_ids, andMonoBinds binds)
+ returnTc (data_ids, andMonoBindList binds)
where
data_cons = tyConDataCons tycon
fields = [ (con, field) | con <- data_cons,
= fieldLabelName field1 `compare` fieldLabelName field2
\end{code}
--- Check that all the types of all the strict arguments are in Eval
-
-\begin{code}
-checkConstructorContext con_id
- | not (isLocallyDefined con_id)
- = returnTc ()
-
- | otherwise -- It is locally defined
- = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
- let
- strict_marks = dataConStrictMarks con_id
- (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id
-
- eval_theta = [ (eval_clas, [arg_ty])
- | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
- arg_tys strict_marks
- ]
- in
- tcAddErrCtxt (evalCtxt con_id eval_theta) $
- tcSimplifyCheckThetas theta eval_theta
-\end{code}
-
\begin{code}
mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
-- These fields all have the same name, but are from
Constructors
~~~~~~~~~~~~
\begin{code}
-tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id
-
-tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
- = tcDataCon tycon tyvars ctxt name btys src_loc
+tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s DataCon
-tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
- = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
-
-tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
+tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc)
= tcAddSrcLoc src_loc $
- tcHsType ty `thenTc` \ arg_ty ->
+ tcLookupTyVarBndrs ex_tvs `thenNF_Tc` \ (kinds, ex_tyvars) ->
+ tcContext ex_ctxt `thenTc` \ ex_theta ->
+ tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta details
+
+tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (VanillaCon btys)
+ = tc_datacon_help tycon tyvars ctxt name ex_tyvars ex_theta btys
+
+tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (InfixCon bty1 bty2)
+ = tc_datacon_help tycon tyvars ctxt name ex_tyvars ex_theta [bty1,bty2]
+
+tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (NewCon ty)
+ = tcHsType ty `thenTc` \ arg_ty ->
-- can't allow an unboxed type here, because we're effectively
-- going to remove the constructor while coercing it to a boxed type.
checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_`
[{- No labelled fields -}]
tyvars
ctxt
- [] [] -- Temporary; existential chaps
+ ex_tyvars ex_theta
[arg_ty]
- tycon
+ tycon data_con_id
+ data_con_id = mkDataConId data_con
in
returnTc data_con
-tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
- = tcAddSrcLoc src_loc $
+tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (RecCon fields)
+ = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
mapTc tcField fields `thenTc` \ field_label_infos_s ->
let
field_label_infos = concat field_label_infos_s
- stricts = [strict | (_, _, strict) <- field_label_infos]
+ arg_stricts = [strict | (_, _, strict) <- field_label_infos]
arg_tys = [ty | (_, ty, _) <- field_label_infos]
field_labels = [ mkFieldLabel (getName name) ty tag
| ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
data_con = mkDataCon (getName name)
- stricts
+ arg_stricts
field_labels
tyvars
(thinContext arg_tys ctxt)
- [] [] -- Temporary; existential chaps
+ ex_tyvars ex_theta
arg_tys
- tycon
+ tycon data_con_id
+ data_con_id = mkDataConId data_con
in
returnTc data_con
= tcHsType (get_pty bty) `thenTc` \ field_ty ->
returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
-tcDataCon tycon tyvars ctxt name btys src_loc
- = tcAddSrcLoc src_loc $
- let
- stricts = map get_strictness btys
- tys = map get_pty btys
+tc_datacon_help tycon tyvars ctxt name ex_tyvars ex_theta btys
+ = let
+ arg_stricts = map get_strictness btys
+ tys = map get_pty btys
in
mapTc tcHsType tys `thenTc` \ arg_tys ->
let
data_con = mkDataCon (getName name)
- stricts
+ arg_stricts
[{- No field labels -}]
tyvars
(thinContext arg_tys ctxt)
- [] [] -- Temporary existential chaps
+ ex_tyvars ex_theta
arg_tys
- tycon
+ tycon data_con_id
+ data_con_id = mkDataConId data_con
in
returnTc data_con
= filter in_arg_tys ctxt
where
arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $
- tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars
+ in_arg_tys (clas,tys) = not $ isEmptyVarSet $
+ tyVarsOfTypes tys `intersectVarSet` arg_tyvars
get_strictness (Banged _) = MarkedStrict
get_strictness (Unbanged _) = NotMarkedStrict
= sep [ptext SLIT("Newtype constructor field has an unboxed type:"),
quotes (ppr ty)]
-evalCtxt con eval_theta
- = hsep [ptext SLIT("When checking the Eval context for constructor:"),
- ppr con,
- text "::", ppr eval_theta]
+exRecConErr name
+ = ptext SLIT("Can't combine named fields with locally-quantified type variables")
+ $$
+ (ptext SLIT("In the declaration of data constructor") <+> ppr name)
\end{code}
tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
- tcSplitForAllTy, tcSplitRhoTy,
+ tcSplitRhoTy,
tcInstTyVars,
- tcInstSigTyVars,
- tcInstType,
- tcInstSigType, tcInstTcType, tcInstSigTcType,
- tcInstTheta,
+ tcInstTcType,
- zonkTcTyVars, zonkSigTyVar,
+ typeToTcType,
+
+ --------------------------------
+ TcKind,
+ newKindVar, newKindVars,
+ kindToTcKind,
+ zonkTcKind,
+
+ --------------------------------
+ zonkTcTyVar, zonkTcTyVars, zonkTcTyVarBndr,
zonkTcType, zonkTcTypes, zonkTcThetaType,
- zonkTcTypeToType,
- zonkTcTyVar,
- zonkTcTyVarToTyVar
+
+ zonkTcTypeToType, zonkTcTyVarToTyVar,
+ zonkTcKindToKind
) where
-- friends:
-import Type ( Type, ThetaType, GenType(..), mkAppTy,
- tyVarsOfTypes, splitDictTy_maybe,
- isTyVarTy, instantiateTy
+import PprType ()
+import Type ( Type, Kind, ThetaType, GenType(..), TyNote(..),
+ mkAppTy,
+ splitDictTy_maybe, splitForAllTys,
+ isTyVarTy, mkTyVarTys,
+ fullSubstTy, substFlexiTy,
+ boxedTypeKind, superKind
)
-import TyVar ( TyVar, GenTyVar(..), GenTyVarSet,
- TyVarEnv, lookupTyVarEnv, addToTyVarEnv,
- emptyTyVarEnv, zipTyVarEnv, tyVarSetToList
+import VarEnv
+import VarSet ( emptyVarSet )
+import Var ( TyVar, GenTyVar, tyVarKind, tyVarFlexi, tyVarName,
+ mkFlexiTyVar, removeTyVarFlexi, isFlexiTyVar, isTyVar
)
-- others:
-import Class ( Class )
-import TyCon ( isFunTyCon )
-import Kind ( Kind )
import TcMonad
import Name ( changeUnique )
-import TysPrim ( voidTy )
+import TysWiredIn ( voidTy )
+import Name ( NamedThing(..), changeUnique, mkSysLocalName )
import Unique ( Unique )
-import UniqFM ( UniqFM )
-import BasicTypes ( unused )
-import Util ( nOfThem, panic )
+import Util ( nOfThem )
+import Outputable
\end{code}
Data types
~~~~~~~~~~
-
-
-\begin{code}
-type TcType s = GenType (TcBox s) -- Used during typechecker
- -- Invariant on ForAllTy in TcTypes:
- -- forall a. T
- -- a cannot occur inside a MutTyVar in T; that is,
- -- T is "flattened" before quantifying over a
-
-type TcThetaType s = [(Class, [TcType s])]
-type TcRhoType s = TcType s -- No ForAllTys
-type TcTauType s = TcType s -- No DictTys or ForAllTys
-
-type TcBox s = TcRef s (TcMaybe s)
-
-data TcMaybe s = UnBound
- | BoundTo (TcType s)
-
--- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
--- because you get a synonym loop if you do!
-
-type TcTyVar s = GenTyVar (TcBox s)
-type TcTyVarSet s = GenTyVarSet (TcBox s)
-\end{code}
+See TcMonad.lhs
\begin{code}
tcTyVarToTyVar :: TcTyVar s -> TyVar
-tcTyVarToTyVar (TyVar uniq kind name _) = TyVar uniq kind name unused
+tcTyVarToTyVar = removeTyVarFlexi
\end{code}
Utility functions
These tcSplit functions are like their non-Tc analogues, but they
follow through bound type variables.
-\begin{code}
-tcSplitForAllTy :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
-tcSplitForAllTy t
- = go t t []
- where
- go syn_t (ForAllTy tv t) tvs = go t t (tv:tvs)
- go syn_t (SynTy _ t) tvs = go syn_t t tvs
- go syn_t (TyVarTy tv) tvs = tcReadTyVar tv `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo ty | not (isTyVarTy ty) -> go syn_t ty tvs
- other -> returnNF_Tc (reverse tvs, syn_t)
- go syn_t t tvs = returnNF_Tc (reverse tvs, syn_t)
+No need for tcSplitForAllTy because a type variable can't be instantiated
+to a for-all type.
+\begin{code}
tcSplitRhoTy :: TcType s -> NF_TcM s (TcThetaType s, TcType s)
tcSplitRhoTy t
= go t t []
go syn_t (FunTy arg res) ts = case splitDictTy_maybe arg of
Just pair -> go res res (pair:ts)
Nothing -> returnNF_Tc (reverse ts, syn_t)
- go syn_t (SynTy _ t) ts = go syn_t t ts
+ go syn_t (NoteTy _ t) ts = go syn_t t ts
go syn_t (TyVarTy tv) ts = tcReadTyVar tv `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
BoundTo ty | not (isTyVarTy ty) -> go syn_t ty ts
\end{code}
-Type instantiation
+New type variables
~~~~~~~~~~~~~~~~~~
\begin{code}
newTcTyVar kind
= tcGetUnique `thenNF_Tc` \ uniq ->
tcNewMutVar UnBound `thenNF_Tc` \ box ->
- returnNF_Tc (TyVar uniq kind Nothing box)
+ let
+ name = mkSysLocalName uniq
+ in
+ returnNF_Tc (mkFlexiTyVar name kind box)
newTyVarTy :: Kind -> NF_TcM s (TcType s)
newTyVarTy kind
newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
+newKindVar :: NF_TcM s (TcKind s)
+newKindVar = newTyVarTy superKind
+
+newKindVars :: Int -> NF_TcM s [TcKind s]
+newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ())
+\end{code}
+
+Type instantiation
+~~~~~~~~~~~~~~~~~~
--- For signature type variables, use the user name for the type variable
-tcInstTyVars, tcInstSigTyVars
- :: [GenTyVar flexi]
- -> NF_TcM s ([TcTyVar s], [TcType s], TyVarEnv (TcType s))
+Instantiating a bunch of type variables
-tcInstTyVars tyvars = inst_tyvars inst_tyvar tyvars
-tcInstSigTyVars tyvars = inst_tyvars inst_sig_tyvar tyvars
+\begin{code}
+tcInstTyVars :: [GenTyVar flexi]
+ -> NF_TcM s ([TcTyVar s], [TcType s], TyVarEnv (TcType s))
-inst_tyvars inst tyvars
- = mapNF_Tc inst tyvars `thenNF_Tc` \ tc_tyvars ->
+tcInstTyVars tyvars
+ = mapNF_Tc inst_tyvar tyvars `thenNF_Tc` \ tc_tyvars ->
let
- tys = map TyVarTy tc_tyvars
+ tys = mkTyVarTys tc_tyvars
in
- returnNF_Tc (tc_tyvars, tys, zipTyVarEnv tyvars tys)
-
-inst_tyvar (TyVar _ kind name _)
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutVar UnBound `thenNF_Tc` \ box ->
- returnNF_Tc (TyVar uniq kind Nothing box)
- -- The "Nothing" means that it'll always print with its
- -- unique (or something similar). If we leave the original (Just Name)
- -- in there then error messages will say "can't match (T a) against (T a)"
+ returnNF_Tc (tc_tyvars, tys, zipVarEnv tyvars tys)
-inst_sig_tyvar (TyVar _ kind name _)
+inst_tyvar tyvar -- Could use the name from the tyvar?
= tcGetUnique `thenNF_Tc` \ uniq ->
-
tcNewMutVar UnBound `thenNF_Tc` \ box ->
- -- Was DontBind, but we've nuked that "optimisation"
let
- name' = case name of
- Nothing -> Nothing
- Just n -> Just (changeUnique n uniq)
+ name = changeUnique (tyVarName tyvar) uniq
+ -- Note that we don't change the print-name
+ -- This won't confuse the type checker but there's a chance
+ -- that two different tyvars will print the same way
+ -- in an error message. -dppr-debug will show up the difference
+ -- Better watch out for this. If worst comes to worst, just
+ -- use mkSysLocalName.
in
-
- returnNF_Tc (TyVar uniq kind name' box)
- -- We propagate the name of the sigature type variable
+ returnNF_Tc (mkFlexiTyVar name (tyVarKind tyvar) box)
\end{code}
-@tcInstType@ and @tcInstSigType@ both create a fresh instance of a
-type, returning a @TcType@. All inner for-alls are instantiated with
-fresh TcTyVars.
+@tcInstTcType@ instantiates the outer-level for-alls of a TcType with
+fresh type variables, returning them and the instantiated body of the for-all.
-The difference is that tcInstType instantiates all forall'd type
-variables (and their bindees) with anonymous type variables, whereas
-tcInstSigType instantiates them with named type variables.
-@tcInstSigType@ also doesn't take an environment.
-
-On the other hand, @tcInstTcType@ instantiates a TcType. It uses
-instantiateTy which could take advantage of sharing some day.
\begin{code}
tcInstTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
tcInstTcType ty
- = tcSplitForAllTy ty `thenNF_Tc` \ (tyvars, rho) ->
+ = let
+ (tyvars, rho) = splitForAllTys ty
+ in
case tyvars of
[] -> returnNF_Tc ([], ty) -- Nothing to do
other -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
- returnNF_Tc (tyvars', instantiateTy tenv rho)
-
-tcInstSigTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
-tcInstSigTcType ty
- = tcSplitForAllTy ty `thenNF_Tc` \ (tyvars, rho) ->
- case tyvars of
- [] -> returnNF_Tc ([], ty) -- Nothing to do
- other -> tcInstSigTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
- returnNF_Tc (tyvars', instantiateTy tenv rho)
-
-tcInstType :: TyVarEnv (TcType s)
- -> GenType flexi
- -> NF_TcM s (TcType s)
-tcInstType tenv ty_to_inst
- = tcConvert bind_fn occ_fn tenv ty_to_inst
- where
- bind_fn = inst_tyvar
- occ_fn env tyvar = case lookupTyVarEnv env tyvar of
- Just ty -> returnNF_Tc ty
- Nothing -> panic "tcInstType:1" --(vcat [ppr ty_to_inst,
- -- ppr tyvar])
-
-tcInstSigType :: GenType flexi -> NF_TcM s (TcType s)
-tcInstSigType ty_to_inst
- = tcConvert bind_fn occ_fn emptyTyVarEnv ty_to_inst
- where
- bind_fn = inst_sig_tyvar -- Note: inst_sig_tyvar, not inst_tyvar
- -- I don't think that can lead to strange error messages
- -- of the form can't match (T a) against (T a)
- -- See notes with inst_tyvar
-
- occ_fn env tyvar = case lookupTyVarEnv env tyvar of
- Just ty -> returnNF_Tc ty
- Nothing -> panic "tcInstType:2"-- (vcat [ppr ty_to_inst,
- -- ppr tyvar])
-
-zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
-zonkTcTyVarToTyVar tv
- = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
- case tv_ty of -- Should be a tyvar!
-
- TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv')
-
- _ -> --pprTrace "zonkTcTyVarToTyVar:" (hsep [ppr tv, ppr tv_ty]) $
- returnNF_Tc (tcTyVarToTyVar tv)
-
-
-zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type
-zonkTcTypeToType env ty
- = tcConvert zonkTcTyVarToTyVar occ_fn env ty
- where
- occ_fn env tyvar
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo (TyVarTy tyvar') -> lookup env tyvar'
- BoundTo other_ty -> tcConvert zonkTcTyVarToTyVar occ_fn env other_ty
- other -> lookup env tyvar
-
- lookup env tyvar = case lookupTyVarEnv env tyvar of
- Just ty -> returnNF_Tc ty
- Nothing -> returnNF_Tc voidTy -- Unbound type variables go to Void
-
-
-tcConvert bind_fn occ_fn env ty_to_convert
- = doo env ty_to_convert
- where
- doo env (TyConApp tycon tys) = mapNF_Tc (doo env) tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (TyConApp tycon tys')
-
- doo env (SynTy ty1 ty2) = doo env ty1 `thenNF_Tc` \ ty1' ->
- doo env ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (SynTy ty1' ty2')
-
- doo env (FunTy arg res) = doo env arg `thenNF_Tc` \ arg' ->
- doo env res `thenNF_Tc` \ res' ->
- returnNF_Tc (FunTy arg' res')
-
- doo env (AppTy fun arg) = doo env fun `thenNF_Tc` \ fun' ->
- doo env arg `thenNF_Tc` \ arg' ->
- returnNF_Tc (mkAppTy fun' arg')
-
- -- The two interesting cases!
- doo env (TyVarTy tv) = occ_fn env tv
+ returnNF_Tc (tyvars', fullSubstTy tenv emptyVarSet rho)
+ -- Since the tyvars are freshly made,
+ -- they cannot possibly be captured by
+ -- any existing for-alls. Hence emptyVarSet
+\end{code}
- doo env (ForAllTy tyvar ty)
- = bind_fn tyvar `thenNF_Tc` \ tyvar' ->
- let
- new_env = addToTyVarEnv env tyvar (TyVarTy tyvar')
- in
- doo new_env ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (ForAllTy tyvar' ty')
+Sometimes we have to convert a Type to a TcType. I wonder whether we could
+do this less than we do?
+\begin{code}
+typeToTcType :: Type -> TcType s
+typeToTcType t = substFlexiTy emptyVarEnv t
-tcInstTheta :: TyVarEnv (TcType s) -> ThetaType -> NF_TcM s (TcThetaType s)
-tcInstTheta tenv theta
- = mapNF_Tc go theta
- where
- go (clas,tys) = mapNF_Tc (tcInstType tenv) tys `thenNF_Tc` \ tc_tys ->
- returnNF_Tc (clas, tc_tys)
+kindToTcKind :: Kind -> TcKind s
+kindToTcKind = typeToTcType
\end{code}
+
Reading and writing TcTyVars
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
Writing is easy:
\begin{code}
-tcWriteTyVar (TyVar uniq kind name box) ty = tcWriteMutVar box (BoundTo ty)
+tcWriteTyVar tyvar ty = tcWriteMutVar (tyVarFlexi tyvar) (BoundTo ty)
\end{code}
Reading is more interesting. The easy thing to do is just to read, thus:
\begin{verbatim}
-tcReadTyVar (TyVar uniq kind name box) = tcReadMutVar box
+tcReadTyVar tyvar = tcReadMutVar (tyVarFlexi tyvar)
\end{verbatim}
But it's more fun to short out indirections on the way: If this
We return Nothing iff the original box was unbound.
\begin{code}
-tcReadTyVar (TyVar uniq kind name box)
+tcReadTyVar tyvar
= tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
BoundTo ty -> short_out ty `thenNF_Tc` \ ty' ->
returnNF_Tc (BoundTo ty')
other -> returnNF_Tc other
+ where
+ box = tyVarFlexi tyvar
short_out :: TcType s -> NF_TcM s (TcType s)
-short_out ty@(TyVarTy (TyVar uniq kind name box))
+short_out ty@(TyVarTy tyvar)
= tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
BoundTo ty' -> short_out ty' `thenNF_Tc` \ ty' ->
returnNF_Tc ty'
other -> returnNF_Tc ty
+ where
+ box = tyVarFlexi tyvar
short_out other_ty = returnNF_Tc other_ty
\end{code}
-Zonking
-~~~~~~~
+Zonking Tc types to Tc types
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-zonkTcTyVars :: TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
-zonkTcTyVars tyvars
- = mapNF_Tc zonkTcTyVar (tyVarSetToList tyvars) `thenNF_Tc` \ tys ->
- returnNF_Tc (tyVarsOfTypes tys)
+zonkTcTyVars :: [TcTyVar s] -> NF_TcM s [TcType s]
+zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
zonkTcTyVar :: TcTyVar s -> NF_TcM s (TcType s)
zonkTcTyVar tyvar
+ | not (isFlexiTyVar tyvar) -- Not a flexi tyvar. This can happen when
+ -- zonking a forall type, when the bound type variable
+ -- needn't be a flexi.
+ = ASSERT( isTyVar tyvar )
+ returnNF_Tc (TyVarTy tyvar)
+
+ | otherwise -- Is a flexi tyvar
= tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
BoundTo ty@(TyVarTy tyvar') -> returnNF_Tc ty -- tcReadTyVar never returns a bound tyvar
BoundTo other -> zonkTcType other
other -> returnNF_Tc (TyVarTy tyvar)
--- Signature type variables only get bound to each other,
--- never to a type
-zonkSigTyVar :: TcTyVar s -> NF_TcM s (TcTyVar s)
-zonkSigTyVar tyvar
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo ty@(TyVarTy tyvar') -> returnNF_Tc tyvar' -- tcReadTyVar never returns a bound tyvar
- BoundTo other -> panic "zonkSigTyVar" -- Should only be bound to another tyvar
- other -> returnNF_Tc tyvar
-
+zonkTcTyVarBndr :: TcTyVar s -> NF_TcM s (TcTyVar s)
+zonkTcTyVarBndr tyvar
+ = zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') ->
+ returnNF_Tc tyvar'
+
zonkTcTypes :: [TcType s] -> NF_TcM s [TcType s]
zonkTcTypes tys = mapNF_Tc zonkTcType tys
zonk (c,ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts ->
returnNF_Tc (c, new_ts)
+zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
+zonkTcKind = zonkTcType
+
zonkTcType :: TcType s -> NF_TcM s (TcType s)
zonkTcType (TyVarTy tyvar) = zonkTcTyVar tyvar
= mapNF_Tc zonkTcType tys `thenNF_Tc` \ tys' ->
returnNF_Tc (TyConApp tc tys')
-zonkTcType (SynTy ty1 ty2)
+zonkTcType (NoteTy (SynNote ty1) ty2)
= zonkTcType ty1 `thenNF_Tc` \ ty1' ->
zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (SynTy ty1' ty2')
+ returnNF_Tc (NoteTy (SynNote ty1') ty2')
+
+zonkTcType (NoteTy (FTVNote _) ty2) = zonkTcType ty2
zonkTcType (ForAllTy tv ty)
= zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
zonkTcType ty2 `thenNF_Tc` \ ty2' ->
returnNF_Tc (FunTy ty1' ty2')
\end{code}
+
+Zonking Tc types to Type/Kind
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+zonkTcKindToKind :: TcKind s -> NF_TcM s Kind
+zonkTcKindToKind kind = zonkTcToType boxedTypeKind emptyVarEnv kind
+
+zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type
+zonkTcTypeToType env ty = zonkTcToType voidTy env ty
+
+zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
+zonkTcTyVarToTyVar tv
+ = zonkTcTyVarBndr tv `thenNF_Tc` \ tv' ->
+ returnNF_Tc (tcTyVarToTyVar tv')
+
+-- zonkTcToType is used for Kinds as well
+zonkTcToType :: Type -> TyVarEnv Type -> TcType s -> NF_TcM s Type
+zonkTcToType unbound_var_ty env ty
+ = go ty
+ where
+ go (TyConApp tycon tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
+ returnNF_Tc (TyConApp tycon tys')
+
+ go (NoteTy (SynNote ty1) ty2) = go ty1 `thenNF_Tc` \ ty1' ->
+ go ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (NoteTy (SynNote ty1') ty2')
+
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations
+
+ go (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
+ go res `thenNF_Tc` \ res' ->
+ returnNF_Tc (FunTy arg' res')
+
+ go (AppTy fun arg) = go fun `thenNF_Tc` \ fun' ->
+ go arg `thenNF_Tc` \ arg' ->
+ returnNF_Tc (mkAppTy fun' arg')
+
+ -- The two interesting cases!
+ -- c.f. zonkTcTyVar
+ go (TyVarTy tyvar)
+ | not (isFlexiTyVar tyvar) = lookup env tyvar
+
+ | otherwise = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ BoundTo (TyVarTy tyvar') -> lookup env tyvar'
+ BoundTo other_ty -> go other_ty
+ other -> lookup env tyvar
+
+ go (ForAllTy tyvar ty)
+ = zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' ->
+ let
+ new_env = extendVarEnv env tyvar (TyVarTy tyvar')
+ in
+ zonkTcToType unbound_var_ty new_env ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (ForAllTy tyvar' ty')
+
+
+ lookup env tyvar = returnNF_Tc (case lookupVarEnv env tyvar of
+ Just ty -> ty
+ Nothing -> unbound_var_ty)
+\end{code}
+
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Unify]{Unifier}
+
+The unifier is now squarely in the typechecker monad (because of the
+updatable substitution).
+
+\begin{code}
+module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
+ unifyFunTy, unifyListTy, unifyTupleTy, unifyUnboxedTupleTy,
+ unifyKind, unifyKinds
+ ) where
+
+#include "HsVersions.h"
+
+-- friends:
+import TcMonad
+import TcEnv ( tidyType, tidyTypes, tidyTyVar )
+import Type ( GenType(..), Type, tyVarsOfType, funTyCon,
+ typeKind, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
+ Kind, hasMoreBoxityInfo, openTypeKind, boxedTypeKind, superKind,
+ splitAppTy_maybe
+ )
+import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon,
+ tyConArity, matchesTyCon )
+import Name ( isSysLocalName )
+import Var ( TyVar, tyVarKind, varName )
+import VarEnv
+import VarSet ( varSetElems )
+import TcType ( TcType, TcMaybe(..), TcTauType, TcTyVar,
+ TcKind,
+ newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
+ )
+-- others:
+import BasicTypes ( Arity )
+import TysWiredIn ( listTyCon, mkListTy, mkTupleTy, mkUnboxedTupleTy )
+import PprType () -- Instances
+import Util
+import Outputable
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The Kind variants}
+%* *
+%************************************************************************
+
+\begin{code}
+unifyKind :: TcKind s -- Expected
+ -> TcKind s -- Actual
+ -> TcM s ()
+unifyKind k1 k2
+ = tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $
+ uTys k1 k1 k2 k2
+
+unifyKinds :: [TcKind s] -> [TcKind s] -> TcM s ()
+unifyKinds [] [] = returnTc ()
+unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_`
+ unifyKinds ks1 ks2
+unifyKinds _ _ = panic "unifyKinds: length mis-match"
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Unify-exported]{Exported unification functions}
+%* *
+%************************************************************************
+
+The exported functions are all defined as versions of some
+non-exported generic functions.
+
+Unify two @TauType@s. Dead straightforward.
+
+\begin{code}
+unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
+unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred
+ = tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $
+ uTys ty1 ty1 ty2 ty2
+\end{code}
+
+@unifyTauTyList@ unifies corresponding elements of two lists of
+@TauType@s. It uses @uTys@ to do the real work. The lists should be
+of equal length. We charge down the list explicitly so that we can
+complain if their lengths differ.
+
+\begin{code}
+unifyTauTyLists :: [TcTauType s] -> [TcTauType s] -> TcM s ()
+unifyTauTyLists [] [] = returnTc ()
+unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_`
+ unifyTauTyLists tys1 tys2
+unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!"
+\end{code}
+
+@unifyTauTyList@ takes a single list of @TauType@s and unifies them
+all together. It is used, for example, when typechecking explicit
+lists, when all the elts should be of the same type.
+
+\begin{code}
+unifyTauTyList :: [TcTauType s] -> TcM s ()
+unifyTauTyList [] = returnTc ()
+unifyTauTyList [ty] = returnTc ()
+unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_`
+ unifyTauTyList tys
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Unify-uTys]{@uTys@: getting down to business}
+%* *
+%************************************************************************
+
+@uTys@ is the heart of the unifier. Each arg happens twice, because
+we want to report errors in terms of synomyms if poss. The first of
+the pair is used in error messages only; it is always the same as the
+second, except that if the first is a synonym then the second may be a
+de-synonym'd version. This way we get better error messages.
+
+We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
+
+\begin{code}
+uTys :: TcTauType s -> TcTauType s -- Error reporting ty1 and real ty1
+ -> TcTauType s -> TcTauType s -- Error reporting ty2 and real ty2
+ -> TcM s ()
+
+ -- Always expand synonyms (see notes at end)
+uTys ps_ty1 (NoteTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (NoteTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
+
+ -- Variables; go for uVar
+uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1
+ -- "True" means args swapped
+
+ -- Functions; just check the two parts
+uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
+ = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
+
+ -- Type constructors must match
+uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
+ = checkTcM (con1 `matchesTyCon` con2 && length tys1 == length tys2)
+ (failWithTcM (unifyMisMatch ps_ty1 ps_ty2)) `thenTc_`
+ unifyTauTyLists tys1 tys2
+
+ -- Applications need a bit of care!
+ -- They can match FunTy and TyConApp, so use splitAppTy_maybe
+ -- NB: we've already dealt with type variables and Notes,
+ -- so if one type is an App the other one jolly well better be too
+uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2
+ = case splitAppTy_maybe ty2 of
+ Just (s2,t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
+ Nothing -> failWithTcM (unifyMisMatch ps_ty1 ps_ty2)
+
+ -- Now the same, but the other way round
+ -- ** DON'T ** swap the types, because when unifying kinds
+ -- we need to check that the expected type has less boxity info
+ -- than the inferred one; so we need to keep them the right way round
+uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2)
+ = case splitAppTy_maybe ty1 of
+ Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
+ Nothing -> failWithTcM (unifyMisMatch ps_ty1 ps_ty2)
+
+ -- Not expecting for-alls in unification
+ -- ... but the error message from the unifyMisMatch more informative
+ -- than a panic message!
+
+ -- Anything else fails
+uTys ps_ty1 ty1 ps_ty2 ty2 = failWithTcM (unifyMisMatch ps_ty1 ps_ty2)
+\end{code}
+
+Notes on synonyms
+~~~~~~~~~~~~~~~~~
+If you are tempted to make a short cut on synonyms, as in this
+pseudocode...
+
+\begin{verbatim}
+uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
+ = if (con1 == con2) then
+ -- Good news! Same synonym constructors, so we can shortcut
+ -- by unifying their arguments and ignoring their expansions.
+ unifyTauTypeLists args1 args2
+ else
+ -- Never mind. Just expand them and try again
+ uTys ty1 ty2
+\end{verbatim}
+
+then THINK AGAIN. Here is the whole story, as detected and reported
+by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}:
+\begin{quotation}
+Here's a test program that should detect the problem:
+
+\begin{verbatim}
+ type Bogus a = Int
+ x = (1 :: Bogus Char) :: Bogus Bool
+\end{verbatim}
+
+The problem with [the attempted shortcut code] is that
+\begin{verbatim}
+ con1 == con2
+\end{verbatim}
+is not a sufficient condition to be able to use the shortcut!
+You also need to know that the type synonym actually USES all
+its arguments. For example, consider the following type synonym
+which does not use all its arguments.
+\begin{verbatim}
+ type Bogus a = Int
+\end{verbatim}
+
+If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool},
+the unifier would blithely try to unify \tr{Char} with \tr{Bool} and
+would fail, even though the expanded forms (both \tr{Int}) should
+match.
+
+Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would
+unnecessarily bind \tr{t} to \tr{Char}.
+
+... You could explicitly test for the problem synonyms and mark them
+somehow as needing expansion, perhaps also issuing a warning to the
+user.
+\end{quotation}
+
+
+%************************************************************************
+%* *
+\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
+%* *
+%************************************************************************
+
+@uVar@ is called when at least one of the types being unified is a
+variable. It does {\em not} assume that the variable is a fixed point
+of the substitution; rather, notice that @uVar@ (defined below) nips
+back into @uTys@ if it turns out that the variable is already bound.
+
+\begin{code}
+uVar :: Bool -- False => tyvar is the "expected"
+ -- True => ty is the "expected" thing
+ -> TcTyVar s
+ -> TcTauType s -> TcTauType s -- printing and real versions
+ -> TcM s ()
+
+uVar swapped tv1 ps_ty2 ty2
+ = tcReadTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
+ case maybe_ty1 of
+ BoundTo ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back
+ | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order
+ other -> uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
+
+ -- Expand synonyms
+uUnboundVar tv1 maybe_ty1 ps_ty2 (NoteTy _ ty2)
+ = uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
+
+
+ -- The both-type-variable case
+uUnboundVar tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
+
+ -- Same type variable => no-op
+ | tv1 == tv2
+ = returnTc ()
+
+ -- Distinct type variables
+ -- ASSERT maybe_ty1 /= BoundTo
+ | otherwise
+ = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
+ case maybe_ty2 of
+ BoundTo ty2' -> uUnboundVar tv1 maybe_ty1 ty2' ty2'
+
+ -- Try to update sys-y type variables in preference to sig-y ones
+ -- (the latter respond False to isSysLocalName)
+ UnBound | can_update_tv2
+ && (tv2_is_sys_y || not can_update_tv1)
+ -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
+
+ | can_update_tv1
+ -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc ()
+
+ other -> failWithTc (unifyKindErr tv1 ps_ty2)
+ where
+ kind1 = tyVarKind tv1
+ kind2 = tyVarKind tv2
+
+ can_update_tv1 = kind2 `hasMoreBoxityInfo` kind1
+ can_update_tv2 = kind1 `hasMoreBoxityInfo` kind2
+
+ -- Try to overwrite sys-y things with sig-y things
+ tv2_is_sys_y = isSysLocalName (varName tv2)
+
+
+ -- Second one isn't a type variable
+uUnboundVar tv1 maybe_ty1 ps_ty2 non_var_ty2
+ | non_var_ty2 == openTypeKind
+ = -- We never bind a kind variable to openTypeKind;
+ -- instead we refine it to boxedTypeKind
+ -- This is a rather dark corner, I have to admit. SLPJ May 98
+ tcWriteTyVar tv1 boxedTypeKind `thenNF_Tc_`
+ returnTc ()
+
+ | tyvar_kind == superKind
+ || typeKind non_var_ty2 `hasMoreBoxityInfo` tyvar_kind
+ -- OK to bind if we're at the kind level, or
+ -- (at the type level) the variable has less boxity info than the type
+ = occur_check non_var_ty2 `thenTc_`
+ tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_`
+ returnTc ()
+
+ | otherwise
+ = failWithTc (unifyKindErr tv1 ps_ty2)
+
+ where
+ tyvar_kind = tyVarKind tv1
+
+ occur_check ty = mapTc occur_check_tv (varSetElems (tyVarsOfType ty)) `thenTc_`
+ returnTc ()
+
+ occur_check_tv tv2
+ | tv1 == tv2 -- Same tyvar; fail
+ = zonkTcType ps_ty2 `thenNF_Tc` \ zonked_ty2 ->
+ failWithTcM (unifyOccurCheck tv1 zonked_ty2)
+
+ | otherwise -- A different tyvar
+ = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
+ case maybe_ty2 of
+ BoundTo ty2' -> occur_check ty2'
+ other -> returnTc ()
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Unify-fun]{@unifyFunTy@}
+%* *
+%************************************************************************
+
+@unifyFunTy@ is used to avoid the fruitless creation of type variables.
+
+\begin{code}
+unifyFunTy :: TcType s -- Fail if ty isn't a function type
+ -> TcM s (TcType s, TcType s) -- otherwise return arg and result types
+
+unifyFunTy ty@(TyVarTy tyvar)
+ = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ BoundTo ty' -> unifyFunTy ty'
+ other -> unify_fun_ty_help ty
+
+unifyFunTy ty
+ = case splitFunTy_maybe ty of
+ Just arg_and_res -> returnTc arg_and_res
+ Nothing -> unify_fun_ty_help ty
+
+unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification
+ = newTyVarTy openTypeKind `thenNF_Tc` \ arg ->
+ newTyVarTy openTypeKind `thenNF_Tc` \ res ->
+ unifyTauTy ty (mkFunTy arg res) `thenTc_`
+ returnTc (arg,res)
+\end{code}
+
+\begin{code}
+unifyListTy :: TcType s -- expected list type
+ -> TcM s (TcType s) -- list element type
+
+unifyListTy ty@(TyVarTy tyvar)
+ = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ BoundTo ty' -> unifyListTy ty'
+ other -> unify_list_ty_help ty
+
+unifyListTy ty
+ = case splitTyConApp_maybe ty of
+ Just (tycon, [arg_ty]) | tycon == listTyCon -> returnTc arg_ty
+ other -> unify_list_ty_help ty
+
+unify_list_ty_help ty -- Revert to ordinary unification
+ = newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
+ unifyTauTy ty (mkListTy elt_ty) `thenTc_`
+ returnTc elt_ty
+\end{code}
+
+\begin{code}
+unifyTupleTy :: Arity -> TcType s -> TcM s [TcType s]
+unifyTupleTy arity ty@(TyVarTy tyvar)
+ = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ BoundTo ty' -> unifyTupleTy arity ty'
+ other -> unify_tuple_ty_help arity ty
+
+unifyTupleTy arity ty
+ = case splitTyConApp_maybe ty of
+ Just (tycon, arg_tys) | isTupleTyCon tycon
+ && tyConArity tycon == arity
+ -> returnTc arg_tys
+ other -> unify_tuple_ty_help arity ty
+
+unify_tuple_ty_help arity ty
+ = mapNF_Tc (\ _ -> newTyVarTy boxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys ->
+ unifyTauTy ty (mkTupleTy arity arg_tys) `thenTc_`
+ returnTc arg_tys
+\end{code}
+
+\begin{code}
+unifyUnboxedTupleTy :: Arity -> TcType s -> TcM s [TcType s]
+unifyUnboxedTupleTy arity ty@(TyVarTy tyvar)
+ = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ BoundTo ty' -> unifyUnboxedTupleTy arity ty'
+ other -> unify_unboxed_tuple_ty_help arity ty
+
+unifyUnboxedTupleTy arity ty
+ = case splitTyConApp_maybe ty of
+ Just (tycon, arg_tys) | isUnboxedTupleTyCon tycon
+ && tyConArity tycon == arity
+ -> returnTc arg_tys
+ other -> unify_tuple_ty_help arity ty
+
+unify_unboxed_tuple_ty_help arity ty
+ = mapNF_Tc (\ _ -> newTyVarTy openTypeKind) [1..arity]`thenNF_Tc` \ arg_tys ->
+ unifyTauTy ty (mkUnboxedTupleTy arity arg_tys) `thenTc_`
+ returnTc arg_tys
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Unify-context]{Errors and contexts}
+%* *
+%************************************************************************
+
+Errors
+~~~~~~
+
+\begin{code}
+unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred
+ = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
+ zonkTcType ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (err ty1' ty2')
+ where
+ err ty1 ty2 = (env1,
+ nest 4
+ (vcat [
+ text "Expected" <+> text s <> colon <+> ppr tidy_ty1,
+ text "Inferred" <+> text s <> colon <+> ppr tidy_ty2
+ ]))
+ where
+ (env1, [tidy_ty1,tidy_ty2]) = tidyTypes tidy_env [ty1,ty2]
+
+unifyMisMatch ty1 ty2
+ = (env2, hang (ptext SLIT("Couldn't match"))
+ 4 (sep [quotes (ppr tidy_ty1), ptext SLIT("against"), quotes (ppr tidy_ty2)]))
+ where
+ (env1, tidy_ty1) = tidyType emptyTidyEnv ty1
+ (env2, tidy_ty2) = tidyType env1 ty2
+
+unifyKindErr tyvar ty
+ = hang (ptext SLIT("Kind mis-match between"))
+ 4 (sep [quotes (hsep [ppr tyvar, ptext SLIT("::"), ppr (tyVarKind tyvar)]),
+ ptext SLIT("and"),
+ quotes (hsep [ppr ty, ptext SLIT("::"), ppr (typeKind ty)])])
+
+unifyOccurCheck tyvar ty
+ = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:"))
+ 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty]))
+ where
+ (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar
+ (env2, tidy_ty) = tidyType env1 ty
+\end{code}
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Unify]{Unifier}
-
-The unifier is now squarely in the typechecker monad (because of the
-updatable substitution).
-
-\begin{code}
-module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
- unifyFunTy, unifyListTy, unifyTupleTy,
- Subst, unifyTysX, unifyTyListsX
- ) where
-
-#include "HsVersions.h"
-
--- friends:
-import TcMonad
-import Type ( GenType(..), Type, tyVarsOfType,
- typeKind, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe )
-import TyCon ( TyCon, mkFunTyCon, isTupleTyCon, tyConArity, Arity )
-import TyVar ( TyVar, GenTyVar(..), tyVarKind, tyVarFlexi,
- TyVarEnv, lookupTyVarEnv, emptyTyVarEnv, addToTyVarEnv,
- tyVarSetToList
- )
-import TcType ( TcType, TcMaybe(..), TcTauType, TcTyVar,
- newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
- )
--- others:
-import Kind ( Kind, hasMoreBoxityInfo, mkTypeKind, mkBoxedTypeKind )
-import TysWiredIn ( listTyCon, mkListTy, mkTupleTy )
-import Maybes ( maybeToBool )
-import PprType () -- Instances
-import Util
-import Outputable
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Unify-exported]{Exported unification functions}
-%* *
-%************************************************************************
-
-The exported functions are all defined as versions of some
-non-exported generic functions.
-
-Unify two @TauType@s. Dead straightforward.
-
-\begin{code}
-unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
-unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred
- = tcAddErrCtxtM (unifyCtxt ty1 ty2) $
- uTys ty1 ty1 ty2 ty2
-\end{code}
-
-@unifyTauTyList@ unifies corresponding elements of two lists of
-@TauType@s. It uses @uTys@ to do the real work. The lists should be
-of equal length. We charge down the list explicitly so that we can
-complain if their lengths differ.
-
-\begin{code}
-unifyTauTyLists :: [TcTauType s] -> [TcTauType s] -> TcM s ()
-unifyTauTyLists [] [] = returnTc ()
-unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_`
- unifyTauTyLists tys1 tys2
-unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!"
-\end{code}
-
-@unifyTauTyList@ takes a single list of @TauType@s and unifies them
-all together. It is used, for example, when typechecking explicit
-lists, when all the elts should be of the same type.
-
-\begin{code}
-unifyTauTyList :: [TcTauType s] -> TcM s ()
-unifyTauTyList [] = returnTc ()
-unifyTauTyList [ty] = returnTc ()
-unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_`
- unifyTauTyList tys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Unify-uTys]{@uTys@: getting down to business}
-%* *
-%************************************************************************
-
-@uTys@ is the heart of the unifier. Each arg happens twice, because
-we want to report errors in terms of synomyms if poss. The first of
-the pair is used in error messages only; it is always the same as the
-second, except that if the first is a synonym then the second may be a
-de-synonym'd version. This way we get better error messages.
-
-We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
-
-\begin{code}
-uTys :: TcTauType s -> TcTauType s -- Error reporting ty1 and real ty1
- -> TcTauType s -> TcTauType s -- Error reporting ty2 and real ty2
- -> TcM s ()
-
- -- Always expand synonyms (see notes at end)
-uTys ps_ty1 (SynTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (SynTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
-
- -- Variables; go for uVar
-uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar tyvar1 ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar tyvar2 ps_ty1 ty1
-
- -- Functions; just check the two parts
-uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
- = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
-
- -- Type constructors must match
-uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
- = checkTc (con1 == con2 && length tys1 == length tys2)
- (unifyMisMatch ps_ty1 ps_ty2) `thenTc_`
- unifyTauTyLists tys1 tys2
-
- -- Applications need a bit of care!
- -- They can match FunTy and TyConApp
-uTys _ (AppTy s1 t1) _ (AppTy s2 t2)
- = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
-
-uTys _ (AppTy s1 t1) _ (FunTy fun2 arg2)
- = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
- where
- -- Converts a -> b to (->) a b
- s2 = TyConApp mkFunTyCon [fun2]
- t2 = arg2
-
-uTys _ (AppTy s1 t1) _ (TyConApp tc tys@(_:_))
- = case snocView tys of
- (ts2, t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
- where
- -- Not efficient, but simple
- s2 = TyConApp tc ts2
-
-uTys ps1 s1 ps2 s2@(AppTy _ _) = uTys ps2 s2 ps1 s1
- -- Swap arguments if the App is in the second argument
-
- -- Not expecting for-alls in unification
-#ifdef DEBUG
-uTys ps_ty1 (ForAllTy _ _) ps_ty2 ty2 = panic "Unify.uTys:ForAllTy (1st arg)"
-uTys ps_ty1 ty1 ps_ty2 (ForAllTy _ _) = panic "Unify.uTys:ForAllTy (2nd arg)"
-#endif
-
- -- Anything else fails
-uTys ps_ty1 ty1 ps_ty2 ty2 = failWithTc (unifyMisMatch ps_ty1 ps_ty2)
-\end{code}
-
-Notes on synonyms
-~~~~~~~~~~~~~~~~~
-If you are tempted to make a short cut on synonyms, as in this
-pseudocode...
-
-\begin{verbatim}
-uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
- = if (con1 == con2) then
- -- Good news! Same synonym constructors, so we can shortcut
- -- by unifying their arguments and ignoring their expansions.
- unifyTauTypeLists args1 args2
- else
- -- Never mind. Just expand them and try again
- uTys ty1 ty2
-\end{verbatim}
-
-then THINK AGAIN. Here is the whole story, as detected and reported
-by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}:
-\begin{quotation}
-Here's a test program that should detect the problem:
-
-\begin{verbatim}
- type Bogus a = Int
- x = (1 :: Bogus Char) :: Bogus Bool
-\end{verbatim}
-
-The problem with [the attempted shortcut code] is that
-\begin{verbatim}
- con1 == con2
-\end{verbatim}
-is not a sufficient condition to be able to use the shortcut!
-You also need to know that the type synonym actually USES all
-its arguments. For example, consider the following type synonym
-which does not use all its arguments.
-\begin{verbatim}
- type Bogus a = Int
-\end{verbatim}
-
-If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool},
-the unifier would blithely try to unify \tr{Char} with \tr{Bool} and
-would fail, even though the expanded forms (both \tr{Int}) should
-match.
-
-Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would
-unnecessarily bind \tr{t} to \tr{Char}.
-
-... You could explicitly test for the problem synonyms and mark them
-somehow as needing expansion, perhaps also issuing a warning to the
-user.
-\end{quotation}
-
-
-%************************************************************************
-%* *
-\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
-%* *
-%************************************************************************
-
-@uVar@ is called when at least one of the types being unified is a
-variable. It does {\em not} assume that the variable is a fixed point
-of the substitution; rather, notice that @bindTo@ (defined below) nips
-back into @uTys@ if it turns out that the variable is already bound.
-
-There is a slight worry that one might try to @bindTo@ a (say) Poly
-tyvar (as tv1) with an Open tyvar (as ty2) which is already unified to
-an unboxed type. In fact this can't happen, because the Open ones are
-always the ones which are unified away.
-
-\begin{code}
-uVar :: TcTyVar s
- -> TcTauType s -> TcTauType s -- printing and real versions
- -> TcM s ()
-
-uVar tv1 ps_ty2 ty2
- = tcReadTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
- case maybe_ty1 of
- BoundTo ty1 -> uTys ty1 ty1 ps_ty2 ty2
- other -> uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
-
- -- Expand synonyms
-uUnboundVar tv1 maybe_ty1 ps_ty2 (SynTy _ ty2)
- = uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
-
-
- -- The both-type-variable case
-uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
- maybe_ty1
- ps_ty2
- ty2@(TyVarTy tv2@(TyVar uniq2 kind2 name2 box2))
-
- -- Same type variable => no-op
- | uniq1 == uniq2
- = returnTc ()
-
- -- Distinct type variables
- -- ASSERT maybe_ty1 /= BoundTo
- | otherwise
- = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
- case maybe_ty2 of
- BoundTo ty2' -> uUnboundVar tv1 maybe_ty1 ty2' ty2'
-
- UnBound | (kind1 == kind2 && not (maybeToBool name1)) -- Same kinds and tv1 is anonymous
- -- so update tv1
- -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc ()
-
- | kind1 `hasMoreBoxityInfo` kind2 -- Update tv2 if possible
- -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
-
- | kind2 `hasMoreBoxityInfo` kind1 -- Update tv1 if possible
- -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc ()
-
- other -> failWithTc (unifyKindErr tv1 ps_ty2)
-
- -- Second one isn't a type variable
-uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) maybe_ty1 ps_ty2 non_var_ty2
- | typeKind non_var_ty2 `hasMoreBoxityInfo` kind1
- = occur_check non_var_ty2 `thenTc_`
- tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_`
- returnTc ()
-
- | otherwise
- = failWithTc (unifyKindErr tv1 ps_ty2)
-
- where
- occur_check ty = mapTc occur_check_tv (tyVarSetToList (tyVarsOfType ty)) `thenTc_`
- returnTc ()
-
- occur_check_tv tv2@(TyVar uniq2 _ _ box2)
- | uniq1 == uniq2 -- Same tyvar; fail
- = failWithTc (unifyOccurCheck tv1 ps_ty2)
-
- | otherwise -- A different tyvar
- = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
- case maybe_ty2 of
- BoundTo ty2' -> occur_check ty2'
- other -> returnTc ()
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Unify-fun]{@unifyFunTy@}
-%* *
-%************************************************************************
-
-@unifyFunTy@ is used to avoid the fruitless creation of type variables.
-
-\begin{code}
-unifyFunTy :: TcType s -- Fail if ty isn't a function type
- -> TcM s (TcType s, TcType s) -- otherwise return arg and result types
-
-unifyFunTy ty@(TyVarTy tyvar)
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo ty' -> unifyFunTy ty'
- other -> unify_fun_ty_help ty
-
-unifyFunTy ty
- = case splitFunTy_maybe ty of
- Just arg_and_res -> returnTc arg_and_res
- Nothing -> unify_fun_ty_help ty
-
-unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification
- = newTyVarTy mkTypeKind `thenNF_Tc` \ arg ->
- newTyVarTy mkTypeKind `thenNF_Tc` \ res ->
- unifyTauTy ty (mkFunTy arg res) `thenTc_`
- returnTc (arg,res)
-\end{code}
-
-\begin{code}
-unifyListTy :: TcType s -- expected list type
- -> TcM s (TcType s) -- list element type
-
-unifyListTy ty@(TyVarTy tyvar)
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo ty' -> unifyListTy ty'
- other -> unify_list_ty_help ty
-
-unifyListTy ty
- = case splitTyConApp_maybe ty of
- Just (tycon, [arg_ty]) | tycon == listTyCon -> returnTc arg_ty
- other -> unify_list_ty_help ty
-
-unify_list_ty_help ty -- Revert to ordinary unification
- = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy ty (mkListTy elt_ty) `thenTc_`
- returnTc elt_ty
-\end{code}
-
-\begin{code}
-unifyTupleTy :: Arity -> TcType s -> TcM s [TcType s]
-unifyTupleTy arity ty@(TyVarTy tyvar)
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo ty' -> unifyTupleTy arity ty'
- other -> unify_tuple_ty_help arity ty
-
-unifyTupleTy arity ty
- = case splitTyConApp_maybe ty of
- Just (tycon, arg_tys) | isTupleTyCon tycon
- && tyConArity tycon == arity
- -> returnTc arg_tys
- other -> unify_tuple_ty_help arity ty
-
-unify_tuple_ty_help arity ty
- = mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys ->
- unifyTauTy ty (mkTupleTy arity arg_tys) `thenTc_`
- returnTc arg_tys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Unification wih a explicit substitution}
-%* *
-%************************************************************************
-
-Unify types with an explicit substitution and no monad.
-
-\begin{code}
-type Subst = TyVarEnv (GenType Bool) -- Not necessarily idempotent
-
-unifyTysX :: GenType Bool
- -> GenType Bool
- -> Maybe Subst
-unifyTysX ty1 ty2 = uTysX ty1 ty2 (\s -> Just s) emptyTyVarEnv
-
-unifyTyListsX :: [GenType Bool] -> [GenType Bool] -> Maybe Subst
-unifyTyListsX tys1 tys2 = uTyListsX tys1 tys2 (\s -> Just s) emptyTyVarEnv
-
-
-uTysX :: GenType Bool
- -> GenType Bool
- -> (Subst -> Maybe Subst)
- -> Subst
- -> Maybe Subst
-
-uTysX (SynTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst
-uTysX ty1 (SynTy _ ty2) k subst = uTysX ty1 ty2 k subst
-
- -- Variables; go for uVar
-uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst
- | tyvar1 == tyvar2
- = k subst
-uTysX (TyVarTy tyvar1) ty2 k subst
- | tyVarFlexi tyvar1
- = uVarX tyvar1 ty2 k subst
-uTysX ty1 (TyVarTy tyvar2) k subst
- | tyVarFlexi tyvar2
- = uVarX tyvar2 ty1 k subst
-
- -- Functions; just check the two parts
-uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst
- = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst
-
- -- Type constructors must match
-uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst
- | (con1 == con2 && length tys1 == length tys2)
- = uTyListsX tys1 tys2 k subst
-
- -- Applications need a bit of care!
- -- They can match FunTy and TyConApp
-uTysX (AppTy s1 t1) (AppTy s2 t2) k subst
- = uTysX s1 s2 (uTysX t1 t2 k) subst
-
-uTysX (AppTy s1 t1) (FunTy fun2 arg2) k subst
- = uTysX s1 s2 (uTysX t1 t2 k) subst
- where
- -- Converts a -> b to (->) a b
- s2 = TyConApp mkFunTyCon [fun2]
- t2 = arg2
-
-uTysX (AppTy s1 t1) (TyConApp tc tys@(_:_)) k subst
- = case snocView tys of
- (ts2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst
- where
- -- Not efficient, but simple
- s2 = TyConApp tc ts2
-
-uTysX s1 s2@(AppTy _ _) k subst = uTysX s2 s1 k subst
- -- Swap arguments if the App is in the second argument
-
- -- Not expecting for-alls in unification
-#ifdef DEBUG
-uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)"
-uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)"
-#endif
-
- -- Anything else fails
-uTysX ty1 ty2 k subst = Nothing
-
-
-uTyListsX [] [] k subst = k subst
-uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst
-uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths
-\end{code}
-
-\begin{code}
--- Invariant: tv1 is a unifiable variable
-uVarX tv1 ty2 k subst
- = case lookupTyVarEnv subst tv1 of
- Just ty1 -> -- Already bound
- uTysX ty1 ty2 k subst
-
- Nothing -- Not already bound
- | typeKind ty2 `hasMoreBoxityInfo` tyVarKind tv1
- && occur_check_ok ty2
- -> -- No kind mismatch nor occur check
- k (addToTyVarEnv subst tv1 ty2)
-
- | otherwise -> Nothing -- Fail if kind mis-match or occur check
- where
- occur_check_ok ty = all occur_check_ok_tv (tyVarSetToList (tyVarsOfType ty))
- occur_check_ok_tv tv | tv1 == tv = False
- | otherwise = case lookupTyVarEnv subst tv of
- Nothing -> True
- Just ty -> occur_check_ok ty
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Unify-context]{Errors and contexts}
-%* *
-%************************************************************************
-
-Errors
-~~~~~~
-
-\begin{code}
-unifyCtxt ty1 ty2 -- ty1 expected, ty2 inferred
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (err ty1' ty2')
- where
- err ty1' ty2' = vcat [
- hsep [ptext SLIT("Expected:"), ppr ty1'],
- hsep [ptext SLIT("Inferred:"), ppr ty2']
- ]
-
-unifyMisMatch ty1 ty2
- = hang (ptext SLIT("Couldn't match the type"))
- 4 (sep [quotes (ppr ty1), ptext SLIT("against"), quotes (ppr ty2)])
-
-unifyKindErr tyvar ty
- = hang (ptext SLIT("Kind mis-match between"))
- 4 (sep [quotes (hsep [ppr tyvar, ptext SLIT("::"), ppr (tyVarKind tyvar)]),
- ptext SLIT("and"),
- quotes (hsep [ppr ty, ptext SLIT("::"), ppr (typeKind ty)])])
-
-unifyOccurCheck tyvar ty
- = hang (ptext SLIT("Occurs check: cannot construct the infinite type:"))
- 8 (sep [ppr tyvar, char '=', ppr ty])
-\end{code}
-
+++ /dev/null
-_interface_ Class 1
-_exports_
-Class Class GenClass;
-_instances_
-_declarations_
-1 type Class = Class.GenClass BasicTypes.Unused ;
-1 data GenClass a;
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Class]{The @Class@ datatype}
#include "HsVersions.h"
-import {-# SOURCE #-} Id ( Id )
import {-# SOURCE #-} TyCon ( TyCon )
import {-# SOURCE #-} Type ( Type )
import {-# SOURCE #-} SpecEnv ( SpecEnv )
-import TyCon ( TyCon )
-import TyVar ( TyVar )
-import Name ( NamedThing(..), Name, getOccName )
+import Var ( Id, TyVar )
+import Name ( NamedThing(..), Name )
import Unique ( Unique, Uniquable(..) )
-import BasicTypes ( Unused )
-import SrcLoc ( SrcLoc )
import Outputable
import Util
\end{code}
mkClass name tyvars super_classes superdict_sels
dict_sels defms tycon class_insts
- = Class (uniqueOf name) name tyvars
+ = Class (getUnique name) name tyvars
super_classes superdict_sels
dict_sels defms
class_insts
\begin{code}
instance Uniquable Class where
- uniqueOf c = classKey c
+ getUnique c = classKey c
instance NamedThing Class where
getName (Class _ n _ _ _ _ _ _ _) = n
+
+instance Outputable Class where
+ ppr c = ppr (getName c)
+
+instance Show Class where
+ showsPrec p c = showsPrecSDoc p (ppr c)
\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1996
-%
-\section[Kind]{The @Kind@ datatype}
-
-\begin{code}
-module Kind (
- GenKind(..), -- Only visible to friends: TcKind
- Kind,
-
- mkArrowKind,
- mkTypeKind,
- mkUnboxedTypeKind,
- mkBoxedTypeKind,
-
- hasMoreBoxityInfo,
- resultKind, argKind,
-
- pprKind, pprParendKind,
-
- isUnboxedTypeKind, isTypeKind, isBoxedTypeKind
- ) where
-
-#include "HsVersions.h"
-
-import Util ( panic, assertPanic )
-import Unique ( Unique, pprUnique )
-import BasicTypes ( Unused )
-import Outputable
-\end{code}
-
-\begin{code}
-data GenKind flexi
- = TypeKind -- Any type (incl unboxed types)
- | BoxedTypeKind -- Any boxed type
- | UnboxedTypeKind -- Any unboxed type
- | ArrowKind (GenKind flexi) (GenKind flexi)
- | VarKind Unique flexi
-
-type Kind = GenKind Unused -- No variables at all
-
-instance Eq (GenKind flexi) where
- TypeKind == TypeKind = True
- BoxedTypeKind == BoxedTypeKind = True
- UnboxedTypeKind == UnboxedTypeKind = True
- (ArrowKind j1 j2) == (ArrowKind k1 k2) = j1==k1 && j2==k2
- (VarKind u1 _) == (VarKind u2 _) = u1==u2
- k1 == k2 = False
-
-mkArrowKind = ArrowKind
-mkTypeKind = TypeKind
-mkUnboxedTypeKind = UnboxedTypeKind
-mkBoxedTypeKind = BoxedTypeKind
-
-isTypeKind :: GenKind flexi -> Bool
-isTypeKind TypeKind = True
-isTypeKind other = False
-
-isBoxedTypeKind :: GenKind flexi -> Bool
-isBoxedTypeKind BoxedTypeKind = True
-isBoxedTypeKind other = False
-
-isUnboxedTypeKind :: GenKind flexi -> Bool
-isUnboxedTypeKind UnboxedTypeKind = True
-isUnboxedTypeKind other = False
-
-hasMoreBoxityInfo :: GenKind flexi -> GenKind flexi -> Bool
-
-BoxedTypeKind `hasMoreBoxityInfo` TypeKind = True
-BoxedTypeKind `hasMoreBoxityInfo` BoxedTypeKind = True
-
-UnboxedTypeKind `hasMoreBoxityInfo` TypeKind = True
-UnboxedTypeKind `hasMoreBoxityInfo` UnboxedTypeKind = True
-
-TypeKind `hasMoreBoxityInfo` TypeKind = True
-
-kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _)
- = ASSERT( if kind1 == kind2 then True
- else pprPanic "hadMoreBoxityInfo" (ppr kind1 <> comma <+> ppr kind2) )
- True
- -- The two kinds can be arrow kinds; for example when unifying
- -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should
- -- have the same kind.
-
-kind1 `hasMoreBoxityInfo` kind2 = False
-
-resultKind :: GenKind flexi -> GenKind flexi -- Get result from arrow kind
-resultKind (ArrowKind _ res_kind) = res_kind
-resultKind other_kind = panic "resultKind"
-
-argKind :: GenKind flexi -> GenKind flexi -- Get argument from arrow kind
-argKind (ArrowKind arg_kind _) = arg_kind
-argKind other_kind = panic "argKind"
-\end{code}
-
-Printing
-~~~~~~~~
-\begin{code}
-instance Outputable (GenKind flexi) where
- ppr kind = pprKind kind
-
-pprKind TypeKind = text "**" -- Can be boxed or unboxed
-pprKind BoxedTypeKind = char '*'
-pprKind UnboxedTypeKind = text "*#" -- Unboxed
-pprKind (ArrowKind k1 k2) = sep [pprParendKind k1, text "->", pprKind k2]
-pprKind (VarKind u _) = char 'k' <> pprUnique u
-
-pprParendKind k@(ArrowKind _ _) = parens (pprKind k)
-pprParendKind k = pprKind k
-\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[PprType]{Printing Types, TyVars, Classes, TyCons}
\begin{code}
module PprType(
- pprTyVar, pprTyVarBndr, pprTyVarBndrs,
- TyCon, pprTyCon, showTyCon,
+ pprKind, pprParendKind,
pprType, pprParendType,
- pprMaybeTy,
- getTyDescription,
pprConstraint, pprTheta,
+ pprTyVarBndr, pprTyVarBndrs,
+
+ getTyDescription,
nmbrType, nmbrGlobalType
) where
-- friends:
-- (PprType can see all the representations it's trying to print)
-import Type ( GenType(..), Type, ThetaType, splitFunTys, splitDictTy_maybe,
- splitForAllTys, splitSigmaTy, splitRhoTy, splitAppTys )
-import TyVar ( GenTyVar(..), TyVar, cloneTyVar )
-import TyCon ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity )
+import Type ( GenType(..), TyNote(..), Kind, Type, ThetaType,
+ splitFunTys, splitDictTy_maybe,
+ splitForAllTys, splitSigmaTy, splitRhoTy,
+ boxedTypeKind
+ )
+import Var ( GenTyVar, TyVar, tyVarKind,
+ tyVarName, setTyVarName
+ )
+import VarEnv
+import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, tyConArity )
import Class ( Class )
-import Kind ( GenKind(..), isBoxedTypeKind, pprParendKind )
-- others:
-import CmdLineOpts ( opt_PprUserLength )
import Maybes ( maybeToBool )
-import Name ( nameString, pprOccName, getOccString, OccName, NamedThing(..) )
+import Name ( getOccString, setNameVisibility, NamedThing(..) )
import Outputable
import PprEnv
-import BasicTypes ( Unused )
-import UniqFM ( UniqFM, addToUFM, emptyUFM, lookupUFM )
-import Unique ( Unique, Uniquable(..), pprUnique,
+import Unique ( Unique, Uniquable(..),
incrUnique, listTyConKey, initTyVarUnique
)
import Util
\end{code}
+%************************************************************************
+%* *
+\subsection{The external interface}
+%* *
+%************************************************************************
+
+@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
+defined to use this. @pprParendType@ is the same, except it puts
+parens around the type, except for the atomic cases. @pprParendType@
+works just by setting the initial context precedence very high.
+
\begin{code}
-instance Outputable (GenType flexi) where
- ppr ty = pprType ty
+pprType, pprParendType :: GenType flexi -> SDoc
+pprType ty = ppr_ty pprTyEnv tOP_PREC ty
+pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty
-instance Outputable TyCon where
- ppr tycon = pprTyCon tycon
+pprKind, pprParendKind :: Kind -> SDoc
+pprKind = pprType
+pprParendKind = pprParendType
-instance Outputable Class where
- -- we use pprIfaceClass for printing in interfaces
- ppr clas = ppr (getName clas)
+pprConstraint :: Class -> [GenType flexi] -> SDoc
+pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
-instance Outputable (GenTyVar flexi) where
- ppr tv = pprTyVar tv
+pprTheta :: ThetaType -> SDoc
+pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
+ where
+ ppr_dict (c,tys) = pprConstraint c tys
+
+instance Outputable (GenType flexi) where
+ ppr ty = pprType ty
\end{code}
+
%************************************************************************
%* *
-\subsection[Type]{@Type@}
+\subsection{Pretty printing}
%* *
%************************************************************************
| otherwise = parens pretty
\end{code}
-@pprType@ is the std @Type@ printer; the overloaded @ppr@ function is
-defined to use this. @pprParendType@ is the same, except it puts
-parens around the type, except for the atomic cases. @pprParendType@
-works just by setting the initial context precedence very high.
-
\begin{code}
-pprType, pprParendType :: GenType flexi -> SDoc
-
-pprType ty = ppr_ty init_ppr_env tOP_PREC ty
-pprParendType ty = ppr_ty init_ppr_env tYCON_PREC ty
-
-pprConstraint :: Class -> [GenType flexi] -> SDoc
-pprConstraint clas tys = hsep [ppr clas, hsep (map (pprParendType) tys)]
-
-pprTheta :: ThetaType -> SDoc
-pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
- where
- ppr_dict (c,tys) = pprConstraint c tys
-
-pprMaybeTy :: Maybe (GenType flexi) -> SDoc
-pprMaybeTy Nothing = char '*'
-pprMaybeTy (Just ty) = pprParendType ty
-\end{code}
-
-\begin{code}
-ppr_ty :: PprEnv flexi bndr occ -> Int
+ppr_ty :: PprEnv (GenTyVar flexi) flexi -> Int
-> GenType flexi
-> SDoc
ppr_ty env ctxt_prec (TyVarTy tyvar)
= pTyVarO env tyvar
- -- TUPLE CASE
+ -- TUPLE CASE (boxed and unboxed)
ppr_ty env ctxt_prec (TyConApp tycon tys)
| isTupleTyCon tycon
- && length tys == tyConArity tycon -- no magic if partially applied
+ && length tys == tyConArity tycon -- no magic if partially applied
= parens tys_w_commas
+
+ | isUnboxedTupleTyCon tycon
+ && length tys == tyConArity tycon -- no magic if partially applied
+ = parens (char '#' <+> tys_w_commas <+> char '#')
where
- tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
+ tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
-- LIST CASE
ppr_ty env ctxt_prec (TyConApp tycon [ty])
- | uniqueOf tycon == listTyConKey
+ | getUnique tycon == listTyConKey
= brackets (ppr_ty env tOP_PREC ty)
-- DICTIONARY CASE, prints {C a}
-- NO-ARGUMENT CASE (=> no parens)
ppr_ty env ctxt_prec (TyConApp tycon [])
- = ppr_tycon env tycon
+ = ppr tycon
-- GENERAL CASE
ppr_ty env ctxt_prec (TyConApp tycon tys)
- = maybeParen ctxt_prec tYCON_PREC (hsep [ppr_tycon env tycon, tys_w_spaces])
+ = maybeParen ctxt_prec tYCON_PREC (hsep [ppr tycon, tys_w_spaces])
where
tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) tys)
ppr_ty env ctxt_prec ty@(ForAllTy _ _)
= getPprStyle $ \ sty ->
- let
- (tyvars, rho_ty) = splitForAllTys ty
- (theta, body_ty) | show_context = splitRhoTy rho_ty
- | otherwise = ([], rho_ty)
+ maybeParen ctxt_prec fUN_PREC $
+ if userStyle sty then
+ sep [ ptext SLIT("forall"), pp_tyvars, ptext SLIT("."), pp_maybe_ctxt, pp_body ]
+ else
+ sep [ ptext SLIT("__forall"), brackets pp_tyvars, pp_ctxt, pp_body ]
+ where
+ (tyvars, rho_ty) = splitForAllTys ty
+ (theta, body_ty) = splitRhoTy rho_ty
- pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars))
- pp_body = ppr_ty env tOP_PREC body_ty
+ pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars)
+ pp_body = ppr_ty env tOP_PREC body_ty
- show_forall = not (userStyle sty)
- show_context = ifaceStyle sty || userStyle sty
- in
- if show_forall then
- maybeParen ctxt_prec fUN_PREC $
- sep [ ptext SLIT("_forall_"), pp_tyvars,
- ppr_theta env theta, ptext SLIT("=>"), pp_body
- ]
+ pp_maybe_ctxt | null theta = empty
+ | otherwise = pp_ctxt
- else if null theta then
- ppr_ty env ctxt_prec body_ty
+ pp_ctxt = ppr_theta env theta <+> ptext SLIT("=>")
- else
- maybeParen ctxt_prec fUN_PREC $
- sep [ppr_theta env theta, ptext SLIT("=>"), pp_body]
ppr_ty env ctxt_prec (FunTy ty1 ty2)
-- We fiddle the precedences passed to left/right branches,
= maybeParen ctxt_prec tYCON_PREC $
ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2
-ppr_ty env ctxt_prec (SynTy ty expansion)
+ppr_ty env ctxt_prec (NoteTy (SynNote ty) expansion)
= ppr_ty env ctxt_prec ty
+ppr_ty env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty
+
ppr_theta env [] = empty
ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
-ppr_dict env ctxt (clas, tys) = ppr_class env clas <+>
+ppr_dict env ctxt (clas, tys) = ppr clas <+>
hsep (map (ppr_ty env tYCON_PREC) tys)
\end{code}
\begin{code}
-init_ppr_env
- = initPprEnv b b b b (Just pprTyVarBndr) (Just ppr) b b b
+pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b
where
b = panic "PprType:init_ppr_env"
-
-ppr_tycon env tycon = ppr tycon
-ppr_class env clas = ppr clas
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-pprTyVar (TyVar uniq kind maybe_name _)
- = case maybe_name of
- -- If the tyvar has a name we can safely use just it, I think
- Just n -> pprOccName (getOccName n) <> ifPprDebug pp_debug
- Nothing -> pprUnique uniq
- where
- pp_debug = text "_" <> pp_kind <> pprUnique uniq
-
- pp_kind = case kind of
- TypeKind -> char 'o'
- BoxedTypeKind -> char 't'
- UnboxedTypeKind -> char 'u'
- ArrowKind _ _ -> char 'a'
-\end{code}
-
-We print type-variable binders with their kinds in interface files.
+We print type-variable binders with their kinds in interface files,
+and when in debug mode.
\begin{code}
-pprTyVarBndr tyvar@(TyVar uniq kind name _)
+pprTyVarBndr tyvar
= getPprStyle $ \ sty ->
- if ifaceStyle sty && not (isBoxedTypeKind kind) then
- hcat [pprTyVar tyvar, text " :: ", pprParendKind kind]
- -- See comments with ppDcolon in PprCore.lhs
+ if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then
+ hcat [ppr tyvar, text " :: ", pprParendKind kind]
+ -- See comments with ppDcolon in PprCore.lhs
else
- pprTyVar tyvar
+ ppr tyvar
+ where
+ kind = tyVarKind tyvar
pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
\end{code}
-%************************************************************************
-%* *
-\subsection[TyCon]{@TyCon@}
-%* *
-%************************************************************************
-
-ToDo; all this is suspiciously like getOccName!
-
-\begin{code}
-showTyCon :: TyCon -> String
-showTyCon tycon = showSDoc (pprTyCon tycon)
-
-pprTyCon :: TyCon -> SDoc
-pprTyCon tycon = ppr (getName tycon)
-\end{code}
-
-
%************************************************************************
%* *
Grab a name for the type. This is used to determine the type
description for profiling.
+
\begin{code}
getTyDescription :: Type -> String
AppTy fun _ -> getTyDescription fun
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
- SynTy ty1 _ -> getTyDescription ty1
+ NoteTy (FTVNote _) ty -> getTyDescription ty
+ NoteTy (SynNote ty1) _ -> getTyDescription ty1
ForAllTy _ ty -> getTyDescription ty
}
where
\end{code}
-
%************************************************************************
%* *
\subsection{Renumbering types}
\begin{code}
nmbrGlobalType :: Type -> Type -- Renumber a top-level type
-nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) initTyVarUnique ty
+nmbrGlobalType ty = nmbrType emptyVarEnv initTyVarUnique ty
-nmbrType :: (TyVar -> TyVar) -- Mapping for free vars
- -> Unique
+nmbrType :: TyVarEnv Type -- Substitution
+ -> Unique -- This unique and its successors are not
+ -- free in the range of the substitution
-> Type
-> Type
nmbrTy :: Type -> NmbrM Type
nmbrTy (TyVarTy tv)
- = lookupTyVar tv `thenNmbr` \ new_tv ->
- returnNmbr (TyVarTy new_tv)
+ = lookupTyVar tv
nmbrTy (AppTy t1 t2)
= nmbrTy t1 `thenNmbr` \ new_t1 ->
returnNmbr (AppTy new_t1 new_t2)
nmbrTy (TyConApp tc tys)
- = nmbrTys tys `thenNmbr` \ new_tys ->
+ = mapNmbr nmbrTy tys `thenNmbr` \ new_tys ->
returnNmbr (TyConApp tc new_tys)
-nmbrTy (SynTy ty1 ty2)
+nmbrTy (NoteTy (SynNote ty1) ty2)
= nmbrTy ty1 `thenNmbr` \ new_ty1 ->
nmbrTy ty2 `thenNmbr` \ new_ty2 ->
- returnNmbr (SynTy new_ty1 new_ty2)
+ returnNmbr (NoteTy (SynNote new_ty1) new_ty2)
+
+nmbrTy (NoteTy (FTVNote _) ty2) = nmbrTy ty2
nmbrTy (ForAllTy tv ty)
= addTyVar tv $ \ new_tv ->
returnNmbr (FunTy new_t1 new_t2)
-nmbrTys tys = mapNmbr nmbrTy tys
-
-lookupTyVar tyvar (NmbrEnv tv_fn tv_env) uniq
- = (uniq, tyvar')
+lookupTyVar tyvar env uniq
+ = (uniq, ty)
where
- tyvar' = case lookupUFM tv_env tyvar of
- Just tyvar' -> tyvar'
- Nothing -> tv_fn tyvar
+ ty = case lookupVarEnv env tyvar of
+ Just ty -> ty
+ Nothing -> TyVarTy tyvar
-addTyVar tv m (NmbrEnv f_tv tv_ufm) u
- = m tv' nenv u'
+addTyVar tv m env u
+ = m tv' env' u'
where
- nenv = NmbrEnv f_tv tv_ufm'
- tv_ufm' = addToUFM tv_ufm tv tv'
- tv' = cloneTyVar tv u
- u' = incrUnique u
+ env' = extendVarEnv env tv (TyVarTy tv')
+ tv' = setTyVarName tv (setNameVisibility Nothing u (tyVarName tv))
+ u' = incrUnique u
\end{code}
Monad stuff
\begin{code}
-data NmbrEnv
- = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars
-
-type NmbrM a = NmbrEnv -> Unique -> (Unique, a) -- Unique is name supply
+type NmbrM a = TyVarEnv Type -> Unique -> (Unique, a) -- Unique is name supply
-initNmbr :: (TyVar -> TyVar) -> Unique -> NmbrM a -> a
-initNmbr tyvar_env uniq m
- = let
- init_nmbr_env = NmbrEnv tyvar_env emptyUFM
- in
- snd (m init_nmbr_env uniq)
+initNmbr :: TyVarEnv Type -> Unique -> NmbrM a -> a
+initNmbr env uniq m
+ = snd (m env uniq)
returnNmbr x nenv u = (u, x)
_interface_ TyCon 1
_exports_
-TyCon TyCon;
+TyCon TyCon isTupleTyCon isUnboxedTupleTyCon isFunTyCon;
_declarations_
1 data TyCon;
+1 isTupleTyCon _:_ TyCon -> PrelBase.Bool ;;
+1 isUnboxedTupleTyCon _:_ TyCon -> PrelBase.Bool ;;
+1 isFunTyCon _:_ TyCon -> PrelBase.Bool ;;
--- /dev/null
+__interface TyCon 1 0 where
+__export TyCon TyCon isTupleTyCon isUnboxedTupleTyCon isFunTyCon;
+1 data TyCon ;
+1 isTupleTyCon :: TyCon -> PrelBase.Bool ;
+1 isUnboxedTupleTyCon :: TyCon -> PrelBase.Bool ;
+1 isFunTyCon :: TyCon -> PrelBase.Bool ;
-
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TyCon]{The @TyCon@ datatype}
\begin{code}
module TyCon(
- TyCon,
+ TyCon, KindCon, Boxity(..),
- Arity, NewOrData(..),
+ isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
+ isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
+ isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon,
- isFunTyCon, isPrimTyCon, isBoxedTyCon, isProductTyCon,
- isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon,
- isEnumerationTyCon, isTupleTyCon,
-
- mkDataTyCon,
+ mkAlgTyCon,
mkFunTyCon,
mkPrimTyCon,
- mkSpecTyCon,
mkTupleTyCon,
-
mkSynTyCon,
+ mkKindCon,
+ superKindCon,
tyConKind,
tyConUnique,
tyConClass_maybe,
getSynTyConDefn,
- maybeTyConSingleCon
+ maybeTyConSingleCon,
+
+ matchesTyCon
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Type ( Type )
-import {-# SOURCE #-} Class ( Class )
-import {-# SOURCE #-} Id ( Id, isNullaryDataCon )
-import {-# SOURCE #-} TysWiredIn ( tupleCon )
-
+import {-# SOURCE #-} Type ( Type, Kind )
+import {-# SOURCE #-} DataCon ( DataCon )
+import Class ( Class )
+import Var ( TyVar )
import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
-import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, TyVar )
-import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkUnboxedTypeKind,
- mkArrowKind, resultKind, argKind
- )
import Maybes
-import Name ( Name, nameUnique, mkWiredInTyConName, NamedThing(getName) )
-import Unique ( Unique, funTyConKey, Uniquable(..) )
+import Name ( Name, nameUnique, NamedThing(getName) )
+import Unique ( Unique, Uniquable(..), superKindConKey )
import PrimRep ( PrimRep(..), isFollowableRep )
-import PrelMods ( pREL_GHC )
-import Util ( panic )
+import Outputable
\end{code}
+%************************************************************************
+%* *
+\subsection{The data type}
+%* *
+%************************************************************************
+
\begin{code}
+type KindCon = TyCon
+
data TyCon
- = FunTyCon -- Kind = Type -> Type -> Type
-
- | DataTyCon Unique
- Name
- Kind
- [TyVar]
- [(Class,[Type])] -- Its context
- [Id{-DataCon-}] -- Its data constructors, with fully polymorphic types
- -- This list can be empty, when we import a data type abstractly,
- -- either (a) the interface is hand-written and doesn't give
- -- the constructors, or
- -- (b) in a quest for fast compilation we don't import
- -- the constructors
- [Class] -- Classes which have derived instances
- (Maybe Class) -- Nothing for ordinary types; Just c for the type constructor
- -- for dictionaries of class c.
- NewOrData
- RecFlag -- Tells whether the data type is part of
- -- a mutually-recursive group or not
-
- | TupleTyCon Unique -- cached
- Name -- again, we could do without this, but
- -- it makes life somewhat easier
- Arity -- just a special case of DataTyCon
- -- Kind = BoxedTypeKind
- -- -> ... (n times) ...
- -- -> BoxedTypeKind
- -- -> BoxedTypeKind
-
- | PrimTyCon -- Primitive types; cannot be defined in Haskell
- Unique -- Always unpointed; hence never represented by a closure
- Name -- Often represented by a bit-pattern for the thing
- Kind -- itself (eg Int#), but sometimes by a pointer to
- Arity -- the thing.
- PrimRep
-
- | SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
- TyCon
- [Maybe Type] -- Specialising types
-
- -- OLD STUFF ABOUT Array types. Use SpecTyCon instead
- -- ([PrimRep] -> PrimRep) -- a heap-allocated object (eg ArrInt#).
- -- The primitive types Arr# and StablePtr# have
- -- parameters (hence arity /= 0); but the rest don't.
- -- Only arrays use the list in a non-trivial way.
- -- Length of that list must == arity.
-
- | SynTyCon
- Unique
- Name
- Kind
- Arity
- [TyVar] -- Argument type variables
- Type -- Right-hand side, mentioning these type vars.
- -- Acts as a template for the expansion when
- -- the tycon is applied to some types.
+ = FunTyCon {
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity
+ }
+
+
+ | AlgTyCon { -- Tuples, data type, and newtype decls.
+ -- All lifted, all boxed
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity,
+
+ tyConTyVars :: [TyVar],
+ dataTyConTheta :: [(Class,[Type])],
+
+ dataCons :: [DataCon],
+ -- Its data constructors, with fully polymorphic types
+ -- This list can be empty, when we import a data type abstractly,
+ -- either (a) the interface is hand-written and doesn't give
+ -- the constructors, or
+ -- (b) in a quest for fast compilation we don't import
+ -- the constructors
+
+ dataTyConDerivings :: [Class], -- Classes which have derived instances
+
+ dataTyConClass_maybe :: (Maybe Class), -- Nothing for ordinary types;
+ -- Just c for the type constructor
+ -- for dictionaries of class c.
+ algTyConFlavour :: NewOrData,
+ algTyConRec :: RecFlag -- Tells whether the data type is part of
+ -- a mutually-recursive group or not
+ }
+
+ | PrimTyCon { -- Primitive types; cannot be defined in Haskell
+ -- NB: All of these guys are *unlifted*, but not all are *unboxed*
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity,
+ primTyConRep :: PrimRep
+ }
+
+ | TupleTyCon {
+
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity,
+ tyConBoxed :: Bool,
+ tyConTyVars :: [TyVar],
+ dataCon :: DataCon
+ }
+
+ | SynTyCon {
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity,
+
+ tyConTyVars :: [TyVar], -- Bound tyvars
+ synTyConDefn :: Type -- Right-hand side, mentioning these type vars.
+ -- Acts as a template for the expansion when
+ -- the tycon is applied to some types.
+ }
+
+ | KindCon { -- Type constructor at the kind level
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity,
+
+ kindConBoxity :: Boxity
+ }
+
+ | SuperKindCon { -- The type of kind variables,
+ tyConUnique :: Unique -- sometimes written as a box
+ }
+
+data Boxity = Boxed | Unboxed | Open
\end{code}
-\begin{code}
-mkFunTyCon = FunTyCon
-mkFunTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("->") FunTyCon
-
-mkSpecTyCon = SpecTyCon
-mkTupleTyCon = TupleTyCon
+%************************************************************************
+%* *
+\subsection{TyCon Construction}
+%* *
+%************************************************************************
-mkDataTyCon name = DataTyCon (nameUnique name) name
+Note: the TyCon constructors all take a Kind as one argument, even though
+they could, in principle, work out their Kind from their other arguments.
+But to do so they need functions from Types, and that makes a nasty
+module mutual-recursion. And they aren't called from many places.
+So we compromise, and move their Kind calculation to the call site.
-mkPrimTyCon name arity rep
- = PrimTyCon (nameUnique name) name (mk_kind arity) arity rep
- where
- mk_kind 0 | isFollowableRep rep = mkBoxedTypeKind -- Represented by a GC-ish ptr
- | otherwise = mkUnboxedTypeKind -- Represented by a non-ptr
- mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1)
+\begin{code}
+superKindCon = SuperKindCon superKindConKey
+
+mkKindCon name kind boxity
+ = KindCon {
+ tyConUnique = nameUnique name,
+ tyConName = name,
+ tyConArity = 0,
+ tyConKind = kind,
+ kindConBoxity = boxity
+ }
+
+mkFunTyCon name kind
+ = FunTyCon {
+ tyConUnique = nameUnique name,
+ tyConName = name,
+ tyConKind = kind,
+ tyConArity = 2
+ }
+
+mkAlgTyCon name kind tyvars theta cons derivs maybe_clas flavour rec
+ = AlgTyCon {
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = length tyvars,
+ tyConTyVars = tyvars,
+ dataTyConTheta = theta,
+ dataCons = cons,
+ dataTyConDerivings = derivs,
+ dataTyConClass_maybe = maybe_clas,
+ algTyConFlavour = flavour,
+ algTyConRec = rec
+ }
+
+mkTupleTyCon name kind arity tyvars con boxed
+ = TupleTyCon {
+ tyConUnique = nameUnique name,
+ tyConName = name,
+ tyConKind = kind,
+ tyConArity = arity,
+ tyConBoxed = boxed,
+ tyConTyVars = tyvars,
+ dataCon = con
+ }
+
+mkPrimTyCon name kind arity rep
+ = PrimTyCon {
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = arity,
+ primTyConRep = rep
+ }
+
+mkSynTyCon name kind arity tyvars rhs
+ = SynTyCon {
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = arity,
+ tyConTyVars = tyvars,
+ synTyConDefn = rhs
+ }
+\end{code}
-mkSynTyCon name = SynTyCon (nameUnique name) name
+\begin{code}
+isFunTyCon (FunTyCon {}) = True
+isFunTyCon _ = False
-isFunTyCon FunTyCon = True
-isFunTyCon _ = False
+isPrimTyCon (PrimTyCon {}) = True
+isPrimTyCon _ = False
-isPrimTyCon (PrimTyCon _ _ _ _ _) = True
-isPrimTyCon _ = False
+isUnLiftedTyCon (PrimTyCon {}) = True
+isUnLiftedTyCon (TupleTyCon { tyConBoxed = False }) = True
+isUnLiftedTyCon _ = False
--- At present there are no unboxed non-primitive types, so
--- isBoxedTyCon is just the negation of isPrimTyCon.
-isBoxedTyCon = not . isPrimTyCon
+-- isBoxedTyCon should not be applied to SynTyCon, nor KindCon
+isBoxedTyCon (AlgTyCon {}) = True
+isBoxedTyCon (FunTyCon {}) = True
+isBoxedTyCon (TupleTyCon {tyConBoxed = boxed}) = boxed
+isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep
-- isAlgTyCon returns True for both @data@ and @newtype@
-isAlgTyCon (DataTyCon _ _ _ _ _ _ _ _ _ _) = True
-isAlgTyCon (TupleTyCon _ _ _) = True
-isAlgTyCon other = False
+isAlgTyCon (AlgTyCon {}) = True
+isAlgTyCon (TupleTyCon {}) = True
+isAlgTyCon other = False
-- isDataTyCon returns False for @newtype@.
-isDataTyCon (DataTyCon _ _ _ _ _ _ _ _ DataType _) = True
-isDataTyCon (TupleTyCon _ _ _) = True
-isDataTyCon other = False
+isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of
+ NewType -> False
+ other -> True
+isDataTyCon (TupleTyCon {}) = True -- is an unboxed tuple a datatype?
+isDataTyCon other = False
-isNewTyCon (DataTyCon _ _ _ _ _ _ _ _ NewType _) = True
-isNewTyCon other = False
+isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True
+isNewTyCon other = False
-- A "product" tycon is non-recursive and has one constructor,
-- whether DataType or NewType
-isProductTyCon (TupleTyCon _ _ _) = True
-isProductTyCon (DataTyCon _ _ _ _ _ [c] _ _ _ NonRecursive) = True
-isProductTyCon other = False
-
-isSynTyCon (SynTyCon _ _ _ _ _ _) = True
-isSynTyCon _ = False
-
-isEnumerationTyCon (TupleTyCon _ _ arity)
- = arity == 0
-isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _ DataType _)
- = not (null data_cons) && all isNullaryDataCon data_cons
-isEnumerationTyCon other = False
-
-isTupleTyCon (TupleTyCon _ _ arity) = arity >= 2 -- treat "0-tuple" specially
-isTupleTyCon (SpecTyCon tc tys) = isTupleTyCon tc
-isTupleTyCon other = False
-\end{code}
+isProductTyCon (AlgTyCon {dataCons = [c], algTyConRec = NonRecursive}) = True
+isProductTyCon (TupleTyCon {}) = True
+isProductTyCon other = False
-\begin{code}
--- Special cases to avoid reconstructing lots of kinds
-kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind
-kind2 = mkBoxedTypeKind `mkArrowKind` kind1
-
-tyConKind :: TyCon -> Kind
-tyConKind FunTyCon = kind2
-tyConKind (DataTyCon _ _ kind _ _ _ _ _ _ _) = kind
-tyConKind (PrimTyCon _ _ kind _ _) = kind
-tyConKind (SynTyCon _ _ k _ _ _) = k
-
-tyConKind (TupleTyCon _ _ n)
- = mkArrow n
- where
- mkArrow 0 = mkBoxedTypeKind
- mkArrow 1 = kind1
- mkArrow 2 = kind2
- mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1)
-
-tyConKind (SpecTyCon tc tys)
- = spec (tyConKind tc) tys
- where
- spec kind [] = kind
- spec kind (Just _ : tys) = spec (resultKind kind) tys
- spec kind (Nothing : tys) =
- argKind kind `mkArrowKind` spec (resultKind kind) tys
-\end{code}
+isSynTyCon (SynTyCon {}) = True
+isSynTyCon _ = False
-\begin{code}
-tyConUnique :: TyCon -> Unique
-tyConUnique FunTyCon = funTyConKey
-tyConUnique (DataTyCon uniq _ _ _ _ _ _ _ _ _) = uniq
-tyConUnique (TupleTyCon uniq _ _) = uniq
-tyConUnique (PrimTyCon uniq _ _ _ _) = uniq
-tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq
-tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon"
-
-tyConArity :: TyCon -> Arity
-tyConArity FunTyCon = 2
-tyConArity (DataTyCon _ _ _ tyvars _ _ _ _ _ _) = length tyvars
-tyConArity (TupleTyCon _ _ arity) = arity
-tyConArity (PrimTyCon _ _ _ arity _) = arity
-tyConArity (SynTyCon _ _ _ arity _ _) = arity
-tyConArity (SpecTyCon _ _ ) = panic "tyConArity:SpecTyCon"
-\end{code}
+isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumType}) = True
+isEnumerationTyCon other = False
-\begin{code}
-tyConTyVars :: TyCon -> [TyVar]
-tyConTyVars FunTyCon = [alphaTyVar,betaTyVar]
-tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _ _ _) = tvs
-tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars
-tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs
-#ifdef DEBUG
-tyConTyVars (PrimTyCon _ _ _ _ _) = panic "tyConTyVars:PrimTyCon"
-tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon"
-#endif
+-- The unit tycon isn't classed as a tuple tycon
+isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2
+isTupleTyCon other = False
+
+isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True
+isUnboxedTupleTyCon other = False
\end{code}
\begin{code}
-tyConDataCons :: TyCon -> [Id]
-tyConFamilySize :: TyCon -> Int
-
-tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _ _) = data_cons
-tyConDataCons (TupleTyCon _ _ a) = [tupleCon a]
-tyConDataCons other = []
+tyConDataCons :: TyCon -> [DataCon]
+tyConDataCons (AlgTyCon {dataCons = cons}) = cons
+tyConDataCons (TupleTyCon {dataCon = con}) = [con]
+tyConDataCons other = []
-- You may think this last equation should fail,
-- but it's quite convenient to return no constructors for
-- a synonym; see for example the call in TcTyClsDecls.
-tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _ _ _) = length data_cons
-tyConFamilySize (TupleTyCon _ _ _) = 1
+tyConFamilySize :: TyCon -> Int
+tyConFamilySize (AlgTyCon {dataCons = cons}) = length cons
+tyConFamilySize (TupleTyCon {}) = 1
#ifdef DEBUG
---tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon other)
+tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
#endif
tyConPrimRep :: TyCon -> PrimRep
-tyConPrimRep (PrimTyCon _ __ _ rep) = rep
-tyConPrimRep _ = PtrRep
+tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
+tyConPrimRep _ = PtrRep
\end{code}
\begin{code}
tyConDerivings :: TyCon -> [Class]
-tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _ _) = derivs
-tyConDerivings other = []
+tyConDerivings (AlgTyCon {dataTyConDerivings = derivs}) = derivs
+tyConDerivings other = []
\end{code}
\begin{code}
tyConTheta :: TyCon -> [(Class, [Type])]
-tyConTheta (DataTyCon _ _ _ _ theta _ _ _ _ _) = theta
-tyConTheta (TupleTyCon _ _ _) = []
+tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta
-- should ask about anything else
\end{code}
\begin{code}
getSynTyConDefn :: TyCon -> ([TyVar], Type)
-getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
+getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,ty)
\end{code}
\begin{code}
-maybeTyConSingleCon :: TyCon -> Maybe Id
-
-maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (tupleCon arity)
-maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _ _ _) = Just c
-maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _ _ _) = Nothing
-maybeTyConSingleCon (PrimTyCon _ _ _ _ _) = Nothing
-maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon"
- -- requires DataCons of TyCon
+maybeTyConSingleCon :: TyCon -> Maybe DataCon
+maybeTyConSingleCon (AlgTyCon {dataCons = [c]}) = Just c
+maybeTyConSingleCon (AlgTyCon {}) = Nothing
+maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
+maybeTyConSingleCon (PrimTyCon {}) = Nothing
\end{code}
\begin{code}
tyConClass_maybe :: TyCon -> Maybe Class
-tyConClass_maybe (DataTyCon _ _ _ _ _ _ _ maybe_cls _ _) = maybe_cls
-tyConClass_maybe other_tycon = Nothing
+tyConClass_maybe (AlgTyCon {dataTyConClass_maybe = maybe_cls}) = maybe_cls
+tyConClass_maybe other_tycon = Nothing
\end{code}
-@derivedFor@ reports if we have an {\em obviously}-derived instance
-for the given class/tycon. Of course, you might be deriving something
-because it a superclass of some other obviously-derived class --- this
-function doesn't deal with that.
-
-ToDo: what about derivings for specialised tycons !!!
%************************************************************************
%* *
a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = uniqueOf a `compare` uniqueOf b
+ compare a b = getUnique a `compare` getUnique b
instance Uniquable TyCon where
- uniqueOf tc = tyConUnique tc
+ getUnique tc = tyConUnique tc
+
+instance Outputable TyCon where
+ ppr tc = ppr (getName tc)
+
+instance NamedThing TyCon where
+ getName = tyConName
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Kind constructors}
+%* *
+%************************************************************************
+
+@matchesTyCon tc1 tc2@ checks whether an appliation
+(tc1 t1..tn) matches (tc2 t1..tn). By "matches" we basically mean "equals",
+except that at the kind level tc2 might have more boxity info that tc1.
+
+E.g. It's ok to bind a type variable
+ tv :: k2
+to a type
+ t :: k1
+
\begin{code}
-instance NamedThing TyCon where
- getName (DataTyCon _ n _ _ _ _ _ _ _ _) = n
- getName (PrimTyCon _ n _ _ _) = n
- getName (SpecTyCon tc _) = getName tc
- getName (SynTyCon _ n _ _ _ _) = n
- getName FunTyCon = mkFunTyConName
- getName (TupleTyCon _ n _) = n
-
-{- LATER:
- getName (SpecTyCon tc tys) = let (OrigName m n) = origName "????" tc in
- (m, n _APPEND_ specMaybeTysSuffix tys)
- getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc))
- getName other = Nothing
--}
+matchesTyCon :: TyCon -- Expected (e.g. arg type of function)
+ -> TyCon -- Inferred (e.g. type of actual arg to function)
+ -> Bool
+
+matchesTyCon (KindCon {kindConBoxity = k1}) (KindCon {kindConBoxity = k2})
+ = k2 `has_more` k1
+ where
+ -- "has_more" means has more boxity info
+ Boxed `has_more` Open = True
+ Boxed `has_more` Boxed = True
+ Unboxed `has_more` Open = True
+ Unboxed `has_more` Unboxed = True
+ Open `has_more` Open = True
+ k1 `has_more` k2 = False
+
+matchesTyCon tc1 tc2 = tyConUnique tc1 == tyConUnique tc2
\end{code}
+++ /dev/null
-\begin{code}
-module TyVar (
- GenTyVar(..), TyVar,
-
- mkTyVar, mkSysTyVar,
- tyVarKind, -- TyVar -> Kind
- tyVarFlexi, -- GenTyVar flexi -> flexi
- setTyVarFlexi,
- cloneTyVar, nameTyVar,
-
- openAlphaTyVar, openAlphaTyVars,
- alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
-
- -- We also export "environments" keyed off of
- -- TyVars and "sets" containing TyVars:
- TyVarEnv,
- emptyTyVarEnv, mkTyVarEnv, zipTyVarEnv, addToTyVarEnv, plusTyVarEnv,
- growTyVarEnvList, isEmptyTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
-
- GenTyVarSet, TyVarSet,
- emptyTyVarSet, unitTyVarSet, unionTyVarSets, addOneToTyVarSet,
- unionManyTyVarSets, intersectTyVarSets, mkTyVarSet,
- tyVarSetToList, elementOfTyVarSet, minusTyVarSet,
- isEmptyTyVarSet, delOneFromTyVarSet
- ) where
-
-#include "HsVersions.h"
-
--- friends
-import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-
--- others
-import UniqSet -- nearly all of it
-import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, delFromUFM,
- plusUFM, sizeUFM, delFromUFM, isNullUFM, UniqFM
- )
-import BasicTypes ( Unused, unused )
-import Name ( mkSysLocalName, mkLocalName, Name, NamedThing(..), OccName )
-import SrcLoc ( noSrcLoc, SrcLoc )
-import Unique ( initTyVarUnique, incrUnique, Unique, Uniquable(..) )
-import Util ( zipEqual )
-import Outputable
-\end{code}
-
-\begin{code}
-data GenTyVar flexi_slot
- = TyVar
- Unique
- Kind
- (Maybe Name) -- User name (if any)
- flexi_slot -- Extra slot used during type and usage
- -- inference, and to contain usages.
-
-type TyVar = GenTyVar Unused
-
-tyVarFlexi :: GenTyVar flexi -> flexi
-tyVarFlexi (TyVar _ _ _ flex) = flex
-
-setTyVarFlexi :: GenTyVar flexi1 -> flexi2 -> GenTyVar flexi2
-setTyVarFlexi (TyVar u k n _) flex = TyVar u k n flex
-\end{code}
-
-
-Simple construction and analysis functions
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-mkTyVar :: Name -> Kind -> TyVar
-mkTyVar name kind = TyVar (uniqueOf name)
- kind
- (Just name)
- unused
-
-mkSysTyVar :: Unique -> Kind -> TyVar
-mkSysTyVar uniq kind = TyVar uniq
- kind
- Nothing
- unused
-
-tyVarKind :: GenTyVar flexi -> Kind
-tyVarKind (TyVar _ kind _ _) = kind
-
-cloneTyVar :: GenTyVar flexi -> Unique -> GenTyVar flexi
-cloneTyVar (TyVar _ k n x) u = TyVar u k Nothing x
- -- Zaps its name
-
-nameTyVar :: GenTyVar flexi -> OccName -> GenTyVar flexi
- -- Give the TyVar a print-name
-nameTyVar (TyVar u k n x) occ = TyVar u k (Just (mkLocalName u occ noSrcLoc)) x
-\end{code}
-
-
-Fixed collection of type variables
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
- -- openAlphaTyVar is prepared to be instantiated
- -- to a boxed or unboxed type variable. It's used for the
- -- result type for "error", so that we can have (error Int# "Help")
-openAlphaTyVar = TyVar initTyVarUnique mkTypeKind Nothing unused
-
-openAlphaTyVars =
- [ TyVar u mkTypeKind Nothing unused
- | u <- iterate incrUnique initTyVarUnique]
-
-alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing unused
- | u <- iterate incrUnique initTyVarUnique]
-
-(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
-
-\end{code}
-
-
-Environments
-~~~~~~~~~~~~
-\begin{code}
-type TyVarEnv elt = UniqFM elt
-
-emptyTyVarEnv :: TyVarEnv a
-mkTyVarEnv :: [(GenTyVar flexi, a)] -> TyVarEnv a
-zipTyVarEnv :: [GenTyVar flexi] -> [a] -> TyVarEnv a
-addToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a
-growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a
-isEmptyTyVarEnv :: TyVarEnv a -> Bool
-lookupTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> Maybe a
-delFromTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> TyVarEnv a
-plusTyVarEnv :: TyVarEnv a -> TyVarEnv a -> TyVarEnv a
-
-emptyTyVarEnv = emptyUFM
-mkTyVarEnv = listToUFM
-addToTyVarEnv = addToUFM
-lookupTyVarEnv = lookupUFM
-delFromTyVarEnv = delFromUFM
-plusTyVarEnv = plusUFM
-isEmptyTyVarEnv = isNullUFM
-
-zipTyVarEnv tyvars tys = listToUFM (zipEqual "zipTyVarEnv" tyvars tys)
-growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
-\end{code}
-
-Sets
-~~~~
-\begin{code}
-type GenTyVarSet flexi = UniqSet (GenTyVar flexi)
-type TyVarSet = UniqSet TyVar
-
-emptyTyVarSet :: GenTyVarSet flexi
-intersectTyVarSets:: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
-unionTyVarSets :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
-unionManyTyVarSets:: [GenTyVarSet flexi] -> GenTyVarSet flexi
-tyVarSetToList :: GenTyVarSet flexi -> [GenTyVar flexi]
-unitTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi
-elementOfTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi -> Bool
-minusTyVarSet :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
-isEmptyTyVarSet :: GenTyVarSet flexi -> Bool
-mkTyVarSet :: [GenTyVar flexi] -> GenTyVarSet flexi
-addOneToTyVarSet :: GenTyVarSet flexi -> GenTyVar flexi -> GenTyVarSet flexi
-delOneFromTyVarSet :: GenTyVarSet flexi -> GenTyVar flexi -> GenTyVarSet flexi
-
-emptyTyVarSet = emptyUniqSet
-unitTyVarSet = unitUniqSet
-addOneToTyVarSet = addOneToUniqSet
-delOneFromTyVarSet = delOneFromUniqSet
-intersectTyVarSets= intersectUniqSets
-unionTyVarSets = unionUniqSets
-unionManyTyVarSets= unionManyUniqSets
-tyVarSetToList = uniqSetToList
-elementOfTyVarSet = elementOfUniqSet
-minusTyVarSet = minusUniqSet
-isEmptyTyVarSet = isEmptyUniqSet
-mkTyVarSet = mkUniqSet
-\end{code}
-
-Instance delarations
-~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-instance Eq (GenTyVar a) where
- (TyVar u1 _ _ _) == (TyVar u2 _ _ _) = u1 == u2
-
-instance Ord (GenTyVar a) where
- compare (TyVar u1 _ _ _) (TyVar u2 _ _ _) = u1 `compare` u2
-
-instance Uniquable (GenTyVar a) where
- uniqueOf (TyVar u _ _ _) = u
-
-instance NamedThing (GenTyVar a) where
- getName (TyVar _ _ (Just n) _) = n
- getName (TyVar u _ _ _) = mkSysLocalName u SLIT("t") noSrcLoc
-\end{code}
_interface_ Type 1
_exports_
-Type Type GenType ;
+Type Type GenType Kind ;
_declarations_
-
1 type Type = GenType BasicTypes.Unused ;
+1 type Kind = Type ;
1 data GenType a ;
--- /dev/null
+__interface Type 1 0 where
+__export Type Type GenType Kind ;
+1 type Type = GenType BasicTypes.Unused ;
+1 type Kind = Type ;
+1 data GenType a ;
+
\begin{code}
module Type (
- GenType(..), Type,
+ GenType(..), TyNote(..), -- Representation visible to friends
+ Type, GenKind, Kind,
+ TyVarSubst, GenTyVarSubst,
+
+ funTyCon, boxedKindCon, unboxedKindCon, openKindCon,
+
+ boxedTypeKind, unboxedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
+ hasMoreBoxityInfo, superKind,
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
- mkAppTy, mkAppTys, splitAppTy, splitAppTys,
+ mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
- mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys,
+ mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, funResultTy,
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy,
+ mkPiType,
TauType, RhoType, SigmaType, ThetaType,
isTauTy,
mkRhoTy, splitRhoTy,
mkSigmaTy, splitSigmaTy,
- isUnpointedType, isUnboxedType, typePrimRep,
-
- matchTy, matchTys,
+ isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType,
+ typePrimRep,
tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
+ addFreeTyVars,
- instantiateTy, instantiateTauTy, instantiateThetaTy, applyToTyVars,
+ substTy, fullSubstTy, substTyVar,
+ substFlexiTy, substFlexiTheta,
showTypeCategory
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Id ( Id )
+import {-# SOURCE #-} DataCon( DataCon )
-- friends:
+import Var ( Id, TyVar, GenTyVar, IdOrTyVar,
+ removeTyVarFlexi,
+ tyVarKind, isId, idType
+ )
+import VarEnv
+import VarSet
+
+import Name ( NamedThing(..), Provenance(..), ExportFlag(..),
+ mkWiredInTyConName, mkGlobalName, varOcc
+ )
+import NameSet
import Class ( classTyCon, Class )
-import Kind ( mkBoxedTypeKind, resultKind, Kind )
-import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
+import TyCon ( TyCon, Boxity(..),
+ mkFunTyCon, mkKindCon, superKindCon,
+ matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
+ isFunTyCon, isEnumerationTyCon,
+ isTupleTyCon, maybeTyConSingleCon,
isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
- tyConPrimRep, tyConClass_maybe, TyCon )
-import TyVar ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar,
- tyVarKind, tyVarFlexi, emptyTyVarSet, unionTyVarSets, minusTyVarSet,
- unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv,
- emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv )
-import Name ( NamedThing(..),
- NameSet,
- unionNameSets, emptyNameSet, unitNameSet, minusNameSet
+ tyConPrimRep, tyConClass_maybe
)
-- others
-import BasicTypes ( Unused )
-import Maybes ( maybeToBool, assocMaybe )
-import PrimRep ( PrimRep(..) )
-import Unique -- quite a few *Keys
-import Util ( thenCmp, panic, assertPanic )
+import BasicTypes ( Unused )
+import SrcLoc ( mkBuiltinSrcLoc )
+import PrelMods ( pREL_GHC )
+import Maybes ( maybeToBool )
+import PrimRep ( PrimRep(..), isFollowableRep )
+import Unique -- quite a few *Keys
+import Util ( thenCmp )
+import Outputable
+
\end{code}
+%************************************************************************
+%* *
+\subsection{Type Classifications}
+%* *
+%************************************************************************
+
+A type is
+
+ *unboxed* iff its representation is other than a pointer
+ Unboxed types cannot instantiate a type variable
+ Unboxed types are always unlifted.
+
+ *lifted* A type is lifted iff it has bottom as an element.
+ Closures always have lifted types: i.e. any
+ let-bound identifier in Core must have a lifted
+ type. Operationally, a lifted object is one that
+ can be entered.
+ (NOTE: previously "pointed").
+ *algebraic* A type with one or more constructors. An algebraic
+ type is one that can be deconstructed with a case
+ expression. *NOT* the same as lifted types,
+ because we also include unboxed tuples in this
+ classification.
+
+ *primitive* iff it is a built-in type that can't be expressed
+ in Haskell.
+
+Currently, all primitive types are unlifted, but that's not necessarily
+the case. (E.g. Int could be primitive.)
+
+Some primitive types are unboxed, such as Int#, whereas some are boxed
+but unlifted (such as ByteArray#). The only primitive types that we
+classify as algebraic are the unboxed tuples.
+
+examples of type classifications:
+
+Type primitive boxed lifted algebraic
+-----------------------------------------------------------------------------
+Int#, Yes No No No
+ByteArray# Yes Yes No No
+(# a, b #) Yes No No Yes
+( a, b ) No Yes Yes Yes
+[a] No Yes Yes Yes
%************************************************************************
%* *
\begin{code}
type Type = GenType Unused -- Used after typechecker
+type GenKind flexi = GenType flexi
+type Kind = Type
+
+type TyVarSubst = TyVarEnv Type
+type GenTyVarSubst flexi = TyVarEnv (GenType flexi)
+
data GenType flexi -- Parameterised over the "flexi" part of a type variable
= TyVarTy (GenTyVar flexi)
(GenType flexi)
(GenType flexi)
- | SynTy -- Saturated application of a type synonym
- (GenType flexi) -- The unexpanded version; always a TyConTy
+ | NoteTy -- Saturated application of a type synonym
+ (TyNote flexi)
(GenType flexi) -- The expanded version
| ForAllTy
(GenTyVar flexi)
(GenType flexi) -- TypeKind
+
+data TyNote flexi
+ = SynNote (GenType flexi) -- The unexpanded version of the type synonym; always a TyConApp
+ | FTVNote (GenTyVarSet flexi) -- The free type variables of the noted expression
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Wired-in type constructors
+%* *
+%************************************************************************
+
+We define a few wired-in type constructors here to avoid module knots
+
+\begin{code}
+funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("->") funTyCon
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
+\end{code}
+
+\begin{code}
+mk_kind_name key str = mkGlobalName key pREL_GHC (varOcc str)
+ (LocalDef mkBuiltinSrcLoc NotExported)
+ -- mk_kind_name is a bit of a hack
+ -- The LocalDef means that we print the name without
+ -- a qualifier, which is what we want for these kinds.
+
+boxedKindConName = mk_kind_name boxedKindConKey SLIT("*")
+boxedKindCon = mkKindCon boxedKindConName superKind Boxed
+
+unboxedKindConName = mk_kind_name unboxedKindConKey SLIT("*#")
+unboxedKindCon = mkKindCon unboxedKindConName superKind Unboxed
+
+openKindConName = mk_kind_name openKindConKey SLIT("*?")
+openKindCon = mkKindCon openKindConName superKind Open
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Kinds}
+%* *
+%************************************************************************
+
+\begin{code}
+superKind :: GenKind flexi -- Box, the type of all kinds
+superKind = TyConApp superKindCon []
+
+boxedTypeKind, unboxedTypeKind, openTypeKind :: GenKind flexi
+boxedTypeKind = TyConApp boxedKindCon []
+unboxedTypeKind = TyConApp unboxedKindCon []
+openTypeKind = TyConApp openKindCon []
+
+mkArrowKind :: GenKind flexi -> GenKind flexi -> GenKind flexi
+mkArrowKind = FunTy
+
+mkArrowKinds :: [GenKind flexi] -> GenKind flexi -> GenKind flexi
+mkArrowKinds arg_kinds result_kind = foldr FunTy result_kind arg_kinds
+\end{code}
+
+\begin{code}
+hasMoreBoxityInfo :: GenKind flexi -> GenKind flexi -> Bool
+
+(NoteTy _ k1) `hasMoreBoxityInfo` k2 = k1 `hasMoreBoxityInfo` k2
+k1 `hasMoreBoxityInfo` (NoteTy _ k2) = k1 `hasMoreBoxityInfo` k2
+
+(TyConApp kc1 ts1) `hasMoreBoxityInfo` (TyConApp kc2 ts2)
+ = ASSERT( null ts1 && null ts2 )
+ kc2 `matchesTyCon` kc1 -- NB the reversal of arguments
+
+kind1@(FunTy _ _) `hasMoreBoxityInfo` kind2@(FunTy _ _)
+ = ASSERT( kind1 == kind2 )
+ True
+ -- The two kinds can be arrow kinds; for example when unifying
+ -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should
+ -- have the same kind.
+
+-- Other cases are impossible
\end{code}
getTyVar :: String -> GenType flexi -> GenTyVar flexi
getTyVar msg (TyVarTy tv) = tv
-getTyVar msg (SynTy _ t) = getTyVar msg t
+getTyVar msg (NoteTy _ t) = getTyVar msg t
getTyVar msg other = panic ("getTyVar: " ++ msg)
getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi)
getTyVar_maybe (TyVarTy tv) = Just tv
-getTyVar_maybe (SynTy _ t) = getTyVar_maybe t
+getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
getTyVar_maybe other = Nothing
isTyVarTy :: GenType flexi -> Bool
-isTyVarTy (TyVarTy tv) = True
-isTyVarTy (SynTy _ ty) = isTyVarTy ty
-isTyVarTy other = False
+isTyVarTy (TyVarTy tv) = True
+isTyVarTy (NoteTy _ ty) = isTyVarTy ty
+isTyVarTy other = False
\end{code}
\begin{code}
mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1
where
- mk_app (SynTy _ ty1) = mk_app ty1
+ mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
mk_app ty1 = AppTy orig_ty1 orig_ty2
-- the Rational part.
mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1
where
- mk_app (SynTy _ ty1) = mk_app ty1
+ mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
-splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
-splitAppTy (FunTy ty1 ty2) = (TyConApp mkFunTyCon [ty1], ty2)
-splitAppTy (AppTy ty1 ty2) = (ty1, ty2)
-splitAppTy (SynTy _ ty) = splitAppTy ty
-splitAppTy (TyConApp tc tys) = split tys []
+splitAppTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
+splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
+splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
+splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
+splitAppTy_maybe (TyConApp tc []) = Nothing
+splitAppTy_maybe (TyConApp tc tys) = split tys []
where
- split [ty2] acc = (TyConApp tc (reverse acc), ty2)
+ split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
split (ty:tys) acc = split tys (ty:acc)
-splitAppTy other = panic "splitAppTy"
+
+splitAppTy_maybe other = Nothing
+
+splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
+splitAppTy ty = case splitAppTy_maybe ty of
+ Just pr -> pr
+ Nothing -> panic "splitAppTy"
splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi])
splitAppTys ty = split ty ty []
where
split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
- split orig_ty (SynTy _ ty) args = split orig_ty ty args
+ split orig_ty (NoteTy _ ty) args = split orig_ty ty args
split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
- (TyConApp mkFunTyCon [], [ty1,ty2])
+ (TyConApp funTyCon [], [ty1,ty2])
split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
split orig_ty ty args = (orig_ty, args)
\end{code}
splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
splitFunTy_maybe (FunTy arg res) = Just (arg, res)
-splitFunTy_maybe (SynTy _ ty) = splitFunTy_maybe ty
+splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
splitFunTy_maybe other = Nothing
splitFunTys ty = split [] ty ty
where
split args orig_ty (FunTy arg res) = split (arg:args) res res
- split args orig_ty (SynTy _ ty) = split args orig_ty ty
+ split args orig_ty (NoteTy _ ty) = split args orig_ty ty
split args orig_ty ty = (reverse args, orig_ty)
+
+funResultTy :: GenType flexi -> GenType flexi
+funResultTy (FunTy arg res) = res
+funResultTy (NoteTy _ ty) = funResultTy ty
+funResultTy ty = ty
\end{code}
splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi])
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-splitTyConApp_maybe (FunTy arg res) = Just (mkFunTyCon, [arg,res])
-splitTyConApp_maybe (SynTy _ ty) = splitTyConApp_maybe ty
+splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
+splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
splitTyConApp_maybe other = Nothing
-- splitAlgTyConApp_maybe looks for
-- "Algebraic" => newtype, data type, or dictionary (not function types)
-- We return the constructors too.
-splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id])
+splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [DataCon])
splitAlgTyConApp_maybe (TyConApp tc tys)
| isAlgTyCon tc &&
- tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
-splitAlgTyConApp_maybe (SynTy _ ty) = splitAlgTyConApp_maybe ty
-splitAlgTyConApp_maybe other = Nothing
+ tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
+splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
+splitAlgTyConApp_maybe other = Nothing
-splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id])
+splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [DataCon])
-- Here the "algebraic" property is an *assertion*
splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
(tc, tys, tyConDataCons tc)
-splitAlgTyConApp (SynTy _ ty) = splitAlgTyConApp ty
+splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
\end{code}
"Dictionary" types are just ordinary data types, but you can
maybe_class = tyConClass_maybe tc
Just clas = maybe_class
-splitDictTy_maybe (SynTy _ ty) = splitDictTy_maybe ty
+splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
splitDictTy_maybe other = Nothing
isDictTy :: GenType flexi -> Bool
| maybeToBool (tyConClass_maybe tc)
&& tyConArity tc == length tys
= True
-isDictTy (SynTy _ ty) = isDictTy ty
-isDictTy other = False
+isDictTy (NoteTy _ ty) = isDictTy ty
+isDictTy other = False
\end{code}
\begin{code}
mkSynTy syn_tycon tys
= ASSERT(isSynTyCon syn_tycon)
- SynTy (TyConApp syn_tycon tys)
- (instantiateTauTy (zipTyVarEnv tyvars tys) body)
+ NoteTy (SynNote (TyConApp syn_tycon tys))
+ (substFlexiTy (zipVarEnv tyvars tys) body)
+ -- The "flexi" is needed so we can get a TcType from a synonym
where
(tyvars, body) = getSynTyConDefn syn_tycon
-isSynTy (SynTy _ _) = True
-isSynTy other = False
+isSynTy (NoteTy (SynNote _) _) = True
+isSynTy other = False
\end{code}
Notes on type synonyms
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi)
-splitForAllTy_maybe (SynTy _ ty) = splitForAllTy_maybe ty
+splitForAllTy_maybe (NoteTy _ ty) = splitForAllTy_maybe ty
splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
splitForAllTy_maybe _ = Nothing
isForAllTy :: GenType flexi -> Bool
-isForAllTy (SynTy _ ty) = isForAllTy ty
+isForAllTy (NoteTy _ ty) = isForAllTy ty
isForAllTy (ForAllTy tyvar ty) = True
isForAllTy _ = False
splitForAllTys ty = split ty ty []
where
split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
- split orig_ty (SynTy _ ty) tvs = split orig_ty ty tvs
+ split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
split orig_ty t tvs = (reverse tvs, orig_ty)
\end{code}
+@mkPiType@ makes a (->) type or a forall type, depending on whether
+it is given a type variable or a term variable.
+
+\begin{code}
+mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work...
+mkPiType v ty | isId v = mkFunTy (idType v) ty
+ | otherwise = ForAllTy v ty
+\end{code}
\begin{code}
applyTy :: GenType flexi -> GenType flexi -> GenType flexi
-applyTy (SynTy _ fun) arg = applyTy fun arg
-applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty
+applyTy (NoteTy _ fun) arg = applyTy fun arg
+applyTy (ForAllTy tv ty) arg = substTy (mkVarEnv [(tv,arg)]) ty
applyTy other arg = panic "applyTy"
applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi
applyTys fun_ty arg_tys
= go [] fun_ty arg_tys
where
- go env ty [] = instantiateTy (mkTyVarEnv env) ty
- go env (SynTy _ fun) args = go env fun args
+ go env ty [] = substTy (mkVarEnv env) ty
+ go env (NoteTy _ fun) args = go env fun args
go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
go env other args = panic "applyTys"
\end{code}
isTauTy (TyConApp _ tys) = all isTauTy tys
isTauTy (AppTy a b) = isTauTy a && isTauTy b
isTauTy (FunTy a b) = isTauTy a && isTauTy b
-isTauTy (SynTy _ ty) = isTauTy ty
+isTauTy (NoteTy _ ty) = isTauTy ty
isTauTy other = False
\end{code}
split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
Just pair -> split res res (pair:ts)
Nothing -> (reverse ts, orig_ty)
- split orig_ty (SynTy _ ty) ts = split orig_ty ty ts
+ split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
split orig_ty ty ts = (reverse ts, orig_ty)
\end{code}
Finding the kind of a type
~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+-- typeKind is only ever used on Types, never Kinds
+-- If it were used on Kinds, the typeKind of FunTy would not be boxedTypeKind;
+-- yet at the type level functions are boxed even if neither argument nor
+-- result are boxed. This seems pretty fishy to me.
+
typeKind :: GenType flexi -> Kind
typeKind (TyVarTy tyvar) = tyVarKind tyvar
-typeKind (TyConApp tycon tys) = foldr (\_ k -> resultKind k) (tyConKind tycon) tys
-typeKind (SynTy _ ty) = typeKind ty
-typeKind (FunTy fun arg) = mkBoxedTypeKind
-typeKind (AppTy fun arg) = resultKind (typeKind fun)
-typeKind (ForAllTy _ _) = mkBoxedTypeKind
+typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
+typeKind (NoteTy _ ty) = typeKind ty
+typeKind (FunTy fun arg) = boxedTypeKind
+typeKind (AppTy fun arg) = funResultTy (typeKind fun)
+typeKind (ForAllTy _ _) = boxedTypeKind
\end{code}
\begin{code}
tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
-tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
+tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
-tyVarsOfType (SynTy ty1 ty2) = tyVarsOfType ty1
-tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
-tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
-tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
+tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
+tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
+tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
+tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
+tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
-tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
+tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
+
+-- Add a Note with the free tyvars to the top of the type
+addFreeTyVars :: GenType flexi -> GenType flexi
+addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
+addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
-- Find the free names of a type, including the type constructors and classes it mentions
namesOfType :: GenType flexi -> NameSet
namesOfType (TyVarTy tv) = unitNameSet (getName tv)
namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
namesOfTypes tys
-namesOfType (SynTy ty1 ty2) = namesOfType ty1
+namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
+namesOfType (NoteTy other_note ty2) = namesOfType ty2
namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
%* *
%************************************************************************
+@substTy@ applies a substitution to a type. It deals correctly with name capture.
+
\begin{code}
-instantiateTy :: TyVarEnv (GenType flexi) -> GenType flexi -> GenType flexi
-instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2
-
-
--- instantiateTy applies a type environment to a type.
--- It can handle shadowing; for example:
--- f = /\ t1 t2 -> \ d ->
--- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
--- in f' t1
--- Here, when we clone t1 to t1', say, we'll come across shadowing
--- when applying the clone environment to the type of f'.
---
--- As a sanity check, we should also check that name capture
--- doesn't occur, but that means keeping track of the free variables of the
--- range of the TyVarEnv, which I don't do just yet.
-
-instantiateTy tenv ty
- | isEmptyTyVarEnv tenv
- = ty
+substTy :: GenTyVarSubst flexi -> GenType flexi -> GenType flexi
+substTy tenv ty = subst_ty tenv tset ty
+ where
+ tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
+ -- If ty doesn't have any for-alls, then this thunk
+ -- will never be evaluated
+\end{code}
- | otherwise
- = go tenv ty
+@fullSubstTy@ is like @substTy@ except that it needs to be given a set
+of in-scope type variables. In exchange it's a bit more efficient, at least
+if you happen to have that set lying around.
+
+\begin{code}
+fullSubstTy :: GenTyVarSubst flexi -- Substitution to apply
+ -> GenTyVarSet flexi -- Superset of the free tyvars of
+ -- the range of the tyvar env
+ -> GenType flexi -> GenType flexi
+-- ASSUMPTION: The substitution is idempotent.
+-- Equivalently: No tyvar is both in scope, and in the domain of the substitution.
+fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty
+ | otherwise = subst_ty tenv tset ty
+
+-- subst_ty does the business
+subst_ty tenv tset ty
+ = go ty
where
- go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
- Nothing -> ty
- Just ty -> ty
- go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys)
- go tenv (SynTy ty1 ty2) = SynTy (go tenv ty1) (go tenv ty2)
- go tenv (FunTy arg res) = FunTy (go tenv arg) (go tenv res)
- go tenv (AppTy fun arg) = mkAppTy (go tenv fun) (go tenv arg)
- go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
- where
- tenv' = case lookupTyVarEnv tenv tv of
- Nothing -> tenv
- Just _ -> delFromTyVarEnv tenv tv
-
--- instantiateTauTy works only (a) on types with no ForAlls,
--- and when (b) all the type variables are being instantiated
--- In return it is more polymorphic than instantiateTy
-
-instantiateTauTy tenv ty = applyToTyVars lookup ty
- where
- lookup tv = case lookupTyVarEnv tenv tv of
- Just ty -> ty -- Must succeed
-
-
-instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType
-instantiateThetaTy tenv theta
- = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta]
-
-applyToTyVars :: (GenTyVar flexi1 -> GenType flexi2)
- -> GenType flexi1
- -> GenType flexi2
-applyToTyVars f ty = go ty
+ go (TyConApp tc tys) = TyConApp tc (map go tys)
+ go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2)
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
+ go (FunTy arg res) = FunTy (go arg) (go res)
+ go (AppTy fun arg) = mkAppTy (go fun) (go arg)
+ go ty@(TyVarTy tv) = case (lookupVarEnv tenv tv) of
+ Nothing -> ty
+ Just ty' -> ty'
+ go (ForAllTy tv ty) = case substTyVar tenv tset tv of
+ (tenv', tset', tv') -> ForAllTy tv' (subst_ty tenv' tset' ty)
+
+substTyVar :: GenTyVarSubst flexi -> GenTyVarSet flexi -> GenTyVar flexi
+ -> (GenTyVarSubst flexi, GenTyVarSet flexi, GenTyVar flexi)
+
+substTyVar tenv tset tv
+ | not (tv `elemVarSet` tset) -- No need to clone
+ -- But must delete from substitution
+ = (tenv `delVarEnv` tv, tset `extendVarSet` tv, tv)
+
+ | otherwise -- The forall's variable is in scope so
+ -- we'd better rename it away from the in-scope variables
+ -- Extending the substitution to do this renaming also
+ -- has the (correct) effect of discarding any existing
+ -- substitution for that variable
+ = (extendVarEnv tenv tv (TyVarTy tv'), tset `extendVarSet` tv', tv')
where
- go (TyVarTy tv) = f tv
- go (TyConApp tc tys) = TyConApp tc (map go tys)
- go (SynTy ty1 ty2) = SynTy (go ty1) (go ty2)
- go (FunTy arg res) = FunTy (go arg) (go res)
- go (AppTy fun arg) = mkAppTy (go fun) (go arg)
- go (ForAllTy tv ty) = panic "instantiateTauTy"
+ tv' = uniqAway tset tv
\end{code}
-%************************************************************************
-%* *
-\subsection{Boxedness and pointedness}
-%* *
-%************************************************************************
+@substFlexiTy@ applies a substitution to a (GenType flexi1) returning
+a (GenType flexi2). Note that we convert from one flexi status to another.
-A type is
- *unboxed* iff its representation is other than a pointer
- Unboxed types cannot instantiate a type variable
- Unboxed types are always unpointed.
+Two assumptions, for (substFlexiTy env ty)
+ (a) the substitution, env, must cover all free tyvars of the type, ty
+ (b) the free vars of the range of the substitution must be
+ different than any of the forall'd variables in the type, ty
- *unpointed* iff it can't be a thunk, and cannot have value bottom
- An unpointed type may or may not be unboxed.
- (E.g. Array# is unpointed, but boxed.)
- An unpointed type *can* instantiate a type variable,
- provided it is boxed.
-
- *primitive* iff it is a built-in type that can't be expressed
- in Haskell
-
-Currently, all primitive types are unpointed, but that's not necessarily
-the case. (E.g. Int could be primitive.)
+The latter assumption is reasonable because, after all, ty has a different
+type to the range of the substitution.
\begin{code}
-isUnboxedType :: Type -> Bool
-isUnboxedType ty = case typePrimRep ty of
- PtrRep -> False
- other -> True
-
--- Danger! Currently the unpointed types are precisely
--- the primitive ones, but that might not always be the case
-isUnpointedType :: Type -> Bool
-isUnpointedType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> isPrimTyCon tc
- other -> False
-
-typePrimRep :: Type -> PrimRep
-typePrimRep ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> tyConPrimRep tc
- other -> PtrRep
+substFlexiTy :: GenTyVarSubst flexi2 -> GenType flexi1 -> GenType flexi2
+substFlexiTy env ty = go ty
+ where
+ go (TyVarTy tv) = case lookupVarEnv env tv of
+ Just ty -> ty
+ Nothing -> pprPanic "substFlexiTy" (ppr tv)
+ go (TyConApp tc tys) = TyConApp tc (map go tys)
+ go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2)
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free tyvar note
+ go (FunTy arg res) = FunTy (go arg) (go res)
+ go (AppTy fun arg) = mkAppTy (go fun) (go arg)
+ go (ForAllTy tv ty) = ForAllTy tv' (substFlexiTy env' ty)
+ where
+ tv' = removeTyVarFlexi tv
+ env' = extendVarEnv env tv (TyVarTy tv')
+
+substFlexiTheta :: GenTyVarSubst flexi2 -> [(Class, [GenType flexi1])]
+ -> [(Class, [GenType flexi2])]
+substFlexiTheta env theta = [(clas, map (substFlexiTy env) tys) | (clas,tys) <- theta]
\end{code}
%************************************************************************
%* *
-\subsection{Matching on types}
+\subsection{Boxedness and liftedness}
%* *
%************************************************************************
-Matching is a {\em unidirectional} process, matching a type against a
-template (which is just a type with type variables in it). The
-matcher assumes that there are no repeated type variables in the
-template, so that it simply returns a mapping of type variables to
-types. It also fails on nested foralls.
+\begin{code}
+isUnboxedType :: GenType flexi -> Bool
+isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
-@matchTys@ matches corresponding elements of a list of templates and
-types.
+isUnLiftedType :: GenType flexi -> Bool
+isUnLiftedType ty = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> isUnLiftedTyCon tc
+ other -> False
-\begin{code}
-matchTy :: GenType Bool -- Template
- -> GenType flexi -- Proposed instance of template
- -> Maybe (TyVarEnv (GenType flexi)) -- Matching substitution
-
-
-matchTys :: [GenType Bool] -- Templates
- -> [GenType flexi] -- Proposed instance of template
- -> Maybe (TyVarEnv (GenType flexi), -- Matching substitution
- [GenType flexi]) -- Left over instance types
-
-matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) emptyTyVarEnv
-matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv
-\end{code}
+isUnboxedTupleType :: GenType flexi -> Bool
+isUnboxedTupleType ty = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> isUnboxedTupleTyCon tc
+ other -> False
-@match@ is the main function.
+isAlgType :: GenType flexi -> Bool
+isAlgType ty = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> isAlgTyCon tc
+ other -> False
-\begin{code}
-match :: GenType Bool -> GenType flexi -- Current match pair
- -> (TyVarEnv (GenType flexi) -> Maybe result) -- Continuation
- -> TyVarEnv (GenType flexi) -- Current substitution
- -> Maybe result
-
--- When matching against a type variable, see if the variable
--- has already been bound. If so, check that what it's bound to
--- is the same as ty; if not, bind it and carry on.
-
-match (TyVarTy v) ty k = \s -> if tyVarFlexi v then
- -- v is a template variable
- case lookupTyVarEnv s v of
- Nothing -> k (addToTyVarEnv s v ty)
- Just ty' | ty' == ty -> k s -- Succeeds
- | otherwise -> Nothing -- Fails
- else
- -- v is not a template variable; ty had better match
- -- Can't use (==) because types differ
- case ty of
- TyVarTy v' | uniqueOf v == uniqueOf v'
- -> k s -- Success
- other -> Nothing -- Failure
-
-match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k)
-match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
-match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
- = match_list tys1 tys2 ( \(s,tys2') ->
- if null tys2' then
- k s -- Succeed
- else
- Nothing -- Fail
- )
-
- -- With type synonyms, we have to be careful for the exact
- -- same reasons as in the unifier. Please see the
- -- considerable commentary there before changing anything
- -- here! (WDP 95/05)
-match (SynTy _ ty1) ty2 k = match ty1 ty2 k
-match ty1 (SynTy _ ty2) k = match ty1 ty2 k
-
--- Catch-all fails
-match _ _ _ = \s -> Nothing
-
-match_list [] tys2 k = \s -> k (s, tys2)
-match_list (ty1:tys1) [] k = \s -> Nothing -- Not enough arg tys => failure
-match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
+typePrimRep :: GenType flexi -> PrimRep
+typePrimRep ty = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> tyConPrimRep tc
+ other -> PtrRep
\end{code}
%************************************************************************
cmpTy :: GenType flexi -> GenType flexi -> Ordering
cmpTy ty1 ty2
- = cmp emptyTyVarEnv ty1 ty2
+ = cmp emptyVarEnv ty1 ty2
where
-- The "env" maps type variables in ty1 to type variables in ty2
-- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
-- we in effect substitute tv2 for tv1 in t1 before continuing
- lookup env tv1 = case lookupTyVarEnv env tv1 of
+ lookup env tv1 = case lookupVarEnv env tv1 of
Just tv2 -> tv2
Nothing -> tv1
- -- Get rid of SynTy
- cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2
- cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2
+ -- Get rid of NoteTy
+ cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
+ cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
-- Deal with equal constructors
cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
- cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (addToTyVarEnv env tv1 tv2) t1 t2
+ cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2
-- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
cmp env (AppTy _ _) (TyVarTy _) = GT
else '.'
Just (tycon, _) ->
- let utc = uniqueOf tycon in
+ let utc = getUnique tycon in
if utc == charDataConKey then 'C'
else if utc == intDataConKey then 'I'
else if utc == floatDataConKey then 'F'
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{Unify}
+
+This module contains a unifier and a matcher, both of which
+use an explicit substitution
+
+\begin{code}
+module Unify ( Subst,
+ unifyTysX, unifyTyListsX,
+ matchTy, matchTys
+ ) where
+
+import Var ( GenTyVar, TyVar, tyVarKind )
+import VarEnv
+import VarSet ( varSetElems )
+import Type ( GenType(..), funTyCon, typeKind, tyVarsOfType, hasMoreBoxityInfo,
+ splitAppTy_maybe
+ )
+import Unique ( Uniquable(..) )
+import Outputable( panic )
+import Util ( snocView )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Unification wih a explicit substitution}
+%* *
+%************************************************************************
+
+Unify types with an explicit substitution and no monad.
+
+\begin{code}
+type Subst flexi_tmpl flexi_result
+ = ([GenTyVar flexi_tmpl], -- Set of template tyvars
+ TyVarEnv (GenType flexi_result)) -- Not necessarily idempotent
+
+unifyTysX :: [GenTyVar flexi] -- Template tyvars
+ -> GenType flexi
+ -> GenType flexi
+ -> Maybe (TyVarEnv (GenType flexi))
+unifyTysX tmpl_tyvars ty1 ty2
+ = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptyVarEnv)
+
+unifyTyListsX :: [GenTyVar flexi] -> [GenType flexi] -> [GenType flexi]
+ -> Maybe (TyVarEnv (GenType flexi))
+unifyTyListsX tmpl_tyvars tys1 tys2
+ = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptyVarEnv)
+
+
+uTysX :: GenType flexi
+ -> GenType flexi
+ -> (Subst flexi flexi -> Maybe result)
+ -> Subst flexi flexi
+ -> Maybe result
+
+uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst
+uTysX ty1 (NoteTy _ ty2) k subst = uTysX ty1 ty2 k subst
+
+ -- Variables; go for uVar
+uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst
+ | tyvar1 == tyvar2
+ = k subst
+uTysX (TyVarTy tyvar1) ty2 k subst@(tmpls,_)
+ | tyvar1 `elem` tmpls
+ = uVarX tyvar1 ty2 k subst
+uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_)
+ | tyvar2 `elem` tmpls
+ = uVarX tyvar2 ty1 k subst
+
+ -- Functions; just check the two parts
+uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst
+ = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst
+
+ -- Type constructors must match
+uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst
+ | (con1 == con2 && length tys1 == length tys2)
+ = uTyListsX tys1 tys2 k subst
+
+ -- Applications need a bit of care!
+ -- They can match FunTy and TyConApp, so use splitAppTy_maybe
+ -- NB: we've already dealt with type variables and Notes,
+ -- so if one type is an App the other one jolly well better be too
+uTysX (AppTy s1 t1) ty2 k subst
+ = case splitAppTy_maybe ty2 of
+ Just (s2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst
+ Nothing -> Nothing -- Fail
+
+uTysX ty1 (AppTy s2 t2) k subst
+ = case splitAppTy_maybe ty1 of
+ Just (s1, t1) -> uTysX s1 s2 (uTysX t1 t2 k) subst
+ Nothing -> Nothing -- Fail
+
+ -- Not expecting for-alls in unification
+#ifdef DEBUG
+uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)"
+uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)"
+#endif
+
+ -- Anything else fails
+uTysX ty1 ty2 k subst = Nothing
+
+
+uTyListsX [] [] k subst = k subst
+uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst
+uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths
+\end{code}
+
+\begin{code}
+-- Invariant: tv1 is a unifiable variable
+uVarX tv1 ty2 k subst@(tmpls, env)
+ = case lookupVarEnv env tv1 of
+ Just ty1 -> -- Already bound
+ uTysX ty1 ty2 k subst
+
+ Nothing -- Not already bound
+ | typeKind ty2 `hasMoreBoxityInfo` tyVarKind tv1
+ && occur_check_ok ty2
+ -> -- No kind mismatch nor occur check
+ k (tmpls, extendVarEnv env tv1 ty2)
+
+ | otherwise -> Nothing -- Fail if kind mis-match or occur check
+ where
+ occur_check_ok ty = all occur_check_ok_tv (varSetElems (tyVarsOfType ty))
+ occur_check_ok_tv tv | tv1 == tv = False
+ | otherwise = case lookupVarEnv env tv of
+ Nothing -> True
+ Just ty -> occur_check_ok ty
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Matching on types}
+%* *
+%************************************************************************
+
+Matching is a {\em unidirectional} process, matching a type against a
+template (which is just a type with type variables in it). The
+matcher assumes that there are no repeated type variables in the
+template, so that it simply returns a mapping of type variables to
+types. It also fails on nested foralls.
+
+@matchTys@ matches corresponding elements of a list of templates and
+types.
+
+\begin{code}
+matchTy :: [GenTyVar flexi_tmpl] -- Template tyvars
+ -> GenType flexi_tmpl -- Template
+ -> GenType flexi_result -- Proposed instance of template
+ -> Maybe (TyVarEnv (GenType flexi_result)) -- Matching substitution
+
+
+matchTys :: [GenTyVar flexi_tmpl] -- Template tyvars
+ -> [GenType flexi_tmpl] -- Templates
+ -> [GenType flexi_result] -- Proposed instance of template
+ -> Maybe (TyVarEnv (GenType flexi_result), -- Matching substitution
+ [GenType flexi_result]) -- Left over instance types
+
+matchTy tmpls ty1 ty2 = match ty1 ty2 (\(_,env) -> Just env)
+ (tmpls, emptyVarEnv)
+
+matchTys tmpls tys1 tys2 = match_list tys1 tys2 (\((_,env),tys) -> Just (env,tys))
+ (tmpls, emptyVarEnv)
+\end{code}
+
+@match@ is the main function.
+
+\begin{code}
+match :: GenType flexi_tmpl -> GenType flexi_result -- Current match pair
+ -> (Subst flexi_tmpl flexi_result -> Maybe result) -- Continuation
+ -> Subst flexi_tmpl flexi_result -- Current substitution
+ -> Maybe result
+
+-- When matching against a type variable, see if the variable
+-- has already been bound. If so, check that what it's bound to
+-- is the same as ty; if not, bind it and carry on.
+
+match (TyVarTy v) ty k = \ s@(tmpls,env) ->
+ if v `elem` tmpls then
+ -- v is a template variable
+ case lookupVarEnv env v of
+ Nothing -> k (tmpls, extendVarEnv env v ty)
+ Just ty' | ty' == ty -> k s -- Succeeds
+ | otherwise -> Nothing -- Fails
+ else
+ -- v is not a template variable; ty had better match
+ -- Can't use (==) because types differ
+ case ty of
+ TyVarTy v' | getUnique v == getUnique v'
+ -> k s -- Success
+ other -> Nothing -- Failure
+
+match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k)
+match (AppTy fun1 arg1) ty2 k = case splitAppTy_maybe ty2 of
+ Just (fun2,arg2) -> match fun1 fun2 (match arg1 arg2 k)
+ Nothing -> \ _ -> Nothing -- Fail
+match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
+ = match_list tys1 tys2 ( \(s,tys2') ->
+ if null tys2' then
+ k s -- Succeed
+ else
+ Nothing -- Fail
+ )
+
+ -- With type synonyms, we have to be careful for the exact
+ -- same reasons as in the unifier. Please see the
+ -- considerable commentary there before changing anything
+ -- here! (WDP 95/05)
+match (NoteTy _ ty1) ty2 k = match ty1 ty2 k
+match ty1 (NoteTy _ ty2) k = match ty1 ty2 k
+
+-- Catch-all fails
+match _ _ _ = \s -> Nothing
+
+match_list [] tys2 k = \s -> k (s, tys2)
+match_list (ty1:tys1) [] k = \s -> Nothing -- Not enough arg tys => failure
+match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
+\end{code}
+
%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[Argv]{@Argv@: direct (non-standard) access to command-line arguments}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Bags]{@Bag@: an unordered collection with duplicates}
%
-% (c) The GRASP Project, Glasgow University, 1994-1995
+% (c) The GRASP Project, Glasgow University, 1994-1998
%
\section[BitSet]{An implementation of very small sets}
module BitSet (
BitSet, -- abstract type
mkBS, listBS, emptyBS, unitBS,
- unionBS, minusBS
+ unionBS, minusBS, intBS
) where
#ifdef __GLASGOW_HASKELL__
_ -> n : more
shiftr x y = shiftRL# x y
+-- intBS is a bit naughty.
+intBS :: BitSet -> Int
+intBS (MkBS w#) = I# (word2Int# w#)
+
#elif defined(__YALE_HASKELL__)
data BitSet = MkBS Int
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
\section{Fast strings}
)
#else
import PrelPack
+#if __GLASGOW_HASKELL__ < 400
import PrelST ( StateAndPtr#(..) )
+#endif
+
+#if __GLASGOW_HASKELL__ <= 303
import PrelHandle ( readHandle,
-#if __GLASGOW_HASKELL__ < 303
+# if __GLASGOW_HASKELL__ < 303
filePtr,
-#endif
+# endif
writeHandle
)
+#endif
+
import PrelIOBase ( Handle__(..), IOError(..), IOErrorType(..),
- IOResult(..), IO(..),
+#if __GLASGOW_HASKELL__ < 400
+ IOResult(..),
+#endif
+ IO(..),
#if __GLASGOW_HASKELL__ >= 303
Handle__Type(..),
#endif
import IO
#define hASH_TBL_SIZE 993
+
+#if __GLASGOW_HASKELL__ >= 400
+#define IOok STret
+#endif
\end{code}
@FastString@s are packed representations of strings
| otherwise = y
compare a b = cmpFS a b
-instance Text FastString where
- showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
- showsPrec p ps r = showsPrec p (unpackFS ps) r
-
getByteArray# :: FastString -> ByteArray#
getByteArray# (FastString _ _ ba#) = ba#
lookupTbl :: FastStringTable -> Int# -> IO [FastString]
lookupTbl (FastStringTable _ arr#) i# =
IO ( \ s# ->
+#if __GLASGOW_HASKELL__ < 400
case readArray# arr# i# s# of { StateAndPtr# s2# r ->
IOok s2# r })
+#else
+ readArray# arr# i# s#)
+#endif
updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
- IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> IOok s2# () }) >>
+ IO (\ s# -> case writeArray# arr# i# ls s# of { s2# ->
+#if __GLASGOW_HASKELL__ < 400
+ IOok s2# () }) >>
+#else
+ (# s2#, () #) }) >>
+#endif
writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
mkFastString# :: Addr# -> Int# -> FastString
else
constructError "hPutFS" >>= \ err ->
fail err
+
+
#else
hPutFS handle (FastString _ l# ba#)
| l# ==# 0# = return ()
where
bottom = error "hPutFS.ba"
+--ToDo: avoid silly code duplic.
+
hPutFS handle (CharStr a# l#)
| l# ==# 0# = return ()
| otherwise = hPutBuf handle (A# a#) (I# l#)
+
#endif
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[FiniteMap]{An implementation of finite maps}
#define OUTPUTABLE_key {--}
#endif
-import {-# SOURCE #-} Name
+import {-# SOURCE #-} Name ( Name )
import GlaExts
import FastString
import Maybes
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ListSetOps]{Set-like operations on lists}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Maybes]{The `Maybe' types and associated utility functions}
%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
This is useful, general stuff for the Native Code Generator.
%
-% (c) The GRASP Project, Glasgow University, 1992-1996
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[Outputable]{Classes for pretty-printing}
``output.''
\begin{code}
+{-# OPTIONS -fno-prune-tydecls #-}
+-- Hopefully temporary; 3.02 complained about not being able
+-- to see the consructors for ForeignObj
+
module Outputable (
Outputable(..), -- Class
hang, punctuate,
speakNth, speakNTimes,
- showSDoc, printSDoc, printErrs, printDump,
+ printSDoc, printErrs, printDump,
printForC, printForAsm, printForIface,
pprCode, pprCols,
+ showSDoc, showsPrecSDoc, pprFSAsString,
+
-- error handling
pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic,
#include "HsVersions.h"
+
import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
-import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprUserLength )
+import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
import FastString
import qualified Pretty
import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
import Util ( panic, assertPanic, panic#, trace )
+import ST ( runST )
+import Foreign
\end{code}
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
+-- Can't make SDoc an instance of Show because SDoc is just a function type
+-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: SDoc -> String
showSDoc d = show (d (mkUserStyle AllTheWay))
-mkUserStyle depth | opt_PprStyle_Debug
- || opt_PprStyle_All = PprDebug
- | otherwise = PprUser depth
+showsPrecSDoc :: Int -> SDoc -> ShowS
+showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
+
+mkUserStyle depth | opt_PprStyle_Debug = PprDebug
+ | otherwise = PprUser depth
\end{code}
\begin{code}
ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
instance (Outputable a, Outputable b) => Outputable (a, b) where
- ppr (x,y) =
- hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen)
+ ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
ppr (x,y,z) =
- parens (sep [ (<>) (ppr x) comma,
- (<>) (ppr y) comma,
- ppr z ])
+ parens (sep [ppr x <> comma,
+ ppr y <> comma,
+ ppr z ])
+
+instance Outputable FastString where
+ ppr fs = text (unpackFS fs) -- Prints an unadorned string,
+ -- no double quotes or anything
+
+pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints
+pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes
+
+instance Show FastString where
+ showsPrec p fs = showsPrecSDoc p (ppr fs)
\end{code}
where
doc = text heading <+> pretty_msg
-pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
+pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
pprTrace heading pretty_msg = trace (show (doc PprDebug))
where
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
\section{Basic ops on packed representations}
import ArrBase ( StateAndMutableByteArray#(..),
StateAndByteArray#(..) )
import STBase
-#else
+#elif __GLASGOW_HASKELL__ < 400
import PrelArr ( StateAndMutableByteArray#(..),
StateAndByteArray#(..) )
import PrelST
+#else
+import PrelST
#endif
\end{code}
freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
new_ps_array size = ST $ \ s ->
+#if __GLASGOW_HASKELL__ < 400
case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
STret s2# (MutableByteArray bot barr#) }
+#else
+ case (newCharArray# size s) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bot barr# #) }
+#endif
where
bot = error "new_ps_array"
write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
+#if __GLASGOW_HASKELL__ < 400
STret s2# () }
+#else
+ (# s2#, () #) }
+#endif
-- same as unsafeFreezeByteArray
freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
+#if __GLASGOW_HASKELL__ < 400
case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
STret s2# (ByteArray (0,I# len#) frozen#) }
+#else
+ case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray (0,I# len#) frozen# #) }
+#endif
\end{code}
import STBase ( ST(..), STret(..), StateAndPtr#(..) )
import ArrBase ( StateAndMutableArray#(..) )
import IOBase ( IO(..), IOResult(..) )
-#else
+#elif __GLASGOW_HASKELL__ < 400
import PrelST ( ST(..), STret(..), StateAndPtr#(..) )
import PrelArr ( StateAndMutableArray#(..) )
import PrelIOBase ( IO(..), IOResult(..) )
+#else
+import PrelST ( ST(..), STret(..) )
+import PrelArr ( MutableVar(..) )
+import PrelIOBase ( IO(..) )
#endif
\end{code}
sstToST :: SST s r -> ST s r
stToSST :: ST s r -> SST s r
-sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
+#if __GLASGOW_HASKELL__ < 400
stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s'
+sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
+#else
+stToSST (ST st) = \ s -> case st s of (# s', r #) -> SST_R r s'
+sstToST sst = ST (\ s -> case sst s of SST_R r s' -> (# s', r #))
+#endif
\end{code}
...and IO
\begin{code}
ioToSST :: IO a -> SST RealWorld (Either IOError a)
+
+#if __GLASGOW_HASKELL__ < 400
ioToSST (IO io)
= \s -> case io s of
IOok s' r -> SST_R (Right r) s'
IOfail s' err -> SST_R (Left err) s'
+#else
+
+-- We should probably be using ST and exceptions instead of SST here, now
+-- that GHC has exceptions and ST is strict.
+
+ioToSST io
+ = \s -> case catch (io >>= return . Right) (return . Left) of { IO m ->
+ case m s of {
+ (# s', r #) -> SST_R r s'
+ } }
+#endif
+
\end{code}
%************************************************************************
%* *
%************************************************************************
-Here we implement mutable variables. ToDo: get rid of the array impl.
+Here we implement mutable variables.
\begin{code}
+#if __GLASGOW_HASKELL__ < 400
type SSTRef s a = MutableArray s Int a
+#else
+type SSTRef s a = MutableVar s a
+#endif
newMutVarSST :: a -> SST s (SSTRef s a)
readMutVarSST :: SSTRef s a -> SST s a
writeMutVarSST :: SSTRef s a -> a -> SST s ()
+#if __GLASGOW_HASKELL__ < 400
+
newMutVarSST init s#
= case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
SST_R (MutableArray vAR_IXS arr#) s2# }
writeMutVarSST (MutableArray _ var#) val s#
= case writeArray# var# 0# val s# of { s2# ->
SST_R () s2# }
+
+#else
+
+newMutVarSST init s#
+ = case (newMutVar# init s#) of { (# s2#, var# #) ->
+ SST_R (MutableVar var#) s2# }
+
+readMutVarSST (MutableVar var#) s#
+ = case readMutVar# var# s# of { (# s2#, r #) ->
+ SST_R r s2# }
+
+writeMutVarSST (MutableVar var#) val s#
+ = case writeMutVar# var# val s# of { s2# ->
+ SST_R () s2# }
+
+#endif
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
\section{String buffers}
stepOnUntil, -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
stepOverLexeme, -- :: StringBuffer -> StringBuffer
scanNumLit, -- :: Int -> StringBuffer -> (Int, StringBuffer)
- expandWhile, -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
+ expandWhile, -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
+ expandWhile#, -- :: (Char# -> Bool) -> StringBuffer -> StringBuffer
expandUntilMatch, -- :: StrinBuffer -> String -> StringBuffer
-- at or beyond end of buffer?
bufferExhausted, -- :: StringBuffer -> Bool
| ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
| otherwise -> StringBuffer fo l# s# c#
+expandWhile# :: (Char# -> Bool) -> StringBuffer -> StringBuffer
+expandWhile# pred (StringBuffer fo l# s# c#) =
+ loop c#
+ where
+ loop c# =
+ case indexCharOffAddr# fo c# of
+ ch# | pred ch# -> loop (c# +# 1#)
+ | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# s# c# -- EOB, return immediately.
+ | otherwise -> StringBuffer fo l# s# c#
scanNumLit :: Int -> StringBuffer -> (Int,StringBuffer)
scanNumLit (I# acc#) (StringBuffer fo l# s# c#) =
loop acc# c# =
case indexCharOffAddr# fo c# of
ch# | isDigit (C# ch#) -> loop (acc# *# 10# +# (ord# ch# -# ord# '0'#)) (c# +# 1#)
- | ch# `eqChar#` '\NUL'# && c# >=# l# -> (I# acc#, StringBuffer fo l# l# l#) -- EOB, return immediately.
+ | ch# `eqChar#` '\NUL'# && c# >=# l# -> (I# acc#, StringBuffer fo l# s# c#) -- EOB, return immediately.
| otherwise -> (I# acc#,StringBuffer fo l# s# c#)
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[UniqFM]{Specialised finite maps, for things with @Uniques@}
Based on @FiniteMaps@ (as you would expect).
Basically, the things need to be in class @Uniquable@, and we use the
-@uniqueOf@ method to grab their @Uniques@.
+@getUnique@ method to grab their @Uniques@.
(A similar thing to @UniqSet@, as opposed to @Set@.)
%* *
%************************************************************************
-We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
+We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
\begin{code}
emptyUFM :: UniqFM elt
\begin{code}
emptyUFM = EmptyUFM
-unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
+unitUFM key elt = mkLeafUFM (u2i (getUnique key)) elt
unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
listToUFM key_elt_pairs
addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
addToUFM_C combiner fm key elt
- = insert_ele combiner fm (u2i (uniqueOf key)) elt
+ = insert_ele combiner fm (u2i (getUnique key)) elt
addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
addListToUFM_C combiner fm key_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getUnique k)) e)
fm key_elt_pairs
addListToUFM_directly_C combiner fm uniq_elt_pairs
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (u2i (uniqueOf key))
+delFromUFM fm key = delete fm (u2i (getUnique key))
delFromUFM_Directly fm u = delete fm (u2i u)
delete EmptyUFM _ = EmptyUFM
Lookup up a binary tree is easy (and fast).
\begin{code}
-elemUFM key fm = case lookUp fm (u2i (uniqueOf key)) of
+elemUFM key fm = case lookUp fm (u2i (getUnique key)) of
Nothing -> False
Just _ -> True
-lookupUFM fm key = lookUp fm (u2i (uniqueOf key))
+lookupUFM fm key = lookUp fm (u2i (getUnique key))
lookupUFM_Directly fm key = lookUp fm (u2i key)
lookupWithDefaultUFM fm deflt key
- = case lookUp fm (u2i (uniqueOf key)) of
+ = case lookUp fm (u2i (getUnique key)) of
Nothing -> deflt
Just elt -> elt
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[UniqSet]{Specialised sets, for things with @Uniques@}
addOneToUniqSet, addListToUniqSet, delOneFromUniqSet,
unionUniqSets, unionManyUniqSets, minusUniqSet,
elementOfUniqSet, mapUniqSet, intersectUniqSets,
- isEmptyUniqSet, filterUniqSet, sizeUniqSet
+ isEmptyUniqSet, filterUniqSet, sizeUniqSet, foldUniqSet,
+ elemUniqSet_Directly, lookupUniqSet
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Name
+import {-# SOURCE #-} Name ( Name )
import Maybes ( maybeToBool )
import UniqFM
%* *
%************************************************************************
-We use @UniqFM@, with a (@uniqueOf@-able) @Unique@ as ``key''
+We use @UniqFM@, with a (@getUnique@-able) @Unique@ as ``key''
and the thing itself as the ``value'' (for later retrieval).
\begin{code}
uniqSetToList :: UniqSet a -> [a]
uniqSetToList (MkUniqSet set) = eltsUFM set
+foldUniqSet :: (a -> b -> b) -> b -> UniqSet a -> b
+foldUniqSet k z (MkUniqSet set) = foldUFM k z set
+
mkUniqSet :: Uniquable a => [a] -> UniqSet a
mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x)
+lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a
+lookupUniqSet (MkUniqSet set) x = lookupUFM set x
+
+elemUniqSet_Directly :: Unique -> UniqSet a -> Bool
+elemUniqSet_Directly x (MkUniqSet set) = maybeToBool (lookupUFM_Directly set x)
+
sizeUniqSet :: UniqSet a -> Int
sizeUniqSet (MkUniqSet set) = sizeUFM set
isEmptyUniqSet :: UniqSet a -> Bool
isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-}
-mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
-mapUniqSet f (MkUniqSet set)
- = MkUniqSet (listToUFM [ let
- mapped_thing = f thing
- in
- (mapped_thing, mapped_thing)
- | thing <- eltsUFM set ])
+mapUniqSet :: (a -> a) -> UniqSet a -> UniqSet a
+ -- VERY IMPORTANT: *assumes* that the function doesn't change the unique
+mapUniqSet f (MkUniqSet set) = MkUniqSet (mapUFM f set)
\end{code}
\begin{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Util]{Highly random utility functions}
-- general list processing
IF_NOT_GHC(forall COMMA exists COMMA)
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
- zipLazy,
+ zipLazy, stretchZipEqual,
mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
startsWith, endsWith, snocView,
zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
\end{code}
+
+\begin{code}
+stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
+-- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
+
+stretchZipEqual f [] [] = []
+stretchZipEqual f (x:xs) (y:ys) = case f x y of
+ Just x' -> x' : stretchZipEqual f xs ys
+ Nothing -> x : stretchZipEqual f xs (y:ys)
+\end{code}
+
+
\begin{code}
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
+++ /dev/null
-Herein are bits of documentation for, or related to, the Glorious
-Glasgow Haskell compilation system. Unless specified otherwise, they
-are nestled in the ghc/docs directory of the distribution.
-
-install_guide/*
- A step-by-step guide on how to configure, build, and install
- the system.
-
-users_guide/*
- The User's Guide for the system. Describes how to "drive" the
- system, how to deal with common problems, how to use the
- profiling tools, what is Known to be Broken, how to use the
- Glasgow extensions, etc.
-
-release_notes/*
- Release notes for the system. What's new in each release, and
- what's coming Real Soon Now.
-
-state_interface/*
- "GHC prelude: types and operations", an addendum to the Peyton
- Jones/Launchbury "state" paper, is the definitive reference
- (bar the compiler source :-) of GHC's lowest-level interfaces
- (primitive ops, etc.).
-
-gransim/
- User's guide for the GranSim parallel-machine simulator.
- By Hans Wolfgang Loidl.
-
-simple-monad.lhs
- A *simple* introduction to the common use of monads in Haskell
- programming. No fancy stuff whatsoever. By Will Partain.
--- /dev/null
+<sect> <idx/Addr/
+<label id="sec:Addr">
+<p>
+
+This library provides machine addresses and is primarily intended for
+use in creating foreign function interfaces using GreenCard.
+
+<tscreen><verb>
+module Addr where
+data Addr -- Address type
+instance Eq Addr
+
+nullAddr :: Addr
+plusAddr :: Addr -> Int -> Addr
+
+-- read value out of _immutable_ memory
+indexCharOffAddr :: Addr -> Int -> Char
+indexIntOffAddr :: Addr -> Int -> Int -- should we drop this?
+indexAddrOffAddr :: Addr -> Int -> Addr
+indexFloatOffAddr :: Addr -> Int -> Float
+indexDoubleOffAddr :: Addr -> Int -> Double
+indexWord8OffAddr :: Addr -> Int -> Word8
+indexWord16OffAddr :: Addr -> Int -> Word16
+indexWord32OffAddr :: Addr -> Int -> Word32
+indexWord64OffAddr :: Addr -> Int -> Word64
+indexInt8OffAddr :: Addr -> Int -> Int8
+indexInt16OffAddr :: Addr -> Int -> Int16
+indexInt32OffAddr :: Addr -> Int -> Int32
+indexInt64OffAddr :: Addr -> Int -> Int64
+
+-- read value out of mutable memory
+readCharOffAddr :: Addr -> Int -> IO Char
+readIntOffAddr :: Addr -> Int -> IO Int -- should we drop this?
+readAddrOffAddr :: Addr -> Int -> IO Addr
+readFloatOffAddr :: Addr -> Int -> IO Float
+readDoubleOffAddr :: Addr -> Int -> IO Double
+readWord8OffAddr :: Addr -> Int -> IO Word8
+readWord16OffAddr :: Addr -> Int -> IO Word16
+readWord32OffAddr :: Addr -> Int -> IO Word32
+readWord64OffAddr :: Addr -> Int -> IO Word64
+readInt8OffAddr :: Addr -> Int -> IO Int8
+readInt16OffAddr :: Addr -> Int -> IO Int16
+readInt32OffAddr :: Addr -> Int -> IO Int32
+readInt64OffAddr :: Addr -> Int -> IO Int64
+
+-- write value into mutable memory
+writeCharOffAddr :: Addr -> Int -> Char -> IO ()
+writeIntOffAddr :: Addr -> Int -> Int -> IO () -- should we drop this?
+writeAddrOffAddr :: Addr -> Int -> Addr -> IO ()
+writeForeignObjOffAddr :: Addr -> Int -> ForeignObj -> IO ()
+writeFloatOffAddr :: Addr -> Int -> Float -> IO ()
+writeDoubleOffAddr :: Addr -> Int -> Double -> IO ()
+writeWord8OffAddr :: Addr -> Int -> Word8 -> IO ()
+writeWord16OffAddr :: Addr -> Int -> Word16 -> IO ()
+writeWord32OffAddr :: Addr -> Int -> Word32 -> IO ()
+writeWord64OffAddr :: Addr -> Int -> Word64 -> IO ()
+writeInt8OffAddr :: Addr -> Int -> Int8 -> IO ()
+writeInt16OffAddr :: Addr -> Int -> Int16 -> IO ()
+writeInt32OffAddr :: Addr -> Int -> Int32 -> IO ()
+writeInt64OffAddr :: Addr -> Int -> Int64 -> IO ()
+</verb></tscreen>
+
+Hugs provides <tt/Addr/ and <tt/nullAddr/ but does not provide any of
+the index, read or write functions. They can be implemented using
+GreenCard if required.
+
+
--- /dev/null
+<sect> <idx/Bits/
+<label id="sec:Bits">
+<p>
+
+This library defines bitwise operations for signed and unsigned ints.
+
+<tscreen><verb>
+module Bits where
+infixl 8 `shift`, `rotate`
+infixl 7 .&.
+infixl 6 `xor`
+infixl 5 .|.
+
+class Bits a where
+ (.&.), (.|.), xor :: a -> a -> a
+ complement :: a -> a
+ shift :: a -> Int -> a
+ rotate :: a -> Int -> a
+ bit :: Int -> a
+ setBit :: a -> Int -> a
+ clearBit :: a -> Int -> a
+ complementBit :: a -> Int -> a
+ testBit :: a -> Int -> Bool
+ bitSize :: a -> Int
+ isSigned :: a -> Bool
+
+shiftL, shiftR :: Bits a => a -> Int -> a
+rotateL, rotateR :: Bits a => a -> Int -> a
+shiftL a i = shift a i
+shiftR a i = shift a (-i)
+rotateL a i = rotate a i
+rotateR a i = rotate a (-i)
+</verb></tscreen>
+
+Notes:
+<itemize>
+<item>
+ <tt/bitSize/ and <tt/isSigned/ are like <tt/floatRadix/ and
+ <tt/floatDigits/ -- they return parameters of the <em/type/ of their
+ argument rather than of the particular argument they are applied to.
+ <tt/bitSize/ returns the number of bits in the type; and
+ <tt/isSigned/ returns whether the type is signed or not.
+<item>
+ <tt/shift/ performs sign extension on signed number types.
+ That is, right shifts fill the top bits with 1 if the number is negative
+ and with 0 otherwise.
+<item>
+ Bits are numbered from 0 with bit 0 being the least significant bit.
+<item>
+ <tt/shift x i/ and <tt/rotate x i/ shift to the left if <tt/i/ is
+ positive and to the right otherwise.
+<!--
+ <item>
+ <tt/rotate/ is well defined only if bitSize returns a number.
+ (Maybe we should impose a Bounded constraint on it?)
+ -->
+<item>
+ <tt/bit i/ is the value with the i'th bit set.
+</itemize>
--- /dev/null
+<sect> <idx/Concurrent/
+<label id="sec:Concurrent">
+<p>
+
+This library provides the Concurrent Haskell extensions as described
+in <url name="Concurrent Haskell" url="http://research.microsoft.com/Users/simonpj/Papers/concurrent-haskell.ps.gz">.
+
+<tscreen><verb>
+module Concurrent where
+
+data ThreadId -- thread identifiers
+instance Eq ThreadId
+instance Ord ThreadId
+
+forkIO :: IO () -> IO ThreadId
+killThread :: ThreadId -> IO ()
+
+data MVar a -- Synchronisation variables
+newEmptyMVar :: IO (MVar a)
+newMVar :: a -> IO (MVar a)
+takeMVar :: MVar a -> IO a
+putMVar :: MVar a -> a -> IO ()
+swapMVar :: MVar a -> a -> IO a
+readMVar :: MVar a -> IO a
+instance Eq (MVar a)
+
+data Chan a -- channels
+newChan :: IO (Chan a)
+writeChan :: Chan a -> a -> IO ()
+readChan :: Chan a -> IO a
+dupChan :: Chan a -> IO (Chan a)
+unReadChan :: Chan a -> a -> IO ()
+getChanContents :: Chan a -> IO [a]
+writeList2Chan :: Chan a -> [a] -> IO ()
+
+data CVar a -- one element channels
+newCVar :: IO (CVar a)
+putCVar :: CVar a -> a -> IO ()
+getCVar :: CVar a -> IO a
+
+data QSem -- General/quantity semaphores
+newQSem :: Int -> IO QSem
+waitQSem :: QSem -> IO ()
+signalQSem :: QSem -> IO ()
+
+data QSemN -- General/quantity semaphores
+newQSemN :: Int -> IO QSemN
+waitQSemN :: QSemN -> Int -> IO ()
+signalQSemN :: QSemN -> Int -> IO ()
+
+type SampleVar a -- Sample variables
+newEmptySampleVar:: IO (SampleVar a)
+newSampleVar :: a -> IO (SampleVar a)
+emptySampleVar :: SampleVar a -> IO ()
+readSampleVar :: SampleVar a -> IO a
+writeSampleVar :: SampleVar a -> a -> IO ()
+</verb></tscreen>
+
+Notes:
+<itemize>
+
+<item>
+ GHC uses preemptive multitasking:
+ Context switches can occur at any time, except if you call a C
+ function (like <tt/getchar/) that blocks waiting for input.
+
+ Hugs uses cooperative multitasking:
+ Context switches only occur when you use one of the primitives
+ defined in this module. This means that programs such as:
+s not been implemented yet on
+Hugs
+<tscreen><verb>
+main = forkIO (write 'a') >> write 'b'
+ where write c = putChar c >> write c
+</verb></tscreen>
+
+ will print either <tt/aaaaaaaaaaaaaa.../ or <tt/bbbbbbbbbbbb.../,
+ instead of some random interleaving of <tt/a/s and <tt/b/s.
+
+ In practice, cooperative multitasking is sufficient for writing
+ simple graphical user interfaces.
+
+<item>
+Hugs does not provide the functions <tt/mergeIO/ or <tt/nmergeIO/ since these
+require preemptive multitasking.
+
+<item>
+Thread identities and <tt/killThread/ have an experimental
+implementation in GHC, but are not yet implemented in Hugs.
+
+Currently <tt/killThread/ simply kills the nominated thread, but the
+plan is that in the future <tt/killThread/ will raise an exception in
+the killed thread which it can catch --- perhaps allowing it to kill
+its children before exiting.
+
+<item>
+The <tt/Ord/ instance for <tt/ThreadId/s provides an arbitrary total ordering
+which might be used to build an ordered binary tree, say.
+
+</itemize>
--- /dev/null
+<sect> <idx/Dynamic/
+<label id="sec:Dynamic">
+<p>
+
+The <tt/Dynamic/ library provides cheap-and-cheerful dynamic types for
+Haskell. A dynamically typed value is one which carries type
+information with it at run-time, and is represented here by the
+abstract type <tt/Dynamic/. Values can be converted into <tt/Dynamic/
+ones, which can then be combined and manipulated by the program using
+the operations provided over the abstract, dynamic type. One of
+these operations allows you to convert a dynamically-typed value back
+into a value with the same (monomorphic) type it had before converting
+it into a dynamically-typed value.
+
+The <tt/Dynamic/ library is capable of dealing with monomorphic types
+only; no support for polymorphic dynamic values, but hopefully that
+can be added at a later stage.
+
+Examples where this library may come in handy (dynamic types, really -
+hopefully the library provided here will suffice) are: persistent
+programming, interpreters, distributed programming etc.
+
+The following operations are provided over the <tt/Dynamic/ type:
+
+<tscreen> <verb>
+data Dynamic -- abstract, instance of: Show --
+
+toDyn :: Typeable a => a -> Dynamic
+fromDyn :: Typeable a => Dynamic -> a -> a
+fromDynamic :: Typeable a => Dynamic -> Maybe a
+</verb></tscreen>
+
+<itemize>
+<item> <tt/toDyn/ converts a value into a dynamic one, provided
+<tt/toDyn/ knows the (concrete) type representation of the value.
+The <tt/Typeable/ type class is used to encode this, overloading a
+function that returns the type representation of a value. More on this
+below.
+<item> There's two ways of going from a dynamic value to one with
+a concrete type: <tt/fromDyn/, tries to convert the dynamic value into
+a value with the same type as its second argument. If this fails, the
+default second argument is just returned. <tt/fromDynamic/ returns a
+<tt/Maybe/ type instead, <tt/Nothing/ coming back if the conversion
+was not possible.
+<item>
+The <tt/Dynamic/ type has got a <tt/Show/ instance which returns
+a pretty printed string of the type of the dynamic value. (Useful when
+debugging).
+</itemize>
+
+<sect1> <idx/Representing types/
+<label id="sec:Dynamic:TypeRep">
+<p>
+
+Haskell types are represented as terms using the <tt/TypeRep/
+abstract type:
+
+<tscreen> <verb>
+data TypeRep -- abstract, instance of: Eq, Show
+data TyCon -- abstract, instance of: Eq, Show
+
+mkTyCon :: String -> TyCon
+mkAppTy :: TyCon -> [TypeRep] -> TypeRep
+mkFunTy :: TypeRep -> TypeRep -> TypeRep
+applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
+</verb></tscreen>
+
+<itemize>
+<item> <tt/mkAppTy/ applies a type constructor to a sequence of types,
+returning a type.
+<item> <tt/mkFunTy/ is a special case of <tt/mkAppTy/, applying
+the function type constructor to a pair of types.
+<item> <tt/applyTy/ applies a type to a function type. If possible,
+the result type is returned.
+<item> Type constructors are represented by the abstract type,
+<tt/TyCon/.
+<item>
+Most importantly, <tt/TypeRep/s can be compared for equality.
+Type equality is used when converting a <tt/Dynamic/ value into a
+value of some specific type, comparing the type representation that
+the <tt/Dynamic/ value embeds with equality of the type representation
+of the type we're trying to convert the dynamically-typed value into.
+<item>
+To allow comparisons between <tt/TypeRep/s to be implemented
+efficiently, the <em/abstract/ <tt/TyCon/ type is used, with
+the constructor function <tt/mkTyCon/ provided:
+
+<tscreen> <verb>
+mkTyCon :: String -> TyCon
+</verb></tscreen>
+
+An implementation of the <tt/Dynamic/ interface guarantees the
+following,
+
+<tscreen> <verb>
+ mkTyCon "a" == mkTyCon "a"
+</verb></tscreen>
+
+A really efficient implementation is possible if we guarantee/demand
+that the strings are unique, and for a particular type constructor,
+the application <tt/mkTyCon/ to the string that represents the type
+constructor is never duplicated. <bf/Q:/ <em>Would this constraint be
+unworkable in practice?</em>
+<item>
+Both <tt/TyCon/ and <tt/TypeRep/ are instances of the <tt/Show/ type
+classes. To have tuple types be shown in infix form, the <tt/Show/
+instance guarantees that type constructors consisting of <tt/n/-commas,
+i.e., (<tt/mkTyCon ",,,,"/), is shown as an <tt/(n+1)/ tuple in infix
+form.
+</itemize>
+
+<sect1>The <tt/Typeable/ class
+<nidx>Typeable class</nidx>
+<label id="sec:Dynamic:Typeable">
+<p>
+
+To ease the construction of <tt/Dynamic/ values, we
+introduce the following type class to help working with <tt/TypeRep/s:
+
+<tscreen><verb>
+class Typeable a where
+ typeOf :: a -> TypeRep
+</verb></tscreen>
+
+<itemize>
+<item> The <tt/typeOf/ function is overloaded to return the type
+representation associated with a type.
+<item> <bf/Important:/ The argument to <tt/typeOf/ is only used to
+carry type information around so that overloading can be resolved.
+<tt/Typeable/ instances should never, ever look at this argument.
+<item> The <tt/Dynamic/ library provide <tt/Typeable/ instances
+for all Prelude and Hugs/GHC extension library types. They are:
+
+<tscreen><verb>
+Prelude types:
+ Int, Char, Bool, Float, Double, Integer, (IO a),
+ [a], (Either a b), (Maybe a), (a->b),
+ (), (,), (,,), (,,,), (,,,,),
+ Ordering, Complex, Array, Handle
+Hugs/GHC types:
+ Addr, Word8, Word16, Word32, Word64,
+ Int8,Int16,Int32,Int64,
+ ForeignObj, MVar, (ST s a), (StablePtr a)
+GHC types:
+ Word, ByteArray, MutableByteArray
+</verb></tscreen>
+
+</itemize>
+
+<sect1> <idx/Utility functions/
+<label id="sec:Dynamic:util">
+<p>
+
+Operations for applying a dynamic function type to a
+dynamically typed argument are commonly useful, and
+also provided:
+
+<tscreen> <verb>
+dynApply :: Dynamic -> Dynamic -> Dynamic -- unsafe.
+dynApplyMb :: Dynamic -> Dynamic -> Maybe Dynamic
+</verb></tscreen>
--- /dev/null
+<sect> <idx/Exception/
+<label id="sec:Exception">
+<p>
+
+The Exception library provides an interface for raising and catching
+both built-in and user defined exceptions.
+
+Exceptions are defined by the following (non-abstract) datatype:
+
+<tscreen><verb>
+data Exception
+ = IOException IOError -- IO exceptions (from 'fail')
+ | ArithException ArithError -- Arithmetic exceptions
+ | ErrorCall String -- Calls to 'error'
+ | NoMethodError String -- A non-existent method was invoked
+ | PatternMatchFail String -- A pattern match failed
+ | NonExhaustiveGuards String -- A guard match failed
+ | RecSelError String -- Selecting a non-existent field
+ | RecConError String -- Field missing in record construction
+ | RecUpdError String -- Record doesn't contain updated field
+ | AssertionFailed String -- Assertions
+ | DynException Dynamic -- Dynamic exceptions
+ | ExternalException ExtError -- External exceptions
+
+instance Eq Exception
+instance Ord Exception
+instance Show Exception
+
+data ArithError
+ = Overflow
+ | Underflow
+ | LossOfPrecision
+ | DivideByZero
+ | Denormal
+
+instance Eq ArithError
+instance Ord ArithError
+instance Show ArithError
+
+data ExtError
+ = StackOverflow
+ | HeapOverflow
+ | ThreadKilled
+
+instance Eq ExtError
+instance Ord ExtError
+instance Show ExtError
+</verb></tscreen>
+
+An implementation should raise the appropriate exception when one of
+the above conditions arises. <em>Note: GHC currently doesn't generate
+the arithmetic or the external exceptions.</em>
+
+Exceptions may be thrown explicitly from anywhere:
+
+<tscreen><verb>
+throw :: Exception -> a
+</verb></tscreen>
+
+Exceptions may be caught and examined in the <tt/IO/ monad:
+
+<tscreen><verb>
+catch :: IO a -> (Exception -> IO a) -> IO a
+catchIO :: IO a -> (IOError -> IO a) -> IO a
+catchArith :: IO a -> (ArithError -> IO a) -> IO a
+catchError :: IO a -> (String -> IO a) -> IO a
+
+getException :: a -> IO (Maybe Exception)
+getExceptionIO :: IO a -> IO (Either Exception a)
+</verb></tscreen>
+
+Each of the functions <tt/catchIO/, <tt/catchArith/, and
+<tt/catchError/ only catch a specific type of exception. All other
+exceptions are effectively re-thrown. An uncaught exception will
+normally cause the program to terminate, with the offending exception
+displayed.
+
+Note that <tt/catchIO/ is identical to <tt/IO.catch/. The
+implementation of <tt/IO/ errors in GHC and Hugs uses exceptions for
+speed.
+
+Also, don't forget to <tt/import Prelude hidiing (catch)/ when using
+this library, to avoid the name clash between <tt/Exception.catch/ and
+<tt/IO.catch/.
+
+The <tt/getException/ function is useful for evaluating a non-IO typed
+value and testing for exceptions. <tt/getException/ evaluates its
+first argument (as if you'd applied <tt/seq/ to it), returning
+<tt/Just <exception>/ if an exception was raised, or
+<tt/Nothing/ otherwise. Note that due to Haskell's unspecified
+evaluation order, an expression may return one of several possible
+exceptions: consider the expression <tt/error "urk" + 1 `div` 0/. Does
+<tt/getException/ return <tt/Just (ErrorCall "urk")/ or <tt/Just
+(ArithError DivideByZero)/? The answer is "either": getException
+makes a non-deterministic choice about which exception to return. If
+you call it again, you might get a different exception back. This is
+ok, because <tt/getException/ is an IO computation.
+
+<tt/getExceptionIO/ is the equivalent function for <tt/IO/ computations
+--- it runs its first argument, and returns either the return value or
+the exception if one was raised. Passing a value of type <tt/IO a/ to
+<tt/getException/ won't work, because the <tt/IO/ type is represented
+by a function, and <tt/getException/ will only evaluate its argument
+to head normal form, hence the <tt/IO/ computation won't be
+performed. Use <tt/getExceptionIO/ instead.
+
+<sect1> <idx/Dynamic Exceptions/
+<label id="sec:Dynamic-Exceptions">
+<p>
+
+Because the <tt/Exception/ datatype isn't extendible, we added an
+interface for throwing and catching exceptions of type <tt/Dynamic/
+(see Section <ref name="Dynamic" id="sec:Dynamic">), which allows
+exception values of any type in the <tt/Typeable/ class to be thrown
+and caught.
+
+<tscreen><verb>
+throwDyn :: Typeable exception => exception -> b
+catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
+</verb></tscreen>
+
+The <tt/catchDyn/ function only catches exceptions of the required
+type; all other exceptions are re-thrown as with <tt/catchIO/ and
+friends above.
+
--- /dev/null
+<!--
+ <sect> <idx/GlaExts/ <p>
+
+ This library provides a convenient bundle of most of the extensions
+ available in GHC and Hugs. This module is generally more stable than
+ the other modules of non-standard extensions so you might choose to
+ import them from here rather than going straight to the horses mouth.
+
+ <tscreen><verb>
+ module GlaExts( module GlaExts, module IOExts, module ST, module Addr ) where
+ import IOExts
+ import ST
+ import Addr
+ trace :: String -> a -> a
+ performGC :: IO ()
+ </verb></tscreen>
+
+ The GHC version also provides the types <tt/RealWorld/,
+ <tt/ByteArray/, <tt/Lift/ and operations on these types. It also
+ provides the unboxed views of the types
+ <tt/Int/,
+ <tt/Addr/,
+ <tt/Word/,
+ <tt/Float/,
+ <tt/Double/,
+ <tt/Integer/ and
+ <tt/Char/
+ and a number of ``primitive operations'' (<tt/+&num/,
+ <tt/plusFloat&num/, etc.).
+
+ -->
--- /dev/null
+<sect> <idx/IOExts/
+<label id="sec:IOExts">
+<p>
+
+This library provides the following extensions to the IO monad:
+<itemize>
+<item>
+The operations <tt/fixIO/, <tt/unsafePerformIO/ and <tt/unsafeInterleaveIO/
+described in <cite id="ImperativeFP">
+
+<item>
+References (aka mutable variables) and mutable arrays (but no form of
+mutable byte arrays)
+
+<item>
+<tt/openFileEx/ extends the standard <tt/openFile/ action with support
+for opening binary files.
+
+<item>
+<tt/performGC/ triggers an immediate garbage collection
+
+<item>
+When called, <tt/trace/ prints the string in its first argument, and then
+returns the second argument as its result. The <tt/trace/ function is not
+referentially transparent, and should only be used for debugging, or for
+monitoring execution.
+
+<!--
+ You should also be warned that, unless you understand some of the
+ details about the way that Haskell programs are executed, results
+ obtained using <tt/trace/ can be rather confusing. For example, the
+ messages may not appear in the order that you expect. Even ignoring the
+ output that they produce, adding calls to <tt/trace/ can change the
+ semantics of your program. Consider this a warning!
+ -->
+
+<item>
+<tt/unsafePtrEq/ compares two values for pointer equality without
+evaluating them. The results are not referentially transparent and
+may vary significantly from one compiler to another or in the face of
+semantics-preserving program changes. However, pointer equality is useful
+in creating a number of referentially transparent constructs such as this
+simplified memoisation function:
+
+<tscreen><verb>
+> cache :: (a -> b) -> (a -> b)
+> cache f = \x -> unsafePerformIO (check x)
+> where
+> ref = unsafePerformIO (newIORef (error "cache", error "cache"))
+> check x = readIORef ref >>= \ (x',a) ->
+> if x `unsafePtrEq` x' then
+> return a
+> else
+> let a = f x in
+> writeIORef ref (x, a) >>
+> return a
+</verb></tscreen>
+
+
+</itemize>
+
+<tscreen><verb>
+module IOExts where
+
+fixIO :: (a -> IO a) -> IO a
+unsafePerformIO :: IO a -> a
+unsafeInterleaveIO :: IO a -> IO a
+
+data IORef a -- mutable variables containing values of type a
+newIORef :: a -> IO (IORef a)
+readIORef :: IORef a -> IO a
+writeIORef :: IORef a -> a -> IO ()
+instance Eq (IORef a)
+
+data IOArray ix elt -- mutable arrays indexed by values of type ix
+ -- containing values of type a.
+newIOArray :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
+boundsIOArray :: Ix ix => IOArray ix elt -> (ix, ix)
+readIOArray :: Ix ix => IOArray ix elt -> ix -> IO elt
+writeIOArray :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
+freezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
+instance Eq (IOArray ix elt)
+
+openFileEx :: FilePath -> IOModeEx -> IO Handle
+data IOModeEx = BinaryMode IO.IOMode | TextMode IO.IOMode
+instance Eq IOModeEx
+instance Read IOModeEx
+instance Show IOModeEx
+
+performGC :: IO ()
+trace :: String -> a -> a
+unsafePtrEq :: a -> a -> Bool
+</verb></tscreen>
+
--- /dev/null
+<sect> <idx/Int/
+<label id="sec:Int">
+<p>
+
+This library provides signed integers of various sizes. The types
+supported are as follows:
+
+<tabular ca="ll">
+type | number of bits @
+<!-- <hline> -->
+Int8 | 8 @
+Int16 | 16 @
+Int32 | 32 @
+Int64 | 64 @
+<!-- <hline> -->
+</tabular>
+
+For each type <it/I/ above, we provide the following instances.
+
+<tscreen><verb>
+data I -- Signed Ints
+iToInt :: I -> Int -- not provided for Int64
+intToi :: Int -> I -- not provided for Int64
+instance Eq I
+instance Ord I
+instance Show I
+instance Read I
+instance Bounded I
+instance Num I
+instance Real I
+instance Integral I
+instance Enum I
+instance Ix I
+instance Bits I
+</verb></tscreen>
+Plus
+<tscreen><verb>
+int8ToInt :: Int8 -> Int
+intToInt8 :: Int -> Int8
+int16ToInt :: Int16 -> Int
+intToInt16 :: Int -> Int16
+int32ToInt :: Int32 -> Int
+intToInt32 :: Int -> Int32
+</verb></tscreen>
+
+<itemize>
+<item>
+Hugs does not provide <tt/Int64/ at the moment.
+
+<item>
+ToDo: complete the set of coercion functions.
+
+</itemize>
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.1 1997/12/16 12:47:31 simonm Exp $
+# $Id: Makefile,v 1.2 1998/12/02 13:20:22 simonm Exp $
TOP=../..
include $(TOP)/mk/boilerplate.mk
+SGML_DOC = libs
+
include $(TOP)/mk/target.mk
--- /dev/null
+<sect> <idx/NumExts/
+<label id="sec:NumExts">
+<p>
+
+The <tt/NumExts/ interface collect together various numeric
+operations that have proven to be commonly useful
+
+<tscreen> <verb>
+-- Going between Doubles and Floats:
+doubleToFloat :: Double -> Float
+floatToDouble :: Float -> Double
+
+showHex :: Integral a => a -> ShowS
+showOct :: Integral a => a -> ShowS
+</verb> </tscreen>
+
+Notes:
+<itemize>
+<item>
+ If <tt/doubleToFloat/ is applied to a <tt/Double/ that is within
+ the representable range for <tt/Float/, the result may be the next
+ higher or lower representable <tt/Float/ value. If the <tt/Double/
+ is out of range, the result is undefined.
+<item>
+ No loss of precision occurs in the other direction with
+ <tt/floatToDouble/, the floating value remains unchanged.
+<item>
+ <tt/showOct/ and <tt/showHex/ will prefix <tt/0o/ and <tt/0x/
+ respectively. Like <tt/Numeric.showInt/, these show functions
+ work on positive numbers only.
+</itemize>
--- /dev/null
+<sect> <idx/Pretty/
+<label id="sec:Pretty">
+<p>
+
+This library contains Simon Peyton Jones' implementation of John
+Hughes's pretty printer combinators.
+
+<tscreen><verb>
+module Pretty where
+infixl 6 <>
+infixl 6 <+>
+infixl 5 $$, $+$
+data Doc -- the Document datatype
+
+-- The primitive Doc values
+empty :: Doc
+text :: String -> Doc
+char :: Char -> Doc
+int :: Int -> Doc
+integer :: Integer -> Doc
+float :: Float -> Doc
+double :: Double -> Doc
+rational :: Rational -> Doc
+semi, comma, colon, space, equals :: Doc
+lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
+parens, brackets, braces :: Doc -> Doc
+quotes, doubleQuotes :: Doc -> Doc
+
+-- Combining Doc values
+(<>) :: Doc -> Doc -> Doc -- Beside
+hcat :: [Doc] -> Doc -- List version of <>
+(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
+hsep :: [Doc] -> Doc -- List version of <+>
+($$) :: Doc -> Doc -> Doc -- Above; if there is no
+ -- overlap it "dovetails" the two
+vcat :: [Doc] -> Doc -- List version of $$
+cat :: [Doc] -> Doc -- Either hcat or vcat
+sep :: [Doc] -> Doc -- Either hsep or vcat
+fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
+fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
+nest :: Int -> Doc -> Doc -- Nested
+hang :: Doc -> Int -> Doc -> Doc
+punctuate :: Doc -> [Doc] -> [Doc]
+-- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
+
+-- Displaying Doc values
+instance Show Doc
+render :: Doc -> String -- Uses default style
+renderStyle :: Style -> Doc -> String
+data Style = Style { lineLength :: Int, -- In chars
+ ribbonsPerLine :: Float, -- Ratio of ribbon length
+ -- to line length
+ mode :: Mode
+ }
+data Mode = PageMode -- Normal
+ | ZigZagMode -- With zig-zag cuts
+ | LeftMode -- No indentation, infinitely long lines
+ | OneLineMode -- All on one line
+</verb></tscreen>
--- /dev/null
+<sect> <idx/ST/
+<label id="sec:ST">
+<p>
+
+This library provides support for <em/strict/ state threads, as
+described in the PLDI '94 paper by John Launchbury and Simon Peyton
+Jones <cite id="LazyStateThreads">. In addition to the monad <tt/ST/,
+it also provides mutable variables <tt/STRef/ and mutable arrays
+<tt/STArray/.
+
+<tscreen><verb>
+module ST( module ST, module Monad ) where
+import Monad
+
+data ST s a -- abstract type
+runST :: forall a. (forall s. ST s a) -> a
+fixST :: (a -> ST s a) -> ST s a
+unsafeInterleaveST :: ST s a -> ST s a
+instance Functor (ST s)
+instance Monad (ST s)
+
+data STRef s a -- mutable variables in state thread s
+ -- containing values of type a.
+newSTRef :: a -> ST s (STRef s a)
+readSTRef :: STRef s a -> ST s a
+writeSTRef :: STRef s a -> a -> ST s ()
+instance Eq (STRef s a)
+
+data STArray s ix elt -- mutable arrays in state thread s
+ -- indexed by values of type ix
+ -- containing values of type a.
+newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
+boundsSTArray :: Ix ix => STArray s ix elt -> (ix, ix)
+readSTArray :: Ix ix => STArray s ix elt -> ix -> ST s elt
+writeSTArray :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
+thawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
+freezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
+unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
+instance Eq (STArray s ix elt)
+</verb></tscreen>
+
+Notes:
+<itemize>
+
+<item>
+GHC also supports ByteArrays --- these aren't supported by Hugs yet.
+
+<item>
+The operations <tt/freezeSTArray/ and <tt/thawSTArray/ convert mutable
+arrays to and from immutable arrays. Semantically, they are identical
+to copying the array and they are usually implemented that way. The
+operation <tt/unsafeFreezeSTArray/ is a faster version of
+<tt/freezeSTArray/ which omits the copying step. It's a safe substitute for
+<tt/freezeSTArray/ if you don't modify the mutable array after freezing it.
+
+<item>
+In the current version of Hugs, the <tt/<idx/runST// operation,
+used to specify encapsulation, is implemented as a language construct,
+and <tt/runST/ is treated as a keyword. We plan to change this to match
+GHC soon.
+
+<!--
+ <item>
+ Note that it is possible to install Hugs 1.4 without support for lazy
+ state threads, and hence the primitives described here may not be
+ available in all implementations. Also, in contrast with the
+ implementation of lazy state threads in previous releases of Hugs and
+ Gofer, there is no direct relationship between the
+ <tt/<idx/ST monad// and the <tt/<idx/IO monad//.
+ -->
+
+<item>
+Hugs provides <tt/thenLazyST/ and <tt/thenStrictST/ so that you can
+import <tt/LazyST/ (say) and still use the strict instance in those
+places where it matters. GHC implements LazyST and ST using different
+types, so this isn't possible.
+</item>
+
+</itemize>
--- /dev/null
+<sect> <idx/Weak/
+<label id="sec:Weak">
+<p>
+
+The <tt/Weak/ library provides a "weak pointer" abstraction, giving
+the user some control over the garbage collection of specified
+objects, and allowing objects to be "finalised" with an arbitrary
+Haskell IO computation when they die.
+
+Weak pointers partially replace the old foreign object interface, as
+we will explain later.
+
+<sect1>Module Signature
+<p>
+
+<tscreen><verb>
+module Weak (
+ Weak, -- abstract
+ -- instance Eq (Weak v)
+
+ mkWeak, -- :: k -> v -> IO () -> IO (Weak v)
+ deRefWeak -- :: Weak v -> IO (Maybe v)
+
+ -- Not yet implemented
+ -- finalise -- :: Weak v -> IO ()
+ -- replaceFinaliser -- :: Weak v -> IO () -> IO ()
+
+ mkWeakPtr -- :: k -> IO () -> IO (Weak k)
+ mkWeakPair -- :: k -> v -> IO () -> IO (Weak (k,v))
+ addFinaliser -- :: k -> IO () -> IO ()
+ addForeignFinaliser -- :: ForeignObj -> IO () -> IO ()
+ ) where
+</verb></tscreen>
+
+<sect1>Weak pointers
+<p>
+
+In general terms, a weak pointer is a reference to an object that is
+not followed by the garbage collector --- that is, the existence of a
+weak pointer to an object has no effect on the lifetime of that
+object. A weak pointer can be de-referenced to find out
+whether the object it refers to is still alive or not, and if so
+to return the object itself.
+
+Weak pointers are particularly useful for caches and memo tables.
+To build a memo table, you build a data structure
+mapping from the function argument (the key) to its result (the
+value). When you apply the function to a new argument you first
+check whether the key/value pair is already in the memo table.
+The key point is that the memo table itself should not keep the
+key and value alive. So the table should contain a weak pointer
+to the key, not an ordinary pointer. The pointer to the value must
+not be weak, because the only reference to the value might indeed be
+from the memo table.
+
+So it looks as if the memo table will keep all its values
+alive for ever. One way to solve this is to purge the table
+occasionally, by deleting entries whose keys have died.
+
+The weak pointers in this library
+support another approach, called <em/finalisation/.
+When the key referred to by a weak pointer dies, the storage manager
+arranges to run a programmer-specified finaliser. In the case of memo
+tables, for example, the finaliser could remove the key/value pair
+from the memo table.
+
+Another difficulty with the memo table is that the value of a
+key/value pair might itself contain a pointer to the key.
+So the memo table keeps the value alive, which keeps the key alive,
+even though there may be no other references to the key so both should
+die. The weak pointers in this library provide a slight
+generalisation of the basic weak-pointer idea, in which each
+weak pointer actually contains both a key and a value.
+We describe this in more detail below.
+
+<sect1>The simple interface
+<p>
+
+<tscreen><verb>
+ mkWeakPtr :: a -> IO () -> IO (Weak a)
+ deRefWeak :: Weak a -> IO (Maybe a)
+ addFinaliser :: a -> IO () -> IO ()
+</verb></tscreen>
+
+<tt/mkWeakPtr/ takes a value of any type <tt/a/, and a finaliser of
+type <tt/IO ()/, and returns a weak pointer object referring
+to the value, of type <tt/Weak a/.
+It is in the <tt/IO/ monad because it has the
+side effect of arranging that the finaliser will be run when the
+object dies. In what follows, a ``weak pointer object'', or ``weak
+pointer'' for short, means precisely ``a Haskell value of
+type <tt/Weak t/'' for some type <tt/t/.
+A weak pointer (object) is a first-class Haskell value; it can be passed to
+functions, stored in data structures, and so on.
+
+<tt/deRefWeak/ dereferences a weak pointer, returning <tt/Just v/ if
+the value is still alive. If the key has already died, then
+<tt/deRefWeak/ returns <tt/Nothing/; that's why it's in the <tt/IO/
+monad - the return value of <tt/deRefWeak/ depends on when the garbage
+collector runs.
+
+<tt/addFinaliser/ is just another name for <tt/mkWeakPtr/ except that
+it throws the weak pointer itself away. (The runtime system will
+remember that the weak pointer and hence the finaliser exists even if
+the program has forgotten it.)
+
+<tscreen><verb>
+ addFinaliser :: a -> IO () -> IO ()
+ addFinaliser v f = do { mkWeakPtr v f; return () }
+</verb></tscreen>
+
+The effect of <tt/addFinaliser/ is simply that the finaliser runs when
+the referenced object dies.
+
+The following properties hold:
+
+<itemize>
+<item> <tt/deRefWeak/ returns the original object until
+that object is considered dead; it returns <tt/Nothing/
+subsequently.
+<item>
+Every finaliser will eventually be run, exactly once, either
+soon after the object dies, or at the end of the program.
+There is no requirement for the programmer to hold onto the
+weak pointer itself; finalisation is completely unaffected by
+whether the weak pointer itself is alive.
+<item>
+There may be multiple weak pointers to a single object.
+In this case, the finalisers for each of these weak pointers will
+all be run in some arbitrary order, or perhaps concurrently,
+when the object dies. If the programmer specifies a finaliser that
+assumes it has the only reference to an object
+(for example, a file that it wishes to close), then the programmer
+must ensure that there is only one such finaliser.
+<item>
+The storage manager attempts to run the finaliser(s) for an
+object soon after the object dies, but promptness is not guaranteed.
+(What is guaranteed is that the finaliser will
+eventually run, exactly once.)
+<item>
+At the moment when a finaliser is run, a call to <tt/deRefWeak/
+will return <tt/Nothing/.
+<item>
+A finaliser may contain a pointer to the object, but that pointer
+will not keep the object alive. For example:
+<tscreen><verb>
+ f :: Show a => a -> IO a
+ f x = addFinaliser x (print (show x))
+</verb></tscreen>
+Here the finaliser <tt/print (show x)/ contains a reference to <tt/x/
+itself, but that does not keep <tt/x/ alive. When that is the only
+reference to <tt/x/, the finaliser is run; and the message appears
+on the screen.
+<item>
+A finaliser may even resurrect the object, by (say) storing it in
+some global data structure.
+</itemize>
+
+<sect1>The general interface
+<p>
+
+The <tt/Weak/ library offers a slight generalisation of
+the simple weak pointers described so far:
+<tscreen><verb>
+ mkWeak :: k -> v -> IO () -> IO (Weak v)
+</verb></tscreen>
+<tt/mkWeak/ takes a key of any type <tt/k/ and a value of any type
+<tt/v/, as well as a finaliser, and returns a weak pointer of type
+<tt/Weak v/.
+
+<tt/deRefWeak/ returns the <em/value/ only, not the key, as its
+type (given above) implies:
+<tscreen><verb>
+ deRefWeak :: Weak a -> IO (Maybe a)
+</verb></tscreen>
+However, <tt/deRefWeak/ returns <tt/Nothing/ if the <em/key/, not the
+value, has died. Furthermore, references from the value to the key
+do not keep the key alive, in the same way that the finaliser does
+not keep the key alive.
+
+Simple weak pointers are readily defined in terms of these more general
+weak pointers:
+<tscreen><verb>
+ mkWeakPtr :: a -> IO () -> IO (Weak a)
+ mkWeakPtr v f = mkWeak v v f
+</verb></tscreen>
+
+These more general weak pointers are enough to implement memo
+tables properly.
+
+<sect1> A precise semantics
+<p>
+The above informal specification is fine for simple situations,
+but matters can get complicated. In particular, it needs to
+be clear exactly when a key dies, so that any weak pointers
+that refer to it can be finalised.
+Suppose, for example, the value of one weak pointer refers
+to the key of another...does that keep the key alive?
+
+The behaviour is simply this:
+
+<itemize>
+<item> If a weak pointer (object) refers to an <em/unreachable/
+key, it may be finalised.
+<item> Finalisation means (a) arrange that subsequent calls
+to <tt/deRefWeak/ return <tt/Nothing/; and (b) run the finaliser.
+</itemize>
+
+This behaviour depends on what it means for a key to be reachable.
+Informally,
+something is reachable if it can be reached by following ordinary
+pointers from the root set, but not following weak pointers.
+We define reachability more precisely as
+follows
+A heap object is reachable if:
+
+<itemize>
+<item> It is directly pointed to by a reachable object, other than
+a weak pointer object.
+<item> It is a weak pointer object whose key is reachable.
+<item> It is the value or finaliser of an object whose key is
+reachable.
+</itemize>
+
+Notice that a pointer to the key from its associated
+value or finaliser does not make the key reachable.
+However, if the key is reachable some other way, then the value
+and the finaliser are reachable, and so, therefore, are any other
+keys they refer to directly or indirectly.
+
+
+<sect1>Finalisation for foreign objects
+<p>
+
+A foreign object is some data that lives outside the Haskell heap, for
+example some <tt/malloc/ed data in C land. It's useful to be able to
+know when the Haskell program no longer needs the <tt/malloc/ed data,
+so it can be <tt/free/d. We can use weak pointers and finalisers for
+this, but we have to be careful: the foreign data is usually
+referenced by an address, ie. an <tt/Addr/ (see Section <ref
+name="Addr" id="sec:Addr">), and we must retain the invariant that
+<em/if the Haskell program still needs the foreign object, then it
+retains the <tt/Addr/ object in the heap/. This invariant isn't
+guaranteed to hold if we use <tt/Addr/, because an <tt/Addr/ consists
+of a box around a raw address <tt/Addr#/. If the Haskell program can
+manipulate the <tt/Addr#/ object independently of the heap-resident
+<tt/Addr/, then the foreign object could be inadvertently finalised
+early, because a weak pointer to the <tt/Addr/ would find no more
+references to its key and trigger the finaliser despite the fact that
+the program still holds the <tt/Addr#/ and intends to use it.
+
+To avoid this somewhat subtle race condition, we use another type of
+foreign address, called <tt/ForeignObj/. Historical note:
+<tt/ForeignObj/ is identical to the old <tt/ForeignObj/ except that it
+no longer supports finalisation - that's provided by the weak
+pointer/finalisation mechanism above.
+
+A <tt/ForeignObj/ is basically an address, but the <tt/ForeignObj/
+itself is a heap-resident object and can therefore be watched by weak
+pointers. A <tt/ForeignObj/ can be passed to C functions (in which
+case the C function gets a straightforward pointer), but it cannot be
+decomposed into an <tt/Addr#/. Operations on <tt/ForeignObj/ are
+provided by the <tt/Foreign/ module (see Section <ref name="Foreign"
+id="sec:Foreign">).
--- /dev/null
+<sect> <idx/Word/
+<label id="sec:Word">
+<p>
+
+This library provides unsigned integers of various sizes.
+The types supported are as follows:
+
+<tabular ca="ll">
+type | number of bits @
+<!-- <hline> -->
+Word8 | 8 @
+Word16 | 16 @
+Word32 | 32 @
+Word64 | 64 @
+<!-- <hline> -->
+</tabular>
+
+For each type <it/W/ above, we provide the following functions and
+instances. The type <it/I/ refers to the signed integer type of the
+same size.
+
+<tscreen><verb>
+data W -- Unsigned Ints
+instance Eq W
+instance Ord W
+instance Show W
+instance Read W
+instance Bounded W
+instance Num W
+instance Real W
+instance Integral W
+instance Enum W
+instance Ix W
+instance Bits W
+</verb></tscreen>
+Plus
+<tscreen><verb>
+word8ToWord32 :: Word8 -> Word32
+word32ToWord8 :: Word32 -> Word8
+word16ToWord32 :: Word16 -> Word32
+word32ToWord16 :: Word32 -> Word16
+
+word8ToInt :: Word8 -> Int
+intToWord8 :: Int -> Word8
+word16ToInt :: Word16 -> Int
+intToWord16 :: Int -> Word16
+word32ToInt :: Word32 -> Int
+intToWord32 :: Int -> Word32
+</verb></tscreen>
+
+Notes:
+<itemize>
+<item>
+ All arithmetic is performed modulo 2^n
+
+ One non-obvious consequequence of this is that <tt/negate/
+ should <em/not/ raise an error on negative arguments.
+
+<item>
+The coercion <tt/wToI/ converts an unsigned n-bit value to the
+signed n-bit value with the same representation. For example,
+<tt/word8ToInt8 0xff = -1/.
+Likewise, <tt/iToW/ converts signed n-bit values to the
+corresponding unsigned n-bit value.
+
+<item>
+ToDo: complete the set of coercion functions.
+
+<item>
+Use <tt/Prelude.fromIntegral :: (Integral a, Num b) => a -> b/ to
+coerce between different sizes or to preserve sign when converting
+between values of the same size.
+
+<item>
+It would be very natural to add a type a type <tt/Natural/ providing
+an unbounded size unsigned integer --- just as <tt/Integer/ provides
+unbounded size signed integers. We do not do that yet since there is
+no demand for it. Doing so would require <tt/Bits.bitSize/ to return
+<tt/Maybe Int/.
+
+<item>
+The <tt/Enum/ instances stop when they reach their upper or lower
+bound --- they don't overflow the way the <tt/Int/ and <tt/Float/
+instances do.
+
+<item>
+It would be useful to provide a function (or a family of functions?)
+which coerced between any two Word types (without going through
+Integer).
+
+</itemize>
+
+Hugs only provides <tt/Eq/, <tt/Ord/, <tt/Read/ and <tt/Show/
+instances for <tt/Word64/ at the moment.
+
-<!doctype linuxdoc system>
+<!doctype linuxdoc system [
+ <!ENTITY addr SYSTEM "Addr.sgml">
+ <!ENTITY bits SYSTEM "Bits.sgml">
+ <!ENTITY concurrent SYSTEM "Concurrent.sgml">
+ <!ENTITY dynamic SYSTEM "Dynamic.sgml">
+ <!ENTITY exception SYSTEM "Exception.sgml">
+ <!ENTITY glaexts SYSTEM "GlaExts.sgml">
+ <!ENTITY ioexts SYSTEM "IOExts.sgml">
+ <!ENTITY int SYSTEM "Int.sgml">
+ <!ENTITY ndset SYSTEM "NDSet.sgml">
+ <!ENTITY numexts SYSTEM "NumExts.sgml">
+ <!ENTITY pretty SYSTEM "Pretty.sgml">
+ <!ENTITY st SYSTEM "ST.sgml">
+ <!ENTITY weak SYSTEM "Weak.sgml">
+ <!ENTITY word SYSTEM "Word.sgml">
+]>
<!-- ToDo:
o Add indexing support (to linuxdoc)
<article>
<title>The Hugs-GHC Extension Libraries
-<author>The Hugs/GHC Team
-<date>August 1998
+<author>Alastair Reid <tt/reid-alastair@cs.yale.edu/
+ Simon Marlow <tt/simonm@dcs.gla.ac.uk/
+<date>v0.8, 28 January 1998
<abstract>
Hugs and GHC provide a common set of libraries to aid portability.
This document specifies the interfaces to these libraries and documents
-known differences.
+known differences. We hope that these modules will be adopted for inclusion
+as Standard Haskell Libraries sometime soon.
</abstract>
<toc>
the form <tt/getXContents/, e.g., <tt/Channel.getChanContents/ and
<tt/IO.hGetContents/. (OK, so the latter isn't called
<tt/getHandleContents/, but you hopefully get the picture.)
-<item>
-Overloaded operators that convert values to some fixed type are named
-<tt/toX/, where <tt/X/ is the type we're converting into, e.g.,
-<tt/toInt/, <tt/toDyn/.
-<p>
-Similarly for overloaded coercion operations that go the other way,
-from a known type to an overloaded one. These have the prefix
-<tt/from/ followed by the name of the type we're converting from,
-e.g., <tt/fromInteger/, <tt/fromDyn/, <tt/fromDynamic/.
-
</itemize>
-<sect> <idx/ST/
-<label id="sec:ST">
-<p>
-
-This library provides support for <em/strict/ state threads, as
-described in the PLDI '94 paper by John Launchbury and Simon Peyton
-Jones <cite id="LazyStateThreads">. In addition to the monad <tt/ST/,
-it also provides mutable variables <tt/STRef/ and mutable arrays
-<tt/STArray/.
-
-<tscreen><verb>
-module ST( module ST, module Monad ) where
-import Monad
-
-data ST s a -- abstract type
-runST :: forall a. (forall s. ST s a) -> a
-fixST :: (a -> ST s a) -> ST s a
-unsafeInterleaveST :: ST s a -> ST s a
-instance Functor (ST s)
-instance Monad (ST s)
-
-data STRef s a -- mutable variables in state thread s
- -- containing values of type a.
-newSTRef :: a -> ST s (STRef s a)
-readSTRef :: STRef s a -> ST s a
-writeSTRef :: STRef s a -> a -> ST s ()
-instance Eq (STRef s a)
+<!-- ========================= -->
-data STArray s ix elt -- mutable arrays in state thread s
- -- indexed by values of type ix
- -- containing values of type a.
-newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
-boundsSTArray :: Ix ix => STArray s ix elt -> (ix, ix)
-readSTArray :: Ix ix => STArray s ix elt -> ix -> ST s elt
-writeSTArray :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
-thawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
-freezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
-unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
-instance Eq (STArray s ix elt)
-</verb></tscreen>
-
-Notes:
-<itemize>
-
-<item>
-GHC also supports ByteArrays --- these aren't supported by Hugs yet.
-
-<item>
-The operations <tt/freezeSTArray/ and <tt/thawSTArray/ convert mutable
-arrays to and from immutable arrays. Semantically, they are identical
-to copying the array and they are usually implemented that way. The
-operation <tt/unsafeFreezeSTArray/ is a faster version of
-<tt/freezeSTArray/ which omits the copying step. It's a safe substitute for
-<tt/freezeSTArray/ if you don't modify the mutable array after freezing it.
-
-<item>
-In the current version of Hugs, the <tt/<idx/runST// operation,
-used to specify encapsulation, is implemented as a language construct,
-and <tt/runST/ is treated as a keyword. We plan to change this to match
-GHC soon.
-
-<!--
- <item>
- Note that it is possible to install Hugs 1.4 without support for lazy
- state threads, and hence the primitives described here may not be
- available in all implementations. Also, in contrast with the
- implementation of lazy state threads in previous releases of Hugs and
- Gofer, there is no direct relationship between the
- <tt/<idx/ST monad// and the <tt/<idx/IO monad//.
- -->
+&addr
+&bits
+&concurrent
+&dynamic
+&exception
-<item>
-Hugs provides <tt/thenLazyST/ and <tt/thenStrictST/ so that you can
-import <tt/LazyST/ (say) and still use the strict instance in those
-places where it matters. GHC implements LazyST and ST using different
-types, so this isn't possible.
-</item>
+<sect> <idx/Foreign/
+<label id="sec:Foreign">
+<p>
+This module is provided by GHC but not by Hugs.
+GreenCard for Hugs provides the <tt/ForeignObj/ type.
-</itemize>
+&glaexts
+&ioexts
+&int
<sect> <idx/LazyST/
<label id="sec:LazyST">
state thread passed to <tt/strictToLazyST/ is not performed until the
result of the lazy state thread it returns is demanded.
-<sect> <idx/IOExts/
-<label id="sec:IOExts">
-<p>
-
-This library provides the following extensions to the IO monad:
-
-<tscreen><verb>
-module IOExts where
-
-fixIO :: (a -> IO a) -> IO a
-unsafePerformIO :: IO a -> a
-unsafeInterleaveIO :: IO a -> IO a
-
-data IORef a -- mutable variables containing values of type a
-newIORef :: a -> IO (IORef a)
-readIORef :: IORef a -> IO a
-writeIORef :: IORef a -> a -> IO ()
-instance Eq (IORef a)
-
-data IOArray ix elt -- mutable arrays indexed by values of type ix
- -- containing values of type a.
-newIOArray :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
-boundsIOArray :: Ix ix => IOArray ix elt -> (ix, ix)
-readIOArray :: Ix ix => IOArray ix elt -> ix -> IO elt
-writeIOArray :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
-freezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
-instance Eq (IOArray ix elt)
-
-openFileEx :: FilePath -> IOModeEx -> IO Handle
-data IOModeEx = BinaryMode IO.IOMode | TextMode IO.IOMode
-instance Eq IOModeEx
-instance Read IOModeEx
-instance Show IOModeEx
-
-performGC :: IO ()
-trace :: String -> a -> a
-unsafePtrEq :: a -> a -> Bool
-
-unsafeIOToST :: IO a -> ST s a
-</verb></tscreen>
-
-<itemize>
-<item>
-The operations <tt/fixIO/, <tt/unsafePerformIO/ and <tt/unsafeInterleaveIO/
-described in <cite id="ImperativeFP">
-
-<item>
-References (aka mutable variables) and mutable arrays (but no form of
-mutable byte arrays)
-
-<item>
-<tt/openFileEx/ extends the standard <tt/openFile/ action with support
-for opening binary files. On platforms that make no distinction
-between text and binary files, <tt/openFileEx/ is indistinguishable
-from <tt/openFile/.
-
-<item>
-<tt/performGC/ triggers an immediate garbage collection
-
-<item>
-When called, <tt/trace/ prints the string in its first argument, and then
-returns the second argument as its result. The <tt/trace/ function is not
-referentially transparent, and should only be used for debugging, or for
-monitoring execution.
-
-<!--
- You should also be warned that, unless you understand some of the
- details about the way that Haskell programs are executed, results
- obtained using <tt/trace/ can be rather confusing. For example, the
- messages may not appear in the order that you expect. Even ignoring the
- output that they produce, adding calls to <tt/trace/ can change the
- semantics of your program. Consider this a warning!
- -->
-
-<item>
-<tt/unsafePtrEq/ compares two values for pointer equality without
-evaluating them. The results are not referentially transparent and
-may vary significantly from one compiler to another or in the face of
-semantics-preserving program changes. However, pointer equality is useful
-in creating a number of referentially transparent constructs such as this
-simplified memoisation function:
-
-<tscreen><verb>
-> cache :: (a -> b) -> (a -> b)
-> cache f = \x -> unsafePerformIO (check x)
-> where
-> ref = unsafePerformIO (newIORef (error "cache", error "cache"))
-> check x = readIORef ref >>= \ (x',a) ->
-> if x `unsafePtrEq` x' then
-> return a
-> else
-> let a = f x in
-> writeIORef ref (x, a) >>
-> return a
-</verb></tscreen>
-
-<item>
-The <tt/unsafeIOToST/ action provides a loop hole for lifting an
-<tt/IO/ action into the <tt/ST/ monad. This is a potentially unsafe
-thing to do, so the onus is on the programmer to ensure that the
-use of <tt/unsafeIOToST/ does not ruin underlying program properties
-such as referential transparency.
-</itemize>
-
-<!--
- <sect> <idx/GlaExts/ <p>
-
- This library provides a convenient bundle of most of the extensions
- available in GHC and Hugs. This module is generally more stable than
- the other modules of non-standard extensions so you might choose to
- import them from here rather than going straight to the horses mouth.
-
- <tscreen><verb>
- module GlaExts( module GlaExts, module IOExts, module ST, module Addr ) where
- import IOExts
- import ST
- import Addr
- trace :: String -> a -> a
- performGC :: IO ()
- </verb></tscreen>
-
- The GHC version also provides the types <tt/PrimIO/, <tt/RealWorld/,
- <tt/ByteArray/, <tt/Lift/ and operations on these types. It also
- provides the unboxed views of the types
- <tt/Int/,
- <tt/Addr/,
- <tt/Word/,
- <tt/Float/,
- <tt/Double/,
- <tt/Integer/ and
- <tt/Char/
- and a number of ``primitive operations'' (<tt/+&num/,
- <tt/plusFloat&num/, etc.).
-
- -->
-
-<sect> <idx/Bits/
-<label id="sec:Bits">
-<p>
-
-This library defines bitwise operations for signed and unsigned ints.
-
-<tscreen><verb>
-module Bits where
-infixl 8 `shift`, `rotate`
-infixl 7 .&.
-infixl 6 `xor`
-infixl 5 .|.
-
-class Bits a where
- (.&.), (.|.), xor :: a -> a -> a
- complement :: a -> a
- shift :: a -> Int -> a
- rotate :: a -> Int -> a
- bit :: Int -> a
- setBit :: a -> Int -> a
- clearBit :: a -> Int -> a
- complementBit :: a -> Int -> a
- testBit :: a -> Int -> Bool
- bitSize :: a -> Int
- isSigned :: a -> Bool
-
-shiftL, shiftR :: Bits a => a -> Int -> a
-rotateL, rotateR :: Bits a => a -> Int -> a
-shiftL a i = shift a i
-shiftR a i = shift a (-i)
-rotateL a i = rotate a i
-rotateR a i = rotate a (-i)
-</verb></tscreen>
-
-Notes:
-<itemize>
-<item>
- <tt/bitSize/ and <tt/isSigned/ are like <tt/floatRadix/ and <tt/floatDigits/
- -- they return parameters of the <em/type/ of their argument rather than
- of the particular argument they are applied to. <tt/bitSize/ returns
- the number of bits in the type; and <tt/isSigned/ returns whether
- the type is signed or not.
-<item>
- <tt/shift/ performs sign extension on signed number types.
- That is, right shifts fill the top bits with 1 if the number is negative
- and with 0 otherwise.
-<item>
- Bits are numbered from 0 with bit 0 being the least significant bit.
-<item>
- <tt/shift x i/ and <tt/rotate x i/ shift to the left if <tt/i/ is
- positive and to the right otherwise.
-<!--
- <item>
- <tt/rotate/ is well defined only if bitSize returns a number.
- (Maybe we should impose a Bounded constraint on it?)
- -->
-<item>
- <tt/bit i/ is the value with the i'th bit set.
-</itemize>
-
-<sect> <idx/Word/
-<label id="sec:Word">
-<p>
-
-This library provides unsigned integers of various sizes.
-The types supported are as follows:
-
-<tabular ca="ll">
-type | number of bits @
-<!-- <hline> -->
-Word8 | 8 @
-Word16 | 16 @
-Word32 | 32 @
-Word64 | 64 @
-<!-- <hline> -->
-</tabular>
-
-For each type <it/W/ above, we provide the following functions and
-instances. The type <it/I/ refers to the signed integer type of the
-same size.
-
-<tscreen><verb>
-data W -- Unsigned Ints
-instance Eq W
-instance Ord W
-instance Show W
-instance Read W
-instance Bounded W
-instance Num W
-instance Real W
-instance Integral W
-instance Enum W
-instance Ix W
-instance Bits W
-</verb></tscreen>
-Plus
-<tscreen><verb>
-word8ToWord32 :: Word8 -> Word32
-word32ToWord8 :: Word32 -> Word8
-word16ToWord32 :: Word16 -> Word32
-word32ToWord16 :: Word32 -> Word16
-
-word8ToInt :: Word8 -> Int
-intToWord8 :: Int -> Word8
-word16ToInt :: Word16 -> Int
-intToWord16 :: Int -> Word16
-word32ToInt :: Word32 -> Int
-intToWord32 :: Int -> Word32
-</verb></tscreen>
-
-Notes:
-<itemize>
-<item>
- All arithmetic is performed modulo 2^n
-
- One non-obvious consequequence of this is that <tt/negate/
- should <em/not/ raise an error on negative arguments.
-
-<item>
-The coercion <tt/wToI/ converts an unsigned n-bit value to the
-signed n-bit value with the same representation. For example,
-<tt/word8ToInt8 0xff = -1/.
-Likewise, <tt/iToW/ converts signed n-bit values to the
-corresponding unsigned n-bit value.
-
-<item>
-ToDo: complete the set of coercion functions.
-
-<item>
-Use <tt/Prelude.fromIntegral :: (Integral a, Num b) => a -> b/ to
-coerce between different sizes or to preserve sign when converting
-between values of the same size.
-
-<item>
-It would be very natural to add a type a type <tt/Natural/ providing
-an unbounded size unsigned integer --- just as <tt/Integer/ provides
-unbounded size signed integers. We do not do that yet since there is
-no demand for it. Doing so would require <tt/Bits.bitSize/ to return
-<tt/Maybe Int/.
-
-<item>
-The <tt/Enum/ instances stop when they reach their upper or lower
-bound --- they don't overflow the way the <tt/Int/ and <tt/Float/
-instances do.
-
-<item>
-It would be useful to provide a function (or a family of functions?)
-which coerced between any two Word types (without going through
-Integer).
-
-</itemize>
-
-Hugs only provides <tt/Eq/, <tt/Ord/, <tt/Read/ and <tt/Show/
-instances for <tt/Word64/ at the moment.
-
-<sect> <idx/Int/
-<label id="sec:Int">
-<p>
-
-This library provides signed integers of various sizes. The types
-supported are as follows:
-
-<tabular ca="ll">
-type | number of bits @
-<!-- <hline> -->
-Int8 | 8 @
-Int16 | 16 @
-Int32 | 32 @
-Int64 | 64 @
-<!-- <hline> -->
-</tabular>
-
-For each type <it/I/ above, we provide the following instances.
-
-<tscreen><verb>
-data I -- Signed Ints
-iToInt :: I -> Int -- not provided for Int64
-intToi :: Int -> I -- not provided for Int64
-instance Eq I
-instance Ord I
-instance Show I
-instance Read I
-instance Bounded I
-instance Num I
-instance Real I
-instance Integral I
-instance Enum I
-instance Ix I
-instance Bits I
-</verb></tscreen>
-Plus
-<tscreen><verb>
-int8ToInt :: Int8 -> Int
-intToInt8 :: Int -> Int8
-int16ToInt :: Int16 -> Int
-intToInt16 :: Int -> Int16
-int32ToInt :: Int32 -> Int
-intToInt32 :: Int -> Int32
-</verb></tscreen>
-
-<itemize>
-<item>
-Hugs does not provide <tt/Int64/ at the moment.
-
-<item>
-ToDo: complete the set of coercion functions.
-
-</itemize>
-
-<sect> <idx/Addr/
-<label id="sec:Addr">
-<p>
-
-This library provides machine addresses and is primarily intended for
-use in creating foreign function interfaces using GreenCard.
-
-<tscreen><verb>
-module Addr where
-data Addr -- Address type
-instance Eq Addr
-
-nullAddr :: Addr
-plusAddr :: Addr -> Int -> Addr
-
--- read value out of _immutable_ memory
-indexCharOffAddr :: Addr -> Int -> Char
-indexIntOffAddr :: Addr -> Int -> Int -- should we drop this?
-indexAddrOffAddr :: Addr -> Int -> Addr
-indexFloatOffAddr :: Addr -> Int -> Float
-indexDoubleOffAddr :: Addr -> Int -> Double
-indexWord8OffAddr :: Addr -> Int -> Word8
-indexWord16OffAddr :: Addr -> Int -> Word16
-indexWord32OffAddr :: Addr -> Int -> Word32
-indexWord64OffAddr :: Addr -> Int -> Word64
-indexInt8OffAddr :: Addr -> Int -> Int8
-indexInt16OffAddr :: Addr -> Int -> Int16
-indexInt32OffAddr :: Addr -> Int -> Int32
-indexInt64OffAddr :: Addr -> Int -> Int64
-
--- read value out of mutable memory
-readCharOffAddr :: Addr -> Int -> IO Char
-readIntOffAddr :: Addr -> Int -> IO Int -- should we drop this?
-readAddrOffAddr :: Addr -> Int -> IO Addr
-readFloatOffAddr :: Addr -> Int -> IO Float
-readDoubleOffAddr :: Addr -> Int -> IO Double
-readWord8OffAddr :: Addr -> Int -> IO Word8
-readWord16OffAddr :: Addr -> Int -> IO Word16
-readWord32OffAddr :: Addr -> Int -> IO Word32
-readWord64OffAddr :: Addr -> Int -> IO Word64
-readInt8OffAddr :: Addr -> Int -> IO Int8
-readInt16OffAddr :: Addr -> Int -> IO Int16
-readInt32OffAddr :: Addr -> Int -> IO Int32
-readInt64OffAddr :: Addr -> Int -> IO Int64
-
--- write value into mutable memory
-writeCharOffAddr :: Addr -> Int -> Char -> IO ()
-writeIntOffAddr :: Addr -> Int -> Int -> IO () -- should we drop this?
-writeAddrOffAddr :: Addr -> Int -> Addr -> IO ()
-writeFloatOffAddr :: Addr -> Int -> Float -> IO ()
-writeDoubleOffAddr :: Addr -> Int -> Double -> IO ()
-writeWord8OffAddr :: Addr -> Int -> Word8 -> IO ()
-writeWord16OffAddr :: Addr -> Int -> Word16 -> IO ()
-writeWord32OffAddr :: Addr -> Int -> Word32 -> IO ()
-writeWord64OffAddr :: Addr -> Int -> Word64 -> IO ()
-writeInt8OffAddr :: Addr -> Int -> Int8 -> IO ()
-writeInt16OffAddr :: Addr -> Int -> Int16 -> IO ()
-writeInt32OffAddr :: Addr -> Int -> Int32 -> IO ()
-writeInt64OffAddr :: Addr -> Int -> Int64 -> IO ()
-</verb></tscreen>
-
-Hugs provides <tt/Addr/ and <tt/nullAddr/ but does not provide any of
-the index, read or write functions. They can be implemented using
-GreenCard if required.
-
-<sect> <idx/NumExts/
-<label id="sec:NumExts">
-<p>
-
-The <tt/NumExts/ interface collect together various numeric
-operations that have proven to be commonly useful
-
-<tscreen> <verb>
--- Going between Doubles and Floats:
-doubleToFloat :: Double -> Float
-floatToDouble :: Float -> Double
-
-showHex :: Integral a => a -> ShowS
-showOct :: Integral a => a -> ShowS
-</verb> </tscreen>
-
-Notes:
-<itemize>
-<item>
- If <tt/doubleToFloat/ is applied to a <tt/Double/ that is within
- the representable range for <tt/Float/, the result may be the next
- higher or lower representable <tt/Float/ value. If the <tt/Double/
- is out of range, the result is undefined.
-<item>
- No loss of precision occurs in the other direction with
- <tt/floatToDouble/, the floating value remains unchanged.
-<item>
- <tt/showOct/ and <tt/showHex/ will prefix <tt/0o/ and <tt/0x/
- respectively. Like <tt/Numeric.showInt/, these show functions
- work on positive numbers only.
-</itemize>
-
-<sect> <idx/Foreign/
-<label id="sec:Foreign">
-<p>
-
-This module provides two types to better allow the Haskell world to
-share its data with the outside world (and vice versa), <em/foreign
-objects/ and <em/stable pointers/:
-
-<tscreen><verb>
-module Foreign where
-data ForeignObj -- abstract, instance of: Eq
-
-makeForeignObj :: Addr{-object-} -> Addr{-finaliser-} -> IO ForeignObj
-writeForeignObj :: ForeignObj -> Addr{-new value-} -> IO ()
-
-data StablePtr a -- abstract, instance of: Eq.
-makeStablePtr :: a -> IO (StablePtr a)
-deRefStablePtr :: StablePtr a -> IO a
-freeStablePtr :: StablePtr a -> IO ()
-</verb> </tscreen>
-
-<itemize>
-<item>The <tt/ForeignObj/ type provides foreign objects, encapsulated
-references to values outside the Haskell heap. Foreign objects are
-finalised by the garbage collector when they become dead. The
-finaliser to use is given as second argument to <tt/makeForeignOj/,
-and is currently a function pointer to a C function with
-the following signature
-
-<tscreen><verb>
-void finaliseFO(void* obj);
-</verb></tscreen>
-
-The finaliser is passed the reference to the external object (i.e.,
-the first argument to <tt/makeForeignObj/.)
-
-<item>
-The <tt/writeForeignObj/ lets you overwrite the encapsulated foreign
-reference with another.
-
-<item>
-Stable pointers allow you to hand out references to Haskell heap
-objects to the outside world. <bf/ToDo:/ <em/say more./
-</itemize>
-
-In addition to the above, the following operations for indexing via
-a <tt/ForeignObj/ are also, mirrored on the same operations provided
-over <tt/Addr/s:
-
-<tscreen><verb>
-indexCharOffForeignObj :: ForeignObj -> Int -> Char
-indexIntOffForeignObj :: ForeignObj -> Int -> Int
-indexAddrOffForeignObj :: ForeignObj -> Int -> Addr
-indexFloatOffForeignObj :: ForeignObj -> Int -> Float
-indexDoubleOffForeignObj :: ForeignObj -> Int -> Double
-indexWord8OffForeignObj :: ForeignObj -> Int -> Word8
-indexWord16OffForeignObj :: ForeignObj -> Int -> Word16
-indexWord32OffForeignObj :: ForeignObj -> Int -> Word32
-indexWord64OffForeignObj :: ForeignObj -> Int -> Word64
-
-indexInt8OffForeignObj :: ForeignObj -> Int -> Int8
-indexInt16OffForeignObj :: ForeignObj -> Int -> Int16
-indexInt32OffForeignObj :: ForeignObj -> Int -> Int32
-indexInt64OffForeignObj :: ForeignObj -> Int -> Int64
-
--- read value out of mutable memory
-readCharOffForeignObj :: ForeignObj -> Int -> IO Char
-readIntOffForeignObj :: ForeignObj -> Int -> IO Int
-readAddrOffForeignObj :: ForeignObj -> Int -> IO Addr
-readFloatOffForeignObj :: ForeignObj -> Int -> IO Float
-readDoubleOffForeignObj :: ForeignObj -> Int -> IO Double
-readWord8OffForeignObj :: ForeignObj -> Int -> IO Word8
-readWord16OffForeignObj :: ForeignObj -> Int -> IO Word16
-readWord32OffForeignObj :: ForeignObj -> Int -> IO Word32
-readWord64OffForeignObj :: ForeignObj -> Int -> IO Word64
-readInt8OffForeignObj :: ForeignObj -> Int -> IO Int8
-readInt16OffForeignObj :: ForeignObj -> Int -> IO Int16
-readInt32OffForeignObj :: ForeignObj -> Int -> IO Int32
-readInt64OffForeignObj :: ForeignObj -> Int -> IO Int64
-
-writeCharOffForeignObj :: ForeignObj -> Int -> Char -> IO ()
-writeIntOffForeignObj :: ForeignObj -> Int -> Int -> IO ()
-writeAddrOffForeignObj :: ForeignObj -> Int -> Addr -> IO ()
-writeFloatOffForeignObj :: ForeignObj -> Int -> Float -> IO ()
-writeDoubleOffForeignObj :: ForeignObj -> Int -> Double -> IO ()
-writeWord8OffForeignObj :: ForeignObj -> Int -> Word8 -> IO ()
-writeWord16OffForeignObj :: ForeignObj -> Int -> Word16 -> IO ()
-writeWord32OffForeignObj :: ForeignObj -> Int -> Word32 -> IO ()
-writeWord64OffForeignObj :: ForeignObj -> Int -> Word64 -> IO ()
-writeInt8OffForeignObj :: ForeignObj -> Int -> Int8 -> IO ()
-writeInt16OffForeignObj :: ForeignObj -> Int -> Int16 -> IO ()
-writeInt32OffForeignObj :: ForeignObj -> Int -> Int32 -> IO ()
-writeInt64OffForeignObj :: ForeignObj -> Int -> Int64 -> IO ()
-</verb></tscreen>
-
-<sect> <idx/Concurrent/
-<label id="sec:Concurrent">
-<p>
-
-This library provides the Concurrent Haskell extensions
-<cite id="concurrentHaskell:popl96">.
-
-We are grateful to the Glasgow Haskell Project for allowing us to
-redistribute their implementation of this module.
-
-<tscreen><verb>
-module Concurrent where
-
-data ThreadId -- thread identifiers
-instance Eq ThreadId
-instance Ord ThreadId
-
-forkIO :: IO () -> IO ThreadId
-killThread :: ThreadId -> IO ()
-
-data MVar a -- Synchronisation variables
-newEmptyMVar :: IO (MVar a)
-newMVar :: a -> IO (MVar a)
-takeMVar :: MVar a -> IO a
-putMVar :: MVar a -> a -> IO ()
-swapMVar :: MVar a -> a -> IO a
-readMVar :: MVar a -> IO a
-instance Eq (MVar a)
-
-data Chan a -- channels
-newChan :: IO (Chan a)
-writeChan :: Chan a -> a -> IO ()
-readChan :: Chan a -> IO a
-dupChan :: Chan a -> IO (Chan a)
-unReadChan :: Chan a -> a -> IO ()
-getChanContents :: Chan a -> IO [a]
-writeList2Chan :: Chan a -> [a] -> IO ()
-
-data CVar a -- one element channels
-newCVar :: IO (CVar a)
-putCVar :: CVar a -> a -> IO ()
-getCVar :: CVar a -> IO a
-
-data QSem -- General/quantity semaphores
-newQSem :: Int -> IO QSem
-waitQSem :: QSem -> IO ()
-signalQSem :: QSem -> IO ()
-
-data QSemN -- General/quantity semaphores
-newQSemN :: Int -> IO QSemN
-waitQSemN :: QSemN -> Int -> IO ()
-signalQSemN :: QSemN -> Int -> IO ()
-
-type SampleVar a -- Sample variables
-newEmptySampleVar:: IO (SampleVar a)
-newSampleVar :: a -> IO (SampleVar a)
-emptySampleVar :: SampleVar a -> IO ()
-readSampleVar :: SampleVar a -> IO a
-writeSampleVar :: SampleVar a -> a -> IO ()
-</verb></tscreen>
-
-Notes:
-<itemize>
-
-<item>
- GHC uses preemptive multitasking:
- Context switches can occur at any time, except if you call a C
- function (like \verb"getchar") that blocks waiting for input.
-
- Hugs uses cooperative multitasking:
- Context switches only occur when you use one of the primitives
- defined in this module. This means that programs such as:
-
-<tscreen><verb>
-main = forkIO (write 'a') >> write 'b'
- where write c = putChar c >> write c
-</verb></tscreen>
-
- will print either <tt/aaaaaaaaaaaaaa.../ or <tt/bbbbbbbbbbbb.../,
- instead of some random interleaving of <tt/a/s and <tt/b/s.
-
- In practice, cooperative multitasking is sufficient for writing
- simple graphical user interfaces.
-
-<item>
-Hugs does not provide the functions <tt/mergeIO/ or <tt/nmergeIO/ since these
-require preemptive multitasking.
-
-<item>
-Thread identities and <tt/killThread/ has not been implemented yet on
-either system. The plan is that <tt/killThread/ will raise an IO
-exception in the killed thread which it can catch --- perhaps allowing -->
---it to kill its children before exiting.
-
-<item>
-The <tt/Ord/ instance for <tt/ThreadId/s provides an arbitrary total ordering
-which might be used to build an ordered binary tree, say.
-
-</itemize>
-
-<sect> <idx/Dynamic/
-<label id="sec:Dynamic">
-<p>
-
-The <tt/Dynamic/ library provides cheap-and-cheerful dynamic types for
-Haskell. A dynamically typed value is one which carries type
-information with it at run-time, and is represented by the
-abstract type <tt/Dynamic/. Values can be converted into <tt/Dynamic/
-ones, which can then be combined and manipulated by the program using
-the operations provided over the abstract, dynamic type. One of
-these operations allows you to convert a dynamically-typed value back
-into a value with the same (monomorphic) type it had before converting
-it into a dynamically-typed value.
-
-The <tt/Dynamic/ library is capable of dealing with monomorphic types
-only; no support for polymorphic dynamic values, but hopefully that
-can be added at a later stage.
-
-Examples where this library may come in handy (dynamic types, really -
-hopefully the library provided here will suffice) are: persistent
-programming, interpreters, distributed programming etc.
-
-The following operations are provided over the <tt/Dynamic/ type:
-
-<tscreen> <verb>
-data Dynamic -- abstract, instance of: Show --
-
-toDyn :: Typeable a => a -> Dynamic
-fromDyn :: Typeable a => Dynamic -> a -> a
-fromDynamic :: Typeable a => Dynamic -> Maybe a
-</verb></tscreen>
-
-<itemize>
-<item> <tt/toDyn/ converts a value into a dynamic one, provided
-<tt/toDyn/ knows the (concrete) type representation of the value.
-The <tt/Typeable/ type class is used to encode this, overloading a
-function that returns the type representation of a value. More on this
-below.
-<item> There's two ways of going from a dynamic value to one with
-a concrete type: <tt/fromDyn/, tries to convert the dynamic value into
-a value with the same type as its second argument. If this fails, the
-default second argument is just returned. <tt/fromDynamic/ returns a
-<tt/Maybe/ type instead, <tt/Nothing/ coming back if the conversion
-was not possible.
-<item>
-The <tt/Dynamic/ type has got a <tt/Show/ instance which returns
-a pretty printed string of the type of the dynamic value. (Useful when
-debugging).
-</itemize>
-
-<sect1> The <tt/Dynamic/ type
-<nidx/The Dynamic type/
-<label id="sec:Dynamic:TypeRep">
-<p>
-
-Haskell types are represented as terms using the <tt/TypeRep/
-abstract type:
-
-<tscreen> <verb>
-data TypeRep -- abstract, instance of: Eq, Show
-data TyCon -- abstract, instance of: Eq, Show
-
-mkTyCon :: String -> TyCon
-mkAppTy :: TyCon -> [TypeRep] -> TypeRep
-mkFunTy :: TypeRep -> TypeRep -> TypeRep
-applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
-</verb></tscreen>
-
-<itemize>
-<item> <tt/mkAppTy/ applies a type constructor to a sequence of types,
-returning a type.
-<item> <tt/mkFunTy/ is a special case of <tt/mkAppTy/, applying
-the function type constructor to a pair of types.
-<item> <tt/applyTy/ applies a type to a function type. If possible,
-the result type is returned.
-<item> Type constructors are represented by the abstract type,
-<tt/TyCon/.
-<item>
-Most importantly, <tt/TypeRep/s can be compared for equality.
-Type equality is used when converting a <tt/Dynamic/ value into a
-value of some specific type, comparing the type representation that
-the <tt/Dynamic/ value embeds with equality of the type representation
-of the type we're trying to convert the dynamically-typed value into.
-<item>
-To allow comparisons between <tt/TypeRep/s to be implemented
-efficiently, the <em/abstract/ <tt/TyCon/ type is used, with
-the constructor function <tt/mkTyCon/ provided:
-
-<tscreen> <verb>
-mkTyCon :: String -> TyCon
-</verb></tscreen>
-
-An implementation of the <tt/Dynamic/ interface guarantees the
-following,
-
-<tscreen> <verb>
- mkTyCon "a" == mkTyCon "a"
-</verb></tscreen>
-
-A really efficient implementation is possible if we guarantee/demand
-that the strings are unique, and for a particular type constructor,
-the application <tt/mkTyCon/ to the string that represents the type
-constructor is never duplicated. Provided you follow the
-the author of <tt/Typeable/
-
- [<bf/Q:/ <em>Would this constraint be
-unworkable in practice?</em>]
-<item>
-Both <tt/TyCon/ and <tt/TypeRep/ are instances of the <tt/Show/ type
-classes. To have tuple types be shown in infix form, the <tt/Show/
-instance guarantees that type constructors consisting of <tt/n/-commas,
-i.e., (<tt/mkTyCon ",,,,"/), is shown as an <tt/(n+1)/ tuple in infix
-form.
-</itemize>
-
-<sect1> <idx/Representing types/
-<label id="sec:Dynamic:Typeable">
-<p>
-
-To ease the construction of <tt/Dynamic/ values, we
-introduce the following type class to help working with <tt/TypeRep/s:
-
-<tscreen><verb>
-class Typeable a where
- typeOf :: a -> TypeRep
-</verb></tscreen>
-
-<itemize>
-<item> The <tt/typeOf/ function is overloaded to return the type
-representation associated with a type.
-<item> <bf/Important:/ The argument to <tt/typeOf/ is only used to
-carry type information around so that overloading can be resolved.
-<tt/Typeable/ instances should never, ever look at this argument.
-<item> The <tt/Dynamic/ library provide <tt/Typeable/ instances
-for all Prelude and Hugs/GHC extension library types. They are:
-
-<tscreen><verb>
-Prelude types:
- Int, Char, Bool, Float, Double, Integer, (IO a),
- [a], (Either a b), (Maybe a), (a->b),
- (), (,), (,,), (,,,), (,,,,),
- Ordering, Complex, Array, Handle
-Hugs/GHC types:
- Addr, Word8, Word16, Word32, Word64,
- Int8,Int16,Int32,Int64,
- ForeignObj, MVar, (ST s a), (StablePtr a)
-GHC types:
- Word, ByteArray, MutableByteArray
-</verb></tscreen>
-
-</itemize>
-
-<sect1> <idx/Utility functions/
-<label id="sec:Dynamic:util">
-<p>
-
-Operations for applying a dynamic function type to a
-dynamically typed argument are commonly useful, and
-also provided:
-
-<tscreen> <verb>
-dynApply :: Dynamic -> Dynamic -> Dynamic -- unsafe.
-dynApplyMb :: Dynamic -> Dynamic -> Maybe Dynamic
-</verb></tscreen>
-
-
-<sect> <idx/GetOpt/
-<label id="sec:GetOpt">
-<p>
-
-The <tt/GetOpt/ library contains Sven Panne's Haskell implementation
-of <tt/getopt/, providing features nigh-on identical to GNU <tt/getopt/:
-
-<tscreen><verb>
-module GetOpt where
-
--- representing a single option:
-data OptDescr a
- = Option [Char] -- list of short option characters
- [String] -- list of long option strings (without "--")
- (ArgDescr a) -- argument descriptor
- String -- explanation of option for user
-
--- argument option:
-data ArgDescr a
- = NoArg a -- no argument expected
- | ReqArg (String -> a) String -- option requires argument
- | OptArg (Maybe String -> a) String -- optional argument
-
-usageInfo :: String -- header
- -> [OptDescr a] -- options recognised
- -> String -- nicely formatted decription of options
-
-getOpt :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- options recognised
- -> [String] -- the command-line
- -> ( [a] -- options
- , [String] -- non-options
- ,[String] -- error messages
- )
-
-data ArgOrder a
- = RequireOrder
- | Permute
- | ReturnInOrder (String -> a)
-
-</verb></tscreen>
-
-<itemize>
-<item> The command-line options recognised is described by a list of
-<tt/OptDescr/ values. The <tt/OptDescr/ describes the long and short
-strings that recognise the option, together with a help string and
-info on whether the option takes extra arguments, if any.
-<item>
-From a list of option values, <tt/usageInfo/ returns a nicely
-formatted string that enumerates the different options supported
-together with a short message about what
-<item>
-To decode a command-line with respect to a list of options,
-<tt/getOpt/ is used. It processes the command-line, and returns
-the list of values that matched (and those that didn't). The first
-argument to <tt/getOpt/ controls whether the user is to give the
-options in any old order or not.
-</itemize>
-
-To hopefully illuminate the role of the different <tt/GetOpt/ data
-structures, here's the command-line options for a (very simple)
-compiler:
-
-<tscreen><verb>
-module Opts where
-
-import GetOpt
-import Maybe ( fromMaybe )
-
-data Flag
- = Verbose | Version
- | Input String | Output String | LibDir String
- deriving Show
-
-options :: [OptDescr Flag]
-options =
- [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
- , Option ['V','?'] ["version"] (NoArg Version) "show version number"
- , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
- , Option ['c'] [] (OptArg inp "FILE") "input FILE"
- , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
- ]
-
-inp,outp :: Maybe String -> Flag
-outp = Output . fromMaybe "stdout"
-inp = Input . fromMaybe "stdout"
-
-compilerOpts :: [String] -> IO ([Flag], [String])
-compilerOpts argv =
- case (getOpt Permute options argv) of
- (o,n,[] ) -> return (o,n)
- (_,_,errs) -> fail (userError (concat errs ++ usageInfo header options))
- where header = "Usage: ic [OPTION...] files..."
-</verb></tscreen>
-
-
-<sect> <idx/Pretty/
-<label id="sec:Pretty">
-<p>
-
-This library contains Simon Peyton Jones' implementation of John
-Hughes's pretty printer combinators.
-
-<tscreen><verb>
-module Pretty where
-infixl 6 <>
-infixl 6 <+>
-infixl 5 $$, $+$
-data Doc -- the Document datatype
-
--- The primitive Doc values
-empty :: Doc
-text :: String -> Doc
-char :: Char -> Doc
-int :: Int -> Doc
-integer :: Integer -> Doc
-float :: Float -> Doc
-double :: Double -> Doc
-rational :: Rational -> Doc
-semi, comma, colon, space, equals :: Doc
-lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
-parens, brackets, braces :: Doc -> Doc
-quotes, doubleQuotes :: Doc -> Doc
-
--- Combining Doc values
-(<>) :: Doc -> Doc -> Doc -- Beside
-hcat :: [Doc] -> Doc -- List version of <>
-(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space
-hsep :: [Doc] -> Doc -- List version of <+>
-($$) :: Doc -> Doc -> Doc -- Above; if there is no
- -- overlap it "dovetails" the two
-vcat :: [Doc] -> Doc -- List version of $$
-cat :: [Doc] -> Doc -- Either hcat or vcat
-sep :: [Doc] -> Doc -- Either hsep or vcat
-fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat
-fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep
-nest :: Int -> Doc -> Doc -- Nested
-hang :: Doc -> Int -> Doc -> Doc
-punctuate :: Doc -> [Doc] -> [Doc]
--- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
+&numexts
+&pretty
+&st
+&weak
+&word
--- Displaying Doc values
-instance Show Doc
-render :: Doc -> String -- Uses default style
-renderStyle :: Style -> Doc -> String
-data Style = Style { lineLength :: Int, -- In chars
- ribbonsPerLine :: Float, -- Ratio of ribbon length
- -- to line length
- mode :: Mode
- }
-data Mode = PageMode -- Normal
- | ZigZagMode -- With zig-zag cuts
- | LeftMode -- No indentation, infinitely long lines
- | OneLineMode -- All on one line
-</verb></tscreen>
+<!-- ========================= -->
<biblio files="refs" style="abbrv">
+++ /dev/null
-Release~2.01 is the first release of Glasgow Haskell for Haskell~1.3.
-It represents a major step forward in GHC development since GHC~0.26
-(July 1995). Note that we are also releasing GHC~0.29, the current
-state-of-play with the Haskell~1.2 compiler---at the same time as
-2.01.
-
-The announcement for this release is distributed as @ANNOUNCE-2.01@
-in the top-level directory. It contains very important caveats about
-2.01, which we do not repeat here!
-
-Information about ``what's ported to which machine'' is in the
-Installation Guide. Since 0.26, we've improved our support for iX86
-(Intel) boxes, notably those running Linux.
-
-%************************************************************************
-%* *
-<sect1>New configuration things in 2.01
-<label id="2-01-config">
-<p>
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-<sect1>User-visible changes in 2.01, including incompatibilities
-<label id="2-01-user-visible">
-<p>
-%* *
-%************************************************************************
-
-GHC~2.01 is a compiler for Haskell~1.3 and, as such, introduces many
-user-visible changes. The GHC user's guide has a section to help you
-upgrade your programs to Haskell~1.3; all user-visible changes
-are described there (and not repeated here).
-
-%************************************************************************
-%* *
-<sect1>New or changed GHC command-line options
-<label id="2-01-options">
-<p>
-%* *
-%************************************************************************
-
-A new flag, @-recomp@ invokes the new ``recompilation checker.''
-We recommend that you use it whenever you use `make' to build your
-Haskell programs. Please see the User's Guide for details.
-
-The flags @-fomit-derived-read@ and
-@-fomit-reexported-instances@ have died; there is no longer any
-need for them.
-
-%************************************************************************
-%* *
-<sect1>New in the compiler proper
-<label id="2-01-new-in-compiler">
-<p>
-%* *
-%************************************************************************
-
-Substantially rewritten. Notable points:
-<itemize>
-<item>
-The typechecker, besides doing all the new 1.3
-features (constructor classes, records, etc.), has been made
-ready to do linear types (e.g., there are now ``usage
-variables'' as well as ``type variables'').
-
-<item>
-The Core language now has one constructor for lambdas
-(@Lam@; rather than two, @CoLam@ and @CoTyLam@);
-also, one constructor for applications (@App@, rather
-than two, @CoApp@ and @CoTyApp@).
-
-Consequently, new more-general datatypes for binders and
-arguments now exist (@CoreBinder@ and @CoreArg@,
-respectively).
-
-Again, the Core language is now ``linear types''-ready
-(though the work hasn't been done yet).
-
-A new Core constructor, @Coerce@, exists to support the
-1.3 @newtype@ construct.
-
-<item>
-The ``renamer''---the part of the compiler that implements
-the Haskell module system---has been completely rewritten.
-
-In part, this is because the 1.3 module system is radically
-changed from 1.2, even if the user is unlikely to notice.
-
-We've implemented the new system with a ``go to the
-horse's mouth'' scheme; that is, to discover the facts about
-an entity @Foo.bar@, we <em>always</em> go to the interface
-for module @Foo@; hence, we can never get duff information
-about @bar@ from some intermediary.
-
-Interface files are no longer mandated by the language, so
-they are completely different in 2.01 compared to 0.2x. They
-will very likely change again. All processing of interface
-files is done in Haskell now (the most likely reason why GHC
-has slowed down :-().
-
-<item>
-Much less special pleading for the Prelude. If you wanted
-to write your own Prelude and drop it in, you would have
-a fighting chance now.
-
-<item>
-No more `make' dependency loops! (Hooray!) The whole compiler
-will build in one `make' run, no fuss or bother.
-</itemize>
-
-%************************************************************************
-%* *
-<sect1>In the ``required'' libraries (incl. Prelude)
-<label id="2-01-new-in-libraries">
-<p>
-%* *
-%************************************************************************
-
-We support standard 1.3 monadic I/O, to the best of our knowledge.
-
-The proposal for @LibPosix@ didn't make it into Haskell 1.3 I/O.
-So it's now a system library, @-syslib posix@. (And, of course,
-the @Lib@ prefix is gone.)
-
-%************************************************************************
-%* *
-<sect1>New in ``Glasgow extensions'' library things
-<label id="2-01-new-in-glaexts">
-<p>
-%* *
-%************************************************************************
-
-The @PreludeGlaMisc@ and @PreludePrimIO@ interfaces have died.
-Use @PreludeGlaST@ instead.
-
-We don't really know what our interfaces-to-nonstandard-things will
-eventually look like...
-
-MallocPtrs now called ForeignObjs
-
-The @_PackedString@ gunk (with leading underscores) is gone. Just
-@import PackedString@ and use ``normal'' names.
-
-All of the following are <em>gone</em>:
-<tscreen><verb>
-data _FILE -- corresponds to a "FILE *" in C
-
-fclose :: _FILE -> PrimIO Int
-fdopen :: Int -> String -> PrimIO _FILE
-fflush :: _FILE -> PrimIO Int
-fopen :: String -> String -> PrimIO _FILE
-fread :: Int -> Int -> _FILE -> PrimIO (Int, _ByteArray Int)
-freopen :: String -> String -> _FILE -> PrimIO _FILE
-fwrite :: _ByteArray Int -> Int -> Int -> _FILE -> PrimIO Int
-
-appendChanPrimIO :: String -> String -> PrimIO ()
-appendFilePrimIO :: String -> String -> PrimIO ()
-getArgsPrimIO :: PrimIO [String]
-readChanPrimIO :: String -> PrimIO String
-</verb></tscreen>
-
-%************************************************************************
-%* *
-<sect1>In the ``system'' libraries
-<label id="2-01-new-in-syslibs">
-<p>
-%* *
-%************************************************************************
-
-The ``system'' libraries are no longer part of GHC (they lived in
-@ghc/lib/@); they have been lifted out into a subsystem in their
-own right (they live in @hslibs@).
-
-Of course, a GHC distribution will ``happen'' to have these libraries
-included; however, we hope the libraries will evolve into a large,
-flourishing, independently-maintained, and independently-distributed
-body of code---preferably compiler-independent, too!
-
-Renamings in the GHC system library (@hslibs/ghc/@): The function
-@BitSet.singletonBS@ is now called @unitBS@. Similarly,
-@FiniteMap.singletonFM@ is now @unitFM@. @Set.singletonSet@
-lingers briefly; @unitSet@ is also available now.
-
-We are <em>not</em> up-to-date with the HBC-for-1.3's HBC library (the source
-hasn't been released yet).
-
-The @Either@, @Maybe@, and @Option@ modules in the HBC
-library (@hslibs/hbc/@) have been deleted---they are too close to
-what Haskell~1.3 provides anyway (hence, confusing).
-
-The POSIX support code is in @hslibs/posix@.
-
-We have added a ``contrib'' system library (@hslibs/contrib/@);
-made up of code that was contributed to the ``Haskell library'',
-mostly by Stephen Bevan. Quite of bit of code for numerical methods
-in there...
-
-%************************************************************************
-%* *
-<sect1>In the runtime system
-<label id="2-01-new-in-rts">
-<p>
-%* *
-%************************************************************************
-
-We have made a point <em>not</em> to beat on the runtime system very much.
-Some bugs have been fixed since 0.26, of course.
-
-The GranSim (parallel-machine simulator) stuff is substantially improved
-(but you're better off using the 0.29 version of it).
-
-%************************************************************************
-%* *
-%<sect1>Other new stuff
-<label id="2-01-new-elsewhere">
-<p>
-%* *
-%************************************************************************
+++ /dev/null
-<sect1>Release notes for version~2.02---3/97
-<label id="release-2-02">
-<p>
-
-Release~2.02 is the first release of Glasgow Haskell for Haskell~1.4.
-
-The announcement for this release is distributed as @ANNOUNCE-2.02@
-in the top-level directory. It contains very important caveats about
-2.02, which we do not repeat here!
-
-Information about ``what's ported to which machine'' is in the
-Installation Guide. Since 2.01, we've added support for Win32
-(Windows NT and Windows 95).
-
-%************************************************************************
-%* *
-<sect1>New configuration things in 2.02
-<label id="2-02-config">
-<p>
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-<sect1>User-visible changes in 2.02, including incompatibilities
-<label id="2-02-user-visible">
-<p>
-%* *
-%************************************************************************
-
-GHC~2.02 is a compiler for Haskell~1.4 and, as such, introduces a
-bunch of user-visible changes. The GHC user's guide has a section to
-help you upgrade your programs to Haskell~1.4 from 1.2; all
-user-visible changes are described there (and not repeated here).
-
-%************************************************************************
-%* *
-<sect1>New or changed GHC command-line options
-<label id="2-02-options">
-<p>
-%* *
-%************************************************************************
-
-<itemize>
-<item> GHC now warns of possibly-incomplete patterns in case expressions
-and function bindings. You can suppress these warnings with @-fno-warn-incomplete-patterns@.
-
-GHC also warns of completely overlapped patterns. You can't switch this off.
-
-<item> GHC can warn of shadowed names, though it does not do so by default.
-Just occasionally this shows up
-an otherwise hard-to-find bug. To warn of shadowed names use @-fwarn-name-shadowing@
-
-<item> You can now generate `make' dependencies via the compiler
-driver, use the option @-M@ together with the list source files to compute
-the dependencies for. By default, the dependencies will be appended to
-the file @Makefile@ in the current directory.
-
-<item> For hackers, the flag @-dshow-rn-trace@ shows what the renamer is up to.
-Sit back and marvel.
-
-</itemize>
-
-
-%************************************************************************
-%* *
-<sect1>New in the compiler proper
-<label id="2-02-new-in-compiler">
-<p>
-%* *
-%************************************************************************
-
-<itemize>
-<item>
-Completely new ``make-world'' system, properly documented (at last) in the
-installation guide. No Jmakefiles; but you *need* Gnu make
-(gmake). The more recent the better (v 3.70+).
-
-<item>
-The ``renamer''---the part of the compiler that implements
-the Haskell module system---has been completely rewritten, again.
-
-The format of interface files has changed significantly. Interface files
-generated by 2.01 will not work with 2.02.
-
-<item>
-Even less special pleading for the Prelude than in 2.01. If you wanted
-to write your own Prelude and drop it in, you would have
-a really good chance now.
-</itemize>
-
-
-%************************************************************************
-%* *
-<sect1>In the libraries
-<label id="2-02-new-in-libraries">
-<p>
-%* *
-%************************************************************************
-
-The libraries have been completely reorganised. There's a description
-in Section <ref name="System Libraries" id="syslibs">.
-
-
-%************************************************************************
-%* *
-<sect1>In ``hslibs'' libraries
-<label id="2-02-new-in-syslibs">
-<p>
-%* *
-%************************************************************************
-
-
-%************************************************************************
-%* *
-<sect1>In the runtime system
-<label id="2-02-new-in-rts">
-<p>
-%* *
-%************************************************************************
-
-<itemize>
-<item> @ForeignObjs@ are properly deallocated when execution halts, as well
-as when the garbage collector spots the @ForeignObj@ as being unreferenced.
-This is important if you are using a @ForeignObj@ to refer to
-a @COM@ object or other remote resource. You want that resource to be relased
-when the program terminates.
-
-<item> Files handles in the IO prelude are implemented using
-@ForeignObjs@, and closed when the file handle is unreferenced. This
-means that if you open zillions of files then just letting go of the
-file handle is enough to close it.
-</itemize>
-
-%************************************************************************
-%* *
-<sect1>Other new stuff
-<label id="2-02-new-elsewhere">
-<p>
-%* *
-%************************************************************************
-
-2.02 is released together with Green Card, a foreign-language
-interface generator for Haskell. More details elsewhere...
-
-
-%************************************************************************
-%* *
-<sect1>Known troublespots
-<label id="2-02-troublespots">
-<p>
-%* *
-%************************************************************************
-
-The 2.02 compiler has the following known deficiencies:
-
-<descrip>
-<tag>native code generator, x86:</tag>
-
-The native code generator for x86 platforms is by default switched
-off, as the code the compiler produces with it enabled was discovered
-just before releaseing to be wonky. Rather than delay the release
-further, GHC on x86 platforms rely on @GCC@ as their
-backend for now. Hopefully fixed soon.
-
-<tag>Simplifier looping:</tag>
-
-The simplifier(Glasgow-speak for optimiser) has been observed to get
-into a loop in one or two cases. If you should observe this, please
-report it as a bug - the work around is to turn off optimisation.
-
-<tag>Undefined @*_vap_info@ symbols:</tag>
-
-If the linker complains about some undefined @*_vap_info@ symbols when
-linking 2.02 compiled programs (very unlikely) - fix this by compiling
-the module where the references are coming from with
-@-fno-lambda-lifting@.
-
-</descrip>
+++ /dev/null
-<sect1>Release notes for version~2.03---4/97
-<label id="release-2-03">
-<p>
-
-GHC 2.03 is a minor upgrade of GHC 2.02. It differs in the following
-ways:
-
-<itemize>
-<item>
- A slew of small bugs are fixed. You can find the complete list
- at:
-
-<tscreen><verb>
-http://www.cse.ogi.edu/~simonpj/ghc-bugs.html
-</verb></tscreen>
-
- One bug remains un-fixes, namely the crash when there's an empty
- comment at the end of file. It's wierd!
-
-<item>
- Last-minute language changes have been implemented (minor changes
- to the libraries, and to module export/hiding scope rules)
-
-<item>
- It is only available as a source distribution. If you want to
- use it you'll have to build it from source. Nowadays this is
- a well-documented process (see the build and installation guide, but
- note that this release is still not self-booting, you still need
- to have The Good Old Compiler (0.29) at your disposal).
-</itemize>
-
-None of the bugs in GHC 2.02 are show-stoppers, so you'll only want
-to upgrade if you are a build-from-source junkie and the bugs are
-irritating you.
-
-Apart from bug-fixes, which are itemized elsewhere,
-the exact language and standard-library changes are as follows:
-<itemize>
-<item>
-A hiding clause hides the unqualified name, but not the qualified name.
-<item>
-There's a new @Numeric@ library, containing mostly mildly marginal
-code for showing and reading numbers. Parts of its exports used to be
-exported by @Prelude@, but now you'll have to import them explicitly.
-It also defines some functions that weren't provided before; have a
-look in the Haskell library report for details of complete interface.
-<item>
-The following extra functions are exported from @IO@:
-@try@, @bracket@, @bracket_@, @hGetLine@, @hWaitForInput@.
-</itemize>
-
-In addition, we've made following changes to GHC libraries/GHC's
-implementation of the Haskell standard prelude:
-
-<itemize>
-<item> The function @fromRational__@, exported from @PrelNum@, is now called @fromRat@.
-(And it's exported by @Numeric@.)
-<item>
-Documentation for the Glasgow specific interfaces plus the system
-libraries have been re-instated. Posix library documentation included also.
-<item>
-@maybe@ is now exported from Prelude, as it should have been in 2.02.
-<item>
-Equality on @IO.Handle@ is now defined as specified by the library
-report.
-<item>
-@Ix.rangeSize@ returns @0@ on an empty range;previously it failed.
-<item>
-The new interface @GlaExts@ which is meant to be the gateway to the
-various Glasgow extensions has now been documented.
-<item>
-@GlaExts@ now exports the representation of @Char@.
-<item>
-The mutable variable interface, @MutVar@, has also been documented,
-together with @ByteArray@, @MutableArray@ and @Foreign@.
-<item>
-Added documentation on how to compile mutually recursive modules with
-2.03.
-</itemize>
+++ /dev/null
-<sect1>Release notes for version~2.04---6/97
-<label id="release-2-04">
-<p>
-
-GHC 2.04 is a minor upgrade of GHC 2.02 (and the bugfix release,
-2.03), representing work done through May '97. This new release
-adds the following:
-
-<itemize>
-<item>
-Data constructors can now have polymorphic fields, and ordinary
-functions can have polymorphic arguments. Details on
-
-<tscreen><verb>
- http://www.cse.ogi.edu/~simonpj/quantification.html
-</verb></tscreen>
-
-Existential types coming, but not done yet.
-
-<item> Pattern guards implemented, see
-
-<tscreen><verb>
-http://www.cse.ogi.edu/~simonpj/guards.html
-</verb></tscreen>
-
-<item> Compiler can now compile itself.
-
-<item> @INLINE@ pragmas honoured (caveat: not yet
-working on instance-decl methods)
-
-<item> Simplifier improvements and better inlining gives
-better code; not sure how *much* better.
-
-<item> @-dshow-rn-stats@ print out amusing statistics about what
-the renamer does.
-
-<item>
-When compiling without -O, the renamer (the pass responsible for
-slurping in interface file and making sure everything is in scope
-etc.) is now more careful about what it will bring in (especially
-data constructors and instance declarations). The upshot of this
-change is that a lot of the (unnecessary) work this pass did in
-2.02/2.03 is now avoided.
-
-@-fno-prune-tydecls@ and @-fno-prune-instdecls@ switch off these
-renamer optimisations. You can try the effect with the renamer
-statistics. War stories welcome.
-
-<item>
- The Heroic Efforts of @Andr\'e Santos <alms@@di.ufpe.br>@ have
- been included, AIX/RS6000 is now a supported @ghc@
- platform! Bug reports concerning this port to (as always)
- @glasgow-haskell-bugs@@dcs.gla.ac.uk@.
-
-<item>
- A lot of the bugs that were present in versions 2.02/2.03
- have been fixed (thanks to everyone that reported bugs!).
- A list of the reported problems with 2.02/2.03 can be found at
-
-<tscreen><verb>
- http://www.dcs.gla.ac.uk/fp/software/ghc/ghc-bugs.html
-</verb></tscreen>
-
- No doubt entries for 2.04 will be added here as well :-)
-
-<item>
- This release is available in source format only. To build it you'll
- need to have either a copy of GHC~0.29 or GHC~2.02/3 installed.
- For people either doing porting work or work on a (supported)
- platform for which there is no GHC binary bundles available, the
- necessary intermediate files are also available (.hc and .hi files).
-
- Consult the installation guide for more information on how
- to build or bootstrap. The guide is included in the distribution
- (in the fptools/docs directory), and an on-line version of the
- document can be found at
-
-<tscreen><verb>
- http://www.dcs.gla.ac.uk/fp/software/ghc/ghc-doc/install-guide.html
-</verb></tscreen>
-</itemize>
-
-In addition to the above, we've made the following minor changes to
-the GHC libraries/our implementation of the Haskell standard prelude:
-
-<itemize>
-<item>
-@isPrefixOf@ and @isSuffixOf@ has been added to @List@.
-<item>
-The empty type @Void@ is now exported from the prelude.
-<item>
-@GlaExts@ exports the @Lift@ data type:
-
-<tscreen><verb>
-data Lift a = Lift a
-</verb></tscreen>
-
-you might need it someday...
-
-<item>
-The @Foreign@ interface now also exports the representations
-for @Word@ and @Addr@.
-
-<item> The low-level file handle interface in the @POSIX@ system
-library has been reworked a bit, most notably is the renaming of
-@Channel@ to @Fd@ and the introduction of operations for converting
-to and from @Handle@ and @Fd@ values. The changes are:
-
-<tscreen><verb>
---Renamed functions (old name in square brackets)
-openFd :: FilePath
- -> OpenMode
- -> Maybe FileMode
- -> OpenFileFlags
- -> IO Fd
- -- [openChannel]
-fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
- --[seekChannel]
-fdRead :: Fd -> ByteCount -> IO (String, ByteCount)
- --[readChannel]
-fdWrite :: Fd -> String -> IO ByteCount
- --[writeChannel]
-fdClose :: Fd -> IO ()
- --[closeChannel]
-setFdOption :: Fd -> FdOption -> Bool -> IO ()
- --[setChannelOption]
-queryFdOption :: Fd -> FdOption -> IO Bool
- --[queryChannelOption]
-dup :: Fd -> IO Fd
- --[dupChannel]
-dupTo :: Fd -> Fd -> IO ()
- --[dupChannelTo]
-
-data FdOption = AppendOnWrite | CloseOnExec | NonBlockingRead
- --[ChannelOption]
-getFdStatus :: Fd -> IO FileStatus
- --[getChannelStatus]
-
--- New data structure collecting together misc flags passed to openFd
-data OpenFileFlags =
- OpenFileFlags {
- append :: Bool,
- exclusive :: Bool,
- noctty :: Bool,
- nonBlock :: Bool,
- trunc :: Bool
- }
-
---New ops for converting between Fd and Handle:
-fdToHandle :: Fd -> IO Handle
-handleToFd :: Handle -> IO Fd
-intToFd :: Int -> Fd -- use with care.
-</verb></tscreen>
-
-</itemize>
+++ /dev/null
-<sect1>Release notes for version~2.06---9/97
-<label id="release-2-06">
-<p>
-
-GHC 2.06 is a minor upgrade of GHC 2.05, and is released as source only. It represents work done through August '97.
-
-Here's a list of the changes made since GHC 2.05:
-
-<itemize>
-
-<item> Fix to reader to allow let expressions in pattern guards.
-
-<item> Tidied up @nofib/parallel@
-
-<item> Changed derived @Show@ (and @Read@) code for constructors
-with labelled fields to bring them into line with the Report.
-
-<item> Fixed @ghc-0.29 -O@ booting problem (codeGen/ClosureInfo not closed.)
-
-<item> Improved error messages for illegal derivings of @Ix@, @Enum@
-and @Bounded@.
-
-<item> Fixed bug in deriving @Ix@ code. (need to actively slurp in
-return and zero)
-
-<item> New module: @PackBase@ - minimum pack/unpack code.
-
-<item> Moved @PackedString@ to ghc system library
-
-<item> Added export of @unionBy@ and @intersectBy@ to @List@ (plus
-commented out unused functions).
-
-<item> Uniform size to @ForeignObj@ closures (indep of GC scheme).
-
-<item> Added @ForeignObj@ support to NCG
-
-<item> Added @index*OffForeignObj#@ primops (for completeness, mostly)
-
-<item> Removed: @Util.mapAccumL@ and @Util.mapAccumR@ (now via List)
-
-<item> Removed: @forall@ and @exists@ from @Util@ (now @any@ and @all@ from @Prelude@).
-
-<item> fixed: handling of source input from stdin in the driver.
-
-<item> x86 NCG should now compile under 2.0x
-
-<item> PECULIAR: compiling -prof "fixes" simplifier performance on deep
- list comprehensions.
-
-<item> Added -O for ghc/lib/cbits
-
-<item> Updated @lndir@ (sync wrt. X11R6.3)
-
-<item> Removed @glafp-utils/msub@
-
-<item> Fixed misleading error message for guards (used to
-mention list comprehensions)
-
-<item> Fixed incorrect handling of default methods (used to
-complain about differing contexts)
-
-<item> Fixed missing @tidyPrimOp@ in @simplCore/SimplCore@
- (Sven Panne bug report.)
-
-<item> Fixed desugaring of record construction for overloaded
-constructors. (Dave Barton bug report.)
-
-<item> Fixed rank-2 polymorphism bug (Ralf Hinze bug report.)
-
-<item> Fixed interface-file parser error on @GHC.->@
-
-<item> Added @-no-recomp@ flag
-
-<item> Changed grouping syntax for simplifier opts, instead of
- '(' and ')', use `&lsqb' and `&rsqb'. The change is made to make
- it more Win32 (and cygwin32) friendly.
-
-<item> Removed the use of @COMPILING_GHC@ in @ghc/compiler/@
-
-<item> Use @COMPILING_NCG@ instead of @COMPILING_GHC@ in @ghc/includes/@
- header files to control visibility of info needed when
- compiling the native code generator.
-
-<item> Tidied up handling of IO error messages in @IOBase@
-
-<item> Fixed @PackBase.unpackCString@ and @PackedString.unpackCString@
-to handle @NULL@ pointer arg gracefully.
-
-<item> fix: archives in @INSTALL_LIBS@ are now ranlib'ed when installing.
-
-<item> fix: for @-monly-x-regs@, the mangler now generates necessary code
- for loading up unstolen registers before GC, and save their updated
- contents (via BaseReg) on GC return before `handing back'
- the registers. This change fixed the @SIGSEGV@ problem reported by
- David Barton on an x86 platform (linux) with 2.05.
-
-<item> changed @SMstats.elapsedtime@ to return non-negative floats. (=>
- no more @-Rghc-timing@ warnings about not finding @InitTime@ etc.)
-
-<item> Change @mkWrapper@ in @WwLib.lhs@ to call
- @splitForAllTyExpandingDicts@ instead of @splitForALlTy@ to fix
- @absApply@ crash. (Jon Mountjoy bug report.)
-
-<item> GHC's interface file parser now uses the latest version of
-Happy.
-
-<item> Happy is now included in the source distribution.
-</itemize>
+++ /dev/null
-<sect1>Release notes for version~2.08---10/97
-<label id="release-2-08">
-<p>
-
-GHC 2.08 is a minor upgrade of GHC 2.07, and is released as source only. It represents work done through September '97.
-
-Here's a list of the changes made since GHC 2.07:
-
-<itemize>
-
-<item> removed deforester from source tree, including the @{-# DEFOREST #-}@
- pragma. This stuff didn't work anymore, so there was no point
- leaving it hanging around. If someone wants to pick it up again,
- the source can be checked out of the repository.
-
-<item> documentation is now built automatically for binary distributions
-
-<item> fixed several bugs affecting binary distributions.
-
-<item> fixed bug in Regex.lhs causing random segmentation faults.
-
-<item> a couple of changes to the simplifier means that binary sizes should
- be (very slightly) smaller.
-
-<item> fixed a problem with error messages not being as accurate as they used to
- be.
-
-<item> fixed a problem with ticky-ticky profiling (symptom: compiling modules
- with -ticky gave lots of parse errors from the C compiler).
-
-<item> added support for @unmapMiddleStackPage@ on cygwin32.
-
-<item> fixed a divide-by-zero problem in the GC statistics code.
-
-</itemize>
-
-The following changes were made to Happy:
-
-<itemize>
-<item> bug fixed in state generation.
-
-<item> happy now reports the number of unused rules and terminals in the
- grammar, and lists which ones are unused in the info file.
-
-<item> happy now tries to avoid generating fully overlapped patterns.
-
-<item> bug fixed in lexer: line numbers weren't being counted for @--@
- commented lines.
-</itemize>
-
+++ /dev/null
-<sect1>Release notes for version~2.09---11/97
-<label id="release-2-09">
-<p>
-
-Changes made since 2.08:
-
-<itemize>
-<item> fixed type-synonym-arity bug in the typechecker.
-
-<item> fixed overloaded-constructor-argument bug in the typechecker.
-
-<item> fix off-by-one error in @PackedString:filterPS@.
-
-<item> fixed @getCurrentDirectory@.
-
-<item> fixed space-leak bug to do with polymorphic recursion and overloading.
-
-<item> fixed lit-deatify that was core dumping on Linux.
-
-<item> some fixes to the native code generator for i386.
-
-<item> unboxed the state in ST and IO, and specialised IO (it is no longer built
- on top of ST).
-
-<item> reversed the sense of @-fwarn-{overlapped,incomplete}-patterns@.
- The driver now has to have the flag to provide the warning.
-
-<item> added @-fwarn-missing-methods@.
-
-<item> added the @-Wnot@, @-W@, and @-Wall@ options. Set up a default
- set of warnings, namely @-fwarn-{overlapped,incomplete}-patterns@.
-
-<item> Added @-fwarn-duplicate-exports@ warning to check for duplicates in
- export lists. Included in default warning set.
-
-<item> Renamed @SampleVar.{write,read}Sample@ to
- @SampleVar.{write,read}SampleVar@.
-
-<item> new @mkdependHS@ options: @-W@ disables warnings of duplicate interface
- files found along the import path. @--include-prelude@ *will* generate
- dependencies on Prelude + any prelude/syslib .hi files used.
-
-<item> removed the @PrimIO@ type. For a limited time only, @PrimIO@
- will be available from @GlaExts@ as a synonym for @IO@.
-
-<item> changed the type of @_ccall_@s to return @(IO a)@.
-
-<item> renamed @mainPrimIO@ to @mainIO@, as it now has type @IO ()@.
-
-<item> fixed the semantics of the @-i@ flag to @mkdependHS@ to be the
- same as GHC.
-
-<item> fix panic when a type constructor is used as a class.
-
-<item> don't arbitrarily truncate cost centre names in profiling information.
-</itemize>
-
-In 2.09, we've made extensive changes to the libraries that provide
-access to various GHC extensions. Many of these extensions are now
-provided by Hugs, and as a result we are now using a common set of
-extension libraries.
-
-Briefly, the changes are as follows (for the definition of the new
-libraries, see the section on GHC/Hugs libraries in the User Guide).
-
-<itemize>
-<item> @Addr@ moved out of @Foreign@ and into its own module.
-
-<item> @MutVar@ module disappeared, @IOExts@ now exports @IORefs@ and
- associated operations.
-
-<item> The @CCallable@ and @CReturnable@ classes now have their own
- module, @CCall@. You only need to import this module to provide a
- new instance of one of these classes.
-
-<item> A new module @IOExts@ provides extensions to the @IO@ monad,
- including @unsafePerformIO@, @unsafeInterleaveIO@, @IORef@s (mutable
- variables), and @IOArray@s (mutable arrays).
-
-<item> Importing @ST@ is now the official way to get access to the @ST@
- monad. This module also supports @STRef@s (mutable variables) and
- @STArray@s (mutable arrays).
-
-<item> A new module @LazyST@ provides an identical interface to @ST@
- except that the underlying implementation of the monad is lazy. Be
- careful about mixing these two in the same program.
-
-<item> The new module @Bits@ provides a class of bit operations. The
- modules @Int@ and @Word@ provide signed and unsiged integer types
- (respectively) of varying sizes, all of which support bit
- operations.
-
-<item> Added @Bits@, @Int@, @Word@ (and a few new primops over words).
-
-<item> The @GlaExts@ module will provide Glasgow-only extensions. For
- now, we've kept the old interface for compatibility, but beware that
- this is deprecated and the relevant extension libraries should be
- imported explicitly.
-
-<item> Several changes to the libraries in @lib/ghc@ - see the User
- Guide for details.
-</itemize>
+++ /dev/null
-<sect1>Release notes for version~2.10---12/97
-<label id="release-2-10">
-<p>
-
-Changes made since 2.09:
-
-<itemize>
-
-<item> export some missing operations from @ST@/@LazyST@.
-
-<item> remove wired-in @runST@ from the compiler, move @runST@ from
-@STBase@ to @UnsafeST@ and give it a type signature. Fix a bug in the
-compiler to do with universal quantification so this actually works.
-
-<item> fix cut-n-paste-o in @PosixUtils.lhs@.
-
-<item> better code for checking for overlapping(incomplete?) patterns.
-
-<item> @-fwarn-simple-patterns@ for pattern-bindings that could fail.
-
-<item> win32 green-card stubs imported.
-
-<item> fix 'make carries on after errors' problem <em>again</em>.
-
-<item> driver fixed to be perl4 compatible again.
-
-<item> obscure happy bug fixed.
-
-<item> @Word@ removed from hbc library to avoid conflicts.
-
-<item> lots of fixes to the binary distribution system - you can now do
-@gmake binary-dist Project=Happy@ from the top-level and get a Happy
-binary distribution. GHC binary distributions no longer contain
-Happy.
-
-<item> add some suffix rules for SGML, we can use SGML-Tools for
-documentation now.
-
-<item> added an new manual for Happy, in SGML format.
-
-<item> added the GHC/Hugs extension library documentation as a separate
-document, and removed that information from the Users' Guide.
-
-<item> Fixed a bug where ':::' wasn't being parsed properly in interface files.
-
-<item> Fixed a long-standing bug in the strictness analyser.
-
-<item> Fixed the cause of the @getWorkerIdAndCons@ panic.
-
-<item> Moved the array tests from ghc/lib into the test framework.
-ghc/lib/tests now doesn't exist.
-
-</itemize>
+++ /dev/null
-Changes made since 2.10:
-
-\begin{itemize}
-
-\item Multi-parameter type classes are fully implemented. There is more
- sharing of dictionaries than in 2.10, so there's a chance that
- efficiency will increase a little too.
-
-\item Error messages from the type checker should be noticeably improved
-
-\item Warnings for unused bindings @-fwarn-unused-names@.
-
-\item The "boing" example works, and many other minor bug fixes.
-
-\item Can only be built with 2.10 or later; committed to Haskell 1.4
- module system and libraries. Much cruft removed as a result.
-
-\item Dramatic clean-up of the @PprStyle@ stuff. No explicit "sty"
-parameters now; it's all handled under the hood in @Outputable.lhs@.
-
-\item The type @Type@ has been substantially changed. Usage types have
- gone away entirely. Type is parameterised wrt the "flexi" slot
- in type variables, rather than wrt the type variable itself.
- That means that many instance decls become much simpler, because
- they are polymorphic in the "flexi" slot rather than needing
- (say) @Outputable@ on the type variable.
-
-\item The dictionary for each class is represented by a new
- data type for that purpose, rather than by a tuple. That in
- turn means that @Type@ can be a straightforward instance of @Eq@ and
- @Ord@ No need for @eqSimpleTy@, @eqTy@.
-
-\item The resulting compiler is just slightly (2%) shorter than the
- old one in terms of source code size.
-
-\item Fix bug in posix signal handling.
-
-\item @Int@ and @Word@ rewritten to use unboxed types and operations.
-
-\item Removed @ghc/Error.{lhs,hi-boot}@
-
-\item Moved contents of @Error@ to @GHCerr@ + adjusted
- import lists of files that use old Error functionality.
-
-\item Moved @seqError@ from @Prelude@ to @GHCerr@.
-
-\item Fix a misleading type checker error msg.
-
-\item Fix a bug in @floatBind@ in @Simplify.lhs@
-
-\item Better failure message when entering an unimplemented instance method
-
-\item The Installation Guide is now in SGML format. SGML-Tools 1.0.3
-or later are required (check @http://www.xs4all.nl/~cg/sgmltools/@).
-The index generation isn't automatic yet, but will hopefully be fixed
-for the next release.
-
-\end{itemize}
+++ /dev/null
-<sect1>Release notes for version~3-00---1/97
-<label id="release-3-00">
-<p>
-
-Changes made since 2.10:
-
-<itemize>
-
-<item> Multi-parameter type classes are fully implemented. There is more
- sharing of dictionaries than in 2.10, so there's a chance that
- efficiency will increase a little too.
-
-<item> Error messages from the type checker should be noticeably improved
-
-<item> Warnings for unused bindings @-fwarn-unused-names@.
-
-<item> The "boing" example works, and many other minor bug fixes.
-
-<item> Can only be built with 2.10 or later; committed to Haskell 1.4
- module system and libraries. Much cruft removed as a result.
-
-<item> Dramatic clean-up of the @PprStyle@ stuff. No explicit "sty"
-parameters now; it's all handled under the hood in @Outputable.lhs@.
-
-<item> The type @Type@ has been substantially changed. Usage types have
- gone away entirely. Type is parameterised wrt the "flexi" slot
- in type variables, rather than wrt the type variable itself.
- That means that many instance decls become much simpler, because
- they are polymorphic in the "flexi" slot rather than needing
- (say) @Outputable@ on the type variable.
-
-<item> The dictionary for each class is represented by a new
- data type for that purpose, rather than by a tuple. That in
- turn means that @Type@ can be a straightforward instance of @Eq@ and
- @Ord@ No need for @eqSimpleTy@, @eqTy@.
-
-<item> The resulting compiler is just slightly (2%) shorter than the
- old one in terms of source code size.
-
-<item> Fix bug in posix signal handling.
-
-<item> @Int@ and @Word@ rewritten to use unboxed types and operations.
-
-<item> Removed @ghc/Error.{lhs,hi-boot}@
-
-<item> Moved contents of @Error@ to @GHCerr@ + adjusted
- import lists of files that use old Error functionality.
-
-<item> Moved @seqError@ from @Prelude@ to @GHCerr@.
-
-<item> Fix a misleading type checker error msg.
-
-<item> Fix a bug in @floatBind@ in @Simplify.lhs@
-
-<item> Better failure message when entering an unimplemented instance method
-
-</itemize>
+++ /dev/null
-<sect1>Release notes for version~3-01---2/98
-<label id="release-3-01">
-<p>
-
-Changes made since 3.00:
-
-<itemize>
-
-<item> Fix interaction of "hiding" on import with "module M" on export.
-
-<item> Fix some floating point conversion problems in @floatExtreme.lc@.
-
-<item> New Hugs/GHC interface <tt/NumExts/ added and documented.
-
-<item> moved @showOct@ and @showHex@ from @Numeric@ to @NumExts@.
-
-<item> imported HBC's quick-sort algorithm from @QSort@ into @List@.
-
-<item> added support for assertions. Conceptually, a new function has
- been added to the Prelude with the following type:
-
- <tscreen> <verb>
- assert :: Bool -> a -> a
- </verb> </tscreen>
-
- which has the following behaviour:
-
- <tscreen> <verb>
- assert pred v
- | pred = v
- | otherwise = error "assertion failed"
- </verb> </tscreen>
-
- However in this form, the practical use of assertions is
- limited as no indication is given as to what assertion failed.
- So to help out here, ghc will rewrite any uses of <tt/assert/
- to instead invoke the function <tt/assert__/ :
-
- <tscreen> <verb>
- assert__ :: String -> Bool -> a -> a
- </verb> </tscreen>
-
- where the first argument to <tt/assert__/ is a compiler generated string
- which encodes the source location of the original <tt/assert/.
-
- Assertions are a Glasgow extension, so -fglasgow-exts is
- needed to use them.
-
-<item>
- Split @-fwarn-unused-names@ into
-
- <descrip>
- <tag>@-fwarn-unused-imports@</tag>
- Warn about unused explicit imports. (in -W)
- <tag>@-fwarn-unused-binds@</tag>
- Warn about unused bindings (in -W)
- <tag>@-fwarn-unused-matches@</tag>
- Warn about unused names in pattern matches
- (not as useful, relegated to -Wall)
- </descrip>
-
-<item> The driver is now always installed as @ghc-<version>@ with a
-link to it from @ghc@.
-
-<item> Library re-organisation: all libraries now live under ghc/lib,
-which has the following structure:
-
-<tscreen> <verb>
- ghc/lib/std -- all prelude files (libHS.a)
- ghc/lib/std/cbits
-
- ghc/lib/exts -- standard Hugs/GHC extensions (libHSexts.a)
- -- available with '-fglasgow-exts'
-
- ghc/lib/posix -- POSIX library (libHSposix.a)
- ghc/lib/posix/cbits -- available with '-syslib posix'
-
- ghc/lib/misc -- used to be hslibs/ghc (libHSmisc.a)
- ghc/lib/misc/cbits -- available with '-syslib misc'
-
- ghc/lib/concurrent -- Concurrent libraries (libHSconc.a)
- -- available with '-concurrent'
-</verb> </tscreen>
-
-Also, several non-standard prelude modules had their names changed to begin
-with 'Prel' to reduce namespace pollution.
-
-<tscreen> <verb>
- Addr ==> PrelAddr (Addr interface available in 'exts')
- ArrBase ==> PrelArr
- CCall ==> PrelCCall (CCall interface available in 'exts')
- ConcBase ==> PrelConc
- GHCerr ==> PrelErr
- Foreign ==> PrelForeign (Foreign interface available in 'exts')
- GHC ==> PrelGHC
- IOHandle ==> PrelHandle
- IOBase ==> PrelIOBase
- GHCmain ==> PrelMain
- STBase ==> PrelST
- Unsafe ==> PrelUnsafe
- UnsafeST ==> PrelUnsafeST
-</verb> </tscreen>
-
-<item> Unboxed types are now not allowed in the field of a newtype
-constructor.
-
-<item> Report the context properly for type errors in newtype
-declarations.
-
-<item> User's Guide replaced with SGML version.
-
-<item> The literate tools have been removed from the standard
-distributions, since they're not needed to format the documentation
-any more.
-
-<item> Lots of bug-fixes to the multi-parameter type classes support.
-
-<item> @alpha-dec-osf1@ and @alpha-dec-osf3@ are now separate
-configurations. It turns out that an @alpha-dec-osf3@ build doesn't
-work on older versions of the OS.
-
-</itemize>
+++ /dev/null
-<sect1>Release notes for version~3-02---5/97
-<label id="release-3-02">
-<p>
-
-Changes made since 3.01:
-
-<itemize>
-
-<item> After a prolonged rest in the bit bucket, the Specialiser is
-now back on-line again! It has been completely rewritten and the
-implementation is a great deal simpler than the version that came with
-@ghc-0.29@.
-(ToDo: insert summary of capabilities.)
-
-<item> The addition of a data type or an instance to a module A should
-now mostly avoid the recompilation of modules that import A.
-
-<item> More internal code cleanup and simplifications
-
-<item> @showList@ and @Show@ instances for tuples now uses @","@ as
-element separators rather than @", "@. Changed to make the strings
-generated by
-
-<item> Misc. bugfixes to
-
-
-<item> When computing the Makefile dependencies, using either
-<tt/ghc -M/ (preferred) or by invoking the <tt/mkdependHS/ script
-directly, <tt/CPP/ will now by default not be run over the input
-files. To have CPP wash your input files, use the command-line option
-<tt/-cpp/.
-
-<item> Added a working specialiser.
-
-<item> Added <tt/unsafeCoerce#/.
-
-<item> Fixed compilation of real floating-point literals: they were
-previously generated as applications of <tt/fromRational/, even when
-not overloaded.
-
-<item> The object splitter had a bug in it that increased binary sizes
-significantly on i386-unknown-linux and sparc-sun-solaris2. Now
-fixed.
-
-<item> Bump some of the constants that affect unfolding agression:
-performance is now better than 2.10, and binary sizes are smaller.
-
-<item> Add NOINLINE pragma, and use it for unsafePerformIO and
-friends. Remove PrelUnsafe and PrelUnsafeST, move the contents into
-PrelIOBase and PrelST respectively. Add NOINLINE pragma to
-LazyST.runST.
-
-</itemize>
+++ /dev/null
-<sect1>Release notes for version~3-03---10/98
-<label id="release-3-03">
-<p>
-
-Changes made since 3.02:
-
-<itemize>
-
-<item> Fix bug in FloatIn to do with <tt/idSpecVars/.
-
-<item> Remove restrictions on superclasses in class declarations.
-
-<item> Add Sven Panne's Haskell GetOpt library (in <tt/-syslib misc/).
-
-<item> Added <tt/MD5/ message digest interface to <tt/-syslib misc/.
-
-<item> Turned off the unfolding of <tt/_casm_/s across modules. Should
-you need the old behaviour back (v. unlikely), use <tt/-funfold-casms-in-hi-file/.
-
-<item> Add Dynamic library.
-
-<item> Add foreign export/import constructs.
-
-<item> Rewritten I/O system.
-
-<item> Add socket option support to the socket library.
-
-<item> Add Int64 and Word64 data types (available from the Int and
- Word libraries respectively).
-
-</itemize>
--- /dev/null
+<sect1>Release notes for version~4.00---10/98
+<label id="release-4-00">
+<p>
+
+<sect2>Language matters
+<p>
+
+<itemize>
+
+<item> Universal and existential quantification: see Section <ref
+name="Explicit universal quantification"
+id="universal-quantification"> and Section <ref name="Existentially
+quantified data constructors" id="existential-quantification">
+respectively.
+
+Universal quantification was in in GHC 2.10 and later, but the
+syntax has changed: it's now @forall a. ...@ instead of @All a => ...@.
+
+<item> Multi-paramter type classes. We have relaxed some of the rules
+ since GHC 3.00. In particular
+
+<descrip>
+ <tag>@-fallow-overlapping-instances@</tag>
+ allows overlapping instances
+ <tag>@-fallow-undecidable-instances@</tag>
+ allows you to write instance contexts that constrain non-type-variables
+</descrip>
+
+Full details in Section <ref name="Multi-parameter type classes"
+id="multi-param-type-classes">.
+</itemize>
+
+<sect2>New Libraries
+<p>
+
+Documentation in <url name="GHC/Hugs Extension Libraries"
+url="libs.html">.
+
+<descrip>
+
+<tag>@Dynamic@</tag>
+
+Dynamic types.
+
+<tag>@Exceptions@</tag>
+
+The library @Exception@ in @-syslib exts@ provide an interface for
+exception handling. Calls to @error@, pattern matching failures and a
+bunch of other exception can be caught.
+
+</descrip>
+
+<sect2>Compiler internals
+<p>
+
+The intermediate language used by GHC has had a radical overhaul.
+The new Core language (coreSyn/CoreSyn.lhs) is much smaller and
+more uniform. The main transformation engine (the "simplifier")
+has been totally rewritten. The compiler is several thousand lines
+shorter as a result. It's also very much easier to understand
+and modify. (It's true. Honest!)
+
+
+<sect2>Run time system
+<p>
+
+There is a completely new runtime system, aimed at integration with
+Hugs. Tons of cruft removed. Some changes to code generation; things
+typically run a bit faster as a result.
+
+An overview of the new RTS is available: <url name="The New GHC/Hugs
+Runtime System" url="http://www.dcs.gla.ac.uk/~simonm/rts.ps">.
+
+<sect2>Storage Manager/Garbage Collector
+<p>
+
+The new storage manager features a dynamically resizing heap, so you
+won't need those pesky @-H@ options anymore. In fact, the @-H@ option
+is now ignored for compatibility with older versions.
+
+Stacks are now also expandable, and the @-K@ option now specifies a
+<em/maximum/ heap size. The default is (a perhaps conservative) @1M@.
+
+The garbage collector now collects CAFs, so there's no more space
+leaks associated with these. If you think you have a CAF-related
+space leak, we'd like to hear about it.
+
+The storage manager current only has a two-space garbage collector,
+which will be slower than 3.02's generational collector when the
+amount of live data is large. A new generational collector is high on
+our priority list.
+
+For the other new tweakables, see Section <ref name="RTS options to
+control the garbage-collector" id="rts-options-gc">.
+
+<sect2>Profiling
+<p>
+
+There is a new profiler based on <em/Cost Centre Stacks/. This is an
+extension of the previous cost centre scheme, whereby the profilier
+stores information about the call-graph of the program and attributes
+costs to nodes of this graph.
+
+For a quick demo, try compiling a program with @-prof -auto-all@, then
+run it with @+RTS -p@ and see what comes out (in the @<prog>.prof@
+file).
+
+The feature is still experimental, and the call graph may not be
+exactly what you were expecting. Also, we only have time/allocation
+profiling at the moment; heap profiling will follow shortly.
+
+<sect2>Miscellaneous
+<p>
+
+<itemize>
+
+<item> Concurrent Haskell is now the default. No need to
+compile/download special libraries. The context switch interval isn't
+tweakable any more; threads just yield after allocating a fixed amount
+of heap (currently 4k). If you want a quicker context switch, that
+won't be possible: this decision was made for efficiency reasons (it
+reduces the penalty for runnning threaded code to almost zero). We
+might allow the context switch interval to be increased in the future;
+but also context switches are pretty fast (faster than before).
+
+<item> @forkIO@ now returns a @ThreadId@, and there's a new operation
+@killThread@ which will terminate an existing thread. See Section
+<ref name="The Concurrent interface" id="concurrent-interface"> for
+more details.
+
+<item> You need @-syslib concurrent@ to get the @Concurrent@ library.
+
+<item> The rewritten IO library from 3.03 has been ported to 4.00.
+
+<item> New constructs: @foriegn import@ and @foreign export@ for
+H/Direct.
+
+<item> Supported architectures: all the development has been done on
+x86(mainly FreeBSD/Linux) so this is the most stable environment.
+Sparc (Solaris) and x86/Win32 (cygwin32) have also been mildly tested, and
+an Alpha port is in the works. Everything else will need a little
+porting effort; we don't have machines here, so any help would be
+greatly appreciated.
+
+<item> Code is faster and smaller, but programs might run slower due
+to the garbage collector (see "Storage Manager" above). Increasing
+the minimum allocation area with the @-A@ RTS option can claw back
+some of this speed.
+
+<item> We now use GMP 2.02, and attempt to use an already-installed
+copy if available. If you have GMP on your system but the configure
+script doesn't detect it, we'd like to know.
+
+<item> @seq@ works better than in 3.xx - you can now @seq@ functions
+without crashing the program.
+
+<item> The @Eval@ class has been removed (i.e. every type is assumed
+to be in class @Eval@). This change has been made in anticipation of
+Haskell 98.
+
+<item> The native code generator has had very little testing (it's not used
+on x86 yet), so Sparcs may have some trouble with it. Try -fvia-C if
+strange errors occur.
+
+<item> The compiler is slightly faster, but sometimes needs more heap.
+If you have an example where this is the case, please let us know.
+
+</itemize>
--- /dev/null
+<sect1>Release notes for version~4.01---11/98
+<label id="release-4-01">
+<p>
+
+<itemize>
+
+<item> <tt/relocate_TSO/ bug fixed.
+
+<item> Weak pointers implemented, and new <tt/Weak/ library provided
+(see <htmlurl name="GHC/Hugs Extension Libraries" url="libs.html">).
+The <tt/ForeignObj/ interface no longer supports finalisation - use
+the <tt/Weak/ interface for that.
+
+<item> Foreign funcion interface is now complete and working.
+
+<item> New interface file format for compatibility with Hugs. No
+user-visible changes except that you'll have to update any .hi-boot
+files you have lying around - check out some GHC-generated .hi files
+for examples.
+
+<item> Space leak in the compiler is partially fixed -
+<tt/-dcore-lint/ is still recommended for decent space behaviour.
+
+<item> New API to the RTS (not interesting unless you're an RTS client
+writer).
+
+<item> <tt/thawIOArray/ added to <tt/IOExts/.
+
+<item> Many many small bugs fixed.
+
+</itemize>
install :: html dvi info
endif
-# These files are just concatenated to produce the complete document, in the
-# same order as they are given below.
-
-SGML_SRCS = \
- user.sgml \
- intro.sgml \
- 3-02-notes.sgml \
- using.sgml \
- runtime_control.sgml \
- profiling.sgml \
- debugging.sgml \
- sooner.sgml \
- lang.sgml \
- glasgow_exts.sgml \
- parallel.sgml \
- vs_haskell.sgml \
- libraries.sgml \
- posix.sgml \
- libmisc.sgml \
- gone_wrong.sgml \
- utils.sgml \
- end.sgml
-
SGML_DOC = users_guide
include $(TOP)/mk/target.mk
<nidx>GHC phases, changing</nidx>
<nidx>phases, changing GHC</nidx>
-You may specify that a different program
-be used for one of the phases of the compilation system, in place of
-whatever the driver @ghc@ has wired into it. For example, you
-might want to try a different assembler. The
-@-pgm<phase-code><program-name>@<nidx>-pgm<phase><stuff> option</nidx> option to
-@ghc@ will cause it to use @<program-name>@ for phase
-@<phase-code>@, where the codes to indicate the phases are:
+You may specify that a different program be used for one of the phases
+of the compilation system, in place of whatever the driver @ghc@ has
+wired into it. For example, you might want to try a different
+assembler. The
+@-pgm<phase-code><program-name>@<nidx>-pgm<phase><stuff>
+option</nidx> option to @ghc@ will cause it to use @<program-name>@
+for phase @<phase-code>@, where the codes to indicate the phases are:
<tabular ca="ll">
<bf>code</bf> | <bf>phase</bf> @@
c | C compiler@@
a | assembler @@
l | linker @@
+dep | Makefile dependency generator @@
</tabular>
%----------------------------------------------------------------------
applicable to one particular phase. You may also <em>force</em> a
specific option @<option>@ to be passed to a particular phase
@<phase-code>@ by feeding the driver the option
-@-opt<phase-code><option>@.<nidx>-opt<phase><stuff> option</nidx> The
-codes to indicate the phases are the same as in the previous section.
+@-opt<phase-code><option>@.<nidx>-opt<phase><stuff>
+option</nidx> The codes to indicate the phases are the same as in the
+previous section.
So, for example, to force an @-Ewurble@ option to the assembler, you
would tell the driver @-opta-Ewurble@ (the dash before the E is
<tag>@-hi@:</tag>
<nidx>-hi option</nidx>
-<em>Do</em> generate an interface file (on @stdout@.) This would
-normally be used in conjunction with @-noC@, which turns off interface
-generation; thus: @-noC -hi@.
-
-<tag>@-hi-with-<section>@:</tag>
-<nidx>-hi-with option</nidx>
-Generate just the specified section of an interface file. In case you're
-only interested in a subset of what @-hi@ outputs, @-hi-with-<section>@
-is just the ticket. For instance
-
-<tscreen> <verb>
--noC -hi-with-declarations -hi-with-exports
-</verb> </tscreen>
-
-will output the sections containing the exports and the
-declarations. Legal sections are: @declarations@, @exports@,
-@instances@, @instance_modules@, @usages@, @fixities@, and
-@interface@.
+<em>Do</em> generate an interface file. This would normally be used in
+conjunction with @-noC@, which turns off interface generation;
+thus: @-noC -hi@.
<tag>@-dshow-passes@:</tag>
<nidx>-dshow-passes option</nidx>
% ghc -noC -O -ddump-simpl -dverbose-simpl -dcore-lint Foo.hs
</verb></tscreen>
+<tag>@-ddump-simpl-iterations@:</tag>
+<nidx>-ddump-simpl-iterations option</nidx>
+Show the output of each <em/iteration/ of the simplifier (each run of
+the simplifier has a maximum number of iterations, normally 4). Used
+when even @-dverbose-simpl@ doesn't cut it.
+
<tag>@-dppr-{user,debug,all@}:</tag>
<nidx>-dppr-user option</nidx>
<nidx>-dppr-debug option</nidx>
%
-% $Id: glasgow_exts.vsgml,v 1.2 1998/07/20 16:16:34 sof Exp $
+% $Id: glasgow_exts.vsgml,v 1.3 1998/12/02 13:20:38 simonm Exp $
%
% GHC Language Extensions.
%
GHC's type system supports explicit unversal quantification in
constructor fields and function arguments. This is useful for things
-like defining @runST@ from the state-thread world amongst other
-things. See Section <ref name="Local universal quantification"
-id="universal-quantification">.
+like defining @runST@ from the state-thread world. See Section <ref
+name="Local universal quantification" id="universal-quantification">.
+
+<tag>Extistentially quantification in data types:</tag>
+
+Some or all of the type variables in a datatype declaration may be
+<em>existentially quantified</em>. More details in Section <ref
+name="Existential Quantification" id="existential-quantification">.
<tag>Calling out to C:</tag>
might expect; e.g., @(+#)@ is addition on @Int#@s, and is the
machine-addition that we all know and love---usually one instruction.
-A numerically-intensive program using unboxed types can go a <em>lot</em>
-faster than its ``standard'' counterpart---we saw a threefold speedup
-on one example.
+There are some restrictions on the use of unboxed types, the main one
+being that you can't pass an unboxed value to a polymorphic function
+or store one in a polymorphic data type. This rules out things like
+@[Int#]@ (ie. lists of unboxed integers). The reason for this
+restriction is that polymorphic arguments and constructor fields are
+assumed to be pointers: if an unboxed integer is stored in one of
+these, the garbage collector would attempt to follow it, leading to
+unpredictable space leaks. Or a @seq@ operation on the polymorphic
+component may attempt to dereference the pointer, with disastrous
+results. Even worse, the unboxed value might be larger than a pointer
+(@Double#@ for instance).
+
+Nevertheless, A numerically-intensive program using unboxed types can
+go a <em>lot</em> faster than its ``standard'' counterpart---we saw a
+threefold speedup on one example.
Please see Section <ref name="The module PrelGHC: really primitive
stuff" id="ghc-libs-ghc"> for the details of unboxed types and the
<em>in-place</em>.
<tag>``Static'' (in C land):</tag>
-A C~routine may pass an @Addr#@ pointer back into Haskell land. There
+A C routine may pass an @Addr#@ pointer back into Haskell land. There
are then primitive operations with which you may merrily grab values
over in C land, by indexing off the ``static'' pointer.
<tag>``Stable'' pointers:</tag>
If, for some reason, you wish to hand a Haskell pointer (i.e.,
-<em>not</em> an unboxed value) to a C~routine, you first make the
+<em>not</em> an unboxed value) to a C routine, you first make the
pointer ``stable,'' so that the garbage collector won't forget that it
exists. That is, GHC provides a safe way to pass Haskell pointers to
C.
<tag>``Foreign objects'':</tag>
A ``foreign object'' is a safe way to pass an external object (a
-C~allocated pointer, say) to Haskell and have Haskell do the Right
+C-allocated pointer, say) to Haskell and have Haskell do the Right
Thing when it no longer references the object. So, for example, C
could pass a large bitmap over to Haskell and say ``please free this
memory when you're done with it.''
</descrip>
-The libraries section give more details on all these ``primitive
+The libraries section gives more details on all these ``primitive
array'' types and the operations on them, Section <ref name="The GHC
Prelude and Libraries" id="ghc-prelude">. Some of these extensions
are also supported by Hugs, and the supporting libraries are described
document.
%************************************************************************
-%* *
-<sect1>Using your own @mainIO@
-<label id="own-mainIO">
-<p>
-<nidx>mainIO, rolling your own</nidx>
-<nidx>GHCmain, module containing mainIO</nidx>
-%* *
-%************************************************************************
-
-Normally, the GHC runtime system begins things by called an internal
-function
-
-<tscreen><verb>
- mainIO :: IO ()
-</verb></tscreen>
-
- which, in turn, fires up your @Main.main@. The standard
-definition of @mainIO@ looks like this:
-
-<tscreen><verb>
- mainIO = catch Main.main
- (\err -> error ("I/O error: " ++ show err ++ "\n"))
-</verb></tscreen>
-
-That is, all it does is run @Main.main@, catching any I/O errors that
-occur and displaying them on standard error before exiting the
-program.
-
-To subvert the above process, you need only provide a @mainIO@ of your
-own (in a module named @PrelMain@).
-
-Here's a little example, stolen from Alastair Reid:
-
-<tscreen><verb>
-module GHCmain ( mainIO ) where
-
-import GlaExts
-
-mainIO :: IO ()
-mainIO = do
- _ccall_ sleep 5
- _ccall_ printf "%d\n" (14::Int)
-</verb></tscreen>
-
-%************************************************************************
%* *
<sect1>Calling~C directly from Haskell
<label id="glasgow-ccalls">
corraled in a few modules, rather than sprinkled all over your code.
It will then be quite easy to update later on.
-WARNING AS OF 2.03: Yes, the @_ccall_@ stuff probably <em>will
-change</em>, to something better, of course! One step in that
-direction is Green Card, a foreign function interface pre-processor
-for Haskell (``Glasgow'' Haskell in particular) --- check out
-
-<tscreen><verb>
-ftp://ftp.dcs.gla.ac.uk/pub/haskell/glasgow/green-card.ANNOUNCE
-ftp://ftp.dcs.gla.ac.uk/pub/haskell/glasgow/green-card-src.tar.gz
-</verb></tscreen>
-
%************************************************************************
%* *
<sect2>@_ccall_@ and @_casm_@: an introduction
You can find appropriate definitions for @StgInt@, @StgForeignObj@,
etc using @gcc@ on your architecture by consulting
-@ghc/includes/StgTypes.lh@. The following table summarises the
+@ghc/includes/StgTypes.h@. The following table summarises the
relationship between Haskell types and C types.
<tabular ca="ll">
<nidx>enterInt</nidx>
<nidx>enterFloat</nidx>
-% ToDo ADR: test these functions!
-
Note Bene: @_ccall_GC_@<nidx>_ccall_GC_</nidx> must be used if any of
these functions are used.
%************************************************************************
%* *
-<sect2>Pointing outside the Haskell heap
+<sect2>Foreign objects: pointing outside the Haskell heap
<label id="glasgow-foreignObjs">
<p>
<nidx>foreign objects (Glasgow extension)</nidx>
within Haskell.
<tscreen><verb>
-void StgPerformGarbageCollection()
+void GarbageCollect()
performGC :: IO ()
</verb></tscreen>
id="glasgow-foreign-headers"> says more about this...)
This scheme is the <em>only</em> way that you will get <em>any</em>
-typechecking of your @_ccall_@s. (It shouldn't be that way,
-but...)
+typechecking of your @_ccall_@s. (It shouldn't be that way, but...).
+GHC will pass the flag @-Wimplicit@ to gcc so that you'll get warnings
+if any @_ccall_@ed functions have no prototypes.
<item>
Try to avoid @_ccall_@s to C~functions that take @float@
@ForeignObjs@ | Yes | Yes | see later @@
</tabular>
+Actually, the @Word@ type is defined as being the same size as a
+pointer on the target architecture, which is <em>probably</em>
+@unsigned long int@.
+
The brave and careful programmer can add their own instances of these
classes for the following types:
your life.
<item> If you call out to C code which may trigger the Haskell garbage
-collector (examples of this later...), then you must use the
-@_ccall_GC_@<nidx>_ccall_GC_ primitive</nidx> or
+collector or create new threads (examples of this later...), then you
+must use the @_ccall_GC_@<nidx>_ccall_GC_ primitive</nidx> or
@_casm_GC_@<nidx>_casm_GC_ primitive</nidx> variant of C-calls. (This
does not work with the native code generator - use @\fvia-C@.) This
stuff is hairy with a capital H! </itemize>
<label id="multi-param-type-classes">
<p>
-(ToDo)
+This section documents GHC's implementation of multi-paramter type
+classes. There's lots of background in the paper <url name="Type
+classes: exploring the design space"
+url="http://www.dcs.gla.ac.uk/~simonpj/multi.ps.gz"> (Simon Peyton
+Jones, Mark Jones, Erik Meijer).
+
+I'd like to thank people who reported shorcomings in the GHC 3.02
+implementation. Our default decisions were all conservative ones, and
+the experience of these heroic pioneers has given useful concrete
+examples to support several generalisations. (These appear below as
+design choices not implemented in 3.02.)
+
+I've discussed these notes with Mark Jones, and I believe that Hugs
+will migrate towards the same design choices as I outline here.
+Thanks to him, and to many others who have offered very useful
+feedback.
+
+<sect2>Types
+<p>
+
+There are the following restrictions on the form of a qualified
+type:
+
+<tscreen><verb>
+ forall tv1..tvn (c1, ...,cn) => type
+</verb></tscreen>
+
+(Here, I write the "foralls" explicitly, although the Haskell source
+language omits them; in Haskell 1.4, all the free type variables of an
+explicit source-language type signature are universally quantified,
+except for the class type variables in a class declaration. However,
+in GHC, you can give the foralls if you want. See Section <ref
+name="Explicit universal quantification"
+id="universal-quantification">).
+
+<enum>
+
+<item> <bf>Each universally quantified type variable
+@tvi@ must be mentioned (i.e. appear free) in @type@</bf>.
+
+The reason for this is that a value with a type that does not obey
+this restriction could not be used without introducing
+ambiguity. Here, for example, is an illegal type:
+
+<tscreen><verb>
+ forall a. Eq a => Int
+</verb></tscreen>
+
+When a value with this type was used, the constraint <tt>Eq tv</tt>
+would be introduced where <tt>tv</tt> is a fresh type variable, and
+(in the dictionary-translation implementation) the value would be
+applied to a dictionary for <tt>Eq tv</tt>. The difficulty is that we
+can never know which instance of <tt>Eq</tt> to use because we never
+get any more information about <tt>tv</tt>.
+
+<item> <bf>Every constraint @ci@ must mention at least one of the
+universally quantified type variables @tvi@</bf>.
+
+For example, this type is OK because <tt>C a b</tt> mentions the
+universally quantified type variable <tt>b</tt>:
+
+<tscreen><verb>
+ forall a. C a b => burble
+</verb></tscreen>
+
+The next type is illegal because the constraint <tt>Eq b</tt> does not
+mention <tt>a</tt>:
+
+<tscreen><verb>
+ forall a. Eq b => burble
+</verb></tscreen>
+
+The reason for this restriction is milder than the other one. The
+excluded types are never useful or necessary (because the offending
+context doesn't need to be witnessed at this point; it can be floated
+out). Furthermore, floating them out increases sharing. Lastly,
+excluding them is a conservative choice; it leaves a patch of
+territory free in case we need it later.
+
+</enum>
+
+These restrictions apply to all types, whether declared in a type signature
+or inferred.
+
+Unlike Haskell 1.4, constraints in types do <bf>not</bf> have to be of
+the form <em>(class type-variables)</em>. Thus, these type signatures
+are perfectly OK
+
+<tscreen><verb>
+ f :: Eq (m a) => [m a] -> [m a]
+ g :: Eq [a] => ...
+</verb></tscreen>
+
+This choice recovers principal types, a property that Haskell 1.4 does not have.
+
+<sect2>Class declarations
+<p>
+
+<enum>
+
+<item> <bf>Multi-parameter type classes are permitted</bf>. For example:
+
+<tscreen><verb>
+ class Collection c a where
+ union :: c a -> c a -> c a
+ ...etc..
+</verb></tscreen>
+
+
+<item> <bf>The class hierarchy must be acyclic</bf>. However, the definition
+of "acyclic" involves only the superclass relationships. For example,
+this is OK:
+
+<tscreen><verb>
+ class C a where {
+ op :: D b => a -> b -> b
+ }
+
+ class C a => D a where { ... }
+</verb></tscreen>
+
+Here, <tt>C</tt> is a superclass of <tt>D</tt>, but it's OK for a
+class operation <tt>op</tt> of <tt>C</tt> to mention <tt>D</tt>. (It
+would not be OK for <tt>D</tt> to be a superclass of <tt>C</tt>.)
+
+<item> <bf>There are no restrictions on the context in a class declaration
+(which introduces superclasses), except that the class hierarchy must
+be acyclic</bf>. So these class declarations are OK:
+
+<tscreen><verb>
+ class Functor (m k) => FiniteMap m k where
+ ...
+
+ class (Monad m, Monad (t m)) => Transform t m where
+ lift :: m a -> (t m) a
+</verb></tscreen>
+
+<item> <bf>In the signature of a class operation, every constraint
+must mention at least one type variable that is not a class type
+variable</bf>.
+
+Thus:
+
+<tscreen><verb>
+ class Collection c a where
+ mapC :: Collection c b => (a->b) -> c a -> c b
+</verb></tscreen>
+
+is OK because the constraint <tt>(Collection a b)</tt> mentions
+<tt>b</tt>, even though it also mentions the class variable
+<tt>a</tt>. On the other hand:
+
+<tscreen><verb>
+ class C a where
+ op :: Eq a => (a,b) -> (a,b)
+</verb></tscreen>
+
+is not OK because the constraint <tt>(Eq a)</tt> mentions on the class
+type variable <tt>a</tt>, but not <tt>b</tt>. However, any such
+example is easily fixed by moving the offending context up to the
+superclass context:
+
+<tscreen><verb>
+ class Eq a => C a where
+ op ::(a,b) -> (a,b)
+</verb></tscreen>
+
+A yet more relaxed rule would allow the context of a class-op signature
+to mention only class type variables. However, that conflicts with
+Rule 1(b) for types above.
+
+<item> <bf>The type of each class operation must mention <em/all/ of
+the class type variables</bf>. For example:
+
+<tscreen><verb>
+ class Coll s a where
+ empty :: s
+ insert :: s -> a -> s
+</verb></tscreen>
+
+is not OK, because the type of <tt>empty</tt> doesn't mention
+<tt>a</tt>. This rule is a consequence of Rule 1(a), above, for
+types, and has the same motivation.
+
+Sometimes, offending class declarations exhibit misunderstandings. For
+example, <tt>Coll</tt> might be rewritten
+
+<tscreen><verb>
+ class Coll s a where
+ empty :: s a
+ insert :: s a -> a -> s a
+</verb></tscreen>
+
+which makes the connection between the type of a collection of
+<tt>a</tt>'s (namely <tt>(s a)</tt>) and the element type <tt>a</tt>.
+Occasionally this really doesn't work, in which case you can split the
+class like this:
+
+<tscreen><verb>
+ class CollE s where
+ empty :: s
+
+ class CollE s => Coll s a where
+ insert :: s -> a -> s
+</verb></tscreen>
+
+</enum>
+
+<sect2>Instance declarations
+<p>
+
+<enum>
+
+<item> <bf>Instance declarations may not overlap</bf>. The two instance
+declarations
+
+<tscreen><verb>
+ instance context1 => C type1 where ...
+ instance context2 => C type2 where ...
+</verb></tscreen>
+
+"overlap" if @type1@ and @type2@ unify
+
+However, if you give the command line option
+@-fallow-overlapping-instances@<nidx>-fallow-overlapping-instances
+option</nidx> then two overlapping instance declarations are permitted
+iff
+
+<itemize>
+<item> EITHER @type1@ and @type2@ do not unify
+<item> OR @type2@ is a substitution instance of @type1@
+ (but not identical to @type1@)
+<item> OR vice versa
+</itemize>
+
+Notice that these rules
+
+<itemize>
+<item> make it clear which instance decl to use
+ (pick the most specific one that matches)
+
+<item> do not mention the contexts @context1@, @context2@
+ Reason: you can pick which instance decl
+ "matches" based on the type.
+</itemize>
+
+Regrettably, GHC doesn't guarantee to detect overlapping instance
+declarations if they appear in different modules. GHC can "see" the
+instance declarations in the transitive closure of all the modules
+imported by the one being compiled, so it can "see" all instance decls
+when it is compiling <tt>Main</tt>. However, it currently chooses not
+to look at ones that can't possibly be of use in the module currently
+being compiled, in the interests of efficiency. (Perhaps we should
+change that decision, at least for <tt>Main</tt>.)
+
+<item> <bf>There are no restrictions on the type in an instance
+<em/head/, except that at least one must not be a type variable</bf>.
+The instance "head" is the bit after the "=>" in an instance decl. For
+example, these are OK:
+
+<tscreen><verb>
+ instance C Int a where ...
+
+ instance D (Int, Int) where ...
+
+ instance E [[a]] where ...
+</verb></tscreen>
+
+Note that instance heads <bf>may</bf> contain repeated type variables.
+For example, this is OK:
+
+<tscreen><verb>
+ instance Stateful (ST s) (MutVar s) where ...
+</verb></tscreen>
+
+The "at least one not a type variable" restriction is to ensure that
+context reduction terminates: each reduction step removes one type
+constructor. For example, the following would make the type checker
+loop if it wasn't excluded:
+
+<tscreen><verb>
+ instance C a => C a where ...
+</verb></tscreen>
+
+There are two situations in which the rule is a bit of a pain. First,
+if one allows overlapping instance declarations then it's quite
+convenient to have a "default instance" declaration that applies if
+something more specific does not:
+
+<tscreen><verb>
+ instance C a where
+ op = ... -- Default
+</verb></tscreen>
+
+Second, sometimes you might want to use the following to get the
+effect of a "class synonym":
+
+<tscreen><verb>
+ class (C1 a, C2 a, C3 a) => C a where { }
+
+ instance (C1 a, C2 a, C3 a) => C a where { }
+</verb></tscreen>
+
+This allows you to write shorter signatures:
+
+<tscreen><verb>
+ f :: C a => ...
+</verb></tscreen>
+
+instead of
+
+<tscreen><verb>
+ f :: (C1 a, C2 a, C3 a) => ...
+</verb></tscreen>
+
+I'm on the lookout for a simple rule that preserves decidability while
+allowing these idioms. The experimental flag
+@-fallow-undecidable-instances@<nidx>-fallow-undecidable-instances
+option</nidx> lifts this restriction, allowing all the types in an
+instance head to be type variables.
+
+<item> <bf>Unlike Haskell 1.4, instance heads may use type
+synonyms</bf>. As always, using a type synonym is just shorthand for
+writing the RHS of the type synonym definition. For example:
+
+<tscreen><verb>
+ type Point = (Int,Int)
+ instance C Point where ...
+ instance C [Point] where ...
+</verb></tscreen>
+
+is legal. However, if you added
+
+<tscreen><verb>
+ instance C (Int,Int) where ...
+</verb></tscreen>
+
+as well, then the compiler will complain about the overlapping
+(actually, identical) instance declarations. As always, type synonyms
+must be fully applied. You cannot, for example, write:
+
+<tscreen><verb>
+ type P a = [[a]]
+ instance Monad P where ...
+</verb></tscreen>
+
+This design decision is independent of all the others, and easily
+reversed, but it makes sense to me.
+
+<item><bf>The types in an instance-declaration <em/context/ must all
+be type variables</bf>. Thus
+
+<tscreen><verb>
+ instance C a b => Eq (a,b) where ...
+</verb></tscreen>
+
+is OK, but
-<sect1> Local universal quantification
+<tscreen><verb>
+ instance C Int b => Foo b where ...
+</verb></tscreen>
+
+is not OK. Again, the intent here is to make sure that context
+reduction terminates.
+
+Voluminous correspondence on the Haskell mailing list has convinced me
+that it's worth experimenting with a more liberal rule. If you use
+the flag <tt>-fallow-undecidable-instances</tt> you can use arbitrary
+types in an instance context. Termination is ensured by having a
+fixed-depth recursion stack. If you exceed the stack depth you get a
+sort of backtrace, and the opportunity to increase the stack depth
+with <tt>-fcontext-stack</tt><em/N/.
+
+</enum>
+
+% -----------------------------------------------------------------------------
+<sect1>Explicit universal quantification
<label id="universal-quantification">
<p>
-(ToDo)
+GHC now allows you to write explicitly quantified types. GHC's
+syntax for this now agrees with Hugs's, namely:
+
+<tscreen><verb>
+ forall a b. (Ord a, Eq b) => a -> b -> a
+</verb></tscreen>
+
+The context is, of course, optional. You can't use <tt>forall</tt> as
+a type variable any more!
+
+Haskell type signatures are implicitly quantified. The <tt>forall</tt>
+allows us to say exactly what this means. For example:
+
+<tscreen><verb>
+ g :: b -> b
+</verb></tscreen>
+
+means this:
+
+<tscreen><verb>
+ g :: forall b. (b -> b)
+</verb></tscreen>
+
+The two are treated identically.
+
+<sect2>Universally-quantified data type fields
+<label id="univ">
+<p>
+
+In a <tt>data</tt> or <tt>newtype</tt> declaration one can quantify
+the types of the constructor arguments. Here are several examples:
+
+<tscreen><verb>
+data T a = T1 (forall b. b -> b -> b) a
+
+data MonadT m = MkMonad { return :: forall a. a -> m a,
+ bind :: forall a b. m a -> (a -> m b) -> m b
+ }
+
+newtype Swizzle = MkSwizzle (Ord a => [a] -> [a])
+</verb></tscreen>
+
+The constructors now have so-called <em/rank 2/ polymorphic
+types, in which there is a for-all in the argument types.:
+
+<tscreen><verb>
+T1 :: forall a. (forall b. b -> b -> b) -> a -> T1 a
+MkMonad :: forall m. (forall a. a -> m a)
+ -> (forall a b. m a -> (a -> m b) -> m b)
+ -> MonadT m
+MkSwizzle :: (Ord a => [a] -> [a]) -> Swizzle
+</verb></tscreen>
+
+Notice that you don't need to use a <tt>forall</tt> if there's an
+explicit context. For example in the first argument of the
+constructor <tt>MkSwizzle</tt>, an implicit "<tt>forall a.</tt>" is
+prefixed to the argument type. The implicit <tt>forall</tt>
+quantifies all type variables that are not already in scope, and are
+mentioned in the type quantified over.
+
+As for type signatures, implicit quantification happens for non-overloaded
+types too. So if you write this:
+<tscreen><verb>
+ data T a = MkT (Either a b) (b -> b)
+</verb></tscreen>
+it's just as if you had written this:
+<tscreen><verb>
+ data T a = MkT (forall b. Either a b) (forall b. b -> b)
+</verb></tscreen>
+That is, since the type variable <tt>b</tt> isn't in scope, it's
+implicitly universally quantified. (Arguably, it would be better
+to <em>require</em> explicit quantification on constructor arguments
+where that is what is wanted. Feedback welcomed.)
+
+<sect2> Construction
+<p>
+
+You construct values of types <tt>T1, MonadT, Swizzle</tt> by applying
+the constructor to suitable values, just as usual. For example,
+
+<tscreen><verb>
+(T1 (\xy->x) 3) :: T Int
+
+(MkSwizzle sort) :: Swizzle
+(MkSwizzle reverse) :: Swizzle
+
+(let r x = Just x
+ b m k = case m of
+ Just y -> k y
+ Nothing -> Nothing
+ in
+ MkMonad r b) :: MonadT Maybe
+</verb></tscreen>
+
+The type of the argument can, as usual, be more general than the type
+required, as <tt>(MkSwizzle reverse)</tt> shows. (<tt>reverse</tt>
+does not need the <tt>Ord</tt> constraint.)
+
+<sect2>Pattern matching
+<p>
+
+When you use pattern matching, the bound variables may now have
+polymorphic types. For example:
+
+<tscreen><verb>
+ f :: T a -> a -> (a, Char)
+ f (T1 f k) x = (f k x, f 'c' 'd')
+
+ g :: (Ord a, Ord b) => Swizzle -> [a] -> (a -> b) -> [b]
+ g (MkSwizzle s) xs f = s (map f (s xs))
+
+ h :: MonadT m -> [m a] -> m [a]
+ h m [] = return m []
+ h m (x:xs) = bind m x $ \y ->
+ bind m (h m xs) $ \ys ->
+ return m (y:ys)
+</verb></tscreen>
+
+In the function <tt>h</tt> we use the record selectors <tt>return</tt>
+and <tt>bind</tt> to extract the polymorphic bind and return functions
+from the <tt>MonadT</tt> data structure, rather than using pattern
+matching.
+
+<sect2>The partial-application restriction
+<p>
+
+There is really only one way in which data structures with polymorphic
+components might surprise you: you must not partially apply them.
+For example, this is illegal:
+
+<tscreen><verb>
+ map MkSwizzle [sort, reverse]
+</verb></tscreen>
+
+The restriction is this: <em>every subexpression of the program must
+have a type that has no for-alls, except that in a function
+application (f e1 ... en) the partial applications are not subject to
+this rule</em>. The restriction makes type inference feasible.
+
+In the illegal example, the sub-expression <tt>MkSwizzle</tt> has the
+polymorphic type <tt>(Ord b => [b] -> [b]) -> Swizzle</tt> and is not
+a sub-expression of an enclosing application. On the other hand, this
+expression is OK:
+
+<tscreen><verb>
+ map (T1 (\a b -> a)) [1,2,3]
+</verb></tscreen>
+
+even though it involves a partial application of <tt>T1</tt>, because
+the sub-expression <tt>T1 (\a b -> a)</tt> has type <tt>Int -> T
+Int</tt>.
+
+<sect2>Type signatures
+<label id="sigs">
+<p>
+
+Once you have data constructors with universally-quantified fields, or
+constants such as <tt>runST</tt> that have rank-2 types, it isn't long
+before you discover that you need more! Consider:
+
+<tscreen><verb>
+ mkTs f x y = [T1 f x, T1 f y]
+</verb></tscreen>
+
+<tt>mkTs</tt> is a fuction that constructs some values of type
+<tt>T</tt>, using some pieces passed to it. The trouble is that since
+<tt>f</tt> is a function argument, Haskell assumes that it is
+monomorphic, so we'll get a type error when applying <tt>T1</tt> to
+it. This is a rather silly example, but the problem really bites in
+practice. Lots of people trip over the fact that you can't make
+"wrappers functions" for <tt>runST</tt> for exactly the same reason.
+In short, it is impossible to build abstractions around functions with
+rank-2 types.
+
+The solution is fairly clear. We provide the ability to give a rank-2
+type signature for <em>ordinary</em> functions (not only data
+constructors), thus:
+
+<tscreen><verb>
+ mkTs :: (forall b. b -> b -> b) -> a -> [T a]
+ mkTs f x y = [T1 f x, T1 f y]
+</verb></tscreen>
+
+This type signature tells the compiler to attribute <tt>f</tt> with
+the polymorphic type <tt>(forall b. b -> b -> b)</tt> when type
+checking the body of <tt>mkTs</tt>, so now the application of
+<tt>T1</tt> is fine.
+
+There are two restrictions:
+
+<itemize>
+<item> You can only define a rank 2 type, specified by the following
+grammar:
+
+<tscreen><verb>
+ rank2type ::= [forall tyvars .] [context =>] funty
+ funty ::= ([forall tyvars .] [context =>] ty) -> funty
+ | ty
+ ty ::= ...current Haskell monotype syntax...
+</verb></tscreen>
+
+Informally, the universal quantification must all be right at the beginning,
+or at the top level of a function argument.
+
+<item> There is a restriction on the definition of a function whose
+type signature is a rank-2 type: the polymorphic arguments must be
+matched on the left hand side of the "<tt>=</tt>" sign. You can't
+define <tt>mkTs</tt> like this:
+
+<tscreen><verb>
+ mkTs :: (forall b. b -> b -> b) -> a -> [T a]
+ mkTs = \ f x y -> [T1 f x, T1 f y]
+</verb></tscreen>
+
+
+The same partial-application rule applies to ordinary functions with
+rank-2 types as applied to data constructors.
+
+</itemize>
+
+% -----------------------------------------------------------------------------
+<sect1>Existentially quantified data constructors
+<label id="existential-quantification">
+<p>
+
+The idea of using existential quantification in data type declarations
+was suggested by Laufer (I believe, thought doubtless someone will
+correct me), and implemented in Hope+. It's been in Lennart
+Augustsson's <tt>hbc</tt> Haskell compiler for several years, and
+proved very useful. Here's the idea. Consider the declaration:
+
+<tscreen><verb>
+ data Foo = forall a. MkFoo a (a -> Bool)
+ | Nil
+</verb></tscreen>
+
+The data type <tt>Foo</tt> has two constructors with types:
+
+<tscreen><verb>
+ MkFoo :: forall a. a -> (a -> Bool) -> Foo
+ Nil :: Foo
+</verb></tscreen>
+
+Notice that the type variable <tt>a</tt> in the type of <tt>MkFoo</tt>
+does not appear in the data type itself, which is plain <tt>Foo</tt>.
+For example, the following expression is fine:
+
+<tscreen><verb>
+ [MkFoo 3 even, MkFoo 'c' isUpper] :: [Foo]
+</verb></tscreen>
+
+Here, <tt>(MkFoo 3 even)</tt> packages an integer with a function
+<tt>even</tt> that maps an integer to <tt>Bool</tt>; and <tt>MkFoo 'c'
+isUpper</tt> packages a character with a compatible function. These
+two things are each of type <tt>Foo</tt> and can be put in a list.
+
+What can we do with a value of type <tt>Foo</tt>?. In particular,
+what happens when we pattern-match on <tt>MkFoo</tt>?
+
+<tscreen><verb>
+ f (MkFoo val fn) = ???
+</verb></tscreen>
+
+Since all we know about <tt>val</tt> and <tt>fn</tt> is that they
+are compatible, the only (useful) thing we can do with them is to
+apply <tt>fn</tt> to <tt>val</tt> to get a boolean. For example:
+
+<tscreen><verb>
+ f :: Foo -> Bool
+ f (MkFoo val fn) = fn val
+</verb></tscreen>
+
+What this allows us to do is to package heterogenous values
+together with a bunch of functions that manipulate them, and then treat
+that collection of packages in a uniform manner. You can express
+quite a bit of object-oriented-like programming this way.
+
+<sect2>Why existential?
+<label id="existential">
+<p>
+
+What has this to do with <em>existential</em> quantification?
+Simply that <tt>MkFoo</tt> has the (nearly) isomorphic type
+
+<tscreen><verb>
+ MkFoo :: (exists a . (a, a -> Bool)) -> Foo
+</verb></tscreen>
+
+But Haskell programmers can safely think of the ordinary
+<em>universally</em> quantified type given above, thereby avoiding
+adding a new existential quantification construct.
+
+<sect2>Type classes
+<p>
+
+An easy extension (implemented in <tt>hbc</tt>) is to allow
+arbitrary contexts before the constructor. For example:
+
+<tscreen><verb>
+ data Baz = forall a. Eq a => Baz1 a a
+ | forall b. Show b => Baz2 b (b -> b)
+</verb></tscreen>
+
+The two constructors have the types you'd expect:
+
+<tscreen><verb>
+ Baz1 :: forall a. Eq a => a -> a -> Baz
+ Baz2 :: forall b. Show b => b -> (b -> b) -> Baz
+</verb></tscreen>
+
+But when pattern matching on <tt>Baz1</tt> the matched values can be compared
+for equality, and when pattern matching on <tt>Baz2</tt> the first matched
+value can be converted to a string (as well as applying the function to it).
+So this program is legal:
+
+<tscreen><verb>
+ f :: Baz -> String
+ f (Baz1 p q) | p == q = "Yes"
+ | otherwise = "No"
+ f (Baz1 v fn) = show (fn v)
+</verb></tscreen>
+
+Operationally, in a dictionary-passing implementation, the
+constructors <tt>Baz1</tt> and <tt>Baz2</tt> must store the
+dictionaries for <tt>Eq</tt> and <tt>Show</tt> respectively, and
+extract it on pattern matching.
+
+Notice the way that the syntax fits smoothly with that used for
+universal quantification earlier.
+
+<sect2>Restrictions
+<p>
+
+There are several restrictions on the ways in which existentially-quantified
+constructors can be use.
+
+<itemize>
+
+<item> When pattern matching, each pattern match introduces a new,
+distinct, type for each existential type variable. These types cannot
+be unified with any other type, nor can they escape from the scope of
+the pattern match. For example, these fragments are incorrect:
+
+<tscreen><verb>
+ f1 (MkFoo a f) = a
+</verb></tscreen>
+
+Here, the type bound by <tt>MkFoo</tt> "escapes", because <tt>a</tt>
+is the result of <tt>f1</tt>. One way to see why this is wrong is to
+ask what type <tt>f1</tt> has:
+
+<tscreen><verb>
+ f1 :: Foo -> a -- Weird!
+</verb></tscreen>
+
+What is this "<tt>a</tt>" in the result type? Clearly we don't mean
+this:
+
+<tscreen><verb>
+ f1 :: forall a. Foo -> a -- Wrong!
+</verb></tscreen>
+
+The original program is just plain wrong. Here's another sort of error
+
+<tscreen><verb>
+ f2 (Baz1 a b) (Baz1 p q) = a==q
+</verb></tscreen>
+
+It's ok to say <tt>a==b</tt> or <tt>p==q</tt>, but
+<tt>a==q</tt> is wrong because it equates the two distinct types arising
+from the two <tt>Baz1</tt> constructors.
+
+
+<item>You can't pattern-match on an existentially quantified
+constructor in a <tt>let</tt> or <tt>where</tt> group of
+bindings. So this is illegal:
+
+<tscreen><verb>
+ f3 x = a==b where { Baz1 a b = x }
+</verb></tscreen>
+
+You can only pattern-match
+on an existentially-quantified constructor in a <tt>case</tt> expression or
+in the patterns of a function definition.
+
+The reason for this restriction is really an implementation one.
+Type-checking binding groups is already a nightmare without
+existentials complicating the picture. Also an existential pattern
+binding at the top level of a module doesn't make sense, because it's
+not clear how to prevent the existentially-quantified type "escaping".
+So for now, there's a simple-to-state restriction. We'll see how
+annoying it is.
+
+<item>You can't use existential quantification for <tt>newtype</tt>
+declarations. So this is illegal:
+
+<tscreen><verb>
+ newtype T = forall a. Ord a => MkT a
+</verb></tscreen>
+
+Reason: a value of type <tt>T</tt> must be represented as a pair
+of a dictionary for <tt>Ord t</tt> and a value of type <tt>t</tt>.
+That contradicts the idea that <tt>newtype</tt> should have no
+concrete representation. You can get just the same efficiency and effect
+by using <tt>data</tt> instead of <tt>newtype</tt>. If there is no
+overloading involved, then there is more of a case for allowing
+an existentially-quantified <tt>newtype</tt>, because the <tt>data</tt>
+because the <tt>data</tt> version does carry an implementation cost,
+but single-field existentially quantified constructors aren't much
+use. So the simple restriction (no existential stuff on <tt>newtype</tt>)
+stands, unless there are convincing reasons to change it.
+</itemize>
%************************************************************************
If you still have a problem after consulting this section, then you
-may have found a <em>bug</em>---please report it! See
-Section <ref name="How to report a bug in the GHC system" id="bug-reports"> for a list of things we'd like to know about
-your bug. If in doubt, send a report---we love mail from irate users :-!
+may have found a <em>bug</em>---please report it! See Section <ref
+name="How to report a bug in the GHC system" id="bug-reports"> for a
+list of things we'd like to know about your bug. If in doubt, send a
+report---we love mail from irate users :-!
-(Section <ref name="Haskell 1.4 vs. Glasgow Haskell 3.00: language
+(Section <ref name="Haskell 1.4 vs. Glasgow Haskell 4.00: language
non-compliance" id="vs-Haskell-defn">, which describes Glasgow
Haskell's shortcomings vs.~the Haskell language definition, may also
be of interest.)
Just say @make all EXTRA_HC_OPTS=-H<a reasonable number>@ and see
how you get along.
+Note that this is less likely to happen if you are compiling with GHC
+4.00 or later, since the introduction of the dynamically expanding
+heap.
+
%-------------------------------------------------------------------
<tag>``The compiler died with a pattern-matching error.''</tag>
This is a bug just as surely as a ``panic.'' Please report it.
<tag>``What about this warning from the C compiler?''</tag>
For example: ``...warning: `Foo' declared `static' but never defined.''
-Unsightly, but not a problem.
+Unsightly, but shouldn't be a problem.
%-------------------------------------------------------------------
<tag>Sensitivity to @.hi@ interface files:</tag>
@-dcore-lint@<nidx>-dcore-lint option</nidx>; this causes a ``lint''
pass to check for errors (notably type errors) after each Core-to-Core
transformation pass. We run with @-dcore-lint@ on all the time; it
-costs about 5\% in compile time. (Or maybe 25\%; who knows?)
+costs about 5\% in compile time.
%-------------------------------------------------------------------
<tag>``Why did I get a link error?''</tag>
If the linker complains about not finding @_<something>_fast@, then
-your interface files haven't settled---keep on compiling! (In
-particular, this error means that arity information, which you can see
-in any @.hi@ file, has changed.)
+something is inconsistent: you probably didn't compile modules in the
+proper dependency order.
%-------------------------------------------------------------------
<tag>``What's a `consistency error'?''</tag>
%-----------------------------------------------------------------------
<tag>``Help! My program crashed!''</tag>
(e.g., a `segmentation fault' or `core dumped')
+<nidx>segmentation fault</nidx>
-If your program has no @_ccall_@s/@_casm_@s in it, then a crash is always
-a BUG in the GHC system, except in one case: If your program is made
-of several modules, each module must have been compiled with a stable
-group of interface (@.hi@) files.
+If your program has no @_ccall_@s/@_casm_@s in it, then a crash is
+always a BUG in the GHC system, except in one case: If your program is
+made of several modules, each module must have been compiled after any
+modules on which it depends (unless you use @.hi-boot@ files, in which
+case these <em/must/ be correct with respect to the module source).
For example, if an interface is lying about the type of an imported
value then GHC may well generate duff code for the importing module.
GHC-compiled program, please see Section <ref name="Hard-core
debugging of GHC-compiled programs" id="hard-core-debug">.
-% (If you have an ``unregisterised'' arity-checking
-% (@-O0 -darity-checks@) around [as we sometimes do at Glasgow], then you
-% might recompile with @-darity-checks@<nidx>-darity-checks option</nidx>,
-% which will definitely detect arity-compatibility errors.)
-
%-------------------------------------------------------------------
<tag>``My program entered an `absent' argument.''</tag>
This is definitely caused by a bug in GHC. Please report it.
<nidx>ANSI C compiler</nidx>
<nidx>high-level assembler</nidx>
<nidx>assembler, high-level</nidx>
+
compiles @hsc@'s C output into assembly language for a particular
-target architecture. (It doesn't have to be an ANSI C compiler, but
-that's preferred; to go fastest, you need GNU C, version 2.x.)
+target architecture. In fact, the only C compiler we currently
+support is <tt/gcc/, because we make use of certain extensions to the
+C language only supported by gcc. Version 2.x is a must; we recommend
+version 2.7.2.1 for stability (we've heard both good and bad reports
+of later versions).
<item>
The <em>assembler</em><nidx>assembler</nidx>---a standard UNIX one, probably
<item>
The linker, which links your code with the appropriate libraries
(including the standard prelude), producing an executable program in
-the default output file named either @a.out@ (*NIX platforms) or @main.exe@
-(Windows port.)
+the default output file named @a.out@.
</enum>
You have considerable control over the compilation process. You feed
<tag>glasgow-haskell-users:</tag>
This list is for GHC users to chat among themselves. Subscribe by
-sending mail to <htmlurl name="majordomo@dcs.gla.ac.uk"
-url="mailto:majordomo@dcs.gla.ac.uk">, with a message body (not
+sending mail to <htmlurl name="majordomo@@dcs.gla.ac.uk"
+url="mailto:majordomo@@dcs.gla.ac.uk">, with a message body (not
header) like this:
<tscreen><verb>
-subscribe glasgow-haskell-users MyName <m.y.self@bigbucks.com>
+subscribe glasgow-haskell-users MyName <m.y.self@@bigbucks.com>
</verb></tscreen>
(The last bit is your all-important e-mail address, of course.)
To communicate with your fellow users, send mail to <url
-name="glasgow-haskell-users@dcs.gla.ac.uk"
-url="mailto:glasgow-haskell-users@dcs.gla.ac.uk">.
+name="glasgow-haskell-users@@dcs.gla.ac.uk"
+url="mailto:glasgow-haskell-users@@dcs.gla.ac.uk">.
To contact the list administrator, send mail to <htmlurl
-name="glasgow-haskell-users-request@dcs.gla.ac.uk"
-url="mailto:glasgow-haskell-users-request@dcs.gla.ac.uk">. An archive
+name="glasgow-haskell-users-request@@dcs.gla.ac.uk"
+url="mailto:glasgow-haskell-users-request@@dcs.gla.ac.uk">. An archive
of the list is available on the Web: <url name="glasgow-haskell-users
mailing list archive"
url="http://www.dcs.gla.ac.uk/mail-www/glasgow-haskell-users">.
who subscribe to this list will muse upon what's wrong and what you
might do about it.
-Subscribe via <htmlurl name="majordomo@dcs.gla.ac.uk"
-url="mailto:majordomo@dcs.gla.ac.uk"> with:
+Subscribe via <htmlurl name="majordomo@@dcs.gla.ac.uk"
+url="mailto:majordomo@@dcs.gla.ac.uk"> with:
<tscreen><verb>
-subscribe glasgow-haskell-bugs My Name <m.y.self@hackers.r.us>
+subscribe glasgow-haskell-bugs My Name <m.y.self@@hackers.r.us>
</verb></tscreen>
Again, you may contact the list administrator at <htmlurl
-name="glasgow-haskell-bugs-request@dcs.gla.ac.uk"
-url="mailto:glasgow-haskell-bugs-request@dcs.gla.ac.uk">.
+name="glasgow-haskell-bugs-request@@dcs.gla.ac.uk"
+url="mailto:glasgow-haskell-bugs-request@@dcs.gla.ac.uk">.
And, yes, an archive of the list is available on the Web at: : <url
name="glasgow-haskell-bugs mailing list archive"
url="http://www.dcs.gla.ac.uk/mail-www/glasgow-haskell-bugs">
</descrip>
There is also the general Haskell mailing list. Subscribe by sending
-email to <htmlurl name="majordomo@dcs.gla.ac.uk"
-url="mailto:majordomo@dcs.gla.ac.uk">, with the usual message body:
+email to <htmlurl name="majordomo@@dcs.gla.ac.uk"
+url="mailto:majordomo@@dcs.gla.ac.uk">, with the usual message body:
<tscreen><verb>
-subscribe haskell My Name <m.y.self@fp.rules.ok.org>
+subscribe haskell My Name <m.y.self@@fp.rules.ok.org>
</verb></tscreen>
Some Haskell-related discussion takes place in the Usenet newsgroup
%************************************************************************
You need to @import PackedString@ and heave in your
-@-syslib misc@ to use @PackedString@s.
+@-syslib ghc@ to use @PackedString@s.
The basic type and functions available are:
<tscreen><verb>
%* *
%************************************************************************
-The GHC system library (@-syslib misc@) also provides interfaces to
+The GHC system library (@-syslib ghc@) also provides interfaces to
several useful C libraries, mostly from the GNU project.
%************************************************************************
documentation (and have a @libreadline.a@ file around somewhere...)
You'll need to link any Readlining program with @-lreadline -ltermcap@,
-besides the usual @-syslib misc@.
+besides the usual @-syslib ghc@ (and @-fhaskell-1.3@).
The main function you'll use is:
<tscreen><verb>
%
-% $Id: libraries.vsgml,v 1.2 1998/08/25 18:07:57 sof Exp $
+% $Id: libraries.vsgml,v 1.3 1998/12/02 13:20:40 simonm Exp $
%
% GHC Prelude and Libraries.
%
<tag>@fromInt@ method in class @Num@:</tag> It's there. Converts from
an @Int@ to the type.
-<tag>@toInt@ method in class @Integral@:</tag> Converts from type type
-to an @Int@.
+<tag>@toInt@ method in class @Integral@:</tag> Converts from Integral
+type to an @Int@.
</descrip>
GHC also internally uses a number of modules that begin with the
-string @Prel@: for this reason, we don't recommend that you use any
-module names beginning with @Prel@ in your own programs. The @Prel@
-modules are always available: in fact, you can get access to several
-extensions this way (for some you might need to give the
-@-fglasgow-exts@<nidx>-fglasgow-exts option</nidx> flag).
+string @Prel@<nidx>Prel module prefix</nidx>: for this reason, we
+don't recommend that you use any module names beginning with @Prel@ in
+your own programs. The @Prel@ modules are always available: in fact,
+you can get access to several extensions this way (for some you might
+need to give the @-fglasgow-exts@<nidx>-fglasgow-exts option</nidx>
+flag).
<sect1>The module @PrelGHC@: really primitive stuff
<label id="ghc-libs-ghc">
<p>
+<nidx>PrelGHC module</nidx>
-This section defines all the types which are primitive in Glasgow
+This module defines all the types which are primitive in Glasgow
Haskell, and the operations provided for them.
A primitive type is one which cannot be defined in Haskell, and which
is therefore built into the language and compiler. Primitive types
-are always unboxed; that is, a value of primitive type cannot be
-bottom.
+are always unlifted; that is, a value of primitive type cannot be
+bottom. We use the convention that primitive types, values, and
+operations have a @#@ suffix.
Primitive values are often represented by a simple bit-pattern, such
as @Int#@, @Float#@, @Double#@. But this is not necessarily the case:
a primitive value might be represented by a pointer to a
heap-allocated object. Examples include @Array#@, the type of
-primitive arrays. You might think this odd: doesn't being
-heap-allocated mean that it has a box? No, it does not. A primitive
-array is heap-allocated because it is too big a value to fit in a
-register, and would be too expensive to copy around; in a sense, it is
-accidental that it is represented by a pointer. If a pointer
-represents a primitive value, then it really does point to that value:
-no unevaluated thunks, no indirections...nothing can be at the other
-end of the pointer than the primitive value.
-
-This section also describes a few non-primitive types, which are needed
-to express the result types of some primitive operations.
+primitive arrays. A primitive array is heap-allocated because it is
+too big a value to fit in a register, and would be too expensive to
+copy around; in a sense, it is accidental that it is represented by a
+pointer. If a pointer represents a primitive value, then it really
+does point to that value: no unevaluated thunks, no
+indirections...nothing can be at the other end of the pointer than the
+primitive value.
+
+<sect2>Unboxed Tuples
+<label id="unboxed-tuples">
+<p>
+
+Unboxed tuples aren't really exported by @PrelGHC@, they're available
+by default with @-fglasgow-exts@. An unboxed tuple looks like this:
+
+<tscreen><verb>
+(# e_1, ..., e_n #)
+</verb></tscreen>
+
+where @e_1..e_n@ are expressions of any type (primitive or
+non-primitive). The type of an unboxed tuple looks the same.
+
+Unboxed tuples are used for functions that need to return multiple
+values, but they avoid the heap allocation normally associated with
+using fully-fledged tuples. When an unboxed tuple is returned, the
+components are put directly into registers or on the stack; the
+unboxed tuple itself does not have a composite representation. Many
+of the primitive operations listed in this section return unboxed
+tuples.
+
+There are some pretty stringent restrictions on the use of unboxed tuples:
+
+<itemize>
+
+<item> Unboxed tuple types are subject to the same restrictions as
+other unboxed types; i.e. they may not be stored in polymorphic data
+structures or passed to polymorphic functions.
+
+<item> Unboxed tuples may only be constructed as the direct result of
+a function, and may only be deconstructed with a @case@ expression.
+eg. the following are valid:
+
+<tscreen><verb>
+f x y = (# x+1, y-1 #)
+g x = case f x x of { (# a, b #) -> a + b }
+</verb></tscreen>
+
+but the following are invalid:
+
+<tscreen><verb>
+f x y = g (# x, y #)
+g (# x, y #) = x + y
+</verb></tscreen>
+
+<item> No variable can have an unboxed tuple type. This is illegal:
+
+<tscreen><verb>
+f :: (# Int, Int #) -> (# Int, Int #)
+f x = x
+</verb></tscreen>
+
+because @x@ has an unboxed tuple type.
+
+</itemize>
+
+Note: we may relax some of these restrictions in the future.
+
+The @IO@ and @ST@ monads use unboxed tuples to avoid unnecessary
+allocation during sequences of operations.
<sect2>Character and numeric types
<p>
<ncdx>Double#</ncdx>
If you really want to know their exact equivalents in C, see
-@ghc/includes/StgTypes.lh@ in the GHC source tree.
+@ghc/includes/StgTypes.h@ in the GHC source tree.
Literals for these types may be written as follows:
<sect2> Primitive-character operations
<p>
-<nidx>characters, primitive</nidx>
+<nidx>characters, primitive operations</nidx>
<nidx>operators, primitive character</nidx>
<tscreen><verb>
<sect2> Primitive-@Int@ operations
<p>
-<nidx>integers, primitive</nidx>
+<nidx>integers, primitive operations</nidx>
<nidx>operators, primitive integer</nidx>
<tscreen><verb>
(And the same for @Float#@s.)
<sect2>Operations on/for @Integers@ (interface to GMP)
-<label id="horrid-Integer-pairing-types">
+<label id="integer-operations">
<p>
<nidx>arbitrary precision integers</nidx>
<nidx>Integer, operations on</nidx>
We implement @Integers@ (arbitrary-precision integers) using the GNU
-multiple-precision (GMP) package (version 1.3.2).
-
-<bf>Note:</bf> some of this might change when we upgrade to using
-GMP~2.x.
+multiple-precision (GMP) package (version 2.0.2).
The data type for @Integer@ must mirror that for @MP_INT@ in @gmp.h@
(see @gmp.info@ in @ghc/includes/runtime/gmp@). It comes out as:
So, @Integer@ is really just a ``pairing'' type for a particular
collection of primitive types.
-The operations in the GMP return other combinations of
-GMP-plus-something, so we need ``pairing'' types for those, too:
-
-<tscreen><verb>
-data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray#
-data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray#
-
--- ????? something to return a string of bytes (in the heap?)
-</verb></tscreen>
-<ncdx>Return2GMPs</ncdx>
-<ncdx>ReturnIntAndGMP</ncdx>
-
The primitive ops to support @Integers@ use the ``pieces'' of the
representation, and are as follows:
not# :: Word# -> Word#
-shiftL#, shiftRL# :: Word# -> Int# -> Word#
- -- shift left, right logical
+shiftL#, shiftRA#, shiftRL# :: Word# -> Int# -> Word#
+ -- shift left, right arithmetic, right logical
int2Word# :: Int# -> Word# -- just a cast, really
word2Int# :: Word# -> Int#
<ncdx>quotWord#</ncdx>
<ncdx>remWord#</ncdx>
<ncdx>shiftL#</ncdx>
+<ncdx>shiftRA#</ncdx>
<ncdx>shiftRL#</ncdx>
<ncdx>int2Word#</ncdx>
<ncdx>word2Int#</ncdx>
it should be entered --- we never usually return an unevaluated
object! This is a pain: primitive ops aren't supposed to do
complicated things like enter objects. The current solution is to
-return a lifted value, but I don't like it!
+return a single element unboxed tuple (see Section <ref name="Unboxed
+Tuples" id="unboxed-tuples">).
<tscreen><verb>
-indexArray# :: Array# elt -> Int# -> PrelBase.Lift elt -- Yuk!
+indexArray# :: Array# elt -> Int# -> (# elt #)
</verb></tscreen>
<ncdx>indexArray#</ncdx>
The type @GHC.RealWorld@ is truly opaque: there are no values defined
of this type, and no operations over it. It is ``primitive'' in that
-sense - but it is <em>not unboxed!</em> Its only role in life is to be
+sense - but it is <em>not unlifted!</em> Its only role in life is to be
the type which distinguishes the @IO@ state transformer.
<tscreen><verb>
A single, primitive, value of type @State# RealWorld@ is provided.
<tscreen><verb>
-realWorld# :: State# GHC.RealWorld
+realWorld# :: State# RealWorld
</verb></tscreen>
<nidx>realWorld# state object</nidx>
(Note: in the compiler, not a @PrimOp@; just a mucho magic
@Id@. Exported from @GHC@, though).
-<sect2>State pairing types
-<p>
-<label id="horrid-pairing-types">
-
-This subsection defines some types which, while they aren't quite
-primitive because we can define them in Haskell, are very nearly so.
-They define constructors which pair a primitive state with a value of
-each primitive type. They are required to express the result type of
-the primitive operations in the state monad.
-<tscreen><verb>
-data StateAndPtr# s elt = StateAndPtr# (State# s) elt
-
-data StateAndChar# s = StateAndChar# (State# s) Char#
-data StateAndInt# s = StateAndInt# (State# s) Int#
-data StateAndWord# s = StateAndWord# (State# s) Word#
-data StateAndFloat# s = StateAndFloat# (State# s) Float#
-data StateAndDouble# s = StateAndDouble# (State# s) Double#
-data StateAndAddr# s = StateAndAddr# (State# s) Addr#
-
-data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
-data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj#
-data StateAndSynchVar# s a = StateAndSynchVar# (State# s) (SynchVar# a)
-
-data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt)
-data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt)
-data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray#
-data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s)
-</verb></tscreen>
-
-Hideous.
-
<sect2>Mutable arrays
<p>
<label id="sect:mutable">
worry about GC striking with a partly-initialised array.
<tscreen><verb>
-newArray# :: Int# -> elt -> State# s -> StateAndMutableArray# s elt
+newArray# :: Int# -> elt -> State# s -> (# State# s, MutableArray# s elt #)
-newCharArray# :: Int# -> State# s -> StateAndMutableByteArray# s
-newIntArray# :: Int# -> State# s -> StateAndMutableByteArray# s
-newAddrArray# :: Int# -> State# s -> StateAndMutableByteArray# s
-newFloatArray# :: Int# -> State# s -> StateAndMutableByteArray# s
-newDoubleArray# :: Int# -> State# s -> StateAndMutableByteArray# s
+newCharArray# :: Int# -> State# s -> (# State# s, MutableByteArray# s elt #)
+newIntArray# :: Int# -> State# s -> (# State# s, MutableByteArray# s elt #)
+newAddrArray# :: Int# -> State# s -> (# State# s, MutableByteArray# s elt #)
+newFloatArray# :: Int# -> State# s -> (# State# s, MutableByteArray# s elt #)
+newDoubleArray# :: Int# -> State# s -> (# State# s, MutableByteArray# s elt #)
</verb></tscreen>
<ncdx>newArray#</ncdx>
<ncdx>newCharArray#</ncdx>
<nidx>arrays, reading and writing</nidx>
<tscreen><verb>
-readArray# :: MutableArray# s elt -> Int# -> State# s -> StateAndPtr# s elt
-readCharArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndChar# s
-readIntArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndInt# s
-readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndAddr# s
-readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndFloat# s
-readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndDouble# s
+readArray# :: MutableArray# s elt -> Int# -> State# s -> (# State# s, elt #)
+readCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)
+readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)
+readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)
writeArray# :: MutableArray# s elt -> Int# -> elt -> State# s -> State# s
writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
by copying the array and then using @unsafeFreeze@.)
<tscreen><verb>
-unsafeFreezeArray# :: MutableArray# s elt -> State# s -> StateAndArray# s elt
-unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> StateAndByteArray# s
+unsafeFreezeArray# :: MutableArray# s elt -> State# s -> (# State# s, Array# s elt #)
+unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)
</verb></tscreen>
<ncdx>unsafeFreezeArray#</ncdx>
<ncdx>unsafeFreezeByteArray#</ncdx>
copies.
<tscreen><verb>
-makeStablePointer# :: a -> State# RealWorld -> StateAndStablePtr# RealWorld a
+makeStablePointer# :: a -> State# RealWorld -> (# State# RealWord, StablePtr# a #)
freeStablePointer# :: StablePtr# a -> State# RealWorld -> State# RealWorld
-deRefStablePointer# :: StablePtr# a -> State# RealWorld -> StateAndPtr RealWorld a
+deRefStablePointer# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
</verb></tscreen>
<ncdx>makeStablePointer#</ncdx>
<ncdx>freeStablePointer#</ncdx>
makeForeignObj#
:: Addr# -- foreign reference
-> Addr# -- pointer to finalisation routine
- -> StateAndForeignObj# RealWorld ForeignObj#
+ -> (# State# RealWorld, ForeignObj# )
writeForeignObj
:: ForeignObj# -- foreign object
-> Addr# -- datum
the operational behaviour of these operations).
<tscreen><verb>
-type SynchVar# s elt -- primitive
+type MVar# s elt -- primitive
-newSynchVar#:: State# s -> StateAndSynchVar# s elt
-takeMVar# :: SynchVar# s elt -> State# s -> StateAndPtr# s elt
+newMVar# :: State# s -> (# State# s, MVar# s elt #)
+takeMVar# :: SynchVar# s elt -> State# s -> (# State# s, elt #)
putMVar# :: SynchVar# s elt -> State# s -> State# s
</verb></tscreen>
<ncdx>SynchVar#</ncdx>
<ncdx>takeMVar</ncdx>
<ncdx>putMVar</ncdx>
-<sect2>@spark#@ primitive operation (for parallel execution)
-<p>
-<nidx>spark primitive operation</nidx>
-
-<em>ToDo: say something</em> It's used in the unfolding for @par@.
-
-<sect2>The @errorIO#@ primitive operation
-<p>
-<nidx>errors, primitive</nidx>
-
-The @errorIO#@ primitive takes an argument much like @IO@. It aborts
-execution of the current program, and continues instead by performing
-the given @IO@-like value on the current state of the world.
-
-<tscreen><verb>
-errorIO# :: (State# RealWorld# -> a) -> a
-</verb></tscreen>
-<ncdx>errorIO#</ncdx>
-
<sect1>GHC/Hugs Extension Libraries
<p>
newIntArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
newFloatArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
newDoubleArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
-
+
boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix)
boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix)
-
-
-readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt
-
+
+
+readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt
+
readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr
readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float
readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
-
-writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s ()
+
+writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s ()
writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s ()
writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s ()
writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s ()
writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s ()
writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s ()
-
-freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
+
+freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt)
</verb></tscreen>
-%ToDo: index these.
+<nidx>newArray</nidx>
+<nidx>newCharArray</nidx>
+<nidx>newAddrArray</nidx>
+<nidx>newIntArray</nidx>
+<nidx>newFloatArray</nidx>
+<nidx>newDoubleArray</nidx>
+<nidx>boundsOfArray</nidx>
+<nidx>boundsOfByteArray</nidx>
+<nidx>readArray</nidx>
+<nidx>readCharArray</nidx>
+<nidx>readIntArray</nidx>
+<nidx>readAddrArray</nidx>
+<nidx>readFloatArray</nidx>
+<nidx>readDoubleArray</nidx>
+<nidx>writeArray</nidx>
+<nidx>writeCharArray</nidx>
+<nidx>writeIntArray</nidx>
+<nidx>writeAddrArray</nidx>
+<nidx>writeFloatArray</nidx>
+<nidx>writeDoubleArray</nidx>
+<nidx>freezeArray</nidx>
+<nidx>freezeCharArray</nidx>
+<nidx>freezeIntArray</nidx>
+<nidx>freezeAddrArray</nidx>
+<nidx>freezeFloatArray</nidx>
+<nidx>freezeDoubleArray</nidx>
+<nidx>unsafeFreezeArray</nidx>
+<nidx>unsafeFreezeByteArray</nidx>
+<nidx>thawArray</nidx>
<sect2>The @ByteArray@ interface
<label id="sec:byte-array">
%************************************************************************
%* *
<sect3>The @Concurrent@ interface (recommended)
+<label id="concurrent-interface">
<p>
<nidx>Concurrent interface</nidx>
%* *
collection of useful concurrency abstractions, including those
mentioned in the ``concurrent paper''.
-Just put @import Concurrent@ into your modules, and away you go.
-To create a ``required thread'':
+Just add the flag @-syslib concurrent@ to your GHC command line and
+put @import Concurrent@ into your modules, and away you go. To create
+a ``required thread'':
<tscreen><verb>
-forkIO :: IO a -> IO a
+forkIO :: IO () -> IO ThreadId
</verb></tscreen>
-The @Concurrent@ interface also provides access to ``I-Vars''
-and ``M-Vars'', which are two flavours of <em>synchronising variables</em>.
-<nidx>synchronising variables (Glasgow extension)</nidx>
-<nidx>concurrency -- synchronising variables</nidx>
+where @ThreadId@ is an abstract type representing a handle to the
+newly created thread. Threads may also be killed:
-@IVars@<nidx>IVars (Glasgow extension)</nidx> are write-once
-variables. They start out empty, and any threads that attempt to read
-them will block until they are filled. Once they are written, any
-blocked threads are freed, and additional reads are permitted.
-Attempting to write a value to a full @IVar@ results in a runtime
-error. Interface:
<tscreen><verb>
-newIVar :: IO (IVar a)
-readIVar :: IVar a -> IO a
-writeIVar :: IVar a -> a -> IO ()
+killThread :: ThreadId -> IO ()
</verb></tscreen>
+this terminates the given thread. Any work already done by the thread
+isn't lost: the computation is suspended until required by another
+thread. The memory used by the thread will be garbage collected if it
+isn't referenced from anywhere else.
+
+NOTE: if you have a @ThreadId@, you essentially have a pointer to the
+thread itself. This means the thread itself can't be garbage
+collected until you drop the @ThreadId@. This misfeature will
+hopefully be corrected at a later date.
+
+The @Concurrent@ interface also provides access to ``M-Vars'', which
+are <em>synchronising variables</em>.
+
+<nidx>synchronising variables (Glasgow extension)</nidx>
+<nidx>concurrency -- synchronising variables</nidx>
+
@MVars@<nidx>MVars (Glasgow extension)</nidx> are rendezvous points,
-mostly for concurrent threads. They begin empty, and any attempt to
-read an empty @MVar@ blocks. When an @MVar@ is written, a
-single blocked thread may be freed. Reading an @MVar@ toggles its
-state from full back to empty. Therefore, any value written to an
-@MVar@ may only be read once. Multiple reads and writes are
-allowed, but there must be at least one read between any two
+mostly for concurrent threads. They begin either empty or full, and
+any attempt to read an empty @MVar@ blocks. When an @MVar@ is
+written, a single blocked thread may be freed. Reading an @MVar@
+toggles its state from full back to empty. Therefore, any value
+written to an @MVar@ may only be read once. Multiple reads and writes
+are allowed, but there must be at least one read between any two
writes. Interface:
+
<tscreen><verb>
newEmptyMVar :: IO (MVar a)
newMVar :: a -> IO (MVar a)
A <em>Sample variable</em> (@SampleVar@) is slightly different from a
normal @MVar@:
+
<itemize>
<item> Reading an empty @SampleVar@ causes the reader to block
(same as @takeMVar@ on empty @MVar@).
%************************************************************************
%* *
-\subsubsubsection{The @Parallel@ interface (recommended)}
+<sect3>The @Parallel@ interface (recommended)
<nidx>Parallel interface</nidx>
+<p>
%* *
%************************************************************************
GHC provides two functions for controlling parallel execution, through
the @Parallel@ interface:
+
<tscreen><verb>
interface Parallel where
infixr 0 `par`
%************************************************************************
%* *
-\subsubsubsection{Underlying functions and primitives}
+<sect3>Underlying functions and primitives
<nidx>parallelism primitives</nidx>
<nidx>primitives for parallelism</nidx>
+<p>
%* *
%************************************************************************
you'd like to see this with your very own eyes, just run GHC with the
@-ddump-simpl@ option. (Anything for a good time...)
-You can use @par@ and @seq@ in Concurrent Haskell, though
-I'm not sure why you would want to.
-
%************************************************************************
%* *
-<sect2>Features common to Concurrent and Parallel Haskell
-<p>
-%* *
-%************************************************************************
-
-Actually, you can use the @`par`@ and @`seq`@ combinators
-(really for Parallel Haskell) in Concurrent Haskell as well.
-But doing things like ``@par@ to @forkIO@ many required threads''
-counts as ``jumping out the 9th-floor window, just to see what happens.''
-
-%************************************************************************
-%* *
-\subsubsubsection{Scheduling policy for concurrent/parallel threads}
+<sect3>Scheduling policy for concurrent/parallel threads
<nidx>Scheduling---concurrent/parallel</nidx>
<nidx>Concurrent/parallel scheduling</nidx>
+<p>
%* *
%************************************************************************
Runnable threads are scheduled in round-robin fashion. Context
switches are signalled by the generation of new sparks or by the
expiry of a virtual timer (the timer interval is configurable with the
-@-C[<num>]@<nidx>-C<num> RTS option (concurrent, parallel)</nidx> RTS option).
-However, a context switch doesn't really happen until the next heap
-allocation. If you want extremely short time slices, the @-C@ RTS
-option can be used to force a context switch at each and every heap
-allocation.
+@-C[<num>]@<nidx>-C<num> RTS option (concurrent,
+parallel)</nidx> RTS option). However, a context switch doesn't
+really happen until the current heap block is full. You can't get any
+faster context switching than this.
When a context switch occurs, pending sparks which have not already
been reduced to weak head normal form are turned into new threads.
-<sect1>Profiling
+<sect>Profiling
<label id="profiling">
<p>
<nidx>profiling, with cost-centres</nidx>
purpose is to help you improve your understanding of your program's
execution behaviour, so you can improve it.
-Any comments, suggestions and/or improvements you have to are welcome.
+Any comments, suggestions and/or improvements you have are welcome.
Recommended ``profiling tricks'' would be especially cool!
-<sect2>How to profile a Haskell program
+<sect1>How to profile a Haskell program
<label id="profiling-intro">
<p>
system. Just visit the <url name="Glasgow FP group web page"
url="http://www.dcs.gla.ac.uk/fp/">...
-<sect2>Compiling programs for profiling
+<sect1>Compiling programs for profiling
<label id="prof-compiler-options">
<p>
<nidx>profiling options</nidx>
%-prof-details should also enable age profiling if we get it going again ...
-<sect2>How to control your profiled program at runtime
+<sect1>How to control your profiled program at runtime
<label id="prof-rts-options">
<p>
<nidx>profiling RTS options</nidx>
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).
-<sect2>What's in a profiling report?
+<sect1>What's in a profiling report?
<label id="prof-output">
<p>
<nidx>profiling report, meaning thereof</nidx>
just a particular form for a function.
</descrip>
-<sect2>Producing graphical heap profiles
+<sect1>Producing graphical heap profiles
<label id="prof-graphs">
<p>
<nidx>heap profiles, producing</nidx>
Utility programs which produce graphical profiles.
-<sect3>@hp2ps@--heap profile to PostScript
+<sect2>@hp2ps@--heap profile to PostScript
<label id="hp2ps">
<p>
<nidx>hp2ps (utility)</nidx>
ensuring that all the data will be displayed.
<tag>@-?@</tag> Print out usage information.
-
-<tag>@-c@</tag> Fill in the bands with colours rather than shades of grey.
-Some people find colour plots easier to read (especially when viewed on a
-non-monochrome medium ;-)
</descrip>
-<sect3>@stat2resid@---residency info from GC stats
+<sect2>@stat2resid@---residency info from GC stats
<label id="stat2resid">
<p>
<nidx>stat2resid (utility)</nidx>
%************************************************************************
%* *
-<sect2>Using ``ticky-ticky'' profiling (for implementors)
+<sect1>Using ``ticky-ticky'' profiling (for implementors)
<label id="ticky-ticky">
<p>
<nidx>ticky-ticky profiling (implementors)</nidx>
@-RTS@<nidx>-RTS option</nidx> as its own. For example:
<tscreen><verb>
-% ./a.out -f +RTS -pT -S -RTS -h foo bar
+% ./a.out -f +RTS -p -S -RTS -h foo bar
</verb></tscreen>
-The RTS will snaffle @-pT -S@ for itself, and the remaining arguments
+The RTS will snaffle @-p -S@ for itself, and the remaining arguments
@-f -h foo bar@ will be handed to your program if/when it calls
@System.getArgs@.
the end of the command line, as in this example:
<tscreen><verb>
-% hls -ltr /usr/etc +RTS -H5m
+% hls -ltr /usr/etc +RTS -A5m
</verb></tscreen>
If you absolutely positively want all the rest of the options in a
%************************************************************************
%* *
-<sect2>Generally-available RTS options
+<sect2>RTS options to control the garbage-collector
+<label id="rts-options-gc">
<p>
-<nidx>RTS options, general</nidx>
+<nidx>RTS options, garbage-collection</nidx>
%* *
%************************************************************************
-The most important RTS options are:
+There are several options to give you precise control over garbage
+collection. Hopefully, you won't need any of these in normal
+operation, but there are several things that can be tweaked for
+maximum performance.
+
<descrip>
-<tag>@-H<size>@:</tag>
-<nidx>-H<size> RTS option</nidx>
-Set the heap size to @<size>@ bytes
-[default: 4M].
+<tag>@-A<size>@:</tag>
+<nidx>-A<size> RTS option</nidx>
+<nidx>allocation area, size</nidx>
+
+[Default: 256k] Set the minimum (and initial) allocation area size
+used by the garbage collector. The allocation area is resized after
+each garbage collection to be a multiple of the size of the current
+live data (currently a factor of 2).
+
+Increasing the minimum allocation area size will typically give better
+performance for programs which quickly generate a large amount of live
+data.
+
+<tag>@-k<size>@:</tag>
+<nidx>-k<size> RTS option</nidx>
+<nidx>stack, minimum size</nidx>
+
+[Default: 1k] Set the initial stack size for new threads. Thread
+stacks (including the main thread's stack) live on the heap, and grow
+as required. The default value is good for concurrent applications
+with lots of small threads; if your program doesn't fit this model
+then increasing this option may help performance.
+
+The main thread is normally started with a slightly larger heap to cut
+down on unnecessary stack growth while the program is starting up.
<tag>@-K<size>@:</tag>
<nidx>-K<size> RTS option</nidx>
-Set the stack size to @<size>@ bytes [default: 64K].
-For concurrent/parallel programs, it is the stack size of the main
-thread; generally speaking, c/p stacks are in heap.
+<nidx>stack, maximum size</nidx>
-Note: if your program seems to be consuming infinite stack space, it
-is probably in a loop :-) Of course, if stacks are in the heap, make
-that infinite <em>heap</em> space...
+[Default: 1M] Set the maximum stack size for an individual thread to
+@<size>@ bytes. This option is there purely to stop the program
+eating up all the available memory in the machine if it gets into an
+infinite loop.
+
+<tag>@-m<n>@:</tag>
+<nidx>-m<n> RTS option</nidx>
+Minimum \% @<n>@ of heap which must be available for allocation.
+The default is 3\%.
+<nidx>heap, minimum free</nidx>
+
+<tag>@-M<size>@:</tag>
+<nidx>-M<size> RTS option</nidx>
+<nidx>heap size, maximum</nidx>
+
+[Default: 64M] Set the maximum heap size to @<size>@ bytes. The heap
+normally grows and shrinks according to the memory requirements of the
+program. The only reason for having this option is to stop the heap
+growing without bound and filling up all the available swap space,
+which at the least will result in the program being summarily killed
+by the operating system.
<tag>@-s<file>@ or @-S<file>@:</tag>
<nidx>-S<file> RTS option</nidx>
@<program>@@.stat@. The @<file>@ @stderr@ is treated
specially, with the output really being sent to @stderr@.
-The amount of heap allocation will typically increase as the total
-heap size is reduced. The reason for this odd behaviour is that
-updates of promoted-to-old-generation objects may require the extra
-allocation of a new-generation object to ensure that there are never
-any pointers from the old generation to the new generation.
+This option is useful for watching how the storage manager adjusts the
+heap size based on the current amount of live data.
-For some garbage collectors (not including the default one, sadly),
-you can convert the @-S@ output into a residency graph (in
-PostScript), using the @stat2resid@<nidx>stat2resid</nidx> utility in
-the GHC distribution (@ghc/utils/stat2resid@).
+% ToDo: --SDM
+%For some garbage collectors (not including the default one, sadly),
+%you can convert the @-S@ output into a residency graph (in
+%PostScript), using the @stat2resid@<nidx>stat2resid</nidx> utility in
+%the GHC distribution (@ghc/utils/stat2resid@).
-<tag>@-N@:</tag>
-<nidx>-N RTS option</nidx>
-Normally, the garbage collector black-holes closures which are being
-evaluated, as a space-saving measure. That's exactly what you want
-for ordinary Haskell programs.
-
-When signal handlers are present, however, a computation may be
-abandoned prematurely, leaving black holes behind. If the signal
-handler shares one of these black-holed closures, disaster can result.
-Use the @-N@ option to prevent black-holing by the garbage collector
-if you suspect that your signal handlers may share <em>any</em>
-subexpressions with the top-level computation. Expect your heap usage
-to increase, since the lifetimes of some closures may be extended.
-</descrip>
+<tag>@-F2s@:</tag>
+<nidx>-F2s RTS option</nidx>
-%************************************************************************
-%* *
-<sect2>RTS options to control the garbage-collector
-<p>
-<nidx>RTS options, garbage-collection</nidx>
-%* *
-%************************************************************************
-
-Besides the @-H@ (set heap size) and @-S@/@-s@ (GC stats) RTS
-options, there are several options to give you precise control over
-garbage collection.
-
-<descrip>
-<tag>@-M<n>@:</tag>
-<nidx>-M<n> RTS option</nidx>
-Minimum \% @<n>@ of heap which must be available for allocation.
-The default is 3\%.
-
-<tag>@-A<size>@:</tag>
-<nidx>-A<size> RTS option</nidx>
-Sets a limit on the size of the allocation area for generational
-garbage collection to @<size>@ bytes (@-A@ gives default of 64k). If
-a negative size is given the size of the allocation is fixed to
--@<size>@. For non-generational collectors, it fixes the minimum
-heap which must be available after a collection, overriding the
-@-M<n>@ RTS option.
-
-<tag>@-G<size>@:</tag>
-<nidx>-G<size> RTS option</nidx>
-Sets the percentage of free space to be promoted before a major
-collection is invoked to @<size>@\%. The default is 66\%. If a
-negative size is given it fixes the size of major generation threshold
-to -@<size>@ bytes.
-
-<tag>@-F2s@:</tag> <nidx>-F2s RTS option</nidx> Forces a program
-compiled for generational GC to use two-space copying collection. The
-two-space collector may outperform the generational collector for
-programs which have a very low heap residency. It can also be used to
-generate a statistics file from which a basic heap residency profile
-can be produced (see Section <ref name="stat2resid - residency info
-from GC stats" id="stat2resid">).
+Forces a program compiled for generational GC to use two-space copying
+collection. The two-space collector may outperform the generational
+collector for programs which have a very low heap residency. It can
+also be used to generate a statistics file from which a basic heap
+residency profile can be produced (see Section <ref name="stat2resid -
+residency info from GC stats" id="stat2resid">).
There will still be a small execution overhead imposed by the
generational compilation as the test for old generation updates will
Force a major garbage collection every @<size>@ bytes. (Normally
used because you're keen on getting major-GC stats, notably heap residency
info.)
+
</descrip>
%************************************************************************
%* *
%************************************************************************
-The RTS options related to profiling are described in Section <ref name="How to control your profiled program at runtime" id="prof-rts-options">; and those for concurrent/parallel stuff, in
-Section <ref name="RTS options for Concurrent/Parallel Haskell" id="parallel-rts-opts">.
+The RTS options related to profiling are described in Section <ref
+name="How to control your profiled program at runtime"
+id="prof-rts-options">; and those for concurrent/parallel stuff, in
+Section <ref name="RTS options for Concurrent/Parallel Haskell"
+id="parallel-rts-opts">.
%************************************************************************
%* *
<tag>@-r<file>@:</tag>
<nidx>-r <file> RTS option</nidx>
+<nidx>ticky ticky profiling</nidx>
Produce ``ticky-ticky'' statistics at the end of the program run.
The @<file>@ business works just like on the @-S@ RTS option (above).
``Ticky-ticky'' statistics are counts of various program actions
-(updates, enters, etc.)
-The program must have been compiled using
+(updates, enters, etc.) The program must have been compiled using
@-fstg-reduction-counts@<nidx>-fstg-reduction-counts option</nidx>
(a.k.a. ``ticky-ticky profiling''), and, for it to be really useful,
linked with suitable system libraries. Not a trivial undertaking:
-consult the installation guide on how to set things up for
-easy ``ticky-ticky'' profiling.
+consult the installation guide on how to set things up for easy
+``ticky-ticky'' profiling.
+
+<tag>@-D<num>@:</tag>
+<nidx>-D RTS option</nidx>
+An RTS debugging flag; varying quantities of output depending on which
+bits are set in @<num>@. Only works if the RTS was compiled with the
+@DEBUG@ option.
+
+<tag>@-N@:</tag>
+<nidx>-N RTS option</nidx>
+
+Normally, the garbage collector black-holes closures which are being
+evaluated, as a space-saving measure. This option turns off
+blackholing. You shouldn't ever need to use it.
-<tag>@-T<num>@:</tag>
-<nidx>-T RTS option</nidx>
-An RTS debugging flag; varying quantities of output depending on which bits
-are set in @<num>@.
+Historical note: this option used to be used to work around a problem
+with signal handling, where a signal handler might need to evaluate
+blackholed closures. Signal handlers are now run in a separate
+thread, and don't suffer from this problem.
<tag>@-Z@:</tag>
<nidx>-Z RTS option</nidx>
If it says you're using more than 20\% of total time in garbage
collecting, then more memory would help.
-You ask for more heap with the @-H<size>@<nidx>-H<size> option</nidx>
-option; e.g.: @ghc -c -O -H16m Foo.hs@.
+If the heap size is approaching the maximum (64M by default), and you
+have lots of memory, try increasing the maximum with the
+@-M<size>@<nidx>-M<size> option</nidx> option, e.g.: @ghc -c -O
+-M16m Foo.hs@.
+
+Increasing the default allocation area size used by the compiler's RTS
+might also help: use the @-A<size>@<nidx>-A<size> option</nidx>
+option.
If GHC persists in being a bad memory citizen, please report it as a
bug.
%----------------------------------------------------------------
<tag>Don't use too much memory!</tag>
-As soon as GHC plus its ``fellow citizens'' (other processes on your machine) start
-using more than the <em>real memory</em> on your machine, and the machine
-starts ``thrashing,'' <em>the party is over</em>. Compile times will be
-worse than terrible! Use something like the csh-builtin @time@
-command to get a report on how many page faults you're getting.
+As soon as GHC plus its ``fellow citizens'' (other processes on your
+machine) start using more than the <em>real memory</em> on your
+machine, and the machine starts ``thrashing,'' <em>the party is
+over</em>. Compile times will be worse than terrible! Use something
+like the csh-builtin @time@ command to get a report on how many page
+faults you're getting.
If you don't know what virtual memory, thrashing, and page faults are,
-or you don't know the memory configuration of your machine, <em>don't</em> try to be clever about memory use: you'll just make your life a
-misery (and for other people, too, probably).
+or you don't know the memory configuration of your machine,
+<em>don't</em> try to be clever about memory use: you'll just make
+your life a misery (and for other people, too, probably).
%----------------------------------------------------------------
<tag>Try to use local disks when linking:</tag>
Because Haskell objects and libraries tend to be large, it can take
-many real seconds to slurp the bits to/from an NFS filesystem (say).
+many real seconds to slurp the bits to/from a remote filesystem.
It would be quite sensible to <em>compile</em> on a fast machine using
remotely-mounted disks; then <em>link</em> on a slow machine that had
@-fno-strictness@<nidx>-fno-strictness anti-option</nidx> and
@-fno-update-analysis@.<nidx>-fno-update-analysis anti-option</nidx>
-If @-ddump-simpl@ produces output after a reasonable time, but
-@-ddump-stg@ doesn't, then it's probably the update analyser
-slowing you down.
+To figure out which part of the compiler is badly behaved, the
+@-dshow-passes@<nidx>-dshow-passes option</nidx> option is your
+friend.
If your module has big wads of constant data, GHC may produce a huge
basic block that will cause the native-code generator's register
-allocator to founder.
-
-If @-ddump-absC@ produces output after a reasonable time, but
-nothing after that---it's probably the native-code generator. Bring
-on @-fvia-C@<nidx>-fvia-C option</nidx> (not that GCC will be that quick about it, either).
+allocator to founder. Bring on @-fvia-C@<nidx>-fvia-C option</nidx>
+(not that GCC will be that quick about it, either).
%----------------------------------------------------------------
<tag>Avoid the consistency-check on linking:</tag>
-Use @-no-link-chk@<nidx>-no-link-chk</nidx>; saves effort. This is probably
-safe in a I-only-compile-things-one-way setup.
+
+Use @-no-link-chk@<nidx>-no-link-chk</nidx>; saves effort. This is
+probably safe in a I-only-compile-things-one-way setup.
%----------------------------------------------------------------
<tag>Explicit @import@ declarations:</tag>
-Instead of saying @import Foo@, say
-@import Foo (...stuff I want...)@.
+
+Instead of saying @import Foo@, say @import Foo (...stuff I want...)@.
Truthfully, the reduction on compilation time will be very small.
However, judicious use of @import@ declarations can make a
%************************************************************************
The key tool to use in making your Haskell program run faster are
-GHC's profiling facilities, described separately in
-Section <ref name="Profiling" id="profiling">. There is <em>no substitute</em> for finding
-where your program's time/space is <em>really</em> going, as opposed
-to where you imagine it is going.
+GHC's profiling facilities, described separately in Section <ref
+name="Profiling" id="profiling">. There is <em>no substitute</em> for
+finding where your program's time/space is <em>really</em> going, as
+opposed to where you imagine it is going.
Another point to bear in mind: By far the best way to improve a
-program's performance <em>dramatically</em> is to use better algorithms.
-Once profiling has thrown the spotlight on the guilty
+program's performance <em>dramatically</em> is to use better
+algorithms. Once profiling has thrown the spotlight on the guilty
time-consumer(s), it may be better to re-think your program than to
try all the tweaks listed below.
Another extremely efficient way to make your program snappy is to use
-library code that has been Seriously Tuned By Someone Else. You <em>might</em> be able
-to write a better quicksort than the one in the HBC library, but it
-will take you much longer than typing @import QSort@.
-(Incidentally, it doesn't hurt if the Someone Else is Lennart
+library code that has been Seriously Tuned By Someone Else. You
+<em>might</em> be able to write a better quicksort than the one in the
+HBC library, but it will take you much longer than typing @import
+QSort@. (Incidentally, it doesn't hurt if the Someone Else is Lennart
Augustsson.)
Please report any overly-slow GHC-compiled programs. The current
At present, @-O2@ is nearly indistinguishable from @-O@.
-%At version 2.01, @-O@ is a dodgy proposition, no matter what.
-
%----------------------------------------------------------------
<tag>Compile via C and crank up GCC:</tag> Even with @-O@, GHC tries to
use a native-code generator, if available. But the native
<descrip>
<tag>Give explicit type signatures:</tag>
Signatures are the basic trick; putting them on exported, top-level
-functions is good software-engineering practice, anyway.
+functions is good software-engineering practice, anyway. (Tip: using
+@-fwarn-missing-signatures@<nidx>-fwarn-missing-signatures
+option</nidx> can help enforce good signature-practice).
-The automatic specialisation of overloaded functions should take care
-of overloaded local and/or unexported functions.
+The automatic specialisation of overloaded functions (with @-O@)
+should take care of overloaded local and/or unexported functions.
<tag>Use @SPECIALIZE@ pragmas:</tag>
<nidx>SPECIALIZE pragma</nidx>
(UK spelling also accepted.) For key overloaded functions, you can
create extra versions (NB: more code space) specialised to particular
types. Thus, if you have an overloaded function:
+
<tscreen><verb>
hammeredLookup :: Ord key => [(key, value)] -> key -> value
</verb></tscreen>
+
If it is heavily used on lists with @Widget@ keys, you could
specialise it as follows:
<tscreen><verb>
It's <em>Your Responsibility</em> to make sure that @blah@ really
behaves as a specialised version of @hammeredLookup@!!!
+[NOTE: this feature isn't implemented in GHC 4.00... ]
+
An example in which the @= blah@ form will Win Big:
<tscreen><verb>
toDouble :: Real a => a -> Double
% @SPECIALIZE instance@ pragmas what @= blah@ hacks are to @SPECIALIZE@
% (value) pragmas...
-<tag>``How do I know what's happening with specialisations?'':</tag>
+%ToDo: there's nothing like this at the moment: --SDM
+
+% <tag>``How do I know what's happening with specialisations?'':</tag>
-The @-fshow-specialisations@<nidx>-fshow-specialisations option</nidx>
-will show the specialisations that actually take place.
+% The @-fshow-specialisations@<nidx>-fshow-specialisations option</nidx>
+% will show the specialisations that actually take place.
-The @-fshow-import-specs@<nidx>-fshow-import-specs option</nidx> will
-show the specialisations that GHC <em>wished</em> were available, but
-were not. You can add the relevant pragmas to your code if you wish.
+% The @-fshow-import-specs@<nidx>-fshow-import-specs option</nidx> will
+% show the specialisations that GHC <em>wished</em> were available, but
+% were not. You can add the relevant pragmas to your code if you wish.
-You're a bit stuck if the desired specialisation is of a Prelude
-function. If it's Really Important, you can just snap a copy of the
-Prelude code, rename it, and then SPECIALIZE that to your heart's
-content.
+% You're a bit stuck if the desired specialisation is of a Prelude
+% function. If it's Really Important, you can just snap a copy of the
+% Prelude code, rename it, and then SPECIALIZE that to your heart's
+% content.
<tag>``But how do I know where overloading is creeping in?'':</tag>
single-constructor types).
%----------------------------------------------------------------
+<tag>Newtypes are better than datatypes:</tag>
+
+If your datatype has a single constructor with a single field, use a
+@newtype@ declaration instead of a @data@ declaration. The @newtype@
+will be optimised away in most cases.
+
+%----------------------------------------------------------------
<tag>``How do I find out a function's strictness?''</tag>
Don't guess---look it up.
#endif
</verb></tscreen>
-GHC reserves the right to <em>disallow</em> any unfolding, even if you
-explicitly asked for one. That's because a function's body may
-become <em>unexportable</em>, because it mentions a non-exported value,
-to which any importing module would have no access.
-
-If you want to see why candidate unfoldings are rejected, use the
-@-freport-disallowed-unfoldings@
-<nidx>-freport-disallowed-unfoldings</nidx>
-option.
+Incedentally, there's also a @NOINLINE@<nidx>NOINLINE pragma</nidx>
+pragma which does the obvious thing.
%----------------------------------------------------------------
<tag>Explicit @export@ list:</tag>
If you do not have an explicit export list in a module, GHC must
assume that everything in that module will be exported. This has
-various pessimising effect. For example, if a bit of code is actually
+various pessimising effects. For example, if a bit of code is actually
<em>unused</em> (perhaps because of unfolding effects), GHC will not be
able to throw it away, because it is exported and some other module
may be relying on its existence.
%----------------------------------------------------------------
<tag>Use unboxed types (a GHC extension):</tag>
-When you are <em>really</em> desperate for speed, and you want to
-get right down to the ``raw bits.''
-Please see Section <ref name="Unboxed types" id="glasgow-unboxed"> for some information about
-using unboxed types.
+When you are <em>really</em> desperate for speed, and you want to get
+right down to the ``raw bits.'' Please see Section <ref name="Unboxed
+types" id="glasgow-unboxed"> for some information about using unboxed
+types.
%----------------------------------------------------------------
<tag>Use @_ccall_s@ (a GHC extension) to plug into fast libraries:</tag>
floating-point unit for both. With @Doubles@, you are much less
likely to hang yourself with numerical errors.
+One time when @Float@ might be a good idea is if you have a
+<em>lot</em> of them, say a giant array of @Float@s. They take up
+half the space in the heap compared to @Doubles@. However, this isn't
+true on a 64-bit machine.
+
%----------------------------------------------------------------
<tag>Use a bigger heap!</tag>
+
If your program's GC stats (@-S@<nidx>-S RTS option</nidx> RTS option)
indicate that it's doing lots of garbage-collection (say, more than
20\% of execution time), more memory might help---with the
-@-H<size>@<nidx>-H<size> RTS option</nidx> RTS option.
-
-%----------------------------------------------------------------
-<tag>Use a smaller heap!</tag>
-Some programs with a very small heap residency (toy programs, usually)
-actually benefit from running the heap size way down. The
-@-H<size>@ RTS option, as above.
-
-%----------------------------------------------------------------
-<tag>Use a smaller ``allocation area'':</tag>
-If you can get the garbage-collector's youngest generation to fit
-entirely in your machine's cache, it may make quite a difference.
-The effect is <em>very machine dependent</em>. But, for example,
-a @+RTS -A128k@<nidx>-A<size> RTS option</nidx> option on one of our
-DEC Alphas was worth an immediate 5\% performance boost.
+@-M<size>@<nidx>-M<size> RTS option</nidx> or
+@-A<size>@<nidx>-A<size> RTS option</nidx> RTS options (see
+Section <ref name="RTS options to control the garbage-collector"
+id="rts-options-gc">).
</descrip>
%************************************************************************
%* *
%************************************************************************
-Decrease the ``go-for-it'' threshold for unfolding smallish expressions.
-Give a @-funfolding-use-threshold0@<nidx>-funfolding-use-threshold0 option</nidx>
-option for the extreme case. (``Only unfoldings with zero cost should proceed.'')
-
-(Note: I have not been too successful at producing code smaller
-than that which comes out with @-O@. WDP 94/12)
+Decrease the ``go-for-it'' threshold for unfolding smallish
+expressions. Give a
+@-funfolding-use-threshold0@<nidx>-funfolding-use-threshold0
+option</nidx> option for the extreme case. (``Only unfoldings with
+zero cost should proceed.'') Warning: except in certain specialiised
+cases (like Happy parsers) this is likely to actually
+<em>increase</em> the size of your program, because unfolding
+generally enables extra simplifying optimisations to be performed.
Avoid @Read@.
might be even easier with the @-F2s@<nidx>-F2s RTS option</nidx> RTS
option; so... @./a.out +RTS -Sstderr -F2s@...]
-Once again, the profiling facilities (Section <ref name="Profiling" id="profiling">) are the
-basic tool for demystifying the space behaviour of your program.
+Once again, the profiling facilities (Section <ref name="Profiling"
+id="profiling">) are the basic tool for demystifying the space
+behaviour of your program.
-Strict functions are good to space usage, as they are for time, as
+Strict functions are good for space usage, as they are for time, as
discussed in the previous section. Strict functions get right down to
business, rather than filling up the heap with closures (the system's
notes to itself about how to evaluate something, should it eventually
be required).
-
-If you have a true blue ``space leak'' (your program keeps gobbling up
-memory and never ``lets go''), then 7 times out of 10 the problem is
-related to a <em>CAF</em> (constant applicative form). Real people call
-them ``top-level values that aren't functions.'' Thus, for example:
-<tscreen><verb>
-x = (1 :: Int)
-f y = x
-ones = [ 1, (1 :: Float), .. ]
-</verb></tscreen>
-@x@ and @ones@ are CAFs; @f@ is not.
-
-The GHC garbage collectors are not clever about CAFs. The part of the
-heap reachable from a CAF is never collected. In the case of
-@ones@ in the example above, it's <em>disastrous</em>. For this
-reason, the GHC ``simplifier'' tries hard to avoid creating CAFs, but
-it cannot subvert the will of a determined CAF-writing programmer (as
-in the case above).
+++ /dev/null
-<!doctype linuxdoc system>
-<article>
-
-<title>The Glasgow Haskell Compiler User's Guide, Version~3.02
-<author>The GHC Team,
-Department of Computing Science,
-University of Glasgow,
-Glasgow, Scotland,
-G12 8QQ
-
-Email: @glasgow-haskell-{bugs,users}-request@@dcs.gla.ac.uk@
-
-<toc>
--- /dev/null
+<!doctype linuxdoc system [
+ <!ENTITY intro SYSTEM "intro.sgml" >
+ <!ENTITY relnotes SYSTEM "4-01-notes.sgml" >
+ <!ENTITY using SYSTEM "using.sgml" >
+ <!ENTITY runtime SYSTEM "runtime_control.sgml" >
+ <!ENTITY prof SYSTEM "profiling.sgml" >
+ <!ENTITY debug SYSTEM "debugging.sgml" >
+ <!ENTITY sooner SYSTEM "sooner.sgml" >
+ <!ENTITY lang SYSTEM "lang.sgml" >
+ <!ENTITY glaexts SYSTEM "glasgow_exts.sgml" >
+ <!ENTITY parallel SYSTEM "parallel.sgml" >
+ <!ENTITY vs-hs SYSTEM "vs_haskell.sgml" >
+ <!ENTITY libs SYSTEM "libraries.sgml" >
+ <!ENTITY posix SYSTEM "posix.sgml" >
+ <!ENTITY libmisc SYSTEM "libmisc.sgml" >
+ <!ENTITY wrong SYSTEM "gone_wrong.sgml" >
+ <!ENTITY utils SYSTEM "utils.sgml" >
+]>
+<article>
+
+<title>The Glasgow Haskell Compiler User's Guide, Version~4.01
+<author>The GHC Team,
+Department of Computing Science,
+University of Glasgow,
+Glasgow, Scotland,
+G12 8QQ
+
+Email: @glasgow-haskell-{bugs,users}-request@@dcs.gla.ac.uk@
+
+<toc>
+
+&intro
+&relnotes
+&using
+ &runtime
+ &debug
+&prof
+&sooner
+&lang
+ &glaexts
+ ¶llel
+ &vs-hs
+&libs
+ &posix
+ &libmisc
+&wrong
+&utils
+
+</article>
%************************************************************************
The basic task of the @ghc@ driver is to run each input file
-through the right phases (parsing, linking, etc.).
+through the right phases (compiling, linking, etc.).
The first phase to run is determined by the input-file suffix, and the
last phase is determined by a flag. If no relevant flag is present,
<nidx>standard error, saving</nidx>
Sometimes, you may cause GHC to be rather chatty on standard error;
-with @-dshow-rn-trace@, for example. You can instruct GHC to
-<em>append</em> this output to a particular log file with a @-odump
-<blah>@<nidx>-odump <blah> option</nidx> option.
+with @-v@, for example. You can instruct GHC to <em>append</em> this
+output to a particular log file with a @-odump <blah>@<nidx>-odump
+<blah> option</nidx> option.
<sect2> Redirecting temporary files
<label id="temp-files">
messages, otherwise known as warnings, can be generated during
compilation. By default, you get a standard set of warnings which are
generally likely to indicate bugs in your program. These are:
-@-fwarn-overlapping-patterns@, @-fwarn-duplicate-exports@, and
+@-fwarn-overlpapping-patterns@, @-fwarn-duplicate-exports@, and
@-fwarn-missing-methods@. The following flags are simple ways to
select standard ``packages'' of warnings:
Consequently, this option does <em>not</em> allow cyclic recursive
definitions.
-<tag>@-fwarn-hi-shadowing@:</tag>
-<nidx>-fwarn-hi-shadowing option</nidx>
-<nidx>interface files, shadowing</nidx>
-
-Warns you about shadowing of interface files along the supplied import path.
-For instance, assuming you invoke @ghc@ with the import path
-@-iutils:src@ and @Utils.hi@ exist in both the @utils@ and @src@
-directories, @-fwarn-hi-shadowing@ will warn you that @utils/Utils.hi@
-shadows @src/Utils.hi@.
-
<tag>@-fwarn-overlapping-patterns@:</tag>
<nidx>-fwarn-overlapping-patterns option</nidx>
<nidx>overlapping patterns, warning</nidx>
<nidx>patterns, overlapping</nidx>
-By default, the compiler will warn you if a set of patterns are either
-incomplete (i.e., you're only matching on a subset of an algebraic
-data type's constructors), or overlapping, i.e.,
+By default, the compiler will warn you if a set of patterns are
+overlapping, i.e.,
<tscreen><verb>
f :: String -> Int
f [] = 0
f (_:xs) = 1
f "2" = 2
-
-g [] = 2
</verb></tscreen>
where the last pattern match in @f@ won't ever be reached, as the
<nidx>incomplete patterns, warning</nidx>
<nidx>patterns, incomplete</nidx>
-Similarly for incomplete patterns, the function @g@ will fail when
-applied to non-empty lists, so the compiler will emit a warning about
-this when this option is enabled.
+Similarly for incomplete patterns, the function @g@ below will fail
+when applied to non-empty lists, so the compiler will emit a warning
+about this when @-fwarn-incomplete-patterns@ is enabled.
+
+<tscreen><verb>
+g [] = 2
+</verb></tscreen>
+
+This option isn't enabled be default because it can be a bit noisy,
+and it doesn't always indicate a bug in the program. However, it's
+generally considered good practice to cover all the cases in your
+functions.
<tag>@-fwarn-missing-methods@:</tag>
<nidx>-fwarn-missing-methods option</nidx>
This option is on by default.
-</descrip>
+<tag>@-fwarn-missing-signatures@:</tag>
+<nidx>-fwarn-missing-signatures option</nidx>
+<nidx>type signatures, missing</nidx>
+
+If you would like GHC to check that every top-level function/value has
+a type signature, use the @-fwarn-missing-signatures@ option. This
+option is off by default.
-If you would like GHC to check that every top-level value has a type
-signature, use the @-fsignatures-required@
-option.<nidx>-fsignatures-required option</nidx>
+</descrip>
If you're feeling really paranoid, the @-dcore-lint@
option<nidx>-dcore-lint option</nidx> is a good choice. It turns on
When GHC compiles a source file @F@ which contains a module @A@, say,
it generates an object @F.o@, <em>and</em> a companion <em>interface
-file</em> @A.hi@.
+file</em> @A.hi@. The interface file is not intended for human
+consumption, as you'll see if you take a look at one. It's merely
+there to help the compiler compile other modules in the same program.
NOTE: Having the name of the interface file follow the module name and
not the file name, means that working with tools such as @make(1)@
nicely.
Putting inter-dependencies of the form @Foo.o : Bar.hi@ into your
-@Makefile@ by hand is rather error-prone. @ghc@ offers you a helping
-hand with it's @-M@ option. To automatically generate
-inter-dependencies, add the following to your @Makefile@:
+@Makefile@ by hand is rather error-prone. Don't worry---never fear,
+@mkdependHS@ is here! (and is distributed as part of GHC) Add the
+following to your @Makefile@:
<tscreen><verb>
depend :
- $(HC) -M $(HC_OPTS) $(SRCS)
+ mkdependHS -- $(HC_OPTS) -- $(SRCS)
</verb></tscreen>
Now, before you start compiling, and any time you change the @imports@
in your program, do @make depend@ before you do @make cool_pgm@.
-@ghc -M@ will then append the needed dependencies to your @Makefile@.
-
-The dependencies are actually generated by another utility,
-@mkdependHS@, which @ghc -M@ just calls upon. @mkdependHS@ is
-distributed with GHC and is documented in Section <ref name="Makefile
+@mkdependHS@ will append the needed dependencies to your @Makefile@.
+@mkdependHS@ is fully describe in Section <ref name="Makefile
dependencies in Haskell: using mkdependHS" id="mkdependHS">.
A few caveats about this simple scheme:
that module @A@ exports, only the things required by the module that
imports @A@ recursively.
-For the example at hand, the boot interface file for A would like the
-following:
+For the example at hand, the boot interface file for A would look like
+the following:
<tscreen><verb>
-_interface_ A 1
-_exports_
-A(A);
-_declarations_
+__interface A 1 where
+__exports A A f;
+__import PrelBase Int;
1 newtype A = A PrelBase.Int ;
+1 f :: A -> A ;
</verb></tscreen>
The syntax is essentially the same as a normal @.hi@ file
<bf>Note:</bf> This is all a temporary solution, a version of the
compiler that handles mutually recursive properly without the manual
-construction of interface file, is in the works.
+construction of interface files, is in the works.
%************************************************************************
%* *
@-fno-specialise@<nidx>-fno-specialise option</nidx> (automatic
specialisation of overloaded functions [because it makes your code
bigger]) [US spelling also accepted], and
-@-fno-update-analyser@<nidx>-fno-update-analyser option</nidx>
-(update analyser, because it sometimes takes a <em>long</em> time).
+@-fno-update-analysis@<nidx>-fno-update-analysis option</nidx> (update
+analyser, because it sometimes takes a <em>long</em> time). This one
+is only enabled with -O2 anyway.
Should you wish to turn individual flags <em>on</em>, you are advised
to use the @-Ofile@ option, described above. Because the order in
The lower-case incantation, @-fvia-c@, is synonymous.
-<tag>@-funfolding-creation-threshold<n>@:</tag>
-<nidx>-funfolding-creation-threshold option</nidx>
+Compiling via C will probably be slower (in compilation time) than
+using GHC's native code generator.
+
+<tag>@-funfolding-interface-threshold<n>@:</tag>
+<nidx>-funfolding-interface-threshold option</nidx>
<nidx>inlining, controlling</nidx>
<nidx>unfolding, controlling</nidx>
(Default: 30) By raising or lowering this number, you can raise or
lower the amount of pragmatic junk that gets spewed into interface
files. (An unfolding has a ``size'' that reflects the cost in terms
of ``code bloat'' of expanding that unfolding in another module. A
-bigger Core expression would be assigned a bigger cost.)
+bigger function would be assigned a bigger cost.)
+
+<tag>@-funfolding-creation-threshold<n>@:</tag>
+<nidx>-funfolding-creation-threshold option</nidx>
+<nidx>inlining, controlling</nidx>
+<nidx>unfolding, controlling</nidx>
+(Default: 30) This option is similar to
+@-funfolding-interface-threshold@, except that it governs unfoldings
+within a single module. Increasing this figure is more likely to
+result in longer compile times than faster code. The next option is
+more useful:
<tag>@-funfolding-use-threshold<n>@:</tag>
<nidx>-funfolding-use-threshold option</nidx>
<nidx>inlining, controlling</nidx>
<nidx>unfolding, controlling</nidx>
-(Default: 3) By raising or lowering this number, you can make the
-compiler more or less keen to expand unfoldings.
-
-OK, folks, these magic numbers `30' and `3' are mildly arbitrary; they
-are of the ``seem to be OK'' variety. The `3' is the more critical
-one; it's what determines how eager GHC is about expanding unfoldings.
-
-% <tag>@-funfolding-override-threshold<n>@:</tag>
-% (Default: 8) [Pretty obscure]
-W hen deciding what unfoldings from a module should be made available
-% to the rest of the world (via this module's interface), the compiler
-% normally likes ``small'' expressions.
-
-% For example, if it sees @foo = bar@, it will decide that the very
-% small expression @bar@ is a great unfolding for @foo@. But if
-% @bar@ turns out to be @(True,False,True)@, we would probably
-% prefer <em>that</em> for the unfolding for @foo@.
-
-% Should we ``override'' the initial small unfolding from @foo=bar@
-% with the bigger-but-better one? Yes, if the bigger one's ``size'' is
-% still under the ``override threshold.'' You can use this flag to
-% adjust this threshold (why, I'm not sure).
-
-% <tag>@-fliberated-case-threshold<n>@:</tag>
-% (Default: 12) [Vastly obscure: NOT IMPLEMENTED YET]
-% ``Case liberation'' lifts evaluation out of recursive functions; it
-% does this by duplicating code. Done without constraint, you can get
-% serious code bloat; so we only do it if the ``size'' of the duplicated
-% code is smaller than some ``threshold.'' This flag can fiddle that
-% threshold.
+(Default: 8) This is the magic cut-off figure for unfolding: below
+this size, a function definition will be unfolded at the call-site,
+any bigger and it won't. The size computed for a function depends on
+two things: the actual size of the expression minus any discounts that
+apply (see @-funfolding-con-discount@).
+
+<tag>@-funfolding-con-discount<n>@:</tag>
+<nidx>-funfolding-con-discount option</nidx>
+<nidx>inlining, controlling</nidx>
+<nidx>unfolding, controlling</nidx>
+(Default: 2) If the compiler decides that it can eliminate some
+computation by performing an unfolding, then this is a discount factor
+that it applies to the funciton size before deciding whether to unfold
+it or not.
+
+OK, folks, these magic numbers `30', `8', and '2' are mildly
+arbitrary; they are of the ``seem to be OK'' variety. The `8' is the
+more critical one; it's what determines how eager GHC is about
+expanding unfoldings.
<tag>@-fsemi-tagging@:</tag>
This option (which <em>does not work</em> with the native-code generator)
<tag>@-D<foo>@:</tag>
<nidx>-D<name> option</nidx>
Define macro @<foo>@ in the usual way. NB: does <em>not</em> affect
-@-D@ macros passed to the C~compiler when compiling via C! For
-those, use the @-optc-Dfoo@ hack...
+@-D@ macros passed to the C~compiler when compiling via C! For those,
+use the @-optc-Dfoo@ hack... (see Section <ref name="Forcing options
+to a particular phase." id="forcing-options-through">).
<tag>@-U<foo>@:</tag>
<nidx>-U<name> option</nidx>
<descrip>
<tag>@__HASKELL1__@:</tag>
<nidx>__HASKELL1__ macro</nidx>
-If defined to $n$, that means GHC supports the
-Haskell language defined in the Haskell report version $1.n$.
+If defined to <em/n/, that means GHC supports the
+Haskell language defined in the Haskell report version <em/1.n/.
Currently 4.
-NB: This macro is set both when pre-processing Haskell source and
-when pre-processing generated C (@.hc@) files.
+NB. This macro is <em/only/ set when pre-processing Haskell source
+(ie. @.hs@ or @.lhs@ files).
<tag>@__GLASGOW_HASKELL__@:</tag>
<nidx>__GLASGOW_HASKELL__ macro</nidx>
-For version $n$ of the GHC system, this will be @#define@d to
-$100 \times n$. So, for version~3.00, it is 300.
-
-This macro is <em>only</em> set when pre-processing Haskell source.
-(<em>Not</em> when pre-processing generated C.)
+For version <em/n/ of the GHC system, this will be @#define@d to
+<em/100n/. So, for version 4.00, it is 400.
With any luck, @__GLASGOW_HASKELL__@ will be undefined in all other
implementations that support C-style pre-processing.
(For reference: the comparable symbols for other systems are:
@__HUGS__@ for Hugs and @__HBC__@ for Chalmers.)
+NB. This macro is set when pre-processing both Haskell source and C
+source, including the C source generated from a Haskell module
+(ie. @.hs@, @.lhs@, @.c@ and @.hc@ files).
+
<tag>@__CONCURRENT_HASKELL__@:</tag>
<nidx>__CONCURRENT_HASKELL__ macro</nidx>
-Only defined when @-concurrent@ is in use!
This symbol is defined when pre-processing Haskell (input) and
-pre-processing C (GHC output).
+pre-processing C (GHC output). Since GHC from verion 4.00 now
+supports concurrent haskell by default, this symbol is always defined.
<tag>@__PARALLEL_HASKELL__@:</tag>
<nidx>__PARALLEL_HASKELL__ macro</nidx>
Section <ref name="Forcing options to a particular phase." id="forcing-options-through">).
A small word of warning: @-cpp@ is not friendly to ``string
-gaps''.<nidx>-cpp vs string gaps</nidx><nidx>string gaps vs -cpp</nidx>. In
-other words, strings such as the following:
+gaps''.<nidx>-cpp vs string gaps</nidx><nidx>string gaps vs
+-cpp</nidx>. In other words, strings such as the following:
<tscreen><verb>
strmod = "\
%* *
%************************************************************************
-To compile a program as Concurrent Haskell, use the @-concurrent@
-option,<nidx>-concurrent option</nidx> both when compiling <em>and
-linking</em>. You will probably need the @-fglasgow-exts@ option, too.
+GHC (as of version 4.00) supports Concurrent Haskell by default,
+without requiring a special option or libraries compiled in a certain
+way. To get access to the support libraries for Concurrent Haskell
+(ie. @Concurrent@ and friends), use the @-syslib concurrent@ option.
Three RTS options are provided for modifying the behaviour of the
threaded runtime system. See the descriptions of @-C[<us>]@, @-q@,
-and @-t<num>@ in Section <ref name="RTS options for Concurrent/Parallel Haskell" id="parallel-rts-opts">.
+and @-t<num>@ in Section <ref name="RTS options for
+Concurrent/Parallel Haskell" id="parallel-rts-opts">.
+
+Concurrent Haskell is described in more detail in Section <ref
+name="Concurrent and Parallel Haskell" id="concurrent-and-parallel">.
%************************************************************************
%* *
%* *
%************************************************************************
-The main thread in a Concurrent Haskell program is given its own
-private stack space, but all other threads are given stack space from
-the heap. Stack space for the main thread can be
-adjusted as usual with the @-K@ RTS
-option,<nidx>-K RTS option (concurrent, parallel)</nidx> but if this
-private stack space is exhausted, the main thread will switch to stack
-segments in the heap, just like any other thread. Thus, problems
-which would normally result in stack overflow in ``sequential Haskell''
-can be expected to result in heap overflow when using threads.
-
-The concurrent runtime system uses black holes as synchronisation
-points for subexpressions which are shared among multiple threads. In
-``sequential Haskell'', a black hole indicates a cyclic data
-dependency, which is a fatal error. However, in concurrent execution, a
-black hole may simply indicate that the desired expression is being
-evaluated by another thread. Therefore, when a thread encounters a
-black hole, it simply blocks and waits for the black hole to be
-updated. Cyclic data dependencies will result in deadlock, and the
-program will fail to terminate.
-
-Because the concurrent runtime system uses black holes as
-synchronisation points, it is not possible to disable black-holing
-with the @-N@ RTS option.<nidx>-N RTS option</nidx> Therefore, the use
-of signal handlers (including timeouts) with the concurrent runtime
-system can lead to problems if a thread attempts to enter a black hole
-that was created by an abandoned computation. The use of signal
-handlers in conjunction with threads is strongly discouraged.
-
+The previous implementation of Concurrent Haskell in GHC had problems
+with using signals handlers in concurrent programs. The current
+system, however, provides thread-safe signal handling (see Section
+<ref name="Signal Handling" id="signals">).
%************************************************************************
%* *
the finest granularity possible, short of a context switch at every
heap allocation.
+[NOTE: this option currently has no effect (version 4.00). Context
+switches happen when the current heap block is full, i.e. every 4k of
+allocation].
+
<tag>@-q[v]@:</tag>
<nidx>-q RTS option</nidx>
-Produce a quasi-parallel profile of thread activity, in the file
-@<program>.qp@. In the style of @hbcpp@, this profile records
-the movement of threads between the green (runnable) and red (blocked)
-queues. If you specify the verbose suboption (@-qv@), the green
-queue is split into green (for the currently running thread only) and
-amber (for other runnable threads). We do not recommend that you use
-the verbose suboption if you are planning to use the @hbcpp@
-profiling tools or if you are context switching at every heap check
-(with @-C@).
+(PARALLEL ONLY) Produce a quasi-parallel profile of thread activity,
+in the file @<program>.qp@. In the style of @hbcpp@, this profile
+records the movement of threads between the green (runnable) and red
+(blocked) queues. If you specify the verbose suboption (@-qv@), the
+green queue is split into green (for the currently running thread
+only) and amber (for other runnable threads). We do not recommend
+that you use the verbose suboption if you are planning to use the
+@hbcpp@ profiling tools or if you are context switching at every heap
+check (with @-C@).
<tag>@-t<num>@:</tag>
<nidx>-t<num> RTS option</nidx>
-Limit the number of concurrent threads per processor to @<num>@.
-The default is 32. Each thread requires slightly over 1K <em>words</em>
-in the heap for thread state and stack objects. (For 32-bit machines,
-this translates to 4K bytes, and for 64-bit machines, 8K bytes.)
+(PARALLEL ONLY) Limit the number of concurrent threads per processor
+to @<num>@. The default is 32. Each thread requires slightly over 1K
+<em>words</em> in the heap for thread state and stack objects. (For
+32-bit machines, this translates to 4K bytes, and for 64-bit machines,
+8K bytes.)
<tag>@-d@:</tag>
<nidx>-d RTS option (parallel)</nidx>
appropriate if your machine has a high communication cost relative to
computation speed.
</descrip>
-
-%************************************************************************
-%* *
-<sect2>Potential problems with Parallel Haskell
-<label id="parallel-problems">
-<p>
-<nidx>Parallel Haskell---problems</nidx>
-<nidx>problems, Parallel Haskell</nidx>
-%* *
-%************************************************************************
-
-The ``Potential problems'' for Concurrent Haskell also apply for
-Parallel Haskell. Please see Section <ref name="Potential problems with Concurrent Haskell" id="concurrent-problems">.
is to Haskell what @Yacc@ is to C.
You can get @happy@ by FTP from @ftp.dcs.gla.ac.uk@ in
-@pub/haskell/happy@, the file @happy-0.8.tar.gz@.
+@pub/haskell/happy@, the file @happy-1.5-src.tar.gz@.
@Happy@ is at its shining best when compiled by GHC.
%************************************************************************
%* *
-<sect1>Haskell~1.4 vs.~Glasgow Haskell~3.00: language non-compliance
+<sect1>Haskell~1.4 vs.~Glasgow Haskell~4.00: language non-compliance
<label id="vs-Haskell-defn">
<p>
<nidx>GHC vs the Haskell 1.4 language</nidx>
Several modules internal to GHC are visible in the standard namespace.
All of these modules begin with @Prel@, so the rule is: don't use any
-modules beginning with @Prel@ in your programl, or you will be
+modules beginning with @Prel@ in your program, or you will be
comprehensively screwed.
+% Not true anymore? -- Simon M.
%-------------------------------------------------------------------
-<tag>Can't export primitive types (e.g., @Int#@):</tag>
+% <tag>Can't export primitive types (e.g., @Int#@):</tag>
+% Don't even try...
-Don't even try...
</descrip>
%************************************************************************
%************************************************************************
<descrip>
+% Not true anymore? We use Rationals all the way -- Simon M.
%-------------------------------------------------------------------
-<tag>Very large/small fractional constants:</tag>
-(i.e., with a decimal point somewhere) GHC does not check that these
-are out of range (e.g., for a @Float@), and bad things will inevitably
-follow. (To be corrected?)
-
-This problem does <em>not</em> exist for integral constants.
-
-For very large/small fractional constants near the limits of your
-floating-point precision, things may go wrong. (It's better than it
-used to be.) Please report any such bugs.
+% <tag>Very large/small fractional constants:</tag>
+% (i.e., with a decimal point somewhere) GHC does not check that these
+% are out of range (e.g., for a @Float@), and bad things will inevitably
+% follow. (To be corrected?)
+%
+% This problem does <em>not</em> exist for integral constants.
+%
+% For very large/small fractional constants near the limits of your
+% floating-point precision, things may go wrong. (It's better than it
+% used to be.) Please report any such bugs.
%-------------------------------------------------------------------
<tag>Unchecked arithmetic:</tag>
operations on @Int@, @Float@, and @Double@ numbers are
<em>unchecked</em> for overflow, underflow, and other sad occurrences.
(note, however that some architectures trap floating-point overflow
-and loss-of-precision and report a floating-point exception).
+and loss-of-precision and report a floating-point
+exception)<nidx>floating-point exceptions</nidx>.
Use @Integer@, @Rational@, etc., numeric types if this stuff
keeps you awake at night.
%-------------------------------------------------------------------
<tag>Unicode character set:</tag>
-Haskell~1.4 embraces the Unicode character set, but GHC~3.00 doesn't
+Haskell 1.4 embraces the Unicode character set, but GHC 4.00 doesn't
handle it. Yet.
</descrip>
CURRENT_DIR=ghc/driver
include $(TOP)/mk/boilerplate.mk
#
-# The driver needs to get at
+# The driver needs to get at the version
include $(TOP)/mk/version.mk
INSTALLING=0
GHC_LIB_DIR GHC_RUNTIME_DIR GHC_UTILS_DIR GHC_INCLUDE_DIR \
GHC_OPT_HILEV_ASM GhcWithNativeCodeGen LeadingUnderscore\
GHC_UNLIT GHC_HSCPP GHC_HSC GHC_SYSMAN \
- CP RM CONTEXT_DIFF \
+ CP RM CONTEXT_DIFF LibGmp \
$(WAY_NAMES) $(WAY_OPTS)
#
WAY_u_NAME=unregisterized (using portable C only)
WAY_u_HC_OPTS=
-# Way `mc': concurrent
-WAY_mc_NAME=concurrent
-WAY_mc_HC_OPTS+=-fstack-check -fconcurrent -D__CONCURRENT_HASKELL__ -optc-DCONCURRENT
-
-# Way `mr':
-WAY_mr_NAME=profiled concurrent
-WAY_mr_HC_OPTS+=-fstack-check -fconcurrent -fscc-profiling -D__CONCURRENT_HASKELL__ -DPROFILING -optc-DCONCURRENT -optc-DPROFILING
-
-# Way `mt':
-WAY_mt_NAME=ticky-ticky concurrent
-WAY_mt_HC_OPTS+=-fstack-check -fconcurrent -fticky-ticky -D__CONCURRENT_HASKELL__ -DTICKY-TICKY -optc-DCONCURRENT -optc-DTICKY_TICKY
-
# Way `mp':
WAY_mp_NAME=parallel
-WAY_mp_HC_OPTS+=-fstack-check -fconcurrent -D__PARALLEL_HASKELL__ -optc-DPAR -optc-DCONCURRENT
+WAY_mp_HC_OPTS+=-fstack-check -fparallel -D__PARALLEL_HASKELL__ -optc-DPAR
#
# Way `mg':
$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_HDR_data = "\.data\n\t\.align 3\n";
$T_HDR_consist = "\.text\n";
$T_HDR_closure = "\.data\n\t\.align 3\n";
+ $T_HDR_srt = "\.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_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_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_srt = "\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_direct = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
#--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd|nextstep3|cygwin32)/ ) {
+ } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|nextstep3|cygwin32)$/ ) {
# NeXT added but not tested. CaS
$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 = '^#'; # regexp that says what comes before APP/NO_APP
$T_CONST_LBL = '^LC(\d+):$';
$T_POST_LBL = ':';
$T_MOVE_DIRVS = '^(\s*(\.(p2)?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_DOT_WORD = '\.(long|word|value|byte|space)';
$T_DOT_GLOBAL = '\.globl';
$T_HDR_literal = "\.text\n\t\.align 2\n";
$T_HDR_misc = "\.text\n\t\.align 2,0x90\n";
$T_HDR_data = "\.data\n\t\.align 2\n";
$T_HDR_consist = "\.text\n";
$T_HDR_closure = "\.data\n\t\.align 2\n";
+ $T_HDR_srt = "\.data\n\t\.align 2\n";
$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 2,0x90\n";
$T_HDR_direct = "\.text\n\t\.align 2,0x90\n";
#--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux)$/ ) {
+ } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|freebsd3)$/ ) {
$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 = # regexp that says what comes before APP/NO_APP
- ($TargetPlatform =~ /-linux$/) ? '#' : '/' ;
+ ($TargetPlatform =~ /-(linux|freebsd3)$/) ? '#' : '/' ;
$T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like
$T_POST_LBL = ':';
$T_X86_PRE_LLBL_PAT = '\.L';
$T_X86_PRE_LLBL = '.L';
$T_X86_BADJMP = '^\tjmp [^\.\*]';
- $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_MOVE_DIRVS = '^(\s*(\.(p2)?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';
+ if ( $TargetPlatform =~ /freebsd3/ ) {
+ $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
+ } else {
+ $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
+ }
+
+ $T_DOT_WORD = '\.(long|value|byte|zero)';
$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_misc = "\.text\n\t\.align 4\n";
$T_HDR_data = "\.data\n\t\.align 4\n"; # ToDo: change align??
$T_HDR_consist = "\.text\n";
$T_HDR_closure = "\.data\n\t\.align 4\n"; # ToDo: change align?
+ $T_HDR_srt = "\.data\n\t\.align 4\n"; # ToDo: change align?
$T_HDR_info = "\.text\n\t\.align 16\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 16\n";
$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_HDR_data = "\.data\n\t\.even\n";
$T_HDR_consist = "\.text\n";
$T_HDR_closure = "\.data\n\t\.even\n";
+ $T_HDR_srt = "\.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_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_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_srt = "\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_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 = 'NOT APPLICABLE'; # regexp that says what comes before APP/NO_APP
$T_CONST_LBL = 'NOT APPLICABLE'; # regexp for what such a lbl looks like
$T_POST_LBL = ':';
$T_HDR_data = "# data\n\.csect \.data[RW]\n\t\.align 2\n";
$T_HDR_consist = "# consist\n\.csect \.data[RW]\n\t\.align 2\n";
$T_HDR_closure = "# closure\n\.csect \.data[RW]\n\t\.align 2\n";
+ $T_HDR_srt = "# closure\n\.csect \.data[RW]\n\t\.align 2\n";
$T_HDR_info = "# info\n\.csect \.data[RW]\n\t\.align 2\n"; #not RO!?
$T_HDR_entry = "# entry\n\.csect \.text[PR]\n\t\.align 2\n";
$T_HDR_fast = "# fast\n\.csect \.text[PR]\n\t\.align 2\n";
$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_COPY_DIRVS = '\.(global|proc|stab)';
$T_hsc_cc_PAT = '\.asciz.*\)(hsc|cc) (.*)\\\\t(.*)"';
- $T_DOT_WORD = '\.word';
+ $T_DOT_WORD = '\.(word|byte|half|skip)';
$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_srt = "\.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_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_HDR_data = "\.data\n\t\.align 8\n";
$T_HDR_consist = "\.text\n";
$T_HDR_closure = "\.data\n\t\.align 4\n";
+ $T_HDR_srt = "\.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";
if ( 0 ) {
print STDERR "T_STABBY: $T_STABBY\n";
print STDERR "T_US: $T_US\n";
-print STDERR "T_DO_GC: $T_DO_GC\n";
print STDERR "T_PRE_APP: $T_PRE_APP\n";
print STDERR "T_CONST_LBL: $T_CONST_LBL\n";
print STDERR "T_POST_LBL: $T_POST_LBL\n";
%slowchk = (); # ditto, its regular "slow" entry code
%fastchk = (); # ditto, fast entry code
%closurechk = (); # ditto, the (static) closure
+ %srtchk = (); # ditto, its SRT (for top-level things)
%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'; $chk[0] = '';
# we use global variables to pass arguments from C to STG land.
# These declarations live in the .hc file and not in the generated C
# stub file, so we let them pass through here.
- } elsif ( /^[\t]?\.comm[\t ]+${TUS}__fexp_.*$/ ) {
+ } elsif ( /^\t\.comm\t__fexp_.*$/ ) {
$chk[++$i] = $_;
$chkcat[$i] = 'data';
$chksymb[$i] = '';
$infochk{$symb} = $i;
- } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_entry$TPOSTLBL[@]?$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_(entry|ret)$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'slow';
$chksymb[$i] = $1;
$slowchk{$1} = $i;
- } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_fast\d+$TPOSTLBL[@]?$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_fast\d*$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'fast';
$chksymb[$i] = $1;
$closurechk{$1} = $i;
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_srt$TPOSTLBL[@]?$/o ) {
+ $chk[++$i] = $_;
+ $chkcat[$i] = 'srt';
+ $chksymb[$i] = $1;
+
+ $srtchk{$1} = $i;
+
} elsif ( /^$TUS[@]?ghc.*c_ID$TPOSTLBL/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'consist';
} elsif ( /^($TUS[@]?__gnu_compiled_c|gcc2_compiled\.)$TPOSTLBL/o ) {
; # toss it
- } elsif ( /^$TUS[@]?ErrorIO_call_count$TPOSTLBL[@]?$/o # HACK!!!!
- || /^$TUS[A-Za-z0-9_]+\.\d+$TPOSTLBL[@]?$/o
+ } elsif ( /^$TUS[A-Za-z0-9_]+\.\d+$TPOSTLBL[@]?$/o
|| /^$TUS[@]?.*_CAT$TPOSTLBL[@]?$/o # PROF: _entryname_CAT
|| /^$TUS[@]?CC_.*_struct$TPOSTLBL[@]?$/o # PROF: _CC_ccident_struct
|| /^$TUS[@]?.*_done$TPOSTLBL[@]?$/o # PROF: _module_done
$chkcat[$i] = 'toc';
$chksymb[$i] = $1;
- } elsif ( $TargetPlatform =~ /^powerpc-|^rs6000-/ && /^CC_.*$/ ) {
+ } elsif ( /^$TUS[@]?CC(S)?_.*$/ ) {
# all CC_ symbols go in the data section...
$chk[++$i] = $_;
$chkcat[$i] = 'data';
$chksymb[$i] = '';
- } elsif ( /^($TUS[@]?(ret_|djn_)[A-Za-z0-9_]+)/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_(alt|dflt)$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'misc';
$chksymb[$i] = '';
- $symbtmp = $1;
- $chksymb[$i] = $symbtmp if ($TargetPlatform =~ /^powerpc-|^rs6000-/) ; #rm andre
+ #$symbtmp = $1;
+ #$chksymb[$i] = $symbtmp if ($TargetPlatform =~ /^powerpc-|^rs6000-/) ; #rm andre
- } elsif ( /^$TUS[@]?vtbl_([A-Za-z0-9_]+)$TPOSTLBL[@]?$/o ) {
+ } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_vtbl$TPOSTLBL[@]?$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'vector';
$chksymb[$i] = $1;
$vectorchk{$1} = $i;
- } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)DirectReturn$TPOSTLBL[@]?$/o ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_upd$TPOSTLBL[@]?$/o ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'misc';
- print STDERR "_upd!!!!! I guess this code is dead!!!!\n";
- # I guess this is never entered, since all _upds are
- # either vtbl_'s or ret_'s, caught above. - andre
- $chksymb[$i] = '';
-
# As a temporary solution for compiling "foreign export" declarations,
# we use global variables to pass arguments from C to STG land.
# These declarations live in the .hc file and not in the generated C
# stub file, so we let them pass through here.
- } elsif ( /^[\t ]*\.comm[\t ]+${TUS}__fexp_.*$/ ) {
+ } elsif ( /^[\t ]+\.comm[\t ]+__fexp_.*$/ ) {
$chk[++$i] = $_;
$chkcat[$i] = 'data';
$chksymb[$i] = '';
|| ! /^(L\.\.\d+|LT\.\..*):$/ ) ) {
local($thing);
chop($thing = $_);
- print STDERR "Funny global thing?: $_"
+ print "Funny global thing?: $_"
unless $KNOWN_FUNNY_THING{$thing}
- || /^$TUS[@]?_(PRIn|PRStart).*$TPOSTLBL[@]?$/o # pointer reversal GC routines
- || /^$TUS[@]?CC_.*$TPOSTLBL$/o # PROF: _CC_ccident ([@]? is a silly hack (see above))
- || /^$TUS__fexp_.*$TPOSTLBL$/o # foreign export droppings (temporary)
- || /^$TUS[@]?_reg.*$TPOSTLBL$/o; # PROF: __reg<module>
+ || /^$TUS[@]?stg_.*$TPOSTLBL[@]?$/o # RTS internals
+ || /^$TUS[@]__fexp_.*$TPOSTLBL$/o # foreign export
+ || /^$TUS[@]?_reg.*$TPOSTLBL$/o # PROF: __reg<module>
+ || /^$TUS[@]?.*_btm$TPOSTLBL$/o # large bitmaps
+ || /^$TUS[@]?.*_closure_tbl$TPOSTLBL$/o; # closure tables
$chk[++$i] = $_;
$chkcat[$i] = 'misc';
if ($TargetPlatform =~ /^powerpc-|^rs6000-/)
$chk[$i] =~ s/\t\.tc (\S+)\[TC\],(\S+_fast\d+)/\t\.tc \1\[TC\],\.\2/;
$chk[$i] =~ s/\t\.tc (\S+)\[TC\],(\S+_entry)\n/\t\.tc \1\[TC\],\.\2\n/;
$chk[$i] =~ s/\t\.tc (\S+)\[TC\],(ret_\S+)/\t\.tc \1\[TC\],\.\2/;
- $chk[$i] =~ s/\t\.tc (\S+)\[TC\],(djn_\S+)/\t\.tc \1\[TC\],\.\2/;
+ $chk[$i] =~ s/\t\.tc (\S+)\[TC\],(alt_\S+)/\t\.tc \1\[TC\],\.\2/;
$chk[$i] =~ s/\t\.tc (\S+)\[TC\],(vtbl_\S+)/\t\.tc \1\[TC\],\.\2/;
- $chk[$i] =~ s/\t\.tc (\S+)\[TC\],ErrorIO_innards/\t\.tc \1\[TC\],\.ErrorIO_innards/;
- $chk[$i] =~ s/\t\.tc (\S+)\[TC\],startStgWorld/\t\.tc \1\[TC\],\.startStgWorld/;
- $chk[$i] =~ s/\.tc UpdatePAP\[TC\],UpdatePAP/\.tc UpdatePAP\[TC\],\.UpdatePAP/;
- $chk[$i] =~ s/\.tc _regMain\[TC\],_regMain/\.tc _regMain\[TC\],\._regMain/; #PROF
- $chk[$i] =~ s/\.tc resumeThread\[TC\],resumeThread/\.tc resumeThread\[TC\],\.resumeThread/; #CONC
- $chk[$i] =~ s/\.tc EnterNodeCode\[TC\],EnterNodeCode/\.tc EnterNodeCode\[TC\],\.EnterNodeCode/; #CONC
- $chk[$i] =~ s/\.tc StackUnderflowEnterNode\[TC\],StackUnderflowEnterNode/\.tc StackUnderflowEnterNode\[TC\],\.StackUnderflowEnterNode/; #CONC
- $chk[$i] =~ s/\.tc stopThreadDirectReturn\[TC\],stopThreadDirectReturn/\.tc stopThreadDirectReturn\[TC\],\.stopThreadDirectReturn/; #CONC
- $chk[$i] =~ s/\.tc CommonUnderflow\[TC\],CommonUnderflow/\.tc CommonUnderflow\[TC\],\.CommonUnderflow/; #PAR
- $chk[$i] =~ s/\.tc IndUpdRetDir\[TC\],IndUpdRetDir/\.tc IndUpdRetDir\[TC\],\.IndUpdRetDir/;
- $chk[$i] =~ s/\t\.tc (_PRStart_\S+)\[TC\],_PRStart_\S+/\t\.tc \1\[TC\],\.\1/;
$tocnumber = $chksymb[$i];
$tocsymb = $chk[$i];
print OUTASM "___stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n";
} elsif ( $chkcat[$i] eq 'closure'
+ || $chkcat[$i] eq 'srt'
|| $chkcat[$i] eq 'infotbl'
|| $chkcat[$i] eq 'slow'
|| $chkcat[$i] eq 'fast' ) { # do them in that order
$chkcat[$closurechk{$symb}] = 'DONE ALREADY';
}
+ # SRT
+ if ( defined($srtchk{$symb}) ) {
+ print OUTASM $T_HDR_srt;
+ print OUTASM $chk[$srtchk{$symb}];
+ $chkcat[$srtchk{$symb}] = 'DONE ALREADY';
+ }
+
# INFO TABLE
if ( defined($infochk{$symb}) ) {
}
$chk[$infochk{$symb}] =~ s/\.long ([_A-Za-z]\S+_entry)/\.long \.\1/;
$chk[$infochk{$symb}] =~ s/\.long ([A-Za-z]\S+_upd)/\.long \.\1/;
- $chk[$infochk{$symb}] =~ s/\.long (IndUpdRet\S+)/\.long \.\1/;
- $chk[$infochk{$symb}] =~ s/\.long StdErrorCode/\.long \.StdErrorCode/;
- $chk[$infochk{$symb}] =~ s/\.long UpdErr/\.long \.UpdErr/;
print OUTASM $chk[$infochk{$symb}];
} else {
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
}
# entry code will be put here!
- # paranoia
- if ( $chk[$infochk{$symb}] =~ /$TDOTWORD[@]?\s+([A-Za-z0-9_]+_entry)$/o
- && $1 ne "${T_US}${symb}_entry" ) {
- print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
- }
-
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
$c = $chk[$slowchk{$symb}];
if ($TargetPlatform =~ /^powerpc-|^rs6000-/) {
- ($p, $r) = split(/TOC\[tc0\], 0\n/, $c);
- if ($symb =~ /^[_A-Z]/)
- {
- print OUTASM "\t\.globl \.${chksymb[$i]}_entry\n";
- print OUTASM "\.csect ${symb}_entry[DS]\n";
- print OUTASM "${p}TOC[tc0], 0\n";
+ ($p, $r) = split(/TOC\[tc0\], 0\n/, $c);
+ if ($symb =~ /^[_A-Z]/)
+ {
+ print OUTASM "\t\.globl \.${chksymb[$i]}_entry\n";
+ print OUTASM "\.csect ${symb}_entry[DS]\n";
+ print OUTASM "${p}TOC[tc0], 0\n";
};
$r =~ s/\.csect \.text\[PR\]\n//; # todo: properly - andre
$c = &mangle_powerpc_tailjump($r);
} elsif ( $TargetPlatform =~ /^i386-/ ) {
# Reg alloc depending, gcc generated code may jump to the fast entry point via
# a number of registers.
- $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%edx\n\tjmp \*\%edx\n//;
- $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%ecx\n\tjmp \*\%ecx\n//;
- $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%eax\n\tjmp \*\%eax\n//;
+ $c =~ s/^\tmovl \$${T_US}${symb}_fast\d*,\%edx\n\tjmp \*\%edx\n//;
+ $c =~ s/^\tmovl \$${T_US}${symb}_fast\d*,\%ecx\n\tjmp \*\%ecx\n//;
+ $c =~ s/^\tmovl \$${T_US}${symb}_fast\d*,\%eax\n\tjmp \*\%eax\n//;
# The next two only apply if we're not stealing %esi or %edi.
- $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%esi\n\tjmp \*\%esi\n// if ($StolenX86Regs < 3);
- $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%edi\n\tjmp \*\%edi\n// if ($StolenX86Regs < 4);
+ $c =~ s/^\tmovl \$${T_US}${symb}_fast\d*,\%esi\n\tjmp \*\%esi\n// if ($StolenX86Regs < 3);
+ $c =~ s/^\tmovl \$${T_US}${symb}_fast\d*,\%edi\n\tjmp \*\%edi\n// if ($StolenX86Regs < 4);
} 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-/ ) {
print OUTASM $T_HDR_vector;
if ($TargetPlatform =~ /^powerpc-|^rs6000-/) {
if ( $symb =~ /^[A-Z]/) {
- print OUTASM "\t\.globl \.vtbl_${symb}\n";
- print OUTASM "\t\.globl vtbl_${symb}\n";
+ print OUTASM "\t\.globl \.${symb}_vtbl\n";
+ print OUTASM "\t\.globl ${symb}_vtbl\n";
};
$chk[$vectorchk{$symb}] =~ s/\.long (\S+)/\.long \.\1/g;
- print OUTASM ".vtbl_${symb}:\n";
+ print OUTASM ".${symb}_vtbl:\n";
print OUTASM $chk[$vectorchk{$symb}];
} else {
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_HDR_direct;
- if ($TargetPlatform =~ /^powerpc-|^rs6000-/) {
- ($p, $r) = split(/TOC\[tc0\], 0\n/, $chk[$directchk{$symb}]);
- &print_doctored($r, 0);
- print OUTASM "\.csect ${symb}DirectReturn[DS]\n";
- print OUTASM "${p}TOC[tc0], 0\n";
- } else {
- &print_doctored($chk[$directchk{$symb}], 0);
- }
- $chkcat[$directchk{$symb}] = 'DONE ALREADY';
} elsif ( $TargetPlatform =~ /^alpha-/ ) {
# Alphas: the commented nop is for the splitter, to ensure
local($entry_patch) = '';
local($exit_patch) = '';
- local($call_entry_patch)= '';
- local($call_exit_patch) = '';
- local($gc_call_entry_patch)= ''; # Patches before and after calls to Perform_GC_wrapper
- local($gc_call_exit_patch) = '';
-
-#OLD: # first, convert calls to *very magic form*: (ToDo: document
- # for real!) from
- #
- # pushl $768
- # call _?PerformGC_wrapper
- # addl $4,%esp
- # to
- # movl $768, %eax
- # call _?PerformGC_wrapper
- #
- # The reason we do this now is to remove the apparent use of
- # %esp, which would throw off the "what patch code do we need"
- # decision.
- #
- # Special macros in ghc/includes/COptWraps.lh, used in
- # ghc/runtime/CallWrap_C.lc, are required for this to work!
- #
-
- s/^\tpushl \$(\d+)\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \$$1,\%eax\n\tcall ${T_DO_GC}\n/go;
- s/^\tpushl \%eax\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tcall ${T_DO_GC}\n/go;
- s/^\tpushl \%edx\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \%edx,\%eax\n\tcall ${T_DO_GC}\n/go;
-
-#= if ( $StolenX86Regs <= 4 ) { # %ecx is ordinary reg
-#= s/^\tpushl \%ecx\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \%ecx,\%eax\n\tcall ${T_DO_GC}\n/go;
-#= }
# gotta watch out for weird instructions that
# invisibly smash various regs:
# movl $_blah,<bad-reg>
# jmp *<bad-reg>
#
- # which is easily fixed as:
- #
- # sigh! try to hack around it...
- #
+
+# the short form may tickle perl bug:
+# s/^\tmovl \$${T_US}(.*),(\%e[abcd]x)\n\tjmp \*$2/\tjmp $T_US$1/g;
+ s/^\tmovl \$${T_US}(.*),\%eax\n\tjmp \*\%eax/\tjmp $T_US$1/g;
+ s/^\tmovl \$${T_US}(.*),\%ebx\n\tjmp \*\%ebx/\tjmp $T_US$1/g;
+ s/^\tmovl \$${T_US}(.*),\%ecx\n\tjmp \*\%ecx/\tjmp $T_US$1/g;
+ s/^\tmovl \$${T_US}(.*),\%edx\n\tjmp \*\%edx/\tjmp $T_US$1/g;
if ($StolenX86Regs <= 2 ) { # YURGH! spurious uses of esi?
s/^\tmovl (.*),\%esi\n\tjmp \*%esi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
die "$Pgm: (mangler) still have jump involving \%edi!\n$_"
if /(jmp|call) .*\%edi/;
}
-#= if ($StolenX86Regs <= 4 ) { # spurious uses of ecx?
-#= s/^\tmovl (.*),\%ecx\n\tjmp \*%ecx\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
-#= s/^\tjmp \*(-?\d*)\((.*\%ecx.*)\)\n/\tmovl $2,\%eax\n\tjmp \*$1\(\%eax\)\n/g;
-#= s/^\tjmp \*\%ecx\n/\tmovl \%ecx,\%eax\n\tjmp \*\%eax\n/g;
-#= die "$Pgm: (mangler) still have jump involving \%ecx!\n$_"
-#= if /(jmp|call) .*\%ecx/;
-#= }
# OK, now we can decide what our patch-up code is going to
# be:
# Offsets into register table - you'd better update these magic
# numbers should you change its contents!
- local($OFFSET_R1)=48;
- local($OFFSET_SpA)=80;
+ # local($OFFSET_R1)=0; No offset for R1 in new RTS.
+ local($OFFSET_Hp)=92;
# Note funky ".=" stuff; we're *adding* to these _patch guys
if ( $StolenX86Regs <= 2
- && ( /${OFFSET_R1}\(\%ebx\)/ || /\%esi/ || /^\tcmps/ ) ) { # R1 (esi)
- $entry_patch .= "\tmovl \%esi,${OFFSET_R1}(\%ebx)\n";
- $exit_patch .= "\tmovl ${OFFSET_R1}(\%ebx),\%esi\n";
-
- $gc_call_entry_patch .= "\tmovl \%esi,${OFFSET_R1}(\%ebx)\n";
- $gc_call_exit_patch .= "\tmovl ${OFFSET_R1}(\%ebx),\%esi\n";
+ && ( /[^0-9]\(\%ebx\)/ || /\%esi/ || /^\tcmps/ ) ) { # R1 (esi)
+ $entry_patch .= "\tmovl \%esi,(\%ebx)\n";
+ $exit_patch .= "\tmovl (\%ebx),\%esi\n";
# nothing for call_{entry,exit} because %esi is callee-save
}
if ( $StolenX86Regs <= 3
- && ( /${OFFSET_SpA}\(\%ebx\)/ || /\%edi/ || /^\t(scas|cmps)/ ) ) { # SpA (edi)
- $entry_patch .= "\tmovl \%edi,${OFFSET_SpA}(\%ebx)\n";
- $exit_patch .= "\tmovl ${OFFSET_SpA}(\%ebx),\%edi\n";
-
- $gc_call_entry_patch .= "\tmovl \%edi,${OFFSET_SpA}(\%ebx)\n";
- $gc_call_exit_patch .= "\tmovl ${OFFSET_SpA}(\%ebx),\%edi\n";
+ && ( /${OFFSET_Hp}\(\%ebx\)/ || /\%edi/ || /^\t(scas|cmps)/ ) ) { # Hp (edi)
+ $entry_patch .= "\tmovl \%edi,${OFFSET_Hp}(\%ebx)\n";
+ $exit_patch .= "\tmovl ${OFFSET_Hp}(\%ebx),\%edi\n";
# nothing for call_{entry,exit} because %edi is callee-save
}
- local ($OFFSET_Hp) = 96;
-
-#= local ($OFFSET_rSaveECX) = 124;
-#= if ( $StolenX86Regs <= 4
-#= && ( /${OFFSET_Hp}\(\%ebx\)/ || /\%ecx/ || /^\t(rep|loop)/ ) ) { # Hp (ecx)
-#= $entry_patch .= "\tmovl \%ecx,${OFFSET_Hp}(\%ebx)\n";
-#= $exit_patch .= "\tmovl ${OFFSET_Hp}(\%ebx),\%ecx\n";
-#=
-#= $call_exit_patch .= "\tmovl \%ecx,${OFFSET_rSaveECX}(\%ebx)\n";
-#= $call_entry_patch .= "\tmovl ${OFFSET_rSaveECX}(\%ebx),\%ecx\n";
-#= # I have a really bad feeling about this if we ever
-#= # have a nested call...
-#= # NB: should just hide it somewhere in the C stack.
-#= }
+
# --------------------------------------------------------
# next, here we go with non-%esp patching!
#
s/^(\t[a-z])/$entry_patch$1/; # before first instruction
-# Actually, call_entry_patch and call_exit_patch never get set,
-# so let's nuke this one
-# s/^(\tcall .*\n(\taddl \$\d+,\%esp\n)?)/$call_exit_patch$1$call_entry_patch/g; # _all_ calls
-
# Before calling GC we must set up the exit condition before the call
# and entry condition when we come back
- s/^(\tcall ${T_DO_GC}\n(\taddl \$\d+,\%esp\n)?)/$gc_call_exit_patch$1$gc_call_entry_patch/g; # _all_ calls
# fix _all_ non-local jumps:
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 ($StolenX86Regs == 2 ) {
die "ARGH! Jump uses \%esi or \%edi with -monly-2-regs:\n$_"
if /^\t(jmp|call) .*\%e(si|di)/;
-#= die "ARGH! Jump uses \%esi, \%edi, or \%ecx with -monly-2-regs:\n$_"
-#= if /^\t(jmp|call) .*\%e(si|di|cx)/;
} elsif ($StolenX86Regs == 3 ) {
die "ARGH! Jump uses \%edi with -monly-3-regs:\n$_"
if /^\t(jmp|call) .*\%edi/;
-#= die "ARGH! Jump uses \%edi or \%ecx with -monly-3-regs:\n$_"
-#= if /^\t(jmp|call) .*\%e(di|cx)/;
-#= } elsif ($StolenX86Regs == 4 ) {
-#= die "ARGH! Jump uses \%ecx with -monly-4-regs:\n$_"
-#= if /^\t(jmp|call) .*\%ecx/;
}
- # final peephole fixes
-
- local($OFFSET_R2)=52;
- s/^\tmovl \%eax,${OFFSET_R2}\(\%ebx\)\n\tjmp \*${OFFSET_R2}\(\%ebx\)\n/\tmovl \%eax,${OFFSET_R2}\(\%ebx\)\n\tjmp \*\%eax\n/;
-
-# the short form may tickle perl bug:
-# s/^\tmovl \$${T_US}(.*),(\%e[abcd]x)\n\tjmp \*$2/\tjmp $T_US$1/g;
- s/^\tmovl \$${T_US}(.*),\%eax\n\tjmp \*\%eax/\tjmp $T_US$1/g;
- s/^\tmovl \$${T_US}(.*),\%ebx\n\tjmp \*\%ebx/\tjmp $T_US$1/g;
- s/^\tmovl \$${T_US}(.*),\%ecx\n\tjmp \*\%ecx/\tjmp $T_US$1/g;
- s/^\tmovl \$${T_US}(.*),\%edx\n\tjmp \*\%edx/\tjmp $T_US$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 ${OFFSET_Hp}\(\%ebx\),\%e.x\n\tmovl \$(.*),(-?[0-9]*)\(\%e.x\)\n\tmovl ${OFFSET_Hp}\(\%ebx\),\%e(.)x/\tmovl ${OFFSET_Hp}\(\%ebx\),\%e$3x\n\tmovl \$$1,$2\(\%e$3x\)/g;
-
- s/^\tmovl ${OFFSET_Hp}\(\%ebx\),\%e(.)x\n\tmovl (.*),\%e(.)x\n\tmovl \%e$3x,(-?[0-9]*\(\%e$1x\))\n\tmovl ${OFFSET_Hp}\(\%ebx\),\%e$1x/\tmovl ${OFFSET_Hp}\(\%ebx\),\%e$1x\n\tmovl $2,\%e$3x\n\tmovl \%e$3x,$4/g;
-
- s/^\tmovl ${OFFSET_Hp}\(\%ebx\),\%edx((\n\t(movl|addl) .*,((-?[0-9]*\(.*)|(\%e[abc]x)))+)\n\tmovl ${OFFSET_Hp}\(\%ebx\),\%edx/\tmovl ${OFFSET_Hp}\(\%ebx\),\%edx$1/g;
- s/^\tmovl ${OFFSET_Hp}\(\%ebx\),\%eax((\n\t(movl|addl) .*,((-?[0-9]*\(.*)|(\%e[bcd]x)))+)\n\tmovl ${OFFSET_Hp}\(\%ebx\),\%eax/\tmovl ${OFFSET_Hp}\(\%ebx\),\%eax$1/g;
-
# --------------------------------------------------------
# that's it -- print it
#
\begin{code}
sub init_FUNNY_THINGS {
%KNOWN_FUNNY_THING = (
- "${T_US}CheckHeapCode${T_POST_LBL}", 1,
- "${T_US}CommonUnderflow${T_POST_LBL}", 1,
- "${T_US}Continue${T_POST_LBL}", 1,
- "${T_US}EnterNodeCode${T_POST_LBL}", 1,
- "${T_US}ErrorIO_call_count${T_POST_LBL}", 1,
- "${T_US}ErrorIO_innards${T_POST_LBL}", 1,
- "${T_US}IndUpdRetDir${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV0${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV1${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV2${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV3${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV4${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV5${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV6${T_POST_LBL}", 1,
- "${T_US}IndUpdRetV7${T_POST_LBL}", 1,
- "${T_US}PrimUnderflow${T_POST_LBL}", 1,
- "${T_US}StackUnderflowEnterNode${T_POST_LBL}", 1,
- "${T_US}StdErrorCode${T_POST_LBL}", 1,
- "${T_US}UnderflowVect0${T_POST_LBL}", 1,
- "${T_US}UnderflowVect1${T_POST_LBL}", 1,
- "${T_US}UnderflowVect2${T_POST_LBL}", 1,
- "${T_US}UnderflowVect3${T_POST_LBL}", 1,
- "${T_US}UnderflowVect4${T_POST_LBL}", 1,
- "${T_US}UnderflowVect5${T_POST_LBL}", 1,
- "${T_US}UnderflowVect6${T_POST_LBL}", 1,
- "${T_US}UnderflowVect7${T_POST_LBL}", 1,
- "${T_US}UpdErr${T_POST_LBL}", 1,
- "${T_US}UpdatePAP${T_POST_LBL}", 1,
- "${T_US}_Enter_Internal${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextAStack${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextBStack${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextCAF${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextGA${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextRoot${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextSpark${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextEvent${T_POST_LBL}", 1,
- "${T_US}_PRMarking_MarkNextClosureInFetchBuffer${T_POST_LBL}", 1,
- "${T_US}_Scavenge_Forward_Ref${T_POST_LBL}", 1,
- "${T_US}__std_entry_error__${T_POST_LBL}", 1,
- "${T_US}_startMarkWorld${T_POST_LBL}", 1,
- "${T_US}resumeThread${T_POST_LBL}", 1,
- "${T_US}startCcRegisteringWorld${T_POST_LBL}", 1,
- "${T_US}startEnterFloat${T_POST_LBL}", 1,
- "${T_US}startEnterInt${T_POST_LBL}", 1,
- "${T_US}startPerformIO${T_POST_LBL}", 1,
- "${T_US}startStgWorld${T_POST_LBL}", 1,
- "${T_US}stopPerformIO${T_POST_LBL}", 1,
- "${T_US}ShouldCompile_Z36d1z5${T_POST_LBL}", 1
+ # example
+ # "${T_US}stg_.*{T_POST_LBL}", 1,
);
}
\end{code}
local($after) = '';
local(@lines) = split(/\n/, $tbl);
local($i, $j); #local ($i, $extra, $words_to_pad, $j);
-
+
# see comment in mangleAsm as to why this silliness is needed.
local($TDOTWORD) = ${T_DOT_WORD};
local($TDOTGLOBAL) = ${T_DOT_GLOBAL};
local($TUS) = ${T_US};
local($TPOSTLBL) = ${T_POST_LBL};
- for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t$TDOTWORD\s+/o; $i++) {
+ # Deal with the header...
+ for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t?$TDOTWORD\s+/o; $i++) {
$label .= $lines[$i] . "\n",
next if $lines[$i] =~ /^[A-Za-z0-9_]+_info$TPOSTLBL[@]?$/o
|| $lines[$i] =~ /$TDOTGLOBAL/o
- || $lines[$i] =~ /^$TUS[@]?vtbl_\S+$TPOSTLBL[@]?$/o;
+ || $lines[$i] =~ /^$TUS[@]?\S+_vtbl$TPOSTLBL[@]?$/o;
$before .= $lines[$i] . "\n"; # otherwise...
}
+ # Grab the table data...
if ( $TargetPlatform !~ /^hppa/ ) {
- for ( ; $i <= $#lines && $lines[$i] =~ /^\t$TDOTWORD\s+/o; $i++) {
+ for ( ; $i <= $#lines && $lines[$i] =~ /^\t?$TDOTWORD\s+/o; $i++) {
push(@words, $lines[$i]);
}
} else { # hppa weirdness
}
}
- # now throw away the first word (entry code):
- shift(@words) if $discard1;
+ # now throw away the first word (SRT) iff it is empty.
+ # The .zero business is for Linux/ELF.
+ # The .skip business is for Sparc/Solaris/ELF.
+ if ($discard1 && $words[0] =~ /^\t?($TDOTWORD\s+0|\.zero\s+4|\.skip\s+4)/) {
+ shift(@words)
+ }
# Padding removed to reduce code size and improve performance on Pentiums.
# Simon M. 13/4/96
$tbl = $before
. (($TargetPlatform !~ /^hppa/) ? '' : join("\n", @imports) . "\n")
- . join("\n", (reverse @words)) . "\n"
+ . join("\n", @words) . "\n"
. $label . $after;
# print STDERR "before=$before\n";
}
\end{code}
-\begin{code}
-sub mini_mangle_asm_i386 {
- local($in_asmf, $out_asmf) = @_;
-
- &init_TARGET_STUFF();
-
- # see mangleAsm comment
- local($TUS) = ${T_US};
- local($TPOSTLBL)=${T_POST_LBL};
-
- 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>) {
- print OUTASM;
-
- next unless
- /^$TUS[@]?(PerformGC|StackOverflow|Yield|PerformReschedule)_wrapper$TPOSTLBL\n/o;
- print OUTASM "\tmovl \%esp, ${T_US}__temp_esp\n";
- print OUTASM "\tmovl \%eax, ${T_US}__temp_eax\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
# if we produced an interface file "no matter what",
# print what we got on stderr (ToDo: honor -ohi flag)
if ( $HiOnStdout ) {
- if ( $HiWith ne '' ) {
- # output some of the sections
- local($hi_after) = "$Tmp_prefix.hi-now";
-
- foreach $hi ( split(' ',$HiWith) ) {
- $HiSection{$hi} = 1;
- }
- &hiSectionsOnly($new_hi, $hi_after);
-
- system("$Cat $hi_after 1>&2 ; $Rm $hi_after; ");
- } else {
- system("$Cat $new_hi 1>&2");
- }
+ system("$Cat $new_hi 1>&2");
} else {
&run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )",
"Replace .$HiSuffix file, if changed");
# read up to _usages_ line
$_ = <OLDHIF>;
- while ($_ ne '' && ! /^_usages_/) {
- print NEWHIF $_ unless /^(_interface_ |\{-# GHC_PRAGMA)/;
+ while ($_ ne '') {
+ print NEWHIF $_ unless /^(__interface|import)/;
$_ = <OLDHIF>;
}
- if ( $_ ne '' ) {
- # skip to next _<anything> line
- $_ = <OLDHIF>;
- while ($_ ne '' && ! /^_/) { $_ = <OLDHIF>; }
-
- # print the rest
- while ($_ ne '') {
- print NEWHIF $_;
- $_ = <OLDHIF>;
- }
- }
-
- close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
- close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
-}
-
-sub hiSectionsOnly {
- local($ifile,$ofile) = @_;
-
- open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
- open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
-
- # read up to _usages_ line
- $_ = <OLDHIF>;
- while ($_ ne '' ) {
- if ( /^_(.*)_/ && $HiSection{$1} ) {
- do { print NEWHIF $_;
- $_ = <OLDHIF>;} until ($_ eq '' || /^_/ );
- } else {
- $_ = <OLDHIF>;
- }
- }
close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
- local(@decl_names) = (); # Entities in _declarations_ section of new module
+ local(@decl_names) = (); # Declarations in new module
foreach $v (sort (keys %Decl)) {
next unless $v =~ /^new:(.*$)/;
push(@decl_names,$1);
}
local($new_module_version) = &calcNewModuleVersion(@decl_names);
- print NEWHI "_interface_ ", $ModuleName{'new'}, " $new_module_version $ProjectVersionInt\n";
-
- if ( $Stuff{'new:instance_modules'} ) {
- print NEWHI "_instance_modules_\n";
- print NEWHI $Stuff{'new:instance_modules'};
- }
+ print NEWHI "__interface ", $ModuleName{'new'}, " $new_module_version $ProjectVersionInt where\n";
- print NEWHI "_usages_\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
-
- print NEWHI "_exports_\n";
+ print NEWHI $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
+ print NEWHI $Stuff{'new:instance_modules'} unless $Stuff{'new:instance_modules'} eq '';
print NEWHI $Stuff{'new:exports'};
+ print NEWHI $Stuff{'new:fixities'} unless $Stuff{'new:fixities'} eq '';
+ print NEWHI $Stuff{'new:instances'} unless $Stuff{'new:instances'} eq '';
- if ( $Stuff{'new:fixities'} ) {
- print NEWHI "_fixities_\n";
- print NEWHI $Stuff{'new:fixities'};
- }
-
- if ( $Stuff{'new:instances'} ) {
- print NEWHI "_instances_\n";
- print NEWHI $Stuff{'new:instances'};
- }
-
- print NEWHI "_declarations_\n";
foreach $v (@decl_names) {
&printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs); # Print new version number
print NEWHI $Decl{"new:$v"}; # Print the new decl itself
}
-
-
close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
}
\end{code}
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
- next if /\{-# GHC_PRAGMA INTERFACE VERSION 20 #-\}/;
- # 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+)/ && $mod ne 'new' ) {
- $ModuleName{$mod} = $1; # used to decide name of interface file.
- $ModuleVersion{$mod} = $2;
+ if ( /^__interface ([A-Z]\S*) (\d+)/ ) {
+ if ( $mod ne 'new' ) {
+ $ModuleVersion{$mod} = $2;
+ }
+ $ModuleName{$mod} = $1; # used to decide name of iface file.
- } elsif ( /^_interface_ ([A-Z]\S*) (\d+)/ && $mod eq 'new' ) { # special case: no version
- $ModuleName{'new'} = $1;
+ } elsif ( /^import / ) {
+ $Stuff{"$mod:usages"} .= $_; # save the whole thing
- } elsif ( /^_([a-z_]+)_$/ ) {
- $now_in = $1;
+ } elsif ( /^__instimport/ ) {
+ $Stuff{"$mod:instance_modules"} .= $_;
- } elsif ( $now_in eq 'usages' && /^(\S+)\s+(!\s+)?(\d+)\s+::(.*)/ ) {
- $Stuff{"$mod:usages"} .= $_; # save the whole thing
+ } elsif ( /^__export/ ) {
+ $Stuff{"$mod:exports"} .= $_;
+ } elsif ( /^infix(r|l)? / ) {
+ $Stuff{"$mod:fixities"} .= $_;
- } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities)$/ ) {
- $Stuff{"$mod:$1"} .= $_; # just save it up
+ } elsif ( /^instance / ) {
+ $Stuff{"$mod:instances"} .= $_;
} elsif ( /^--.*/ ) { # silently ignore comment lines.
;
- } elsif ( $now_in eq 'declarations' ) { # relatively special treatment needed...
- # We're in a declaration
+ } else { # We're in a declaration
# Strip off the initial version number, if any
- if ( /^([0-9]+) (.*\n)/ ) {
- # The "\n" is because we need to keep the newline at the end, so that
- # it looks the same as if there's no version number and this if statement
- # doesn't fire.
+ if ( /^([0-9]+)\s+(.*\n)/ ) {
+
+ # The "\n" is because we need to keep the newline at
+ # the end, so that it looks the same as if there's no version
+ # number and this if statement doesn't fire.
# So there's an initial version number
$version = $1;
$_ = $2;
}
-
- if ( /^(\S+)\s+_:_\s+/ ) {
- # Value declaration
- $current_name = $1;
- $Decl{"$mod:$current_name"} = $_;
- if ($mod eq "old") { $OldVersion{$current_name} = $version; }
- } elsif ( /^type\s+(\S+)/ ) {
+ if ( /^type\s+(\S+)/ ) {
# Type declaration
$current_name = "type $1";
$Decl{"$mod:$current_name"} = $_;
if ($mod eq "old") { $OldVersion{$current_name} = $version; }
- } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
+ } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
# Data declaration
$current_name = "data $3";
$Decl{"$mod:$current_name"} = $_;
if ($mod eq "old") { $OldVersion{$current_name} = $version; }
- } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) {
+ } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) {
# Class declaration
# must be wary of => bit matching after "where"...
# ..hence the [^{}] part
$Decl{"$mod:$current_name"} = $_;
if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+ } elsif ( /^(\S+)\s+::\s+/ ) {
+ # Value declaration
+ $current_name = $1;
+ $Decl{"$mod:$current_name"} = $_;
+ if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
} else { # Continuation line
- $Decl{"$mod:$current_name"} .= $_
+ print STDERR "$Pgm:junk old iface line?:$_";
+ # $Decl{"$mod:$current_name"} .= $_
}
- } 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;
}
local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
local($changed_version) = $unchanged_version + 1;
-# This statement is curious; it is subsumed by the foreach!
-# return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'};
-
foreach $t ( 'usages' , 'exports', 'instance_modules', 'instances', 'fixities' ) {
return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
}
-%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
%
$Oopt_MonadEtaExpansion = '';
$Oopt_FinalStgProfilingMassage = '';
$Oopt_StgStats = '';
- $Oopt_SpecialiseUnboxed = '';
$Oopt_DoSpecialise = '-fspecialise';
$Oopt_FoldrBuild = 0; # *Off* by default!
$Oopt_FB_Support = ''; # was '-fdo-arity-expand';
\end{code}
Things to do with C compilers/etc:
+
+(added -Wimplicit: implicit prototypes cause very hard-to-find
+problems, so I'm turing on the warnings -- SDM 4/5/98)
+
\begin{code}
$CcRegd = $GHC_OPT_HILEV_ASM;
-@CcBoth_flags = ('-S'); # flags for *any* C compilation
+@CcBoth_flags = ('-S','-Wimplicit'); # flags for *any* C compilation
@CcInjects = ();
# GCC flags:
# 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 = ();
+@CcRegd_flags_c = ();
@CcRegd_flags_hc = ();
-$As = ''; # "assembler" is normally GCC
-@As_flags = ();
+$As = ''; # "assembler" is normally GCC
+@As_flags = ();
-$Lnkr = ''; # "linker" is normally GCC
-@Ld_flags = ();
+$Lnkr = ''; # "linker" is normally GCC
+@Ld_flags = ();
# 'nm' is used for consistency checking (ToDo: mk-world-ify)
# ToDo: check the OS or something ("alpha" is surely not the crucial question)
'-fwarn-unused-imports');
@MinusWallOpts = (@MinusWOpts,
'-fwarn-unused-matches',
- '-fwarn-name-shadowing');
+ '-fwarn-name-shadowing',
+ '-fwarn-missing-signatures');
\end{code}
What options \tr{-user-setup-a} turn into (user-defined ``packages''
'_p', "$WAY_p_NAME",
'_t', "$WAY_t_NAME",
'_u', "$WAY_u_NAME",
- '_mc', "$WAY_mc_NAME",
- '_mr', "$WAY_mr_NAME",
- '_mt', "$WAY_mt_NAME",
'_mp', "$WAY_mp_NAME",
'_mg', "$WAY_mg_NAME",
- '_2s', "$WAY_2s_NAME",
- '_1s', "$WAY_1s_NAME",
- '_du', "$WAY_du_NAME",
# system ways end
'_a', "$WAY_a_NAME",
'_b', "$WAY_b_NAME",
'_p', "$WAY_p_HC_OPTS",
'_t', "$WAY_t_HC_OPTS",
'_u', "$WAY_u_HC_OPTS",
- '_mc', "$WAY_mc_HC_OPTS",
- '_mr', "$WAY_mr_HC_OPTS",
- '_mt', "$WAY_mt_HC_OPTS",
'_mp', "$WAY_mp_HC_OPTS",
- '_mg', "$WAY_mg_HC_OPTS",
- '_2s', "$WAY_2s_HC_OPTS",
- '_1s', "$WAY_1s_HC_OPTS",
- '_du', "$WAY_B_HC_OPTS" );
+ '_mg', "$WAY_mg_HC_OPTS");
\end{code}
$Haskell1Version = 4; # i.e., Haskell 1.4
@Cpp_define = ();
+# Cpp symbols defined when we're processing Haskell source.
+
+@HsSourceCppOpts =
+ ( "-D__HASKELL1__=$Haskell1Version"
+ , "-D__GLASGOW_HASKELL__=$ProjectVersionInt"
+ # not yet -- SDM
+ # , "-D__CONCURRENT_HASKELL__"
+ );
+
@UserLibrary_dir= (); #-L things;...
@UserLibrary = (); #-l things asked for by the user
@SysLibrary = (); # will be built up as we go along
$TopClosureFile # defaults to 1.2 one; will be mangled later
- = ( $INSTALLING) ? "$InstLibDirGhc/TopClosureXXXX.o"
- : "$TopPwd/$CURRENT_DIR/$GHC_RUNTIME_DIR/main/TopClosureXXXX.o";
+ = '';
+# ( $INSTALLING) ? "$InstLibDirGhc/TopClosureXXXX.o"
+# : "$TopPwd/$CURRENT_DIR/$GHC_RUNTIME_DIR/main/TopClosureXXXX.o";
# make depend for Haskell
$MkDependHS
$CoreLint = '';
$StgLint = '';
-@CcBoth_flags = ('-S'); # flags for *any* C compilation
-@CcInjects = ();
-
-# GCC flags: those for all files, those only for .c files; those only for .hc files
-@CcRegd_flags = ('-ansi', '-D__STG_GCC_REGS__', '-D__STG_TAILJUMPS__');
-@CcRegd_flags_c = ();
-@CcRegd_flags_hc = ();
-
@Import_dir = ('.'); #-i things
@Include_dir = ('.'); #-I things; other default(s) stuck on AFTER option processing
$HaveNativeCodeGen = $GhcWithNativeCodeGen;
$HscOut = '-C='; # '-C=' ==> .hc output; '-S=' ==> .s output; '-N=' ==> neither
$HscOut = '-S='
- if $HaveNativeCodeGen && $TargetPlatform =~ /^(alpha|sparc)-/;
-# TEMP: disable x86 if $HaveNativeCodeGen && $TargetPlatform =~ /^(i386|alpha|sparc)-/;
+ if $HaveNativeCodeGen && $TargetPlatform =~ /^(alpha)-/;
+# TEMP: disable x86 & Sparc if $HaveNativeCodeGen && $TargetPlatform =~ /^(i386|alpha|sparc)-/;
$ProduceHi = '-hifile=';
$HiOnStdout = 0;
$HiWith = '';
$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
$GRANing = ''; # set to g if compiling for GRAN
-$StkChkByPageFaultOK = 1; # may be set to 0 (false) for some builds
$Specific_hi_file = ''; # set by -ohi <file>; "-" for stdout
$Specific_dump_file = ''; # set by -odump <file>; "-" for stdout
$Using_dump_file = 0;
$Dump_raw_asm = 0;
$Dump_asm_splitting_info = 0;
$NoImplicitPrelude = 0;
-
+# 1 => don't tell the linker to hoist in PrelMain.Main, as an
+# external main is provided instead.
+$NoHaskellMain=0;
} # end of initDriverGlobals (Sigh)
\tr{what(1)}-style strings. Anyway, here are the relevant global
variables and their defaults:
\begin{code}
-$LinkChk = 1; # set to 0 if the link check should *not* be done
+$LinkChk = 0; # set to 0 if the link check should *not* be done
# major & minor version numbers; major numbers must always agree;
# minor disagreements yield a warning.
push (@MkDependHS_flags, "-o$Osuffix") if $Osuffix;
push (@MkDependHS_flags, "-s$BuildTag") if $BuildTag;
- push (@MkDependHS_flags, "-D__HASKELL1__=$Haskell1Version");
# They're not (currently) needed, but we need to quote any -#include options
foreach (@Cmd_opts) {
s/-#include.*$/'$&'/g;
};
- local($to_do) = "$MkDependHS @MkDependHS_flags -- @Cmd_opts -- @Input_file" ;
+ local($to_do) = "$MkDependHS @MkDependHS_flags @HsSourceCppOpts -- @Cmd_opts -- @Input_file" ;
&run_something($to_do, 'Haskell dependencies');
exit $Status;
}
#
# Will be properly fixed in the `new compiler` I hear, at which point
# the cloning can be turned off here.
- '-fclone-binds',
+ #
+ # Let's find out..
+ #'-fclone-binds',
$Oopt_MaxSimplifierIterations,
$Oopt_ShowSimplifierProgress,
# f = E
# g* = f
# ...f...
-# The g=f will get reverse-substituted later, but it's untidy.
+# The g=f will get reverse-substituted later, but it's untidy. --SLPJ
#
-# '-fessential-unfoldings-only',
-# '-fsimpl-uf-use-threshold0',
+# SDM: Here's why it's necessary.
+#
+# If we unfold in the first pass before the specialiser is run
+# we miss opportunities for specialisation because eg. wrappers
+# have been inlined for specialisable functions.
+#
+# This shows up in PrelArr.lhs - the specialised instance for newArray
+# calls the generic rangeSize, because rangeSize is strict and is
+# replaced by its wrapper by the simplifier.
+
+ '-fessential-unfoldings-only',
+ '-fsimpl-uf-use-threshold0',
# See remark re: cloning in defn of minusnotO
'-fclone-binds',
']',
($Oopt_DoSpecialise) ? (
- '-fspecialise-overloaded',
- $Oopt_SpecialiseUnboxed,
$Oopt_DoSpecialise,
) : (),
- '-fsimplify', # need dependency anal after specialiser ...
+ '-fsimplify', # need dependency anal after specialiser ...
'[', # need tossing before calc-inlinings ...
$Oopt_FB_Support,
'-ffloat-lets-exposing-whnf',
'-fclone-binds',
']',
-#LATER: '-fcalc-inlinings1', -- pointless for 2.01
-
# ($Oopt_FoldrBuildWW) ? (
# '-ffoldr-build-ww-anal',
# '-ffoldr-build-worker-wrapper',
%* *
%************************************************************************
-Sort out @$BuildTag@, @$PROFing@, @$CONCURing@, @$PARing@,
+Sort out @$BuildTag@, @$PROFing@, @$PARing@,
@$GRANing@, @$TICKYing@:
\begin{code}
sub setupBuildFlags {
$PROFignore_scc = '-W' if $PROFauto;
push(@HsP_flags, (($PROFignore_scc) ? $PROFignore_scc : '-S'));
-
- if ( $SplitObjFiles ) {
- # can't split with cost centres -- would need global and externs
- print STDERR "$Pgm: WARNING: splitting objects when profiling will *BREAK* if any _scc_s are present!\n";
- # (but it's fine if there aren't any _scc_s around...)
-# $SplitObjFiles = 0; # unset
- #not an error: for now: $Status++;
- }
}
#if ( $BuildTag ne '' ) {
# local($b) = $BuildDescr{$BuildTag};
- # if ($CONCURing eq 'c') { print STDERR "$Pgm: Can't mix $b with -concurrent.\n"; exit 1; }
# if ($PARing eq 'p') { print STDERR "$Pgm: Can't mix $b with -parallel.\n"; exit 1; }
# if ($GRANing eq 'g') { print STDERR "$Pgm: Can't mix $b with -gransim.\n"; exit 1; }
# if ($TICKYing eq 't') { print STDERR "$Pgm: Can't mix $b with -ticky.\n"; exit 1; }
if ($PARing eq 'p') { print STDERR "$Pgm: Can't do profiling with -parallel.\n"; exit 1; }
if ($GRANing eq 'g') { print STDERR "$Pgm: Can't do profiling with -gransim.\n"; exit 1; }
if ($TICKYing eq 't') { print STDERR "$Pgm: Can't do profiling with -ticky.\n"; exit 1; }
- $BuildTag = ($CONCURing eq 'c') ? '_mr' : '_p' ; # possibly "profiled concurrent"...
-
- } elsif ( $CONCURing eq 'c' ) {
- if ($PARing eq 'p') { print STDERR "$Pgm: Can't mix -concurrent with -parallel.\n"; exit 1; }
- if ($GRANing eq 'g') { print STDERR "$Pgm: Can't mix -concurrent with -gransim.\n"; exit 1; }
- $BuildTag = ($TICKYing eq 't') ? '_mt' : '_mc' ; # possibly "ticky concurrent"...
- # "profiled concurrent" already acct'd for...
+ $BuildTag = '_p' ;
} elsif ( $PARing eq 'p' ) {
if ($GRANing eq 'g') { print STDERR "$Pgm: Can't mix -parallel with -gransim.\n"; exit 1; }
$Tag = "${Tag}_" if $Tag ne '';
$HiSuffix_prelude="${Tag}hi";
}
- #push(@HsC_flags, "-hisuf-prelude=.${HiSuffix_prelude}"); # use appropriate Prelude .hi files
- #push(@HsC_flags, "-hisuf=.${HiSuffix}");
-
} # setupBuildFlags
\end{code}
sub setupMachOpts {
if ($TargetPlatform =~ /^alpha-/) {
- # we know how to *mangle* asm for alpha
- unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
- unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
unshift(@CcBoth_flags, ('-static'));
} elsif ($TargetPlatform =~ /^hppa/) {
- # we know how to *mangle* asm for hppa
- unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
unshift(@CcBoth_flags, ('-static'));
#
# We don't put in '-mlong-calls', because it's only
# (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 !~ /nextstep/;
- # I do not know how to do STACK_CHECK_BY_PAGE_FAULT
- # on NeXTs (my fault, not theirs), so I don't.
- # CaS
-
# -fno-defer-pop : basically the same game as for m68k
#
# -fomit-frame-pointer : *must* ; because we're stealing
unshift(@CcRegd_flags, "-DSTOLEN_X86_REGS=$StolenX86Regs");
} elsif ($TargetPlatform =~ /^m68k-/) {
- # we know how to *mangle* asm for m68k
- unshift (@CcRegd_flags, ('-D__STG_REV_TBLS__'));
- unshift (@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK && $TargetPlatform !~ /nextstep/;
- # I do not know how to do STACK_CHECK_BY_PAGE_FAULT
- # on NeXTs (my fault, not theirs), so I don't.
- # CaS
-
# -fno-defer-pop : for the .hc files, we want all the pushing/
# popping of args to routines to be explicit; if we let things
# be deferred 'til after an STGJUMP, imminent death is certain!
# 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-|^rs6000-/) {
- # we know how to *mangle* asm for PowerPC
-# :-( unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
- unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
unshift(@CcBoth_flags, ('-static')); # always easier to start with
unshift(@CcRegd_flags, ('-finhibit-size-directive')); # avoids traceback tables
} elsif ($TargetPlatform =~ /^sparc-/) {
- # we know how to *mangle* asm for SPARC
- unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
- unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
-
}
} # end of setupMachOpts
\end{code}
unshift(@Ld_flags,
(($Ld_main) ? ( '-u', "${uscore}Main_" . $Ld_main . '_closure' ) : ()));
+
+ # things that are referenced by the RTS - make sure that we pull 'em in
unshift(@Ld_flags,
- ( '-u', "${uscore}PrelBase_Z91Z93_closure" # i.e., []
- ,'-u', "${uscore}PrelBase_IZh_static_info"
+ ( '-u', "${uscore}PrelBase_IZh_static_info"
,'-u', "${uscore}PrelBase_CZh_static_info"
- ,'-u', "${uscore}PrelBase_False_inregs_info"
- ,'-u', "${uscore}PrelBase_True_inregs_info"
- ,'-u', "${uscore}DEBUG_REGS"
+ ,'-u', "${uscore}PrelBase_FZh_static_info"
+ ,'-u', "${uscore}PrelBase_DZh_static_info"
+ ,'-u', "${uscore}PrelAddr_AZh_static_info"
+ ,'-u', "${uscore}PrelAddr_WZh_static_info"
+ ,'-u', "${uscore}PrelAddr_I64Zh_static_info"
+ ,'-u', "${uscore}PrelAddr_W64Zh_static_info"
+ ,'-u', "${uscore}PrelForeign_StablePtr_static_info"
+ ,'-u', "${uscore}PrelBase_IZh_con_info"
+ ,'-u', "${uscore}PrelBase_CZh_con_info"
+ ,'-u', "${uscore}PrelBase_FZh_con_info"
+ ,'-u', "${uscore}PrelBase_DZh_con_info"
+ ,'-u', "${uscore}PrelAddr_AZh_con_info"
+ ,'-u', "${uscore}PrelAddr_WZh_con_info"
+ ,'-u', "${uscore}PrelAddr_I64Zh_con_info"
+ ,'-u', "${uscore}PrelAddr_W64Zh_con_info"
+ ,'-u', "${uscore}PrelForeign_StablePtr_con_info"
+ ,'-u', "${uscore}PrelBase_False_static_closure"
+ ,'-u', "${uscore}PrelBase_True_static_closure"
+ ,'-u', "${uscore}PrelPack_unpackCString_closure"
));
+ if (!$NoHaskellMain) {
+ unshift (@Ld_flags,'-u', "${uscore}PrelMain_mainIO_closure");
+ }
if ($TargetPlatform =~ /^powerpc-|^rs6000-/) {
# sometimes we have lots of toc entries...
# unshift(@Ld_flags, ('-Xlinker -bbigtoc -Xlinker -bnoquiet'));
$f .= $BuildTag if $f =~ /^-lHS/;
}
- # fiddle the TopClosure file name...
- $TopClosureFile =~ s/XXXX//;
-
# Push library HSrts, plus boring clib bit
push(@SysLibrary, "-lHSrts${BuildTag}");
- push(@SysLibrary, '-lHSclib');
+
#
# RTS compiled with cygwin32, uses the WinMM API
# to implement the itimers, since cygwin.dll does not
# support it. Only reqd. for `ways' that use itimers.
#
- push(@SysLibrary, '-lwinmm') if $BuildTag ne '' && $TargetPlatform eq 'i386-unknown-cygwin32';
+ push(@SysLibrary, '-lwinmm') if $TargetPlatform eq 'i386-unknown-cygwin32';
# Push the pvm libraries
if ($BuildTag eq '_mp') {
$pvmlib = "$ENV{'PVM_ROOT'}/lib/$ENV{'PVM_ARCH'}";
- push(@SysLibrary, "-L$pvmlib", '-lpvm3', '-lgpvm3');
+ push(@SysLibrary, "-L$pvmlib", '-lgpvm3', '-lpvm3');
if ( $ENV{'PVM_ARCH'} eq 'SUNMP' ) {
push(@SysLibrary, '-lthread', '-lsocket', '-lnsl');
} elsif ( $ENV{'PVM_ARCH'} eq 'SUN4SOL2' ) {
}
# Push the GNU multi-precision arith lib; and the math library
-push(@SysLibrary, '-lgmp');
+
+# If this machine has GMP already installed, then we'll get the installed
+# lib here, because presumably the one in the tree won't have been built.
+
+if ($LibGmp eq 'not-installed') {
+ push(@SysLibrary, "-lgmp");
+} else {
+ push(@SysLibrary, "-l$LibGmp");
+}
+
push(@SysLibrary, '-lm');
\end{code}
$hsc_out = $ifile; $is_hc_file = 0;
$hsc_out_c_stub = '';
$hsc_out_h_stub = '';
- } elsif ($ifile =~ /\.s$/) {
+ } elsif ($ifile =~ /\.[sS]$/) {
$do_hscpp = 0; $do_hsc = 0; $do_cc = 0;
$cc_as = $ifile;
} else { # don't know what it is, but nothing to do herein...
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>"@.
$going_interactive);
}
- if (-f $hsc_out_c_stub) {
- &run_something("cp $hsc_out_c_stub $ofile_c_stub_target", 'Copy foreign export C stubs');
- }
-
if (-f $hsc_out_h_stub) {
&run_something("cp $hsc_out_h_stub $ofile_h_stub_target", 'Copy foreign export header file');
}
+ if (-f $hsc_out_c_stub) {
+ &run_something("cp $hsc_out_c_stub $ofile_c_stub_target", 'Copy foreign export C stubs');
+ local ($hsc_out_s_stub);
+ local ($hsc_out_o_stub);
+ ($ofile_s_stub_target = $ofile_c_stub_target) =~ s/\.(.*)$/\.s/;
+ ($ofile_o_stub_target = $ofile_c_stub_target) =~ s/\.(.*)$/\.o/;
+ &runGcc (0, $ofile_c_stub_target, $ofile_s_stub_target);
+ &runAs ($ofile_o_stub_target, $ofile_s_stub_target);
+ #
+ # Bring the C stub protos into scope when compiling the .hc file.
+ #
+ push (@CcInjects, "#include \"${hsc_out_h_stub}\"\n");
+ # Hack - ensure that the stub .h file is included in the OPTIONS section
+ # if the .hc file is saved.
+ push (@File_options, "-#include \"${ofile_h_stub_target}\"\n");
+
+ }
+
if ($do_cc) {
&runGcc ($is_hc_file, $hsc_out, $cc_as_o);
&runMangler($is_hc_file, $cc_as_o, $cc_as, $ifile_root) if ! $Only_preprocess_hc;
#ToDo: local($or_isuf) = ($Isuffix eq '') ? '' : "|$Isuffix";
-
- if ( $ifile !~ /\.(lhs|hs|hc|c|s|a)$/ && $ifile !~ /_hc$/ ) {
+ if ( $ifile !~ /\.(lhs|hs|hc|c|s|a|S)$/ && $ifile !~ /_hc$/ ) {
# There's sometimes confusion regarding .hi files; users
# supplying them on the command line.
if ( $ifile =~ /\.hi$/ ) {
&run_something($to_do, 'Ineffective C pre-processor');
} else {
local($includes) = '-I' . join(' -I',@Include_dir);
- $to_do .= "$HsCpp $Verbose @HsCpp_flags -D__HASKELL1__=$Haskell1Version -D__GLASGOW_HASKELL__=$ProjectVersionInt $includes $lit2pgm_hscpp >> $hscpp_hsc";
+ $to_do .= "$HsCpp $Verbose @HsCpp_flags @HsSourceCppOpts $includes $lit2pgm_hscpp >> $hscpp_hsc";
push(@Files_to_tidy, $hscpp_hsc );
&run_something($to_do, 'Haskellised C pre-processor');
}
local($cc_help_s) = "ghc$$.s";
$cc = $CcRegd;
- $s_output = ($is_hc_file || $TargetPlatform =~ /^(powerpc|rs6000|hppa|i386)/) ? $cc_as_o : $cc_as;
+ $s_output = ($is_hc_file || $TargetPlatform =~ /^(powerpc|rs6000|hppa)/) ? $cc_as_o : $cc_as;
$c_flags .= " @CcRegd_flags";
$c_flags .= ($is_hc_file) ? " @CcRegd_flags_hc" : " @CcRegd_flags_c";
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"
+#include "Stg.h"
EOINCL
# user may have asked for #includes to be injected...
print TMP @CcInjects if $#CcInjects >= 0;
# Don't redirect stderr into intermediate file if slamming output onto stdout (e.g., with -E)
local($fuse_stderr) = "2>&1" if ! $Only_preprocess_hc;
- local($to_do) = "$cc $Verbose $ddebug_flag $c_flags @Cpp_define -D__HASKELL1__=$Haskell1Version $includes $cc_help > $Tmp_prefix.ccout $fuse_stderr && ( 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.
+ local($to_do) = "$cc $Verbose $ddebug_flag $c_flags @Cpp_define $includes $cc_help > $Tmp_prefix.ccout $fuse_stderr && ( if [ $cc_help_s != $s_output ] ; then mv $cc_help_s $s_output ; else exit 0 ; fi )";
if ( $Only_preprocess_hc ) { # HACK ALERT!
$to_do =~ s/ -S\b//g;
# post-process the assembler [.hc files only]
&mangle_asm($cc_as_o, $cc_as);
-
-#OLD: for sanity:
-#OLD: local($target) = 'oops';
-#OLD: $target = '-alpha' if $TargetPlatform =~ /^alpha-/;
-#OLD: $target = '-hppa' if $TargetPlatform =~ /^hppa/;
-#OLD: $target = '-old-asm' if $TargetPlatform =~ /^i386-/;
-#OLD: $target = '-m68k' if $TargetPlatform =~ /^m68k-/;
-#OLD: $target = '-mips' if $TargetPlatform =~ /^mips-/;
-#OLD: $target = '' if $TargetPlatform =~ /^powerpc-/;
-#OLD: $target = '-solaris' if $TargetPlatform =~ /^sparc-sun-solaris2/;
-#OLD: $target = '-sparc' if $TargetPlatform =~ /^sparc-sun-sunos4/;
-#OLD:
-#OLD: if ( $target ne '' ) {
-#OLD: require("ghc-asm$target.prl")
-#OLD: || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm$target.prl!\n");
-#OLD: &mangle_asm($cc_as_o, "$cc_as-2"); # the OLD one!
-#OLD: &run_something("$Cmp -s $cc_as-2 $cc_as || $Diff $cc_as-2 $cc_as 1>&2 || exit 0",
-#OLD: "Diff'ing old and new mangled .s files"); # NB: to stderr
-#OLD: }
-
} elsif ($TargetPlatform =~ /^hppa/) {
# minor mangling of non-threaded files for hp-pa only
require('ghc-asm.prl')
require('ghc-asm.prl')
|| &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm-powerpc.prl!\n");
&mini_mangle_asm_powerpc($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...
local($asmblr) = ( $As ) ? $As : $CcRegd;
+ # need to add the -I flags in case the file is going through cpp (.S files)
+ local($includes) = '-I' . join(' -I', @Include_dir);
+
if ( ! $SplitObjFiles ) {
- local($to_do) = "$asmblr -o $as_out -c @As_flags $cc_as";
+ local($to_do) = "$asmblr -o $as_out -c @As_flags $includes $cc_as";
push(@Files_to_tidy, $as_out );
&run_something($to_do, 'Unix assembler');
open(CCOUT, "< $Tmp_prefix.ccout")
|| &tidy_up_and_die(1,"$Pgm: failed to open `$Tmp_prefix.ccout'\n");
while ( <CCOUT> ) {
- next if /attribute directive ignored/;
next if /call-clobbered/;
- next if /from .*COptRegs\.lh/;
- next if /from .*(stg|rts)defs\.h:/;
+ next if /control reaches end/;
+ next if /from .*Stg\.h:/;
next if /from ghc\d+.c:\d+:/;
- next if /from .*\.lc/;
- next if /from .*SMinternal\.l?h/;
- next if /ANSI C does not support \`long long\'/;
- next if /warning:.*was declared \`extern\' and later \`static\'/;
- next if /warning: assignment discards \`const\' from pointer target type/;
next if /: At top level:$/;
next if /: In function \`.*\':$/;
next if /\`ghc_cc_ID\' defined but not used/;
arg: while($_ = $args[0]) {
shift(@args);
# sigh, we have to deal with these -option arg specially here.
- /^-(tmpdir|odir|ohi|o|isuf|osuf|hisuf|hisuf-prelude|odump|syslib)$/ &&
+ /^-(tmpdir|odir|ohi|o|isuf|osuf|hisuf|odump|syslib)$/ &&
do { push(@Cmd_opts, $_); push(@Cmd_opts,$args[0]); shift(@args); next arg; };
/^--?./ && do { push(@Cmd_opts, $_); next arg; };
/^-hi$/ && do { $HiOnStdout = 1; $ProduceHi = '-hifile='; next arg; };
# _do_ generate an interface; usually used as: -noC -hi
- /^-hi-with-(.*)$/ && do { $HiOnStdout = 1; $HiWith .= " $1" ; $ProduceHi = '-hifile='; next arg; };
- # limit ourselves to outputting a particular section.
/^-nohi$/ && do { $ProduceHi = '-nohifile='; next arg; };
# don't generate an interface (even if generating C)
$Status++;
}
next arg; };
- # ToDo: remove, not a `normal' user thing to do (should be automatic)
- /^-hisuf-prelude$/ && do { $HiSuffix_prelude = &grab_arg_arg(*Args,'-hisuf-prelude', '');
- if ($HiSuffix =~ /\./ ) {
- print STDERR "$Pgm: -hisuf-prelude suffix shouldn't contain a .\n";
- $Status++;
- }
- next arg; };
/^-odump$/ && do { $Specific_dump_file = &grab_arg_arg(*Args,'-odump', '');
if ($Specific_dump_file =~ /(.*)\/[^\/]*$/) {
local($dir_part) = $1;
: '-fauto-sccs-on-exported-toplevs';
next arg; };
- #--------- ticky/concurrent/parallel -----------------------------------
+ #--------- ticky/parallel ----------------------------------------------
# we sort out the details a bit later on
- /^-concurrent$/ && do { $CONCURing = 'c'; &add_syslib('concurrent'); next arg; };
- # concurrent Haskell; implies -syslib conc
/^-gransim$/ && do { $GRANing = 'g'; &add_syslib('concurrent'); next arg; }; # GranSim
/^-ticky$/ && do { $TICKYing = 't'; next arg; }; # ticky-ticky
/^-parallel$/ && do { $PARing = 'p'; &add_syslib('concurrent'); next arg; }; # parallel Haskell
/^-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 { next arg; }; # a no-op right now
-
/^-fignore-interface-pragmas$/ && do { push(@HsC_flags, $_); next arg; };
/^-fno-implicit-prelude$/ && do { $NoImplicitPrelude= 1; push(@HsC_flags, $_); next arg; };
- # don't do stack checking using page fault `trick'.
- # (esoteric).
- /^-fstack-check$/ && do { $StkChkByPageFaultOK = 0; next arg; };
+
#
# have the compiler proper generate concurrent code,
# really only used when you want to configure your own
- # special user compilation way. (Use -concurrent when
- # compiling `Concurrent Haskell' programs).
+ # special user compilation way.
#
- # (ditto for -fgransim, fscc-profiling and -fticky-ticky)
+ # (ditto for -fgransim, fscc-profiling, -fparallel and -fticky-ticky)
#
- /^-fconcurrent$/ && do { push(@HsC_flags,$_); next arg; };
/^-fscc-profiling$/ && do { push(@HsC_flags,$_); next arg; };
/^-fticky-ticky$/ && do { push(@HsC_flags,$_); next arg; };
/^-fgransim$/ && do { push(@HsC_flags,$_); next arg; };
+ /^-fparallel$/ && do { push(@HsC_flags,$_); next arg; };
- /^-split-objs/ && do {
+ /^-split-objs$/ && do {
if ( $TargetPlatform !~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|rs6000|sparc)-/ ) {
$SplitObjFiles = 0;
print STDERR "WARNING: don't know how to split objects on this platform: $TargetPlatform\n`-split-objs' option ignored\n";
}
next arg; };
- /^-fallow-overlapping-instances$/ && do { push(@HsC_flags, $_);
- next arg; };
+ /^-fallow-overlapping-instances$/ && do { push(@HsC_flags, $_); next arg; };
+ /^-fallow-undecidable-instances$/ && do { push(@HsC_flags, $_); next arg; };
/^-fglasgow-exts$/
&& do { push(@HsC_flags, $_);
push(@HsP_flags, '-N');
next arg; };
- /^-fspeciali[sz]e-unboxed$/
- && do { $Oopt_DoSpecialise = '-fspecialise';
- $Oopt_SpecialiseUnboxed = '-fspecialise-unboxed';
- next arg; };
/^-fspeciali[sz]e$/
&& do { $Oopt_DoSpecialise = '-fspecialise'; next arg; };
/^-fno-speciali[sz]e$/
/^(-fmax-simplifier-iterations)(.*)$/
&& do { $Oopt_MaxSimplifierIterations = $1 . &grab_arg_arg(*Args,$1, $2);
next arg; };
- /^(-fshow-simplifier-progress)/
- && do { $Oopt_ShowSimplifierProgress = $1;
- next arg; };
/^-fno-pedantic-bottoms$/
&& do { $Oopt_PedanticBottoms = ''; next arg; };
+ /^-fno-pre-inlining$/
+ && do { push(@HsC_flags, $_); next arg };
+
/^-fdo-monad-eta-expansion$/
&& do { $Oopt_MonadEtaExpansion = $_; next arg; };
/^-fno-let-from-(case|app|strict-let)$/ # experimental, really (WDP 95/10)
&& do { push(@HsC_flags, $_); next arg; };
- /^(-freturn-in-regs-threshold)(.*)$/
- && do { local($what) = $1;
- local($num) = &grab_arg_arg(*Args,$what, $2);
- if ($num < 2 || $num > 8) {
- die "Bad experimental flag: $_\n";
- } else {
- $HscOut = '-C='; # force using C compiler
- push(@HsC_flags, "$what$num");
- push(@CcRegd_flags, "-D__STG_REGS_AVAIL__=$num");
- }
- next arg; };
-
# --------------- Warnings etc. ------
- /^-fshow-import-specs/
- && do { push(@HsC_flags, $_); next arg; };
-
- /^-fsignatures-required/
- && do { push(@HsC_flags, $_); next arg; };
-
/^-fwarn-(.*)$/ && do { push(@HsC_flags, $_); next arg; };
/^-fno-(.*)$/ && do { push(@HsC_antiflags, "-f$1");
#---------- Linker (gcc, really) ---------------------------------------
/^-static$/ && do { push(@Ld_flags, $_); next arg; };
+ /^-no-hs-main$/ && do { $NoHaskellMain=1; next arg; };
#---------- mixed cc and linker magic ----------------------------------
# this optimisation stuff is finally sorted out later on...
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* -----------------------------------------------------------------------------
+ * Bytecode assembler
+ *
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: Assembler.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:20:52 $
+ *
+ * NB This is one of the few files shared between Hugs and the runtime system,
+ * so it is very important that it not conflict with either and that it not
+ * rely on either.
+ * (In fact, it might be fun to create a GreenCard interface to this file too.)
+ * ---------------------------------------------------------------------------*/
+
+/* ToDo: put this somewhere more sensible */
+extern void DEBUG_LoadSymbols( char *name );
+
+/* This file is supposed to be somewhat self-contained because it is one
+ * of the major external interfaces to the runtime system.
+ * Keeping it self-contained reduces the chance of conflict with Hugs
+ * (or anything else that includes it).
+ * The big disadvantage of being self-contained is that definitions
+ * like AsmNat8, etc duplicate definitions in StgTypes.h.
+ * I'm not sure what we can do about this but, if you try to fix it,
+ * please remember why it was done this way in the first place.
+ * -- ADR
+ */
+
+typedef unsigned char AsmNat8;
+typedef unsigned int AsmNat;
+typedef signed int AsmInt;
+typedef signed long long int AsmInt64; /* ToDo: not portable! */
+typedef unsigned int AsmWord;
+typedef void* AsmAddr;
+typedef unsigned char AsmChar;
+typedef float AsmFloat; /* ToDo: not on Alphas! */
+typedef double AsmDouble;
+typedef char* AsmString;
+
+/* I want to #include this file into the file that defines the
+ * functions but I don't want to expose the structures that
+ * these types point to.
+ * This hack is the best I could think of. Surely there's a better way?
+ */
+#ifdef INSIDE_ASSEMBLER_C
+typedef struct AsmObject_ *AsmObject;
+typedef struct AsmBCO_ *AsmBCO;
+typedef struct AsmCAF_ *AsmCAF;
+typedef struct AsmCon_ *AsmCon;
+typedef StgInfoTable *AsmInfo;
+typedef StgClosure *AsmClosure;
+typedef Instr AsmInstr;
+#else
+/* the types we export are totally opaque */
+typedef void *AsmObject;
+typedef void *AsmBCO;
+typedef void *AsmCAF;
+typedef void *AsmCon;
+typedef void *AsmInfo;
+typedef void *AsmClosure;
+typedef unsigned int AsmInstr;
+#endif
+
+typedef int AsmSp; /* stack offset */
+typedef int AsmPc; /* program counter */
+typedef AsmSp AsmVar; /* offset of a Var on the stack */
+
+/* --------------------------------------------------------------------------
+ * "Types" used within the assembler
+ *
+ * Some of these types are synonyms for the same underlying representation
+ * to let Hugs (or whoever) generate useful Haskell types from the type
+ * of a primitive operation.
+ *
+ * Extreme care should be taken if you change any of these - the
+ * same constants are hardwired into Hugs (ILLEGAL_REP) and into
+ * pieces of assembly language used to implement foreign import/export.
+ * And, of course, you'll have to change the primop table in Assembler.c
+ * ------------------------------------------------------------------------*/
+
+typedef enum {
+ ILLEGAL_REP = 0,
+
+ /* The following can be passed to C */
+ CHAR_REP = 'C',
+ INT_REP = 'I',
+#ifdef PROVIDE_INT64
+ INT64_REP = 'z',
+#endif
+#ifdef PROVIDE_INTEGER
+ INTEGER_REP = 'Z',
+#endif
+#ifdef PROVIDE_WORD
+ WORD_REP = 'W',
+#endif
+#ifdef PROVIDE_ADDR
+ ADDR_REP = 'A',
+#endif
+ FLOAT_REP = 'F',
+ DOUBLE_REP = 'D',
+#ifdef PROVIDE_STABLE
+ STABLE_REP = 's', /* StablePtr a */
+#endif
+#ifdef PROVIDE_FOREIGN
+ FOREIGN_REP = 'f', /* ForeignObj */
+#endif
+#ifdef PROVIDE_WEAK
+ WEAK_REP = 'w', /* Weak a */
+#endif
+#ifdef PROVIDE_ARRAY
+ BARR_REP = 'x', /* PrimByteArray a */
+ MUTBARR_REP = 'm', /* PrimMutableByteArray s a */
+#endif
+
+ /* The following can't be passed to C */
+ PTR_REP = 'P',
+ ALPHA_REP = 'a', /* a */
+ BETA_REP = 'b', /* b */
+ BOOL_REP = 'B', /* Bool */
+ IO_REP = 'i', /* IO a */
+ HANDLER_REP = 'H', /* Exception -> IO a */
+ ERROR_REP = 'E', /* Exception */
+#ifdef PROVIDE_ARRAY
+ ARR_REP = 'X', /* PrimArray a */
+ REF_REP = 'R', /* Ref s a */
+ MUTARR_REP = 'M', /* PrimMutableArray s a */
+#endif
+#ifdef PROVIDE_CONCURRENT
+ THREADID_REP = 'T', /* ThreadId */
+ MVAR_REP = 'r', /* MVar a */
+#endif
+
+ /* Allegedly used in the IO monad */
+ VOID_REP = 'v'
+} AsmRep;
+
+/* --------------------------------------------------------------------------
+ * Allocating (top level) heap objects
+ * ------------------------------------------------------------------------*/
+
+extern AsmBCO asmBeginBCO ( void );
+extern void asmEndBCO ( AsmBCO bco );
+
+extern AsmBCO asmBeginContinuation ( AsmSp sp );
+extern void asmEndContinuation ( AsmBCO bco );
+
+extern AsmObject asmMkObject ( AsmClosure c );
+
+extern AsmCAF asmBeginCAF ( void );
+extern void asmEndCAF ( AsmCAF caf, AsmBCO body );
+
+extern AsmInfo asmMkInfo ( AsmNat tag, AsmNat ptrs );
+extern AsmCon asmBeginCon ( AsmInfo info );
+extern void asmEndCon ( AsmCon con );
+
+/* NB: we add ptrs to other objects in left-to-right order.
+ * This is different from pushing arguments on the stack which is done
+ * in right to left order.
+ */
+extern void asmAddPtr ( AsmObject obj, AsmObject arg );
+
+extern int asmObjectHasClosure( AsmObject obj );
+extern AsmClosure asmClosureOfObject ( AsmObject obj );
+extern void asmMarkObject ( AsmObject obj );
+
+/* --------------------------------------------------------------------------
+ * Generating instruction streams
+ * ------------------------------------------------------------------------*/
+
+extern AsmSp asmBeginArgCheck ( AsmBCO bco );
+extern void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg );
+
+extern AsmSp asmBeginEnter ( AsmBCO bco );
+extern void asmEndEnter ( AsmBCO bco, AsmSp sp1, AsmSp sp2 );
+
+extern AsmVar asmBind ( AsmBCO bco, AsmRep rep );
+extern void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep );
+
+extern AsmSp asmBeginCase ( AsmBCO bco );
+extern void asmEndCase ( AsmBCO bco );
+extern AsmSp asmContinuation ( AsmBCO bco, AsmBCO ret_addr );
+
+extern AsmSp asmBeginAlt ( AsmBCO bco );
+extern void asmEndAlt ( AsmBCO bco, AsmSp sp );
+extern AsmPc asmTest ( AsmBCO bco, AsmWord tag );
+extern AsmPc asmTestInt ( AsmBCO bco, AsmVar v, AsmInt x );
+extern void asmFixBranch ( AsmBCO bco, AsmPc pc );
+extern void asmPanic ( AsmBCO bco );
+
+extern AsmVar asmBox ( AsmBCO bco, AsmRep rep );
+extern AsmVar asmUnbox ( AsmBCO bco, AsmRep rep );
+extern void asmReturnUnboxed ( AsmBCO bco, AsmRep rep );
+
+/* push unboxed Ints, Floats, etc */
+extern void asmConstInt ( AsmBCO bco, AsmInt x );
+#ifdef PROVIDE_ADDR
+extern void asmConstAddr ( AsmBCO bco, AsmAddr x );
+#endif
+#ifdef PROVIDE_WORD
+extern void asmConstWord ( AsmBCO bco, AsmWord x );
+#endif
+extern void asmConstChar ( AsmBCO bco, AsmChar x );
+extern void asmConstFloat ( AsmBCO bco, AsmFloat x );
+extern void asmConstDouble ( AsmBCO bco, AsmDouble x );
+#ifdef PROVIDE_INT64
+extern void asmConstInt64 ( AsmBCO bco, AsmInt64 x );
+#endif
+#ifdef PROVIDE_INTEGER
+extern void asmConstInteger ( AsmBCO bco, AsmString x );
+#endif
+
+/* Which monad (if any) does the primop live in? */
+typedef enum {
+ MONAD_Id, /* no monad (aka the identity monad) */
+ MONAD_ST,
+ MONAD_IO
+} AsmMonad;
+
+typedef struct {
+ char* name;
+ char* args;
+ char* results;
+ AsmMonad monad;
+ AsmNat8 prefix; /* should be StgInstr */
+ AsmNat8 opcode; /* should be Primop1 or Primop2 */
+} AsmPrim;
+
+extern const AsmPrim asmPrimOps[]; /* null terminated list */
+
+extern const AsmPrim* asmFindPrim ( char* s );
+extern const AsmPrim* asmFindPrimop ( AsmInstr prefix, AsmInstr op );
+extern AsmSp asmBeginPrim ( AsmBCO bco );
+extern void asmEndPrim ( AsmBCO bco, const AsmPrim* prim, AsmSp base );
+
+/* --------------------------------------------------------------------------
+ * Heap manipulation
+ * ------------------------------------------------------------------------*/
+
+extern AsmVar asmClosure ( AsmBCO bco, AsmObject p );
+
+extern AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info );
+
+extern AsmSp asmBeginPack ( AsmBCO bco );
+extern void asmEndPack ( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info );
+
+extern void asmBeginUnpack ( AsmBCO bco );
+extern void asmEndUnpack ( AsmBCO bco );
+
+extern AsmVar asmAllocAP ( AsmBCO bco, AsmNat size );
+extern AsmSp asmBeginMkAP ( AsmBCO bco );
+extern void asmEndMkAP ( AsmBCO bco, AsmVar v, AsmSp start );
+
+extern AsmVar asmAllocPAP ( AsmBCO bco, AsmNat size );
+extern AsmSp asmBeginMkPAP ( AsmBCO bco );
+extern void asmEndMkPAP ( AsmBCO bco, AsmVar v, AsmSp start );
+
+/* --------------------------------------------------------------------------
+ * C-call and H-call
+ * ------------------------------------------------------------------------*/
+
+extern const AsmPrim ccall_Id;
+extern const AsmPrim ccall_IO;
+
+typedef struct {
+ char * arg_tys;
+ int arg_size;
+ char * result_tys;
+ int result_size;
+} CFunDescriptor;
+
+typedef struct {
+ char * arg_tys;
+ char * result_tys;
+} HFunDescriptor;
+
+CFunDescriptor* mkDescriptor( char* as, char* rs );
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Block.h,v 1.2 1998/12/02 13:20:53 simonm Exp $
+ *
+ * Block structure for the storage manager
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef BLOCK_H
+#define BLOCK_H
+
+/* The actual block and megablock-size constants are defined in
+ * includes/Constants.h, all constants here are derived from these.
+ */
+
+/* Block related constants (4k blocks) */
+
+#define BLOCK_SIZE_W (BLOCK_SIZE/sizeof(W_))
+#define BLOCK_MASK (BLOCK_SIZE-1)
+
+#define BLOCK_ROUND_UP(p) ((void *) (((W_)(p)+BLOCK_SIZE-1) & ~BLOCK_MASK))
+#define BLOCK_ROUND_DOWN(p) ((void *) ((W_)(p) & ~BLOCK_MASK))
+
+/* Megablock related constants (1M megablocks) */
+
+#define MBLOCK_SIZE_W (MBLOCK_SIZE/sizeof(W_))
+#define MBLOCK_MASK (MBLOCK_SIZE-1)
+
+#define MBLOCK_ROUND_UP(p) ((void *)(((W_)(p)+MBLOCK_SIZE-1) & ~MBLOCK_MASK))
+#define MBLOCK_ROUND_DOWN(p) ((void *)((W_)(p) & ~MBLOCK_MASK ))
+
+
+/* -----------------------------------------------------------------------------
+ * Block descriptor. This structure *must* be the right length, so we
+ * can do pointer arithmetic on pointers to it.
+ */
+
+/* The block descriptor is 64 bytes on a 64-bit machine, and 32-bytes
+ * on a 32-bit machine.
+ */
+
+typedef struct _bdescr {
+ StgPtr start; /* start addr of memory */
+ StgPtr free; /* first free byte of memory */
+ struct _bdescr *link; /* used for chaining blocks together */
+ struct _bdescr *back; /* used (occasionally) for doubly-linked lists*/
+ StgNat32 gen; /* generation */
+ StgNat32 step; /* step */
+ StgNat32 blocks; /* no. of blocks (if grp head, 0 otherwise) */
+#if SIZEOF_VOID_P == 8
+ StgNat32 _padding[5];
+#else
+ StgNat32 _padding[1];
+#endif
+} bdescr;
+
+#if SIZEOF_VOID_P == 8
+#define BDESCR_SIZE 0x40
+#define BDESCR_MASK 0x3f
+#define BDESCR_SHIFT 6
+#else
+#define BDESCR_SIZE 0x20
+#define BDESCR_MASK 0x1f
+#define BDESCR_SHIFT 5
+#endif
+
+/* Useful Macros ------------------------------------------------------------ */
+
+/* Offset of first real data block in a megablock */
+
+#define FIRST_BLOCK_OFF \
+ ((W_)BLOCK_ROUND_UP(MBLOCK_SIZE / BLOCK_SIZE * BDESCR_SIZE))
+
+/* First data block in a given megablock */
+
+#define FIRST_BLOCK(m) ((void *)(FIRST_BLOCK_OFF + (W_)(m)))
+
+/* Last data block in a given megablock */
+
+#define LAST_BLOCK(m) ((void *)(MBLOCK_SIZE-BLOCK_SIZE + (W_)(m)))
+
+/* First real block descriptor in a megablock */
+
+#define FIRST_BDESCR(m) \
+ ((bdescr *)((FIRST_BLOCK_OFF>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
+
+/* Number of usable blocks in a megablock */
+
+#define BLOCKS_PER_MBLOCK ((MBLOCK_SIZE - FIRST_BLOCK_OFF) / BLOCK_SIZE)
+
+/* How many blocks in this megablock group */
+
+#define MBLOCK_GROUP_BLOCKS(n) \
+ (BLOCKS_PER_MBLOCK + (n-1) * (MBLOCK_SIZE / BLOCK_SIZE))
+
+/* Compute the required size of a megablock group */
+
+#define BLOCKS_TO_MBLOCKS(n) \
+ (1 + (W_)MBLOCK_ROUND_UP((n-BLOCKS_PER_MBLOCK) * BLOCK_SIZE) / MBLOCK_SIZE)
+
+#endif BLOCK_H
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: CCall.h,v 1.2 1998/12/02 13:20:53 simonm Exp $
+ *
+ * Macros for performing C calls from the STG world.
+ * -------------------------------------------------------------------------- */
+
+#ifndef CCALL_H
+#define CCALL_H
+
+/*
+ * Most C-Calls made from STG land are of the 'unsafe' variety.
+ * An unsafe C-Call is one where we trust the C function not to do
+ * anything nefarious while it has control.
+ *
+ * Nefarious actions include doing allocation on the Haskell heap,
+ * garbage collecting, creating/deleting threads, re-entering the
+ * scheduler, and messing with runtime system data structures.
+ *
+ * For these calls, the code generator will kindly provide CALLER_SAVE
+ * and CALLER_RESTORE macros for any registers that are live across the
+ * call. These macros may expand into saves of the relevant registers
+ * if those registers are designated caller-saves by the C calling
+ * convention, otherwise they will expand to nothing.
+ */
+
+/* Unsafe C-Calls have no macros: we just use a straightforward call.
+ */
+
+/*
+ * An STGCALL<n> is used when we want the relevant registers to be
+ * saved automatically. An STGCALL doesn't return a result, there's
+ * an alternative set of RET_STGCALL<n> macros for that (and we hope
+ * that the restoring of the caller-saves registers doesn't clobber
+ * the result!)
+ */
+
+#define STGCALL0(f) \
+ CALLER_SAVE_ALL (void) f(); CALLER_RESTORE_ALL
+
+#define STGCALL1(f,a) \
+ CALLER_SAVE_ALL (void) f(a); CALLER_RESTORE_ALL
+
+#define STGCALL2(f,a,b) \
+ CALLER_SAVE_ALL (void) f(a,b); CALLER_RESTORE_ALL
+
+#define STGCALL3(f,a,b,c) \
+ CALLER_SAVE_ALL (void) f(a,b,c); CALLER_RESTORE_ALL
+
+#define STGCALL4(f,a,b,c,d) \
+ CALLER_SAVE_ALL (void) f(a,b,c,d); CALLER_RESTORE_ALL
+
+#define STGCALL5(f,a,b,c,d,e) \
+ CALLER_SAVE_ALL (void) f(a,b,c,d,e); CALLER_RESTORE_ALL
+
+
+#define RET_STGCALL0(t,f) \
+ ({ t _r; CALLER_SAVE_ALL _r = f(); CALLER_RESTORE_ALL; _r; })
+
+#define RET_STGCALL1(t,f,a) \
+ ({ t _r; CALLER_SAVE_ALL _r = f(a); CALLER_RESTORE_ALL; _r; })
+
+#define RET_STGCALL2(t,f,a,b) \
+ ({ t _r; CALLER_SAVE_ALL _r = f(a,b); CALLER_RESTORE_ALL; _r; })
+
+#define RET_STGCALL3(t,f,a,b,c) \
+ ({ t _r; CALLER_SAVE_ALL _r = f(a,b,c); CALLER_RESTORE_ALL; _r; })
+
+#define RET_STGCALL4(t,f,a,b,c,d) \
+ ({ t _r; CALLER_SAVE_ALL _r = f(a,b,c,d); CALLER_RESTORE_ALL; _r; })
+
+#define RET_STGCALL5(t,f,a,b,c,d,e) \
+ ({ t _r; CALLER_SAVE_ALL _r = f(a,b,c,d,e); CALLER_RESTORE_ALL; _r; })
+
+
+/*
+ * A PRIM_STGCALL is used when we have arranged to save the R<n>,
+ * F<n>, and D<n> registers already, we only need the "system"
+ * registers saved for us. These are used in PrimOps, where the
+ * compiler has a good idea of what registers are live, and so doesn't
+ * need to save all of them.
+ */
+
+#define PRIM_STGCALL0(f) \
+ CALLER_SAVE_SYSTEM (void) f(); CALLER_RESTORE_SYSTEM
+
+#define PRIM_STGCALL1(f,a) \
+ CALLER_SAVE_SYSTEM (void) f(a); CALLER_RESTORE_SYSTEM
+
+#define PRIM_STGCALL2(f,a,b) \
+ CALLER_SAVE_SYSTEM (void) f(a,b); CALLER_RESTORE_SYSTEM
+
+#define PRIM_STGCALL3(f,a,b,c) \
+ CALLER_SAVE_SYSTEM (void) f(a,b,c); CALLER_RESTORE_SYSTEM
+
+#define PRIM_STGCALL4(f,a,b,c,d) \
+ CALLER_SAVE_SYSTEM (void) f(a,b,c,d); CALLER_RESTORE_SYSTEM
+
+#define PRIM_STGCALL5(f,a,b,c,d,e) \
+ CALLER_SAVE_SYSTEM (void) f(a,b,c,d,e); CALLER_RESTORE_SYSTEM
+
+
+#define RET_PRIM_STGCALL0(t,f) \
+ ({ t _r; CALLER_SAVE_SYSTEM _r = f(); CALLER_RESTORE_SYSTEM; _r; })
+
+#define RET_PRIM_STGCALL1(t,f,a) \
+ ({ t _r; CALLER_SAVE_SYSTEM _r = f(a); CALLER_RESTORE_SYSTEM; _r; })
+
+#define RET_PRIM_STGCALL2(t,f,a,b) \
+ ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b); CALLER_RESTORE_SYSTEM; _r; })
+
+#define RET_PRIM_STGCALL3(t,f,a,b,c) \
+ ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c); CALLER_RESTORE_SYSTEM; _r; })
+
+#define RET_PRIM_STGCALL4(t,f,a,b,c,d) \
+ ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c,d); CALLER_RESTORE_SYSTEM; _r; })
+
+#define RET_PRIM_STGCALL5(t,f,a,b,c,d,e) \
+ ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c,d,e); CALLER_RESTORE_SYSTEM; _r; })
+
+/* ToDo: ccalls that might garbage collect - do we need to return to
+ * the scheduler to perform these? Similarly, ccalls that might want
+ * to call Haskell right back, or start a new thread or something.
+ */
+
+#endif /* CCALL_H */
+
+++ /dev/null
-\section[COptJumps]{Macros for tail-jumping}
-
-% this file is part of the C-as-assembler document
-
-\begin{code}
-#ifndef COPTJUMPS_H
-#define COPTJUMPS_H
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[COptJumps-portable]{Tail-(non-)jumping in ``portable~C''}
-%* *
-%************************************************************************
-
-\begin{code}
-#if ! (defined(__STG_TAILJUMPS__) && defined(__GNUC__))
-
-#define JMP_(target) return((F_) (target))
-#define RESUME_(target) JMP_(target)
-\end{code}
-
-Don't need to do anything magical for the mini-interpreter, because
-we're really going to use the plain old C one (and the debugging
-variant, too, for that matter).
-
-%************************************************************************
-%* *
-\subsection[COptJumps-optimised]{Tail-jumping in ``optimised~C''}
-%* *
-%************************************************************************
-
-\begin{code}
-#else /* __STG_TAILJUMPS__ && __GNUC__ */
-\end{code}
-
-GCC will have assumed that pushing/popping of C-stack frames is going
-on when it generated its code, and used stack space accordingly.
-However, we actually {\em post-process away} all such stack-framery
-(see \tr{ghc/driver/ghc-asm.lprl}). Things will be OK however, if we
-initially make sure there are @RESERVED_C_STACK_BYTES@ on the C-stack
-to begin with, for local variables.
-
-\begin{code}
-#define RESERVED_C_STACK_BYTES (512 * sizeof(I_)) /* MUST BE OF GENEROUS ALIGNMENT */
-\end{code}
-
-The platform-specific details are given in alphabetical order.
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-alpha]{Tail-jumping on Alphas}
-%* *
-%************************************************************************
-
-We have to set the procedure value register (\$27) before branching, so
-that the target function can load the gp (\$29) as appropriate.
-
-It seems that \tr{_procedure} can't be declared within the body of the
-\tr{JMP_} macro...at least, not if we want it to be \$27, which we do!
-
-\begin{code}
-#if alpha_TARGET_ARCH
- /* ToDo: less specific? */
-
-/*
- Jumping to a new block of code, we need to set up $27 to point
- at the target, so that the callee can establish its gp (as an
- offset from its own starting address). For some reason, gcc
- refuses to give us $27 for _procedure if it's declared as a
- local variable, so the workaround is to make it a global.
-
- Note: The local variable works in gcc 2.6.2, but fails in 2.5.8.
- */
-
-/* MOVED: to COptRegs.lh -- very unsatisfactorily.
- Otherwise, we can get a "global register variable follows a
- function definition" error.
-
- Once we can take gcc 2.6.x as std, then we can use
- the local variant, and the problem goes away. (WDP 95/02)
-
-register void *_procedure __asm__("$27");
-*/
-
-#define JMP_(cont) \
- do { _procedure = (void *)(cont); \
- goto *_procedure; \
- } while(0)
-
-/*
- When we resume at the point where a call was originally made,
- we need to restore $26, so that gp can be reloaded appropriately.
- However, sometimes we ``resume'' by entering a new function
- (typically EnterNodeCode), so we need to set up $27 as well.
- */
-
-#define RESUME_(cont) \
- do { _procedure = (void *)(cont); \
- __asm__ volatile("mov $27,$26"); \
- goto *_procedure; \
- } while(0);
-
-#define MINI_INTERPRETER_SETUP \
- __asm__ volatile ("stq $9,-8($30)\n" \
- "stq $10,-16($30)\n" \
- "stq $11,-24($30)\n" \
- "stq $12,-32($30)\n" \
- "stq $13,-40($30)\n" \
- "stq $14,-48($30)\n" \
- "stq $15,-56($30)\n" \
- "stt $f2,-64($30)\n" \
- "stt $f3,-72($30)\n" \
- "stt $f4,-80($30)\n" \
- "stt $f5,-88($30)\n" \
- "stt $f6,-96($30)\n" \
- "stt $f7,-104($30)\n" \
- "stt $f8,-112($30)\n" \
- "stt $f9,-120($30)\n" \
- "lda $30,-%0($30)" : : \
- "K" (RESERVED_C_STACK_BYTES+8*sizeof(double)+8*sizeof(long)));
-
-#define MINI_INTERPRETER_END \
- __asm__ volatile (".align 3\n" \
- ".globl miniInterpretEnd\n" \
- "miniInterpretEnd:\n" \
- "lda $30,%0($30)\n" \
- "ldq $9,-8($30)\n" \
- "ldq $10,-16($30)\n" \
- "ldq $11,-24($30)\n" \
- "ldq $12,-32($30)\n" \
- "ldq $13,-40($30)\n" \
- "ldq $14,-48($30)\n" \
- "ldq $15,-56($30)\n" \
- "ldt $f2,-64($30)\n" \
- "ldt $f3,-72($30)\n" \
- "ldt $f4,-80($30)\n" \
- "ldt $f5,-88($30)\n" \
- "ldt $f6,-96($30)\n" \
- "ldt $f7,-104($30)\n" \
- "ldt $f8,-112($30)\n" \
- "ldt $f9,-120($30)" : : \
- "K" (RESERVED_C_STACK_BYTES+8*sizeof(double)+8*sizeof(long)));
-
-#endif /* __alpha */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-Hpux]{Tail-jumping on a HP-PA machine running HP-UX}
-%* *
-%************************************************************************
-
-\begin{code}
-#if hppa1_1_hp_hpux_TARGET
-
-/* do FUNBEGIN/END the easy way */
-#define FUNBEGIN __asm__ volatile ("--- BEGIN ---");
-#define FUNEND __asm__ volatile ("--- END ---");
-
-/* The stack grows up! Local variables are allocated just above the
- frame pointer, and extra arguments are stashed just below the stack
- pointer, so the safe space is again in the middle (cf. sparc).
-
- Sven Panne <Sven.Panne@informatik.uni-muenchen.de> writes:
-
- But now for the reallly bad news: Some nasty guy in the threaded world
- modifies R3 (the frame pointer)!! This should not happen (as far as I
- know R3 should be a callee-saves register). Sadly, I can't reproduce
- this behaviour consistently, Perhaps it is some strange point of our
- boxes here? (uname -svrm gives HP-UX A.09.05 A 9000/715)
-
- ...
-
- So here is my next try: Don't calculate the register buffer by _adding_
- to FP[r3], but by _subtracting_ from SP! The patch below should result in the
- same addresses (+/- some bytes :-) By the way, is the SP[r30] after returning
- from the threaded world the same as the one before entering it?
- I really hope so, otherwise %#*&!!
- */
-
-#define JMP_(cont) \
- do { void *_procedure = (void *)(cont); \
- goto *_procedure; \
- } while(0)
-
-#define RESUME_(cont) JMP_(cont)
-
-#define MINI_INTERPRETER_SETUP \
- StgChar space[RESERVED_C_STACK_BYTES+16*sizeof(long)+10*sizeof(double)]; \
- /* __asm__ volatile ("ldo %0(%%r3),%%r19\n" */ \
- __asm__ volatile ("ldo %0(%%r30),%%r19\n" \
- "\tstw %%r3, 0(0,%%r19)\n" \
- "\tstw %%r4, 4(0,%%r19)\n" \
- "\tstw %%r5, 8(0,%%r19)\n" \
- "\tstw %%r6,12(0,%%r19)\n" \
- "\tstw %%r7,16(0,%%r19)\n" \
- "\tstw %%r8,20(0,%%r19)\n" \
- "\tstw %%r9,24(0,%%r19)\n" \
- "\tstw %%r10,28(0,%%r19)\n" \
- "\tstw %%r11,32(0,%%r19)\n" \
- "\tstw %%r12,36(0,%%r19)\n" \
- "\tstw %%r13,40(0,%%r19)\n" \
- "\tstw %%r14,44(0,%%r19)\n" \
- "\tstw %%r15,48(0,%%r19)\n" \
- "\tstw %%r16,52(0,%%r19)\n" \
- "\tstw %%r17,56(0,%%r19)\n" \
- "\tstw %%r18,60(0,%%r19)\n" \
- "\tldo 80(%%r19),%%r19\n" \
- "\tfstds %%fr12,-16(0,%%r19)\n" \
- "\tfstds %%fr13, -8(0,%%r19)\n" \
- "\tfstds %%fr14, 0(0,%%r19)\n" \
- "\tfstds %%fr15, 8(0,%%r19)\n" \
- "\tldo 32(%%r19),%%r19\n" \
- "\tfstds %%fr16,-16(0,%%r19)\n" \
- "\tfstds %%fr17, -8(0,%%r19)\n" \
- "\tfstds %%fr18, 0(0,%%r19)\n" \
- "\tfstds %%fr19, 8(0,%%r19)\n" \
- "\tldo 32(%%r19),%%r19\n" \
- "\tfstds %%fr20,-16(0,%%r19)\n" \
- "\tfstds %%fr21, -8(0,%%r19)\n" : : \
- /* "n" (RESERVED_C_STACK_BYTES - (116 * sizeof(long) + 10 * sizeof(double))) : "%r19" ); */ \
- "n" (-(116 * sizeof(long) + 10 * sizeof(double))) : "%r19" );
-
-#define MINI_INTERPRETER_END \
- __asm__ volatile (".align 4\n" \
- "\t.EXPORT miniInterpretEnd,CODE\n" \
- "\t.EXPORT miniInterpretEnd,ENTRY,PRIV_LEV=3\n" \
- "miniInterpretEnd\n" \
- /* "\tldo %0(%%r3),%%r19\n" */ \
- "\tldo %0(%%r30),%%r19\n" \
- "\tldw 0(0,%%r19),%%r3\n" \
- "\tldw 4(0,%%r19),%%r4\n" \
- "\tldw 8(0,%%r19),%%r5\n" \
- "\tldw 12(0,%%r19),%%r6\n" \
- "\tldw 16(0,%%r19),%%r7\n" \
- "\tldw 20(0,%%r19),%%r8\n" \
- "\tldw 24(0,%%r19),%%r9\n" \
- "\tldw 28(0,%%r19),%%r10\n" \
- "\tldw 32(0,%%r19),%%r11\n" \
- "\tldw 36(0,%%r19),%%r12\n" \
- "\tldw 40(0,%%r19),%%r13\n" \
- "\tldw 44(0,%%r19),%%r14\n" \
- "\tldw 48(0,%%r19),%%r15\n" \
- "\tldw 52(0,%%r19),%%r16\n" \
- "\tldw 56(0,%%r19),%%r17\n" \
- "\tldw 60(0,%%r19),%%r18\n" \
- "\tldo 80(%%r19),%%r19\n" \
- "\tfldds -16(0,%%r19),%%fr12\n" \
- "\tfldds -8(0,%%r19),%%fr13\n" \
- "\tfldds 0(0,%%r19),%%fr14\n" \
- "\tfldds 8(0,%%r19),%%fr15\n" \
- "\tldo 32(%%r19),%%r19\n" \
- "\tfldds -16(0,%%r19),%%fr16\n" \
- "\tfldds -8(0,%%r19),%%fr17\n" \
- "\tfldds 0(0,%%r19),%%fr18\n" \
- "\tfldds 8(0,%%r19),%%fr19\n" \
- "\tldo 32(%%r19),%%r19\n" \
- "\tfldds -16(0,%%r19),%%fr20\n" \
- "\tfldds -8(0,%%r19),%%fr21\n" : : \
- /* "n" (RESERVED_C_STACK_BYTES - (116 * sizeof(long) + 10 * sizeof(double))) : "%r19"); */ \
- "n" (-(116 * sizeof(long) + 10 * sizeof(double))) : "%r19");
-
-#endif /* hppa1.1-hp-hpux* */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-iX86]{Tail-jumping on a 386/486}
-%* *
-%************************************************************************
-
-\begin{code}
-#if i386_TARGET_ARCH
-
-/* *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"
-#endif
-
-/* do FUNBEGIN/END the easy way */
-#define FUNBEGIN __asm__ volatile ("--- BEGIN ---");
-#define FUNEND __asm__ volatile ("--- END ---");
-
-/* try "m68k-style" for now */
-extern void __DISCARD__(STG_NO_ARGS);
-
-#define JMP_(cont) \
- do { void *target; \
- __DISCARD__(); \
- target = (void *)(cont); \
- goto *target; \
- } while(0)
-
-#define RESUME_(target) JMP_(target)
-
-/* The safe part of the stack frame is near the top */
-
-#define MINI_INTERPRETER_SETUP \
- StgChar space[RESERVED_C_STACK_BYTES+4*sizeof(long)]; \
- __asm__ volatile ("leal %c0(%%esp),%%eax\n" \
- "\tmovl %%ebx,0(%%eax)\n" \
- "\tmovl %%esi,4(%%eax)\n" \
- "\tmovl %%edi,8(%%eax)\n" \
- "\tmovl %%ebp,12(%%eax)\n" \
- : : "n" (RESERVED_C_STACK_BYTES) \
- : "%eax");
-
-/* the initial "addl $f,%esp" in ..._END compensates for
- the "call" (rather than a jump) in miniInterpret.
-*/
-
-#define MINI_INTERPRETER_END \
- __asm__ volatile (".align 4\n" \
- ".globl " MINI_INTERPRET_END "\n" \
- MINI_INTERPRET_END ":\n" \
- "\tnop" \
- : : : "memory" ); \
- __asm__ volatile ("addl $4,%%esp\n" \
- "\tleal %c0(%%esp),%%eax\n" \
- "\tmovl 0(%%eax),%%ebx\n" \
- "\tmovl 4(%%eax),%%esi\n" \
- "\tmovl 8(%%eax),%%edi\n" \
- "\tmovl 12(%%eax),%%ebp" \
- : : "n" (RESERVED_C_STACK_BYTES) : "%eax");
-
-#endif /* __i[3456]86__ */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-m68k]{Tail-jumping on m68k boxes}
-%* *
-%************************************************************************
-
-For 680x0s, we use a quite-magic @JMP_@ macro, which includes
-beginning- and end-of-function markers.
-
-\begin{code}
-#if m68k_TARGET_ARCH
-
-#define FUNBEGIN __asm__ volatile ("--- BEGIN ---");
-#define FUNEND __asm__ volatile ("--- END ---");
-\end{code}
-
-The call to \tr{__DISCARD__} in @JMP_@ is fodder for GCC, to force it
-to pop arguments to previous function calls before the end of the
-current function. This is unnecessary if we can manage to compile
-with \tr{-fomit-frame-pointer} as well as \tr{-fno-defer-pop}. (WDP
-95/02: Either false or dodgy.) At the moment, the asm mangler removes
-these calls to \tr{__DISCARD__}.
-
-
-\begin{code}
-extern void __DISCARD__(STG_NO_ARGS);
-
-#define JMP_(cont) \
- do { void *target; \
- __DISCARD__(); \
- target = (void *)(cont); \
- goto *target; \
- } while(0)
-
-#define RESUME_(target) JMP_(target)
-
-#define MINI_INTERPRETER_SETUP \
- StgChar space[RESERVED_C_STACK_BYTES+11*sizeof(long)]; \
- __asm__ volatile ("moveml a2-a6/d2-d7,sp@(%c0)\n" \
- "\tlea sp@(%c0),a6" : : "J" (RESERVED_C_STACK_BYTES));
-
-#define MINI_INTERPRETER_END \
- __asm__ volatile (".even\n" \
- ".globl _miniInterpretEnd\n" \
- "_miniInterpretEnd:\n" \
- "\taddqw #4,sp\n" \
- "\tmoveml sp@(%c0),a2-a6/d2-d7" : : "J" (RESERVED_C_STACK_BYTES));
-
-#endif /* __m68k__ */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-mips]{Tail-jumping on a MIPS box}
-%* *
-%************************************************************************
-
-\begin{code}
-#if mipseb_TARGET_ARCH || mipsel_TARGET_ARCH
-
-/* do FUNBEGIN/END the easy way */
-#define FUNBEGIN __asm__ volatile ("--- BEGIN ---");
-#define FUNEND __asm__ volatile ("--- END ---");
-
-/* try "m68k-style" for now */
-extern void __DISCARD__(STG_NO_ARGS);
-
-/* this is "alpha-style" */
-#define JMP_(cont) \
- do { __DISCARD__(); \
- _procedure = (void *)(cont); \
- goto *_procedure; \
- } while(0)
-
-#define RESUME_(target) JMP_(target)
-
-/* _All_ callee-saved regs, whether we steal them or not, must be saved
- (and restored).
-*/
-
-#define MINI_INTERPRETER_SETUP \
- StgChar space[RESERVED_C_STACK_BYTES+6*sizeof(double)+9*sizeof(long)]; \
- __asm__ volatile ("addu $2,$sp,%0\n" \
- "\ts.d $f20,0($2)\n" \
- "\ts.d $f22,8($2)\n" \
- "\ts.d $f24,16($2)\n" \
- "\ts.d $f26,24($2)\n" \
- "\ts.d $f28,32($2)\n" \
- "\ts.d $f30,40($2)\n" \
- "\tsw $16,48($2)\n" \
- "\tsw $17,52($2)\n" \
- "\tsw $18,56($2)\n" \
- "\tsw $19,60($2)\n" \
- "\tsw $20,64($2)\n" \
- "\tsw $21,68($2)\n" \
- "\tsw $22,72($2)\n" \
- "\tsw $23,76($2)\n" \
- "\tsw $fp,80($2)\n" \
- : : "I" (RESERVED_C_STACK_BYTES+16) : "$2" );
-
- /* the 16 bytes is for the argument-register save-area above $sp */
-
-#define MINI_INTERPRETER_END \
- __asm__ volatile (".align 2\n" \
- ".globl miniInterpretEnd\n" \
- "miniInterpretEnd:\n" \
- "\taddu $2,$sp,%0\n" \
- "\tl.d $f20,0($2)\n" \
- "\tl.d $f22,8($2)\n" \
- "\tl.d $f24,16($2)\n" \
- "\tl.d $f26,24($2)\n" \
- "\tl.d $f28,32($2)\n" \
- "\tl.d $f30,40($2)\n" \
- "\tlw $16,48($2)\n" \
- "\tlw $17,52($2)\n" \
- "\tlw $18,56($2)\n" \
- "\tlw $19,60($2)\n" \
- "\tlw $20,64($2)\n" \
- "\tlw $21,68($2)\n" \
- "\tlw $22,72($2)\n" \
- "\tlw $23,76($2)\n" \
- "\tlw $fp,80($2)\n" \
- : : "I" (RESERVED_C_STACK_BYTES+16) : "$2" );
-
-#endif /* mips */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-powerpc]{Tail-jumping on an IBM PowerPC running AIX}
-%* *
-%************************************************************************
-
-\begin{code}
-#if powerpc_TARGET_ARCH || rs6000_TARGET_ARCH
-
-/* do FUNBEGIN/END the easy way */
-#define FUNBEGIN __asm__ volatile ("--- BEGIN ---");
-#define FUNEND __asm__ volatile ("--- END ---");
-
-/* try "m68k-style" for now */
-extern void __DISCARD__(STG_NO_ARGS);
-
-/* this is "alpha-style" */
-#define JMP_(cont) \
- do { void *_procedure = (void *)(cont); \
- goto *_procedure; \
- } while(0)
-
-#define RESUME_(target) JMP_(target)
-
-/* _All_ callee-saved regs, whether we steal them or not, must be saved
- (and restored).
-*/
-
-#define MINI_INTERPRETER_SETUP \
- StgChar space[RESERVED_C_STACK_BYTES+6*sizeof(double)+19*sizeof(long)]; \
- __asm__ volatile ("stm 13,-176(1)\n" \
- "\tstfd 14,-200(1)\n" \
- "\tstfd 15,-208(1)\n" \
- "\tstfd 16,-216(1)\n" \
- "\tstfd 17,-224(1)\n" \
- "\tstfd 18,-232(1)\n" \
- "\tstfd 19,-240(1)\n" \
- : : "I" (RESERVED_C_STACK_BYTES+16) : "1" );
-
- /* the 16 bytes is for the argument-register save-area above $sp */
-
-#define MINI_INTERPRETER_END \
- __asm__ volatile (".globl miniInterpretEnd\n" \
- "miniInterpretEnd:\n" \
- "\tlm 13,-176(1)\n" \
- "\tlfd 14,-200(1)\n" \
- "\tlfd 15,-208(1)\n" \
- "\tlfd 16,-216(1)\n" \
- "\tlfd 17,-224(1)\n" \
- "\tlfd 18,-232(1)\n" \
- "\tlfd 19,-240(1)\n" \
- : : "I" (RESERVED_C_STACK_BYTES+16) : "1" );
-
-#endif /* powerpc */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-sparc]{Tail-jumping on Sun4s}
-%* *
-%************************************************************************
-
-We want tailjumps to be calls, because `call xxx' is the only Sparc branch
-that allows an arbitrary label as a target. (Gcc's ``goto *target'' construct
-ends up loading the label into a register and then jumping, at the cost of
-two extra instructions for the 32-bit load.)
-
-When entering the threaded world, we stash our return address in a known
-location so that \tr{%i7} is available as an extra callee-saves register.
-Of course, we have to restore this when coming out of the threaded world.
-
-I hate this god-forsaken architecture. Since the top of the reserved
-stack space is used for globals and the bottom is reserved for outgoing arguments,
-we have to stick our return address somewhere in the middle. Currently, I'm
-allowing 100 extra outgoing arguments beyond the first 6. --JSM
-
-\begin{code}
-#if sparc_TARGET_ARCH
-
-#ifdef solaris2_TARGET_OS
-#define MINI_INTERPRET_END "miniInterpretEnd"
-#else
-#define MINI_INTERPRET_END "_miniInterpretEnd"
-#endif
-
-#define JMP_(cont) ((F_) (cont))()
- /* Oh so happily, the above turns into a "call" instruction,
- which, on a SPARC, is nothing but a "jmpl" with the
- return address in %o7 [which we don't care about].
- */
-#define RESUME_(target) JMP_(target)
-
-#define MINI_INTERPRETER_SETUP \
- StgChar space[RESERVED_C_STACK_BYTES+sizeof(void *)]; \
- register void *i7 __asm__("%i7"); \
- ((void **)(space))[100] = i7;
-
-#define MINI_INTERPRETER_END \
- __asm__ volatile (".align 4\n" \
- ".global " MINI_INTERPRET_END "\n" \
- MINI_INTERPRET_END ":\n" \
- "\tld %1,%0" : "=r" (i7) : "m" (((void **)(space))[100]));
-
-#endif /* __sparc__ */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[COptJumps-OOPS]{Someone screwed up here, too...}
-%* *
-%************************************************************************
-
-If one of the above machine-dependent sections wasn't triggered,
-@JMP_@ won't be defined and you'll get link errors (if not
-C-compiler errors).
-
-\begin{code}
-#if !defined(JMP_)
-*???????* No JMP_ macro???
-#endif
-
-#endif /* __STG_TAILJUMPS__ */
-\end{code}
-
-If @FUNBEGIN@ and @FUNEND@ weren't defined, give them the default
-(nothing). Also, define @FB_@ and @FE_@ (short forms).
-\begin{code}
-#if ! defined(FUNBEGIN)
-#define FUNBEGIN /* nothing */
-#endif
-#if ! defined(FUNEND)
-#define FUNEND /* nothing */
-#endif
-
-#define FB_ FUNBEGIN /* short forms */
-#define FE_ FUNEND
-
-#endif /* ! that's all of... COPTJUMPS_H */
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1993
-%
-\section[StgRegs-decls]{STG-machine register mappings}
-
-\begin{code}
-#ifndef COPTREGS_H
-#define COPTREGS_H
-
-#include "StgMachDeps.h"
-#include "StgTypes.h"
-#include "MachRegs.h"
-
-#define GLOBAL_REG_DECL(type,name,reg) register type name REG(reg);
-
-\end{code}
-
-Various parts of the GHC system use various sets of ``registers,'' by
-which we mean (frequently-used) words of globally-visible information.
-For example, the everyday ``Haskell threaded world,'' uses the
-``registers'' @Hp@, @R4@, etc., etc.
-
-We would really like to ``steal'' machine registers from the C
-execution model (via GCC's global-variable-in-register extension) and
-map some/all of our ``STG registers'' onto real machine registers.
-This has a profound benefit in terms of execution speed.
-
-This file/document/section sets out the various (machine-dependent)
-mappings that we use.
-
-Note: for one machine, there are {\em several} possible register
-mappings, {\em one} of which is in force at any time. Obviously, the
-``main'' mapping (used in the Haskell threaded world) dominates, but
-when garbage-collecting (for example), we'd rather not tie up all
-those registers in that way (i.e., for global-variables that aren't
-used in the GC). Instead, we'd rather bring in {\em another} register
-mapping, tuned to the needs of a particular (isolated) bit of C code.
-As there are several garbage collectors there are quite a few possible
-mappings.
-
-%************************************************************************
-%* *
-\subsection[saved-STG-regs]{Saved STG registers}
-%* *
-%************************************************************************
-
-The following stuff is available regardless of register map. It allows
-us access to the saved STG registers from other parts of the RTS (notably
-from the storage manager).
-
-\begin{code}
-
-typedef struct rt {
- StgDouble rDbl[2]; /* Put a double first to ensure expected alignment */
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
- StgWord64 rLng[2];
-#endif
- StgFloat rFlt[4];
- StgUnion rR[8];
- PP_ rSpA;
- PP_ rSuA;
- P_ rSpB;
- P_ rSuB;
- P_ rHp;
- P_ rHpLim;
- I_ rTag;
- StgRetAddr rRet;
- I_ rActivity; /* NB: UNUSED */
- P_ rCstkptr; /* used for iX86 registerizing only! offset=100 */
- P_ rWrapReturn; /* ditto; offset=104 */
- P_ rSaveECX; /* ditto; offset=108 */
-#if defined(CONCURRENT)
- P_ rStkO;
- I_ rLiveness;
-#endif
-} STGRegisterTable;
-
-\end{code}
-
-There are several confusing macro sets for accessing STG registers at various
-stages in their lives.
-
-
-The MAIN_* macros refer to the save locations for the main thread.
-These are generally useful when the main thread is suspended. Note
-that the save locations for S[up][AB] are actually in the pseudo stack
-object, MainStkO, when running threads.
-
-The SAVE_* macros refer to the save locations for the current thread,
-without using BaseReg. These are used when we cannot be sure that any
-STG registers are actually loaded in machine registers.
-
-The RTBL_* macros refer to the register table locations for the current
-thread, indexed from BaseReg. If BaseReg is in a machine register, that
-register {\em must} be loaded with the address of the register table.
-
-OK, now... In the sequential world at least, each of those
-``register'' declarations also set up a ``backup'' location; for
-register @r@, the backup location (a global variable) is @r_SAVE@.
-
-We need @SAVE_STG_REGS@ and @RESTORE_STG_REGS@ macros, which copy back
-and forth between the ``registers'' and their \tr{*_SAVE} backup
-locations.
-
-In the parallel world, we have the closely-related business of
-saving/restoring ``thread state''. We do it in two stages:
-save/restore to/from \tr{*_SAVE} locations, then fill in the
-``thread-state object'' (TSO) from the \tr{*_SAVE} locations. (This
-means the thread-state saving can more easily be written in C, rather
-than assembler.)
-
-Why no space to save BaseReg? Because either (1) if in a caller-save
-register, the caller will have saved it; or (2) if in a callee-save
-register, the miniInterpret machinery will have saved it. This works
-because we entered ``threaded Haskell land'' in a v disciplined
-way---i.e., via miniInterpret.
-
-However, the bits of code that use the various GC register maps (SCAV,
-MARK, SCAN) are called in less-disciplined ways, so their base-regs
-need saving/restoring. (WDP 95/02)
-
-\begin{code}
-
-#ifndef PAR
-extern STGRegisterTable MainRegTable;
-#endif /* PAR */
-
-/* these are for the main register table */
-#define MAIN_R1 (MainRegTable.rR[0])
-#define MAIN_R2 (MainRegTable.rR[1])
-#define MAIN_R3 (MainRegTable.rR[2])
-#define MAIN_R4 (MainRegTable.rR[3])
-#define MAIN_R5 (MainRegTable.rR[4])
-#define MAIN_R6 (MainRegTable.rR[5])
-#define MAIN_R7 (MainRegTable.rR[6])
-#define MAIN_R8 (MainRegTable.rR[7])
-#define MAIN_Flt1 (MainRegTable.rFlt[0])
-#define MAIN_Flt2 (MainRegTable.rFlt[1])
-#define MAIN_Flt3 (MainRegTable.rFlt[2])
-#define MAIN_Flt4 (MainRegTable.rFlt[3])
-#define MAIN_Dbl1 (MainRegTable.rDbl[0])
-#define MAIN_Dbl2 (MainRegTable.rDbl[1])
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define MAIN_Lng1 (MainRegTable.rLng[0])
-#define MAIN_Lng2 (MainRegTable.rLng[1])
-#endif
-
-#define MAIN_Hp (MainRegTable.rHp)
-#define MAIN_HpLim (MainRegTable.rHpLim)
-#define MAIN_Tag (MainRegTable.rTag)
-#define MAIN_Ret (MainRegTable.rRet)
-
-#define MAIN_StkO (MainStkO)
-#define MAIN_Liveness (MainRegTable.rLiveness)
-
-#ifndef CONCURRENT
-
-#define MAIN_SpA (MainRegTable.rSpA)
-#define MAIN_SuA (MainRegTable.rSuA)
-#define MAIN_SpB (MainRegTable.rSpB)
-#define MAIN_SuB (MainRegTable.rSuB)
-
-/* these are really for *SAVE*ing */
-#define SAVE_R1 MAIN_R1
-#define SAVE_R2 MAIN_R2
-#define SAVE_R3 MAIN_R3
-#define SAVE_R4 MAIN_R4
-#define SAVE_R5 MAIN_R5
-#define SAVE_R6 MAIN_R6
-#define SAVE_R7 MAIN_R7
-#define SAVE_R8 MAIN_R8
-#define SAVE_Flt1 MAIN_Flt1
-#define SAVE_Flt2 MAIN_Flt2
-#define SAVE_Flt3 MAIN_Flt3
-#define SAVE_Flt4 MAIN_Flt4
-#define SAVE_Dbl1 MAIN_Dbl1
-#define SAVE_Dbl2 MAIN_Dbl2
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define SAVE_Lng1 MAIN_Lng1
-#define SAVE_Lng2 MAIN_Lng2
-#endif
-
-#define SAVE_SpA MAIN_SpA
-#define SAVE_SuA MAIN_SuA
-#define SAVE_SpB MAIN_SpB
-#define SAVE_SuB MAIN_SuB
-
-#define SAVE_Tag MAIN_Tag
-#define SAVE_Ret MAIN_Ret
-
-#else
-
-extern P_ MainStkO;
-
-#define MAIN_SpA (STKO_SpA(MainStkO))
-#define MAIN_SuA (STKO_SuA(MainStkO))
-#define MAIN_SpB (STKO_SpB(MainStkO))
-#define MAIN_SuB (STKO_SuB(MainStkO))
-
-extern STGRegisterTable *CurrentRegTable;
-
-/* these are really for *SAVE*ing */
-#define SAVE_R1 (CurrentRegTable->rR[0])
-#define SAVE_R2 (CurrentRegTable->rR[1])
-#define SAVE_R3 (CurrentRegTable->rR[2])
-#define SAVE_R4 (CurrentRegTable->rR[3])
-#define SAVE_R5 (CurrentRegTable->rR[4])
-#define SAVE_R6 (CurrentRegTable->rR[5])
-#define SAVE_R7 (CurrentRegTable->rR[6])
-#define SAVE_R8 (CurrentRegTable->rR[7])
-#define SAVE_Flt1 (CurrentRegTable->rFlt[0])
-#define SAVE_Flt2 (CurrentRegTable->rFlt[1])
-#define SAVE_Flt3 (CurrentRegTable->rFlt[2])
-#define SAVE_Flt4 (CurrentRegTable->rFlt[3])
-#define SAVE_Dbl1 (CurrentRegTable->rDbl[0])
-#define SAVE_Dbl2 (CurrentRegTable->rDbl[1])
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define SAVE_Lng1 (CurrentRegTable->rLng[0])
-#define SAVE_Lng2 (CurrentRegTable->rLng[1])
-#endif
-
-/* These are only valid when StkOReg is loaded! */
-
-#define SAVE_SpA (STKO_SpA(StkOReg))
-#define SAVE_SuA (STKO_SuA(StkOReg))
-#define SAVE_SpB (STKO_SpB(StkOReg))
-#define SAVE_SuB (STKO_SuB(StkOReg))
-
-#define SAVE_Tag (CurrentRegTable->rTag)
-#define SAVE_Ret (CurrentRegTable->rRet)
-
-#define SAVE_StkO (CurrentRegTable->rStkO)
-#define SAVE_Liveness (CurrentRegTable->rLiveness)
-
-#endif /* CONCURRENT */
-
-/* Note that the SAVE_ locations for the Hp registers are in the smInfo structure */
-
-#define SAVE_Hp (StorageMgrInfo.hp)
-#define SAVE_HpLim (StorageMgrInfo.hplim)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[null-mapping-StgRegs]{The empty register mapping}
-%* *
-%************************************************************************
-
-This mapping leaves all machine registers free for normal C allocation.
-In the RTS, this is the preferred mapping, because it allows gcc to use
-all available registers, with the normal callee-saves conventions.
-\begin{code}
-#if defined(NULL_REG_MAP)
-#else
-\end{code}
-
-This is a HACK here; see comment in COptJumps.lh.
-\begin{code}
-#if alpha_TARGET_ARCH && defined(__STG_TAILJUMPS__) && defined(__GNUC__)
-register void *_procedure __asm__("$27");
-#endif
-#if (mipsel_TARGET_ARCH || mipseb_TARGET_ARCH) && defined(__STG_TAILJUMPS__) && defined(__GNUC__)
-register void *_procedure __asm__("$25");
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[mark-mapping-StgRegs]{The ``mark'' register mapping}
-%* *
-%************************************************************************
-
-The mark mapping is used for pointer-reversal marking during GC. It
-is used by most of the current garbage collectors.
-
-\begin{code}
-#if defined(MARK_REG_MAP)
-\end{code}
-
-Mark (GC) register mapping:
-
-\begin{verbatim}
- sparc m68k alpha mipseX hppa iX86 powerpc
- ----- ---- ----- ------ ---- ---- -------
-MarkBase ebx
-
-Mark i0 a2 $9 $16 r4 ebp
-MStack i1 a3 $10 $17 r5 esi
-MRoot i2 a4 $11 $18 r6 edi
-BitArray i3 a5 $12 $19 r7
-HeapBase i4 d3 $13 $20 r8
-HeapLim i5 d4 $14 $21 r9
-
-\end{verbatim}
-
-\begin{code}
-
-typedef struct {
- P_ rMark;
- P_ rMStack;
- P_ rMRoot;
- BitWord *rBitArray;
- P_ rHeapBase;
- P_ rHeapLim;
- P_ rMarkBase;
-} RegisterTable;
-
-#define REGDUMP(dump) static RegisterTable dump
-
-#define SAVE_Mark (MarkRegTable.rMark)
-#define SAVE_MStack (MarkRegTable.rMStack)
-#define SAVE_MRoot (MarkRegTable.rMRoot)
-#define SAVE_BitArray (MarkRegTable.rBitArray)
-#define SAVE_HeapBase (MarkRegTable.rHeapBase)
-#define SAVE_HeapLim (MarkRegTable.rHeapLim)
-
-extern RegisterTable MarkRegTable;
-
-#ifdef REG_MarkBase
-GLOBAL_REG_DECL(RegisterTable *,MarkBaseReg,REG_MarkBase)
-#else
-#define MarkBaseReg (&MarkRegTable)
-#endif
-
-#ifdef REG_Mark
-GLOBAL_REG_DECL(P_,Mark,REG_Mark)
-#else
-#define Mark SAVE_Mark
-#endif
-
-#ifdef REG_MStack
-GLOBAL_REG_DECL(P_,MStack,REG_MStack)
-#else
-#define MStack SAVE_MStack
-#endif
-
-#ifdef REG_MRoot
-GLOBAL_REG_DECL(P_,MRoot,REG_MRoot)
-#else
-#define MRoot SAVE_MRoot
-#endif
-
-#ifdef REG_BitArray
-GLOBAL_REG_DECL(P_,BitArray,REG_BitArray)
-#else
-#define BitArray SAVE_BitArray
-#endif
-
-#ifdef REG_HeapBase
-GLOBAL_REG_DECL(P_,HeapBase,REG_HeapBase)
-#else
-#define HeapBase SAVE_HeapBase
-#endif
-
-#ifdef REG_HeapLim
-GLOBAL_REG_DECL(P_,HeapLim,REG_HeapLim)
-#else
-#define HeapLim SAVE_HeapLim
-#endif
-
-#if defined(__STG_GCC_REGS__)
-/* Keep -Wmissing-prototypes from complaining */
-void SAVE_REGS PROTO((RegisterTable *dump));
-void RESTORE_REGS PROTO((RegisterTable *dump));
-
-extern STG_INLINE
-void SAVE_REGS(dump)
-RegisterTable *dump;
-{
-#ifdef REG_MarkBase
- dump->rMarkBase = (P_) MarkBaseReg; /* save whatever is in it */
- MarkBaseReg = dump; /* set it correctly */
-#endif
-#ifdef REG_Mark
- dump->rMark = Mark;
-#endif
-#ifdef REG_MStack
- dump->rMStack = MStack;
-#endif
-#ifdef REG_MRoot
- dump->rMRoot = MRoot;
-#endif
-#ifdef REG_BitArray
- dump->rBitArray = BitArray;
-#endif
-#ifdef REG_HeapBase
- dump->rHeapBase = HeapBase;
-#endif
-#ifdef REG_HeapLim
- dump->rHeapLim = HeapLim;
-#endif
-}
-
-extern STG_INLINE
-void RESTORE_REGS(dump)
-RegisterTable *dump;
-{
-#ifdef REG_Mark
- Mark = dump->rMark;
-#endif
-#ifdef REG_MStack
- MStack = dump->rMStack;
-#endif
-#ifdef REG_MRoot
- MRoot = dump->rMRoot;
-#endif
-#ifdef REG_BitArray
- BitArray = dump->rBitArray;
-#endif
-#ifdef REG_HeapBase
- HeapBase = dump->rHeapBase;
-#endif
-#ifdef REG_HeapLim
- HeapLim = dump->rHeapLim;
-#endif
-#ifdef REG_MarkBase
- MarkBaseReg = (RegisterTable *) dump->rMarkBase; /* restore to whatever it was */
-#endif
-}
-#else
-#define SAVE_REGS(dump)
-#define RESTORE_REGS(dump)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[scan-mapping-StgRegs]{The ``scan'' register mapping}
-%* *
-%************************************************************************
-
-The scan mapping is used for all of the in-place garbage collectors.
-On architectures with register windows, like the SPARC, these must
-reside in global registers, because the scan code is not threaded.
-
-\begin{code}
-#else
-#if defined(SCAN_REG_MAP)
-\end{code}
-
-Scan (GC) register mapping:
-
-\begin{verbatim}
- sparc m68k alpha mipseX hppa iX86 powerpc
- ----- ---- ----- ------ ---- ---- -------
-ScanBase g4
-
-Scan a2 $9 $16 r4 ebx
-New a3 $10 $17 r5 ebp
-LinkLim a4 $11 $18 r6 esi
-
-\end{verbatim}
-
-\begin{code}
-
-typedef struct {
- P_ rScan;
- P_ rNew;
- P_ rLinkLim;
- P_ rScanBase;
-} RegisterTable;
-
-#define REGDUMP(dump) static RegisterTable dump
-
-#define SAVE_Scan (ScanRegTable.rScan)
-#define SAVE_New (ScanRegTable.rNew)
-#define SAVE_LinkLim (ScanRegTable.rLinkLim)
-
-extern RegisterTable ScanRegTable;
-
-#ifdef REG_ScanBase
-GLOBAL_REG_DECL(RegisterTable *,ScanBaseReg,REG_ScanBase)
-#else
-#define ScanBaseReg (&ScanRegTable)
-#endif
-
-#ifdef REG_Scan
-GLOBAL_REG_DECL(P_,Scan,REG_Scan)
-#else
-# ifdef REG_ScanBase
-# define Scan (ScanBaseReg->rScan)
-# else
-# define Scan SAVE_Scan
-# endif
-#endif
-
-#ifdef REG_New
-GLOBAL_REG_DECL(P_,New,REG_New)
-#else
-# ifdef REG_ScanBase
-# define New (ScanBaseReg->rNew)
-# else
-# define New SAVE_New
-# endif
-#endif
-
-#ifdef REG_LinkLim
-GLOBAL_REG_DECL(P_,LinkLim,REG_LinkLim)
-#else
-# ifdef REG_ScanBase
-# define LinkLim (ScanBaseReg->rLinkLim)
-# else
-# define LinkLim SAVE_LinkLim
-# endif
-#endif
-
-#if defined(__STG_GCC_REGS__)
-/* Keep -Wmissing-prototypes from complaining */
-void SAVE_REGS PROTO((RegisterTable *dump));
-void RESTORE_REGS PROTO((RegisterTable *dump));
-
-extern STG_INLINE
-void SAVE_REGS(dump)
-RegisterTable *dump;
-{
-#ifdef REG_ScanBase
- dump->rScanBase = (P_) ScanBaseReg; /* save whatever is in it */
- ScanBaseReg = dump; /* set it correctly */
-#endif
-#ifdef REG_Scan
- dump->rScan = Scan;
-#endif
-#ifdef REG_New
- dump->rNew = New;
-#endif
-#ifdef REG_LinkLim
- dump->rLinkLim = LinkLim;
-#endif
-}
-
-extern STG_INLINE
-void RESTORE_REGS(dump)
-RegisterTable *dump;
-{
-#ifdef REG_Scan
- Scan = dump->rScan;
-#endif
-#ifdef REG_New
- New = dump->rNew;
-#endif
-#ifdef REG_LinkLim
- LinkLim = dump->rLinkLim;
-#endif
-#ifdef REG_ScanBase
- ScanBaseReg = (RegisterTable *) dump->rScanBase; /* restore to whatever it was */
-#endif
-}
-#else
-#define SAVE_REGS(dump)
-#define RESTORE_REGS(dump)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[scav-mapping-StgRegs]{The ``scavenge'' register mapping}
-%* *
-%************************************************************************
-
-The scan mapping is used for all of the in-place garbage collectors.
-(I believe that it must use a subset of the registers that are used
-in the mark mapping, but I could be wrong. --JSM)
-
-Note: registers must not be mangled by sliding register windows,
-etc. or there'll be trouble. ADR
-
-\begin{code}
-#else
-#if defined(SCAV_REG_MAP)
-\end{code}
-
-Scavenge (GC) register mapping:
-
-\begin{verbatim}
- sparc m68k alpha mipseX hppa iX86 powerpc
- ----- ---- ----- ------ ---- ---- -------
-ScavBase g4
-
-Scav a2 $9 $16 r4 ebx
-ToHp a3 $10 $17 r5 ebp
-OldGen (gn/ap) a4 $11 $18 r6 esi
-AllocGen (gn) a5
-OldHp (gn) d3
-
-\end{verbatim}
-
-(Calling this struct @ScavRegisterTable@ would make it possible for
-@gdb@ to display it properly. At the moment, @gdb@ confuses it with
-the scan register table etc. ADR )
-
-\begin{code}
-
-typedef struct {
- P_ rScav;
- P_ rToHp;
- P_ rOldGen;
-#ifdef GCgn
- P_ rAllocGen;
- P_ rOldHp;
-#endif
- P_ rScavBase;
-} RegisterTable;
-
-#define REGDUMP(dump) static RegisterTable dump
-
-#define SAVE_Scav (ScavRegTable.rScav)
-#define SAVE_ToHp (ScavRegTable.rToHp)
-#define SAVE_OldGen (ScavRegTable.rOldGen)
-#define SAVE_AllocGen (ScavRegTable.rAllocGen)
-#define SAVE_OldHp (ScavRegTable.rOldHp)
-
-extern RegisterTable ScavRegTable;
-
-#ifdef REG_ScavBase
-GLOBAL_REG_DECL(RegisterTable *,ScavBaseReg,REG_ScavBase)
-#else
-#define ScavBaseReg (&ScavRegTable)
-#endif
-
-#ifdef REG_Scav
-GLOBAL_REG_DECL(P_,Scav,REG_Scav)
-#else
-# ifdef REG_ScavBase
-# define Scav (ScavBaseReg->rScav)
-# else
-# define Scav SAVE_Scav
-# endif
-#endif
-
-#ifdef REG_ToHp
-GLOBAL_REG_DECL(P_,ToHp,REG_ToHp)
-#else
-# ifdef REG_ScavBase
-# define ToHp (ScavBaseReg->rToHp)
-# else
-# define ToHp SAVE_ToHp
-# endif
-#endif
-
-#ifdef REG_OldGen
-GLOBAL_REG_DECL(P_,OldGen,REG_OldGen)
-#else
-# ifdef REG_ScavBase
-# define OldGen (ScavBaseReg->rOldGen)
-# else
-# define OldGen SAVE_OldGen
-# endif
-#endif
-
-#ifdef REG_AllocGen
-GLOBAL_REG_DECL(P_,AllocGen,REG_AllocGen)
-#else
-# ifdef REG_ScavBase
-# define AllocGen (ScavBaseReg->rAllocGen)
-# else
-# define AllocGen SAVE_AllocGen
-# endif
-#endif
-
-#ifdef REG_OldHp
-GLOBAL_REG_DECL(P_,OldHp,REG_OldHp)
-#else
-# ifdef REG_ScavBase
-# define OldHp (ScavBaseReg->rOldHp)
-# else
-# define OldHp SAVE_OldHp
-# endif
-#endif
-
-#if defined(__STG_GCC_REGS__)
-/* Keep -Wmissing-prototypes from complaining */
-void SAVE_REGS PROTO((RegisterTable *dump));
-void RESTORE_REGS PROTO((RegisterTable *dump));
-
-extern STG_INLINE
-void SAVE_REGS(dump)
-RegisterTable *dump;
-{
-#ifdef REG_ScavBase
- dump->rScavBase = (P_) ScavBaseReg; /* save whatever is in it */
- ScavBaseReg = dump; /* set it correctly */
-#endif
-#ifdef REG_Scav
- dump->rScav = Scav;
-#endif
-#ifdef REG_ToHp
- dump->rToHp = ToHp;
-#endif
-#ifdef REG_OldGen
- dump->rOldGen = OldGen;
-#endif
-#ifdef REG_AllocGen
- dump->rAllocGen = AllocGen;
-#endif
-#ifdef REG_OldHp
- dump->rOldHp = OldHp;
-#endif
-}
-
-extern STG_INLINE
-void RESTORE_REGS(dump)
-RegisterTable *dump;
-{
-#ifdef REG_Scav
- Scav = dump->rScav;
-#endif
-#ifdef REG_ToHp
- ToHp = dump->rToHp;
-#endif
-#ifdef REG_OldGen
- OldGen = dump->rOldGen;
-#endif
-#ifdef REG_AllocGen
- AllocGen = dump->rAllocGen;
-#endif
-#ifdef REG_OldHp
- OldHp = dump->rOldHp;
-#endif
-#ifdef REG_ScavBase
- ScavBaseReg = (RegisterTable *) dump->rScavBase; /* restore to whatever it was */
-#endif
-}
-#else
-#define SAVE_REGS(dump)
-#define RESTORE_REGS(dump)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[main-mapping-StgRegs]{The main register mapping (Haskell threaded world)}
-%* *
-%************************************************************************
-
-\begin{code}
-#else /* For simplicity, the default is MAIN_REG_MAP (this one) */
-\end{code}
-
-Main register-mapping summary: (1)~Specific architecture's details are
-given later. (2)~Entries marked \tr{!} are caller-saves registers
-that {\em must be saved} across ccalls; those marked \tr{@} are
-caller-saves registers that need {\em not} be saved; those marked
-\tr{#} are caller-saves registers that need to be restored, but don't
-need to be saved; the rest are callee-save registers (the best kind).
-
-IF YOU CHANGE THIS TABLE, YOU MAY NEED TO CHANGE CallWrapper.s
-(or equiv) and [who knows?] maybe something else. Check the
-documentation in the porter's part of the installation guide.
-
-\begin{verbatim}
- sparc m68k alpha mipseX hppa iX86 powerpc
- ----- ---- ----- ------ ---- ---- -------
-BaseReg# a5 ebx
-
-StkOReg (CONCURRENT)
-
-R1/Node l1 d7 $1! $9! %r11
-R2 l2 d6 $2! $10! %r12
-R3 l3 d5 $3! $11! %r13
-R4 l4 $4! $12! %r14
-R5 l5 $5! $13! %r15
-R6 l6 $6! $14! %r16
-R7 l7 $7! $15! %r17
-R8 $8! $24! %r18
-
-TagReg@
-
-FltReg1 f2! fp2 $f1 $f20 %fr12
-FltReg2 f3! fp3 $f2 $f22 %fr12R
-FltReg3 f4! fp4 $f3 $f24 %fr13
-FltReg4 f5! fp5 $f4 $f26 %fr13R
-
-DblReg1 f6! fp6 $f5 $f28 %fr20 * SEE NOTES!
-DblReg2 f8! fp7 $f6 $f30 %fr20 * SEE NOTES!
-
-SpA i0 a3 $9 $16 %r4
-SuA i1 d3 $10 $17 %r5
-SpB i2 a4 $11 $18 %r6
-SuB i3 d4 $12 $19 %r7
-
-Hp i4 a2 $13 $20 %r8
-HpLim i5 $14 $21 %r9
-
-RetReg l0 $15 $22 %r10
-
-Liveness (CONCURRENT)
-
-StdUpdRetVec#
-StkStub# i7 $23
-\end{verbatim}
-
-Notes:
-\begin{enumerate}
-\item
-Registers not mentioned in the summary table end up in the default
-(a memory location in @MainRegTable@).
-
-\item
-@BaseReg@ is in a machine register if anything is (well, unless everything is!)
-It points to a block of memory in which the things which don't end up in machine
-registers live.
-
-\item
-Exceptions to previous point:
-If the following labels are in machine registers, then the
-corresponding register name refers to what's in its register; otherwise,
-it refers to the label:
-\begin{verbatim}
-StdUpdRetVecReg vtbl_StdUpdFrame
-StkStubReg STK_STUB_closure
-\end{verbatim}
-Also, if TagReg is not in a machine register, its name refers to
-@INFO_TAG(InfoPtr)@, the tag field from the info table pointed to by
-register R2 (InfoPtr).
-
-\end{enumerate}
-
-Next, we have the code to declare the various global registers. Those
-STG registers which don't actually live in machine registers are
-defined as macros which refer to the registers as fixed offsets into
-the register table. Note that the register table will contain blank
-spots for the STG registers that reside in machine registers. Not to
-worry; these blank spots will be filled in whenever the register
-context is saved, so the space does not go to waste.
-
-\begin{code}
-
-#define Node (R1.p)
-#define InfoPtr (R2.d)
-
-/* these are if we get stuck using the reg-tbl "register" (no machine reg avail) */
-#define RTBL_Dbl1 (BaseReg->rDbl[0])
-#define RTBL_Dbl2 (BaseReg->rDbl[1])
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define RTBL_Lng1 (BaseReg->rLng[0])
-#define RTBL_Lng2 (BaseReg->rLng[1])
-#endif
-#define RTBL_Flt1 (BaseReg->rFlt[0])
-#define RTBL_Flt2 (BaseReg->rFlt[1])
-#define RTBL_Flt3 (BaseReg->rFlt[2])
-#define RTBL_Flt4 (BaseReg->rFlt[3])
-#define RTBL_R1 (BaseReg->rR[0])
-#define RTBL_R2 (BaseReg->rR[1])
-#define RTBL_R3 (BaseReg->rR[2])
-#define RTBL_R4 (BaseReg->rR[3])
-#define RTBL_R5 (BaseReg->rR[4])
-#define RTBL_R6 (BaseReg->rR[5])
-#define RTBL_R7 (BaseReg->rR[6])
-#define RTBL_R8 (BaseReg->rR[7])
-#define RTBL_SpA (BaseReg->rSpA)
-#define RTBL_SuA (BaseReg->rSuA)
-#define RTBL_SpB (BaseReg->rSpB)
-#define RTBL_SuB (BaseReg->rSuB)
-#define RTBL_Hp (BaseReg->rHp)
-#define RTBL_HpLim (BaseReg->rHpLim)
-#define RTBL_Tag (BaseReg->rTag)
-#define RTBL_Ret (BaseReg->rRet)
-#define RTBL_StkO (BaseReg->rStkO)
-#define RTBL_Liveness (BaseReg->rLiveness)
-
-#ifdef REG_Base
-GLOBAL_REG_DECL(STGRegisterTable *,BaseReg,REG_Base)
-#else
-#ifdef CONCURRENT
-#define BaseReg CurrentRegTable
-#else
-#define BaseReg (&MainRegTable)
-#endif /* CONCURRENT */
-#endif /* REG_Base */
-
-#ifdef REG_StkO
-GLOBAL_REG_DECL(P_,StkOReg,REG_StkO)
-#else
-#define StkOReg RTBL_StkO
-#endif
-
-#ifndef __STG_REGS_AVAIL__ /* driver ensures it is 2 or more */
-# define __STG_REGS_AVAIL__ 8 /* R1 to R8 */
-/* this would only be non-8 if doing weird experiments (WDP 95/11) */
-/* or it might be set lower for a particular arch... */
-#endif
-
-/* R1 is used for Node */
-#ifdef REG_R1
-GLOBAL_REG_DECL(StgUnion,R1,REG_R1)
-#else
-#define R1 RTBL_R1
-#endif
-
-/* R2 is used for InfoPtr */
-#ifdef REG_R2
-GLOBAL_REG_DECL(StgUnion,R2,REG_R2)
-#else
-#define R2 RTBL_R2
-#endif
-
-#ifdef REG_R3
-GLOBAL_REG_DECL(StgUnion,R3,REG_R3)
-#else
-# define R3 RTBL_R3
-#endif
-
-#ifdef REG_R4
-GLOBAL_REG_DECL(StgUnion,R4,REG_R4)
-#else
-# define R4 RTBL_R4
-#endif
-
-#ifdef REG_R5
-GLOBAL_REG_DECL(StgUnion,R5,REG_R5)
-#else
-# define R5 RTBL_R5
-#endif
-
-#ifdef REG_R6
-GLOBAL_REG_DECL(StgUnion,R6,REG_R6)
-#else
-# define R6 RTBL_R6
-#endif
-
-#ifdef REG_R7
-GLOBAL_REG_DECL(StgUnion,R7,REG_R7)
-#else
-# define R7 RTBL_R7
-#endif
-
-#ifdef REG_R8
-GLOBAL_REG_DECL(StgUnion,R8,REG_R8)
-#else
-# define R8 RTBL_R8
-#endif
-
-#ifdef REG_Flt1
-GLOBAL_REG_DECL(StgFloat,FltReg1,REG_Flt1)
-#else
-#define FltReg1 RTBL_Flt1
-#endif
-
-#ifdef REG_Flt2
-GLOBAL_REG_DECL(StgFloat,FltReg2,REG_Flt2)
-#else
-#define FltReg2 RTBL_Flt2
-#endif
-
-#ifdef REG_Flt3
-GLOBAL_REG_DECL(StgFloat,FltReg3,REG_Flt3)
-#else
-#define FltReg3 RTBL_Flt3
-#endif
-
-#ifdef REG_Flt4
-GLOBAL_REG_DECL(StgFloat,FltReg4,REG_Flt4)
-#else
-#define FltReg4 RTBL_Flt4
-#endif
-
-#ifdef REG_Dbl1
-GLOBAL_REG_DECL(StgDouble,DblReg1,REG_Dbl1)
-#else
-#define DblReg1 RTBL_Dbl1
-#endif
-
-#ifdef REG_Dbl2
-GLOBAL_REG_DECL(StgDouble,DblReg2,REG_Dbl2)
-#else
-#define DblReg2 RTBL_Dbl2
-#endif
-
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#ifdef REG_Lng1
-GLOBAL_REG_DECL(StgWord64,LngReg1,REG_Lng1)
-#else
-#define LngReg1 RTBL_Lng1
-#endif
-#endif
-
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#ifdef REG_Lng2
-GLOBAL_REG_DECL(StgWord64,LngReg2,REG_Lng2)
-#else
-#define LngReg2 RTBL_Lng2
-#endif
-#endif
-
-#ifdef REG_Tag
-GLOBAL_REG_DECL(I_,TagReg,REG_Tag)
-
-#define SET_TAG(tag) TagReg = tag
-#else
-#define TagReg INFO_TAG(InfoPtr)
-#define SET_TAG(tag) /* nothing */
-#endif
-
-#ifdef REG_Ret
-GLOBAL_REG_DECL(StgRetAddr,RetReg,REG_Ret)
-#else
-#define RetReg RTBL_Ret
-#endif
-
-#ifdef REG_SpA
-GLOBAL_REG_DECL(PP_,SpA,REG_SpA)
-#else
-#define SpA RTBL_SpA
-#endif
-
-#ifdef REG_SuA
-GLOBAL_REG_DECL(PP_,SuA,REG_SuA)
-#else
-#define SuA RTBL_SuA
-#endif
-
-#ifdef REG_SpB
-GLOBAL_REG_DECL(P_,SpB,REG_SpB)
-#else
-#define SpB RTBL_SpB
-#endif
-
-#ifdef REG_SuB
-GLOBAL_REG_DECL(P_,SuB,REG_SuB)
-#else
-#define SuB RTBL_SuB
-#endif
-
-#ifdef REG_Hp
-GLOBAL_REG_DECL(P_,Hp,REG_Hp)
-#else
-#define Hp RTBL_Hp
-#endif
-
-#ifdef REG_HpLim
-GLOBAL_REG_DECL(P_,HpLim,REG_HpLim)
-#else
-#define HpLim RTBL_HpLim
-#endif
-
-#ifdef REG_Liveness
-GLOBAL_REG_DECL(I_,LivenessReg,REG_Liveness)
-#else
-#define LivenessReg RTBL_Liveness
-#endif
-
-#ifdef REG_StdUpdRetVec
-GLOBAL_REG_DECL(D_,StdUpdRetVecReg,REG_StdUpdRetVec)
-#else
-#define StdUpdRetVecReg vtbl_StdUpdFrame
-#endif
-
-#ifdef REG_StkStub
-GLOBAL_REG_DECL(P_,StkStubReg,REG_StkStub)
-#else
-#define StkStubReg STK_STUB_closure
-#endif
-
-#ifdef CALLER_SAVES_StkO
-#define CALLER_SAVE_StkO SAVE_StkO = StkOReg;
-#define CALLER_RESTORE_StkO StkOReg = SAVE_StkO;
-#else
-#define CALLER_SAVE_StkO /* nothing */
-#define CALLER_RESTORE_StkO /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R1
-#define CALLER_SAVE_R1 SAVE_R1 = R1;
-#define CALLER_RESTORE_R1 R1 = SAVE_R1;
-#else
-#define CALLER_SAVE_R1 /* nothing */
-#define CALLER_RESTORE_R1 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R2
-#define CALLER_SAVE_R2 SAVE_R2 = R2;
-#define CALLER_RESTORE_R2 R2 = SAVE_R2;
-#else
-#define CALLER_SAVE_R2 /* nothing */
-#define CALLER_RESTORE_R2 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R3
-#define CALLER_SAVE_R3 SAVE_R3 = R3;
-#define CALLER_RESTORE_R3 R3 = SAVE_R3;
-#else
-#define CALLER_SAVE_R3 /* nothing */
-#define CALLER_RESTORE_R3 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R4
-#define CALLER_SAVE_R4 SAVE_R4 = R4;
-#define CALLER_RESTORE_R4 R4 = SAVE_R4;
-#else
-#define CALLER_SAVE_R4 /* nothing */
-#define CALLER_RESTORE_R4 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R5
-#define CALLER_SAVE_R5 SAVE_R5 = R5;
-#define CALLER_RESTORE_R5 R5 = SAVE_R5;
-#else
-#define CALLER_SAVE_R5 /* nothing */
-#define CALLER_RESTORE_R5 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R6
-#define CALLER_SAVE_R6 SAVE_R6 = R6;
-#define CALLER_RESTORE_R6 R6 = SAVE_R6;
-#else
-#define CALLER_SAVE_R6 /* nothing */
-#define CALLER_RESTORE_R6 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R7
-#define CALLER_SAVE_R7 SAVE_R7 = R7;
-#define CALLER_RESTORE_R7 R7 = SAVE_R7;
-#else
-#define CALLER_SAVE_R7 /* nothing */
-#define CALLER_RESTORE_R7 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R8
-#define CALLER_SAVE_R8 SAVE_R8 = R8;
-#define CALLER_RESTORE_R8 R8 = SAVE_R8;
-#else
-#define CALLER_SAVE_R8 /* nothing */
-#define CALLER_RESTORE_R8 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_FltReg1
-#define CALLER_SAVE_FltReg1 SAVE_Flt1 = FltReg1;
-#define CALLER_RESTORE_FltReg1 FltReg1 = SAVE_Flt1;
-#else
-#define CALLER_SAVE_FltReg1 /* nothing */
-#define CALLER_RESTORE_FltReg1 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_FltReg2
-#define CALLER_SAVE_FltReg2 SAVE_Flt2 = FltReg2;
-#define CALLER_RESTORE_FltReg2 FltReg2 = SAVE_Flt2;
-#else
-#define CALLER_SAVE_FltReg2 /* nothing */
-#define CALLER_RESTORE_FltReg2 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_FltReg3
-#define CALLER_SAVE_FltReg3 SAVE_Flt3 = FltReg3;
-#define CALLER_RESTORE_FltReg3 FltReg3 = SAVE_Flt3;
-#else
-#define CALLER_SAVE_FltReg3 /* nothing */
-#define CALLER_RESTORE_FltReg3 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_FltReg4
-#define CALLER_SAVE_FltReg4 SAVE_Flt4 = FltReg4;
-#define CALLER_RESTORE_FltReg4 FltReg4 = SAVE_Flt4;
-#else
-#define CALLER_SAVE_FltReg4 /* nothing */
-#define CALLER_RESTORE_FltReg4 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_DblReg1
-#define CALLER_SAVE_DblReg1 SAVE_Dbl1 = DblReg1;
-#define CALLER_RESTORE_DblReg1 DblReg1 = SAVE_Dbl1;
-#else
-#define CALLER_SAVE_DblReg1 /* nothing */
-#define CALLER_RESTORE_DblReg1 /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_DblReg2
-#define CALLER_SAVE_DblReg2 SAVE_Dbl2 = DblReg2;
-#define CALLER_RESTORE_DblReg2 DblReg2 = SAVE_Dbl2;
-#else
-#define CALLER_SAVE_DblReg2 /* nothing */
-#define CALLER_RESTORE_DblReg2 /* nothing */
-#endif
-
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#ifdef CALLER_SAVES_LngReg1
-#define CALLER_SAVE_LngReg1 SAVE_Lng1 = LngReg1;
-#define CALLER_RESTORE_LngReg1 LngReg1 = SAVE_Lng1;
-#else
-#define CALLER_SAVE_LngReg1 /* nothing */
-#define CALLER_RESTORE_LngReg1 /* nothing */
-#endif
-#endif
-
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#ifdef CALLER_SAVES_LngReg2
-#define CALLER_SAVE_LngReg2 SAVE_Lng2 = LngReg2;
-#define CALLER_RESTORE_LngReg2 LngReg2 = SAVE_Lng2;
-#else
-#define CALLER_SAVE_LngReg2 /* nothing */
-#define CALLER_RESTORE_LngReg2 /* nothing */
-#endif
-#endif
-
-#ifdef CALLER_SAVES_Tag
-#define CALLER_SAVE_Tag SAVE_Tag = TagReg;
-#define CALLER_RESTORE_Tag TagReg = SAVE_Tag;
-#else
-#define CALLER_SAVE_Tag /* nothing */
-#define CALLER_RESTORE_Tag /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_Ret
-#define CALLER_SAVE_Ret SAVE_Ret = RetReg;
-#define CALLER_RESTORE_Ret RetReg = SAVE_Ret;
-#else
-#define CALLER_SAVE_Ret /* nothing */
-#define CALLER_RESTORE_Ret /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_SpA
-#define CALLER_SAVE_SpA SAVE_SpA = SpA;
-#define CALLER_RESTORE_SpA SpA = SAVE_SpA;
-#else
-#define CALLER_SAVE_SpA /* nothing */
-#define CALLER_RESTORE_SpA /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_SuA
-#define CALLER_SAVE_SuA SAVE_SuA = SuA;
-#define CALLER_RESTORE_SuA SuA = SAVE_SuA;
-#else
-#define CALLER_SAVE_SuA /* nothing */
-#define CALLER_RESTORE_SuA /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_SpB
-#define CALLER_SAVE_SpB SAVE_SpB = SpB;
-#define CALLER_RESTORE_SpB SpB = SAVE_SpB;
-#else
-#define CALLER_SAVE_SpB /* nothing */
-#define CALLER_RESTORE_SpB /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_SuB
-#define CALLER_SAVE_SuB SAVE_SuB = SuB;
-#define CALLER_RESTORE_SuB SuB = SAVE_SuB;
-#else
-#define CALLER_SAVE_SuB /* nothing */
-#define CALLER_RESTORE_SuB /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_Hp
-#define CALLER_SAVE_Hp SAVE_Hp = Hp;
-#define CALLER_RESTORE_Hp Hp = SAVE_Hp;
-#else
-#define CALLER_SAVE_Hp /* nothing */
-#define CALLER_RESTORE_Hp /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_HpLim
-#define CALLER_SAVE_HpLim SAVE_HpLim = HpLim;
-#define CALLER_RESTORE_HpLim HpLim = SAVE_HpLim;
-#else
-#define CALLER_SAVE_HpLim /* nothing */
-#define CALLER_RESTORE_HpLim /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_Liveness
-#define CALLER_SAVE_Liveness SAVE_Liveness = LivenessReg;
-#define CALLER_RESTORE_Liveness LivenessReg = SAVE_Liveness;
-#else
-#define CALLER_SAVE_Liveness /* nothing */
-#define CALLER_RESTORE_Liveness /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_Base
-#ifndef CONCURRENT
-#define CALLER_SAVE_Base /* nothing, ever (it holds a fixed value) */
-#define CALLER_RESTORE_Base BaseReg = &MainRegTable;
-#else
-#define CALLER_SAVE_Base /* nothing */
-#define CALLER_RESTORE_Base BaseReg = CurrentRegTable;
-#endif
-#else
-#define CALLER_SAVE_Base /* nothing */
-#define CALLER_RESTORE_Base /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_StdUpdRetVec
-#define CALLER_RESTORE_StdUpdRetVec StdUpdRetVecReg = vtbl_StdUpdFrame;
-#else
-#define CALLER_RESTORE_StdUpdRetVec /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_StkStub
-#define CALLER_RESTORE_StkStub StdUpdRetVecReg = STK_STUB_closure;
-#else
-#define CALLER_RESTORE_StkStub /* nothing */
-#endif
-
-\end{code}
-
-Concluding \tr{#endifs} and multi-slurp protection:
-
-\begin{code}
-
-#endif /* SCAV_REG_MAP */
-#endif /* SCAN_REG_MAP */
-#endif /* MARK_REG_MAP */
-#endif /* NULL_REG_MAP */
-
-#endif /* STGREGS_H */
-\end{code}
+++ /dev/null
-\section[COptWraps]{Wrappers for calls to ``STG C'' routines}
-
-% this file is part of the C-as-assembler document
-
-\begin{code}
-#ifndef COPTWRAPS_H
-#define COPTWRAPS_H
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[COptWraps-portable]{Wrappers for ``portable~C''}
-%* *
-%************************************************************************
-
-@STGCALL@ macros are used when we really have to be careful about saving
-any caller-saves STG registers. @SAFESTGCALL@ macros are used
-when the caller has previously arranged to save/restore volatile user
-registers (vanilla, float, and double STG registers), and we only have to
-worry about the ``system'' registers (stack and heap pointers, @STK_STUB@,
-etc.). @STGCALL_GC@ macros are used whenever the callee is going to
-need to access (and perhaps modify) some STG registers. @ULTRASAFESTGCALL@
-is available for our own routines that we are absolutely certain will not
-damage any STG registers.
-
-In short,
-\begin{itemize}
-\item @STGCALL@ saves/restores all caller-saves STG registers.
-\item @SAFESTGCALL@ saves/restores only caller-saves STG ``system'' registers.
-\item @ULTRASAFECALL@ is a simple call, without a wrapper.
-\item @STGCALL_GC@ saves/restores {\em all} STG registers.
-\end{itemize}
-
-Several macros are provided to handle outcalls to functions requiring from
-one to five arguments. (If we could assume GCC, we could use macro varargs,
-but unfortunately, we have to cater to ANSI C as well.)
-
-\begin{code}
-
-#define ULTRASAFESTGCALL0(t,p,f) f()
-#define ULTRASAFESTGCALL1(t,p,f,a) f(a)
-#define ULTRASAFESTGCALL2(t,p,f,a,b) f(a,b)
-#define ULTRASAFESTGCALL3(t,p,f,a,b,c) f(a,b,c)
-#define ULTRASAFESTGCALL4(t,p,f,a,b,c,d) f(a,b,c,d)
-#define ULTRASAFESTGCALL5(t,p,f,a,b,c,d,e) f(a,b,c,d,e)
-
-#if ! (defined(__GNUC__) && defined(__STG_GCC_REGS__))
-
-#define STGCALL0(t,p,f) f()
-#define STGCALL1(t,p,f,a) f(a)
-#define STGCALL2(t,p,f,a,b) f(a,b)
-#define STGCALL3(t,p,f,a,b,c) f(a,b,c)
-#define STGCALL4(t,p,f,a,b,c,d) f(a,b,c,d)
-#define STGCALL5(t,p,f,a,b,c,d,e) f(a,b,c,d,e)
-
-#define SAFESTGCALL0(t,p,f) f()
-#define SAFESTGCALL1(t,p,f,a) f(a)
-#define SAFESTGCALL2(t,p,f,a,b) f(a,b)
-#define SAFESTGCALL3(t,p,f,a,b,c) f(a,b,c)
-#define SAFESTGCALL4(t,p,f,a,b,c,d) f(a,b,c,d)
-#define SAFESTGCALL5(t,p,f,a,b,c,d,e) f(a,b,c,d,e)
-
-/*
- * Generic call_GC wrappers have gone away in favor of these partially
- * evaluated versions.
- */
-
-#define DO_GC(args) \
- 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}
-
-%************************************************************************
-%* *
-\subsection[COptWraps-optimised]{Wrappers in ``optimised~C''}
-%* *
-%************************************************************************
-
-We {\em expect} the call-wrappery to be boring---the defaults shown
-herein will kick in--- but you never know.
-
-For example: Don't try an @STGCALL6@ on a SPARC! That's because you
-cannot pass that many arguments to \tr{f} just by heaving them into
-\tr{%o*} registers; anything else is too painful to contemplate.
-
-\begin{code}
-#else /* __GNUC__ && __STG_GCC_REGS__ */
-
-#if !(defined(CALLER_SAVES_SYSTEM) || defined(CALLER_SAVES_USER))
-#define STGCALL0(t,p,f) f()
-#define STGCALL1(t,p,f,a) f(a)
-#define STGCALL2(t,p,f,a,b) f(a,b)
-#define STGCALL3(t,p,f,a,b,c) f(a,b,c)
-#define STGCALL4(t,p,f,a,b,c,d) f(a,b,c,d)
-#define STGCALL5(t,p,f,a,b,c,d,e) f(a,b,c,d,e)
-
-#else
-
-extern void callWrapper(STG_NO_ARGS);
-
-#define STGCALL0(t,p,f) \
- ({t (*_w)p = (t (*)p) callWrapper; (*_w)((void *)f);})
-
-#define STGCALL1(t,p,f,a) \
- ({t (*_w)p = (t (*)p) callWrapper; (*_w)((void *)f,a);})
-
-#define STGCALL2(t,p,f,a,b) \
- ({t (*_w)p = (t (*)p) callWrapper; (*_w)((void *)f,a,b);})
-
-#define STGCALL3(t,p,f,a,b,c) \
- ({t (*_w)p = (t (*)p) callWrapper; (*_w)((void *)f,a,b,c);})
-
-#define STGCALL4(t,p,f,a,b,c,d) \
- ({t (*_w)p = (t (*)p) callWrapper; (*_w)((void *)f,a,b,c,d);})
-
-#define STGCALL5(t,p,f,a,b,c,d,e) \
- ({t (*_w)p = (t (*)p) callWrapper; (*_w)((void *)f,a,b,c,d,e);})
-
-#endif
-
-#if !defined(CALLER_SAVES_SYSTEM)
-#define SAFESTGCALL0(t,p,f) f()
-#define SAFESTGCALL1(t,p,f,a) f(a)
-#define SAFESTGCALL2(t,p,f,a,b) f(a,b)
-#define SAFESTGCALL3(t,p,f,a,b,c) f(a,b,c)
-#define SAFESTGCALL4(t,p,f,a,b,c,d) f(a,b,c,d)
-#define SAFESTGCALL5(t,p,f,a,b,c,d,e) f(a,b,c,d,e)
-
-#else
-
-extern void callWrapper_safe(STG_NO_ARGS);
-
-#define SAFESTGCALL0(t,p,f) \
- ({t (*_w)p = (t (*)p) callWrapper_safe; (*_w)((void *)f);})
-
-#define SAFESTGCALL1(t,p,f,a) \
- ({t (*_w)p = (t (*)p) callWrapper_safe; (*_w)((void *)f,a);})
-
-#define SAFESTGCALL2(t,p,f,a,b) \
- ({t (*_w)p = (t (*)p) callWrapper_safe; (*_w)((void *)f,a,b);})
-
-#define SAFESTGCALL3(t,p,f,a,b,c) \
- ({t (*_w)p = (t (*)p) callWrapper_safe; (*_w)((void *)f,a,b,c);})
-
-#define SAFESTGCALL4(t,p,f,a,b,c,d) \
- ({t (*_w)p = (t (*)p) callWrapper_safe; (*_w)((void *)f,a,b,c,d);})
-
-#define SAFESTGCALL5(t,p,f,a,b,c,d,e) \
- ({t (*_w)p = (t (*)p) callWrapper_safe; (*_w)((void *)f,a,b,c,d,e);})
-
-#endif
-
-/*
- * Generic call_GC wrappers have gone away in favor of these partially
- * evaluated versions. These are only here so that we can avoid putting
- * all of the STG register save/restore code at each call site.
- */
-
-#ifndef CALLWRAPPER_C
-/*
- * We may have funny declarations in CallWrapper_C, to avoid sliding the
- * register windows and other nastiness.
- */
-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}
-
-%************************************************************************
-%* *
-\subsection[COptWraps-magic]{Magic assembly bits for call wrappers}
-%* *
-%************************************************************************
-
-Call wrappers need to be able to call arbitrary functions, regardless of
-their arguments and return types. (Okay, we actually only allow up to
-five arguments, because on the SPARC it gets more complicated to handle
-any more.) The nasty bit is that the return value can be in either an
-integer register or a floating point register, and we don't know which.
-(We {\em don't} handle structure returns, and we don't want to.)
-Still, we have to stash the result away while we restore caller-saves
-STG registers, and then we have to pass the result back to our caller
-in the end.
-
-Getting this right requires three extremely @MAGIC@ macros, no doubt
-chock full of assembly gook for the current platform. These are
-@MAGIC_CALL_SET
-UP@, which gets ready for one of these magic calls,
-@MAGIC_CALL@, which performs the call and stashes away all possible
-results, and @MAGIC_RETURN@, which collects all possible results back
-up again.
-
-For example, in the SPARC version, the @SETUP@ guarantees that we
-have enough space to store all of our argument registers for a wee
-bit, and it gives a `C' name to the register that we're going to use
-for the call. (It helps to do the call in actual `C' fashion, so that
-gcc knows about register death.) It also stashes the incoming arguments
-in the space provided. The @MAGIC_CALL@ then reloads the argument
-registers, rotated by one, so that the function to call is in \tr{%o5},
-calls the function in `C' fashion, and stashes away the possible return
-values (either \tr{%o0} or \tr{%f0}) on the stack. Finally, @MAGIC_RETURN@
-ensures that \tr{%o0} and \tr{%f0} are both set to the values we stashed
-away. Presumably, we then fall into a return instruction and our caller
-gets whatever it's after.
-
-%************************************************************************
-%* *
-\subsubsection[alpha-magic]{Call-wrapper MAGIC for DEC Alpha}
-%* *
-%************************************************************************
-
-\begin{code}
-
-#if defined(__GNUC__) && defined(__STG_GCC_REGS__)
-
-#if alpha_TARGET_ARCH
-
-#define MAGIC_CALL_SETUP \
- long WeNeedThisSpace[7]; \
- double AndThisSpaceToo[6]; \
- register void (*f)() __asm__("$21");\
- __asm__ volatile ( \
- "stq $16,8($30)\n" \
- "\tstq $17,16($30)\n" \
- "\tstq $18,24($30)\n" \
- "\tstq $19,32($30)\n" \
- "\tstq $20,40($30)\n" \
- "\tstq $21,48($30)\n" \
- "\tstt $f16,56($30)\n" \
- "\tstt $f17,64($30)\n" \
- "\tstt $f18,72($30)\n" \
- "\tstt $f19,80($30)\n" \
- "\tstt $f20,88($30)\n" \
- "\tstt $f21,96($30)");
-
-#define MAGIC_CALL \
- __asm__ volatile ( \
- "ldq $21,8($30)\n" \
- "\tldq $16,16($30)\n" \
- "\tldq $17,24($30)\n" \
- "\tldq $18,32($30)\n" \
- "\tldq $19,40($30)\n" \
- "\tldq $20,48($30)\n" \
- "\tldt $f16,56($30)\n" \
- "\tldt $f17,64($30)\n" \
- "\tldt $f18,72($30)\n" \
- "\tldt $f19,80($30)\n" \
- "\tldt $f20,88($30)\n" \
- "\tldt $f21,96($30)");\
- (*f)(); \
- __asm__ volatile ( \
- "stq $0,8($30)\n" \
- "\tstt $f0,16($30)");
-
-#define MAGIC_RETURN \
- __asm__ volatile ( \
- "ldq $0,8($30)\n" \
- "\tldt $f0,16($30)");
-
-#define WRAPPER_NAME(f) /* nothing */
-
-/*
- Threaded code needs to be able to grab the return address, in case we have
- an intervening context switch.
- */
-
-#define SET_RETADDR(loc) { register StgFunPtrFunPtr ra __asm__ ("$26"); loc = ra; }
-
-#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
-
-#define WRAPPER_RETURN(x) \
- do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
-
-#define SEPARATE_WRAPPER_RESTORE /* none */
-
-#endif /* __alpha */
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[hppa-magic]{Call-wrapper MAGIC for HP-PA}
-%* *
-%************************************************************************
-
-\begin{code}
-
-#if hppa1_1_TARGET_ARCH
-
-#define MAGIC_CALL_SETUP \
- long SavedIntArgRegs[4]; \
- double SavedFltArgRegs[2]; \
- register void (*f)() __asm__("%r28");\
- __asm__ volatile ( \
- "copy %r26,%r28\n" \
- "\tstw %r25,8(0,%r3)\n" \
- "\tstw %r24,12(0,%r3)\n" \
- "\tstw %r23,16(0,%r3)\n" \
- "\tldo 40(%r3),%r19\n" \
- "\tfstds %fr5,-16(0,%r19)\n"\
- "\tfstds %fr7, -8(0,%r19)\n");
-
-
-#define MAGIC_CALL \
- __asm__ volatile ( \
- "ldw 8(0,%r3),%r26\n" \
- "\tldw 12(0,%r3),%r25\n" \
- "\tldw 16(0,%r3),%r24\n" \
- "\tldw -52(0,%r3),%r23\n" \
- "\tldw -56(0,%r3),%r19\n" \
- "\tstw %r19,-52(0,%r30)\n" \
- "\tldo 40(%r3),%r19\n" \
- "\tfldds -16(0,%r19),%fr5\n"\
- "\tfldds -8(0,%r19),%fr7\n" \
- "\tldo -64(%r3),%r19\n" \
- "\tldo -64(%r30),%r20\n" \
- "\tfldds -16(0,%r19),%fr4\n"\
- "\tfstds %fr4,-16(0,%r20)\n"\
- "\tfldds -8(0,%r19)%fr4\n" \
- "\tfstds %fr4,-8(0,%r19)\n" \
- "\tfldds 0(0,%r19),%fr4\n" \
- "\tfstds %fr4,0(0,%r19)\n" \
- "\tfldds 8(0,%r19),%fr4\n" \
- "\tfstds %fr4,8(0,%r19)\n");\
- (*f)(); \
- __asm__ volatile ( \
- "stw %r28,8(0,%r3)\n" \
- "\tfstds %fr4,16(0,%r3)");
-
-#define MAGIC_RETURN \
- __asm__ volatile ( \
- "\tfldds 16(0,%r3),%fr4" \
- "ldw 8(0,%r3),%r28\n");
-
-#define WRAPPER_NAME(f) /* nothing */
-
-/*
- Threaded code needs to be able to grab the return address, in case we have
- an intervening context switch.
- */
-
-#define SET_RETADDR(loc) __asm__ volatile ("stw %%r2, %0" : "=m" ((void *)(loc)));
-
-#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
-
-#define WRAPPER_RETURN(x) \
- do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
-
-#define SEPARATE_WRAPPER_RESTORE /* none */
-
-#endif /* __hppa */
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[iX86-magic]{Call-wrapper MAGIC for iX86}
-%* *
-%************************************************************************
-
-\begin{code}
-#if i386_TARGET_ARCH
-
-/* modelled loosely on SPARC stuff */
-
-/* NB: no MAGIC_CALL_SETUP, MAGIC_CALL, or MAGIC_RETURN! */
-
-#define WRAPPER_NAME(f) /*nothing*/
-
-#if defined(solaris2_TARGET_OS) || defined(linux_TARGET_OS)
-#define REAL_NAME(f) #f
-#else
-#define REAL_NAME(f) "_" #f
-#endif
-
-/*
- Threaded code needs to be able to grab the return address, in case we have
- an intervening context switch.
- */
-
-#define SET_RETADDR(loc,val) loc = val;
-
-/* the grab-%eax-quickly HACK is here because we use a VERY SPECIAL
- calling convention on iX86 just for calling PerformGC_wrapper.
- (WDP 95/09)
-
- NB: mangler makes sure that __temp_{eax,esp} get loaded.
- (This is about as ugly as it can get.)
-*/
-
-#define WRAPPER_SETUP(f,ret_addr,args) \
- __asm__ volatile ( \
- "movl " REAL_NAME(__temp_esp) ",%%edx\n" \
- "\tmovl (%%edx),%0\n" \
- "\tmovl " REAL_NAME(__temp_eax) ",%1" \
- : "=r" (ret_addr), "=r" (args) ); \
- SaveAllStgContext(ret_addr);
-
-/* Note re WRAPPER_SETUP: we have special code just for PerformGC_wrapper;
- pls see its definition. WDP 95/09
-
- Also note the EXTREMELY UGLY slamming in of an "sp_offset"; the
- return address *is* on the stack, but it is hard to get there
- before GCC has moved the sp pointer... WDP 95/11
-*/
-
-#define WRAPPER_RETURN(x) \
- do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
-
-#define SEPARATE_WRAPPER_RESTORE /* none */
-
-#endif /* iX86 */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[m68k-magic]{Call-wrapper MAGIC for m68k}
-%* *
-%************************************************************************
-
-\begin{code}
-
-#if m68k_TARGET_ARCH
-
-#define MAGIC_CALL_SETUP \
- int WeNeedThisSpace[5]; \
- register void (*f)() __asm__("a0"); \
- __asm__ volatile ( \
- "movel a6@(8),a0\n" \
- "\tmovel a6@(12),a6@(-20)\n" \
- "\tmovel a6@(16),a6@(-16)\n" \
- "\tmovel a6@(20),a6@(-12)\n" \
- "\tmovel a6@(24),a6@(-8)\n" \
- "\tmovel a6@(28),a6@(-4)");
-
-#define MAGIC_CALL \
- (*f)(); \
- __asm__ volatile ( \
- "movel d0, sp@-\n" \
- "\tmovel d1,sp@-");
-
-#define MAGIC_RETURN \
- __asm__ volatile ( \
- "movel sp@+,d0\n" \
- "\tmovel sp@+,d1");
-
-#define WRAPPER_NAME(f) /* nothing */
-
-#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
-
-#define WRAPPER_RETURN(x) \
- do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
-
-#define SEPARATE_WRAPPER_RESTORE /* none */
-
-#endif /* __mc680x0__ */
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[mips-magic]{Call-wrapper MAGIC for MIPS}
-%* *
-%************************************************************************
-
-\begin{code}
-#if mipseb_TARGET_ARCH || mipsel_TARGET_ARCH
-
-/* shift 4 arg registers down one */
-
-#define MAGIC_CALL_SETUP \
- register void (*f)() __asm__("$2"); \
- __asm__ volatile ( \
- "move $2,$4\n" \
- "\tmove $4,$5\n" \
- "\tmove $5,$6\n" \
- "\tmove $6,$7\n" \
- "\tlw $7,16($sp)\n" \
- "\taddu $sp,$sp,4\n" \
- : : : "$2" );
-
-#define MAGIC_CALL \
- (*f)(); \
- __asm__ volatile ( \
- "subu $sp,$sp,4\n" \
- "\ts.d $f0, -8($sp)\n" \
- "\tsw $2, -12($sp)");
-
-#define MAGIC_RETURN \
- __asm__ volatile ( \
- "l.d $f0, -8($sp)\n" \
- "\tlw $2, -12($sp)");
-
-#define WRAPPER_NAME(f) /* nothing */
-
-/*
- Threaded code needs to be able to grab the return address, in case we have
- an intervening context switch.
- */
-
-#define SET_RETADDR(loc) { register StgFunPtrFunPtr ra __asm__ ("$31"); loc = ra; }
-
-#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
-
-#define WRAPPER_RETURN(x) \
- do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
-
-#define SEPARATE_WRAPPER_RESTORE /* none */
-
-#endif /* mips */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[powerpc-magic]{Call-wrapper MAGIC for PowerPC}
-%* *
-%************************************************************************
-
-\begin{code}
-#if powerpc_TARGET_ARCH || rs6000_TARGET_ARCH
-
-#define MAGIC_CALL_SETUP \
- register void (*f)() __asm__("$2"); \
- __asm__ volatile ( \
- "not used!!!????\n" \
- : : : "$2" );
-
-#define MAGIC_CALL \
- (*f)(); \
- __asm__ volatile ( \
- "not used!!!????\n");
-
-#define MAGIC_RETURN \
- __asm__ volatile ( \
- "not used!!!????\n");
-
-#define WRAPPER_NAME(f) /* nothing */
-
-#define SET_RETADDR(loc) \
- __asm__ volatile ( \
- "mflr 0\n" \
- "\tst 0,%0" \
- :"=m" (loc) :: "0");
-/* __asm__ volatile ("st %%r0, %0" : "=m" ((void *)(loc))); */
-
-#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
-
-/* we have to make sure the STG registers are restored.
-GCC tries to restore the value the registers had in
-the beginning of the current call, which we don't want.
-We defeat it by saving the registers in the stack again. :-( */
-
-#define WRAPPER_RETURN(x) \
- do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0); \
- __asm__ volatile ( \
- "cal 1,136(1)\n" \
- "\tstm 14,-72(1)\n" \
- "\tstu 1,-136(1)");
-
-#define SEPARATE_WRAPPER_RESTORE /* none */
-
-#endif /* powerpc */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[sparc-magic]{Call-wrapper MAGIC for SPARC}
-%* *
-%************************************************************************
-
-\begin{code}
-#if sparc_TARGET_ARCH
-
-#define MAGIC_CALL_SETUP \
- int WeNeedThisSpace[6]; \
- register void (*f)() __asm__("%o5");\
- __asm__ volatile ( \
- "std %i0,[%fp-40]\n" \
- "\tstd %i2,[%fp-32]\n" \
- "\tstd %i4,[%fp-24]");
-
-/* Lest GCC attempt to stick something in
- the delay slot: with compile with
- -fno-delayed-branch. A weak solution. WDP 96/07
-*/
-#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" \
- : : : "%o0", "%o1", "%o2", "%o3", "%o4", "%o5");\
- (*f)(); \
- __asm__ volatile ( \
- "std %f0,[%fp-40]\n" \
- "\tstd %o0,[%fp-32]");
-#if 0
-/* We leave nothing to chance here; we have seen
- GCC stick "unwanted" code in the branch delay
- slot, causing mischief (WDP 96/05)
-*/
-/* the problem with this one: GCC has no way of
- knowing there is a "call" in there, so it
- does not do any calling-convention stuff
- (e.g., saving used regs). WDP 96/07
-*/
-#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", "%o7", "%f0", "memory");
-#endif /* 0 */
-
-#define MAGIC_RETURN \
- __asm__ volatile ( \
- "ldd [%fp-40],%f0\n" \
- "\tldd [%fp-32],%i0");
-
-/*
- We rename the entry points for wrappers so that we can introduce a
- new entry point after the prologue. We want to ensure that the
- register window does not slide! However, we insert a call to
- abort() to make gcc _believe_ that the window slid.
- */
-
-#define WRAPPER_NAME(f) __asm__("L" #f "_wrapper")
-
-#ifdef solaris2_TARGET_OS
-#define REAL_NAME(f) #f
-#else
-#define REAL_NAME(f) "_" #f
-#endif
-
-#define WRAPPER_SETUP(f,ignore1,ignore2) \
- __asm__ volatile ( \
- ".global " REAL_NAME(f) "_wrapper\n"\
- REAL_NAME(f) "_wrapper:\n" \
- "\tstd %o0,[%sp-24]\n" \
- "\tmov %o7,%i7"); \
- SaveAllStgContext(); \
- __asm__ volatile ( \
- "ldd [%sp-24],%i0\n" \
- "\tmov %i0,%o0\n" \
- "\tmov %i1,%o1");
-/*
- * In the above, we want to ensure that the arguments are both in the
- * %i registers and the %o registers, with the assumption that gcc
- * will expect them now to be in one or the other. This is a terrible
- * hack.
- */
-
-/*
- Threaded code needs to be able to grab the return address, in case
- we have an intervening context switch. Note that we want the
- address of the next instruction to be executed, so we add 8 to the
- link address.
- */
-
-#define SET_RETADDR(loc) \
- __asm__ volatile ( \
- "add %%i7,8,%%o7\n" \
- "\tst %%o7,%0" \
- : "=m" (loc) : : "%o7");
-
-
-#define WRAPPER_RETURN(x) \
- __asm__ volatile ( \
- "call Lwrapper_restore" #x "\n" \
- "\tnop"); \
- abort();
-
-/*
- The sparc is a big nuisance. We use a separate function for
- restoring STG registers so that gcc won't try to leave anything
- (like the address of MainRegTable) in the stack frame that we
- didn't build. We also use a leaf return in a format that allows us
- to pass %o7 in as an argument known to gcc, in the hope that its
- value will be preserved during the reloading of STG registers.
- Note that the current gcc (2.5.6) does not use the delay slot
- here (%#), but perhaps future versions will.
- */
-
-#if defined(CONCURRENT)
-#define WRAPPER_REENTER \
-void wrapper_restore_and_reenter_node(STG_NO_ARGS) \
-{ \
- __asm__("Lwrapper_restore1:"); \
- RestoreAllStgRegs(); \
- JMP_(EnterNodeCode); \
-}
-#else
-#define WRAPPER_REENTER
-#endif
-
-#define SEPARATE_WRAPPER_RESTORE \
-void wrapper_restore(STG_NO_ARGS) \
-{ \
- register void *o7 __asm__("%o7"); \
- __asm__ volatile ( \
- "Lwrapper_restore0:\n" \
- "\tmov %%i7,%0" : "=r" (o7)); \
- RestoreAllStgRegs(); \
- __asm__ volatile ("jmp %0+8%#" : : "r" (o7)); \
-} \
-WRAPPER_REENTER
-
-#endif /* __sparc__ */
-
-#endif /* __GNUC__ && __STG_GCC_REGS__ */
-
-\end{code}
-
-That's all, folks.
-\begin{code}
-#endif /* ! COPTWRAPS_H */
-\end{code}
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: ClosureMacros.h,v 1.2 1998/12/02 13:20:58 simonm Exp $
+ *
+ * Macros for building and manipulating closures
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef CLOSUREMACROS_H
+#define CLOSUREMACROS_H
+
+/* -----------------------------------------------------------------------------
+ Fixed Header Size
+
+ The compiler tries to abstract away from the actual value of this
+ constant.
+ -------------------------------------------------------------------------- */
+
+#define _FHS sizeof(StgHeader)
+
+/* -----------------------------------------------------------------------------
+ Info tables are slammed up against the entry code, and the label
+ for the info table is at the *end* of the table itself. This
+ inline function adjusts an info pointer to point to the beginning
+ of the table, so we can use standard C structure indexing on it.
+
+ Note: this works for SRT info tables as long as you don't want to
+ access the SRT, since they are laid out the same with the SRT
+ pointer as the first word in the table.
+
+ NOTES ABOUT MANGLED C VS. MINI-INTERPRETER:
+
+ A couple of definitions:
+
+ "info pointer" The first word of the closure. Might point
+ to either the end or the beginning of the
+ info table, depending on whether we're using
+ the mini interpretter or not. GET_INFO(c)
+ retrieves the info pointer of a closure.
+
+ "info table" The info table structure associated with a
+ closure. This is always a pointer to the
+ beginning of the structure, so we can
+ use standard C structure indexing to pull out
+ the fields. get_itbl(c) returns a pointer to
+ the info table for closure c.
+
+ An address of the form xxxx_info points to the end of the info
+ table or the beginning of the info table depending on whether we're
+ mangling or not respectively. So,
+
+ c->header.info = xxx_info
+
+ makes absolute sense, whether mangling or not.
+
+ -------------------------------------------------------------------------- */
+
+#define INIT_INFO(i) info : &(i)
+#define SET_INFO(c,i) ((c)->header.info = (i))
+#define GET_INFO(c) ((c)->header.info)
+
+#if USE_MINIINTERPRETER
+#define INIT_ENTRY(e) entry : (F_)(e)
+#define GET_ENTRY(c) ((c)->header.info->entry)
+#define ENTRY_CODE(info) (stgCast(StgInfoTable*,info)->entry)
+#define INFO_PTR_TO_STRUCT(info) (info)
+#define get_itbl(c) ((c)->header.info)
+static __inline__ StgFunPtr get_entry(const StgInfoTable *itbl) {
+ return itbl->entry;
+}
+#else
+#define INIT_ENTRY(e) code : {}
+#define GET_ENTRY(c) stgCast(StgFunPtr,((c)->header.info))
+#define ENTRY_CODE(info) (info)
+#define INFO_PTR_TO_STRUCT(info) (stgCast(StgInfoTable*,info) - 1)
+#define get_itbl(c) (stgCast(StgInfoTable*,(c)->header.info) -1)
+static __inline__ StgFunPtr get_entry(const StgInfoTable *itbl) {
+ return stgCast(StgFunPtr,itbl+1);
+}
+#endif
+
+/* -----------------------------------------------------------------------------
+ Macros for distinguishing data pointers from code pointers
+ -------------------------------------------------------------------------- */
+/*
+ * We use some symbols inserted automatically by the linker to decide
+ * whether a pointer points to text, data, or user space. These tests
+ * assume that text is lower in the address space than data, which in
+ * turn is lower than user allocated memory.
+ *
+ * If this assumption is false (say on some strange architecture) then
+ * the tests IS_CODE_PTR and IS_DATA_PTR below will need to be
+ * modified (and that should be all that's necessary).
+ *
+ * _start } start of read-only text space
+ * _etext } end of read-only text space
+ * _end } end of read-write data space
+ */
+extern StgFun start;
+extern StgFun TEXT_SECTION_END_MARKER_DECL;
+extern StgFun DATA_SECTION_END_MARKER_DECL;
+
+#define IS_CODE_PTR(p) ((P_)(p) < (P_)&TEXT_SECTION_END_MARKER)
+#define IS_DATA_PTR(p) ((P_)(p) >= (P_)&TEXT_SECTION_END_MARKER && (P_)(p) < (P_)&DATA_SECTION_END_MARKER)
+#define IS_USER_PTR(p) ((P_)(p) >= (P_)&DATA_SECTION_END_MARKER)
+
+/* -----------------------------------------------------------------------------
+ Macros for distinguishing infotables from closures.
+
+ You'd think it'd be easy to tell an info pointer from a closure pointer:
+ closures live on the heap and infotables are in read only memory. Right?
+ Wrong! Static closures live in read only memory and Hugs allocates
+ infotables for constructors on the (writable) C heap.
+
+ ToDo: in the combined Hugs-GHC system, the following are but crude
+ approximations. This absolutely has to be fixed.
+ -------------------------------------------------------------------------- */
+
+#ifdef USE_MINIINTERPRETER
+/* yoiks: one of the dreaded pointer equality tests */
+#define IS_HUGS_CONSTR_INFO(info) (stgCast(StgInfoTable*,info)->entry == stgCast(StgFunPtr,&Hugs_CONSTR_entry))
+#else
+#define IS_HUGS_CONSTR_INFO(info) 0 /* ToDo: more than mildly bogus */
+#endif
+
+#ifdef USE_MINIINTERPRETER
+/* in the mininterpreter, we put infotables on closures */
+#define LOOKS_LIKE_GHC_INFO(info) IS_CODE_PTR(info)
+#else
+/* otherwise we have entry pointers on closures */
+#define LOOKS_LIKE_GHC_INFO(info) IS_CODE_PTR(info)
+#endif
+
+#define LOOKS_LIKE_STATIC(r) IS_DATA_PTR(r)
+
+/* -----------------------------------------------------------------------------
+ Macros for calculating how big a closure will be (used during allocation)
+ -------------------------------------------------------------------------- */
+
+/* ToDo: replace unsigned int by nat. The only fly in the ointment is that
+ * nat comes from Rts.h which many folk dont include. Sigh!
+ */
+static __inline__ StgOffset AP_sizeW ( unsigned int n_args )
+{ return sizeofW(StgAP_UPD) + n_args; }
+
+static __inline__ StgOffset PAP_sizeW ( unsigned int n_args )
+{ return sizeofW(StgPAP) + n_args; }
+
+static __inline__ StgOffset CONSTR_sizeW( unsigned int p, unsigned int np )
+{ return sizeofW(StgHeader) + p + np; }
+
+static __inline__ StgOffset BCO_sizeW ( unsigned int p, unsigned int np, unsigned int is )
+{ return sizeofW(StgBCO) + p + np + (is+sizeof(StgWord)-1)/sizeof(StgWord); }
+
+static __inline__ StgOffset THUNK_SELECTOR_sizeW ( void )
+{ return sizeofW(StgHeader) + MIN_UPD_SIZE; }
+
+static __inline__ StgOffset BLACKHOLE_sizeW ( void )
+{ return sizeofW(StgHeader) + MIN_UPD_SIZE; }
+
+static __inline__ StgOffset CAF_sizeW ( void )
+{ return sizeofW(StgCAF); }
+
+/* --------------------------------------------------------------------------
+ * Sizes of closures
+ * ------------------------------------------------------------------------*/
+
+static __inline__ StgOffset size_fromITBL( const StgInfoTable* itbl )
+{ return sizeof(StgClosure)
+ + sizeof(StgPtr) * itbl->layout.payload.ptrs
+ + sizeof(StgWord) * itbl->layout.payload.nptrs; }
+
+static __inline__ StgOffset sizeW_fromITBL( const StgInfoTable* itbl )
+{ return sizeofW(StgClosure)
+ + sizeofW(StgPtr) * itbl->layout.payload.ptrs
+ + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+
+static __inline__ StgOffset pap_size( StgPAP* x )
+{ return sizeof(StgPAP)
+ + sizeof(StgWord) * x->n_args; }
+
+static __inline__ StgOffset pap_sizeW( StgPAP* x )
+{ return PAP_sizeW(x->n_args); }
+
+/* These two functions give the same result - but have slightly
+ * different types.
+ */
+static __inline__ StgOffset arr_words_sizeW( StgArrWords* x )
+{ return sizeofW(StgArrWords) + x->words; }
+static __inline__ StgOffset arr_ptrs_sizeW( StgArrPtrs* x )
+{ return sizeofW(StgArrPtrs) + x->ptrs; }
+
+static __inline__ StgWord bco_sizeW( StgBCO* bco )
+{ return BCO_sizeW(bco->n_ptrs,bco->n_words,bco->n_instrs); }
+
+static __inline__ StgWord tso_sizeW ( StgTSO *tso )
+{ return TSO_STRUCT_SIZEW + tso->stack_size; }
+
+/* -----------------------------------------------------------------------------
+ Macros for building closures
+ -------------------------------------------------------------------------- */
+
+#ifdef PROFILING
+#define SET_PROF_HDR(c,ccs_) (c)->header.prof.ccs = ccs_
+#define SET_STATIC_PROF_HDR(ccs_) prof : { ccs : ccs_ },
+#else
+#define SET_PROF_HDR(c,ccs)
+#define SET_STATIC_PROF_HDR(ccs)
+#endif
+
+#ifdef GRAN
+#define SET_GRAN_HDR(c,pe) (c)->header.gran.procs = pe
+#define SET_STATIC_GRAN_HDR gran : { procs : Everywhere },
+#else
+#define SET_GRAN_HDR(c,pe)
+#define SET_STATIC_GRAN_HDR
+#endif
+
+/* there is no PAR header, as far as I can tell -- SDM */
+
+#ifdef PAR
+#define SET_PAR_HDR(c,stuff)
+#define SET_STATIC_PAR_HDR(stuff)
+#else
+#define SET_PAR_HDR(c,stuff)
+#define SET_STATIC_PAR_HDR(stuff)
+#endif
+
+#ifdef TICKY
+#define SET_TICKY_HDR(c,stuff) (c)->header.ticky.updated = stuff
+#define SET_STATIC_TICKY_HDR(stuff) ticky : { updated : stuff }
+#else
+#define SET_TICKY_HDR(c,stuff)
+#define SET_STATIC_TICKY_HDR(stuff)
+#endif
+#define SET_HDR(c,info,ccs) \
+ { \
+ SET_INFO(c,info); \
+ SET_GRAN_HDR((StgClosure *)(c),ThisPE); \
+ SET_PAR_HDR((StgClosure *)(c),LOCAL_GA); \
+ SET_PROF_HDR((StgClosure *)(c),ccs); \
+ SET_TICKY_HDR((StgClosure *)(c),0); \
+ }
+
+/* works for all ARR_WORDS, ARR_PTRS variants (at the moment...) */
+
+#define SET_ARR_HDR(c,info,costCentreStack,n_words) \
+ SET_HDR(c,info,costCentreStack); \
+ (c)->words = n_words;
+
+/* -----------------------------------------------------------------------------
+ Static closures are defined as follows:
+
+
+SET_STATIC_HDR(PrelBase_CZh_closure,PrelBase_CZh_info,costCentreStack,const);
+
+ The info argument must have type 'StgInfoTable' or
+ 'StgSRTInfoTable', since we use '&' to get its address in the macro.
+ -------------------------------------------------------------------------- */
+
+#define SET_STATIC_HDR(label,info,costCentreStack,closure_class,info_class) \
+ info_class info; \
+ closure_class StgClosure label = { \
+ STATIC_HDR(info,costCentreStack)
+
+#define STATIC_HDR(info,ccs) \
+ header : { \
+ INIT_INFO(info), \
+ SET_STATIC_GRAN_HDR \
+ SET_STATIC_PAR_HDR(LOCAL_GA) \
+ SET_STATIC_PROF_HDR(ccs) \
+ SET_STATIC_TICKY_HDR(0) \
+ }
+
+/* how to get hold of the static link field for a static closure.
+ *
+ * Note that we have to use (*cast(T*,&e)) instead of cast(T,e)
+ * because C won't let us take the address of a casted expression. Huh?
+ */
+#define STATIC_LINK(info,p) \
+ (*stgCast(StgClosure**,&((p)->payload[info->layout.payload.ptrs + \
+ info->layout.payload.nptrs])))
+#define STATIC_LINK2(info,p) \
+ (*stgCast(StgClosure**,&((p)->payload[info->layout.payload.ptrs + \
+ info->layout.payload.nptrs + 1])))
+
+/* -----------------------------------------------------------------------------
+ INTLIKE and CHARLIKE closures.
+ -------------------------------------------------------------------------- */
+
+#define CHARLIKE_CLOSURE(n) ((P_)&CHARLIKE_closure[n])
+#define INTLIKE_CLOSURE(n) ((P_)&INTLIKE_closure[(n)-MIN_INTLIKE])
+
+/* -----------------------------------------------------------------------------
+ Payload access
+ -------------------------------------------------------------------------- */
+
+#define payloadPtr( c, i ) (*stgCast(StgPtr*, ((c)->payload+(i))))
+#define payloadCPtr( c, i ) (*stgCast(StgClosure**, ((c)->payload+(i))))
+#define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
+
+/* -----------------------------------------------------------------------------
+ CONSTRs.
+ -------------------------------------------------------------------------- */
+
+/* constructors don't have SRTs */
+#define GET_TAG(info) (INFO_PTR_TO_STRUCT(info)->srt_len)
+
+/* -----------------------------------------------------------------------------
+ BCOs.
+ -------------------------------------------------------------------------- */
+
+#define bcoConstPtr( bco, i ) (*stgCast(StgPtr*, ((bco)->payload+(i))))
+#define bcoConstCPtr( bco, i ) (*stgCast(StgClosurePtr*,((bco)->payload+(i))))
+#define bcoConstInfoPtr( bco, i )(*stgCast(StgInfoTable**,((bco)->payload+(bco)->n_ptrs+i)))
+#define bcoConstInt( bco, i ) (*stgCast(StgInt*, ((bco)->payload+(bco)->n_ptrs+i)))
+#define bcoConstInt64( bco, i ) (PK_Int64(stgCast(StgWord*,(bco)->payload+(bco)->n_ptrs+i)))
+#define bcoConstWord( bco, i ) (*stgCast(StgWord*, ((bco)->payload+(bco)->n_ptrs+i)))
+#define bcoConstAddr( bco, i ) (*stgCast(StgAddr*, ((bco)->payload+(bco)->n_ptrs+i)))
+#define bcoConstChar( bco, i ) (*stgCast(StgChar*, ((bco)->payload+(bco)->n_ptrs+i)))
+#define bcoConstFloat( bco, i ) (PK_FLT(stgCast(StgWord*,(bco)->payload+(bco)->n_ptrs+i)))
+#define bcoConstDouble( bco, i ) (PK_DBL(stgCast(StgWord*,(bco)->payload+(bco)->n_ptrs+i)))
+#define bcoInstr( bco, i ) (stgCast(StgNat8*, ((bco)->payload+(bco)->n_ptrs+(bco)->n_words))[i])
+
+#endif /* CLOSUREMACROS_H */
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: ClosureTypes.h,v 1.2 1998/12/02 13:20:58 simonm Exp $
+ *
+ * Closure Type Constants
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef CLOSURETYPES_H
+#define CLOSURETYPES_H
+
+/* Out here because the native code generator needs to get at them. */
+
+/* Object tag 0 raises an internal error */
+#define INVALID_OBJECT 0
+
+#define CONSTR 1
+/* #define CONSTR_p_np */
+#define CONSTR_INTLIKE 2
+#define CONSTR_CHARLIKE 3
+#define CONSTR_STATIC 4
+#define CONSTR_NOCAF_STATIC 5
+
+#define FUN 6
+#define FUN_STATIC 7
+
+#define THUNK 8
+/* #define THUNK_p_np */
+#define THUNK_STATIC 9
+#define THUNK_SELECTOR 10
+
+#define BCO 11
+
+#define AP_UPD 12
+#define PAP 13
+
+#define IND 14
+#define IND_OLDGEN 15
+#define IND_PERM 16
+#define IND_OLDGEN_PERM 17
+#define IND_STATIC 18
+
+#define CAF_UNENTERED 19
+#define CAF_ENTERED 20
+#define CAF_BLACKHOLE 21
+
+#define RET_BCO 22
+#define RET_SMALL 23
+#define RET_VEC_SMALL 24
+#define RET_BIG 25
+#define RET_VEC_BIG 26
+#define RET_DYN 27
+#define UPDATE_FRAME 28
+#define CATCH_FRAME 29
+#define STOP_FRAME 30
+#define SEQ_FRAME 31
+
+#define BLACKHOLE 32
+#define MVAR 33
+
+#define ARR_WORDS 34
+#define ARR_PTRS 35
+
+#define MUT_ARR_WORDS 36
+#define MUT_ARR_PTRS 37
+#define MUT_ARR_PTRS_FROZEN 38
+#define MUT_VAR 39
+
+#define WEAK 40
+#define FOREIGN 41
+
+#define TSO 42
+#define BLOCKED_FETCH 43
+#define FETCH_ME 44
+
+#define EVACUATED 45
+
+#endif CLOSURETYPES_H
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: Closures.h,v 1.2 1998/12/02 13:20:59 simonm Exp $
+ *
+ * Closures
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef CLOSURES_H
+#define CLOSURES_H
+
+/*
+ * The Layout of a closure header depends on which kind of system we're
+ * compiling for: profiling, parallel, ticky, etc.
+ */
+
+/* -----------------------------------------------------------------------------
+ The profiling header
+ -------------------------------------------------------------------------- */
+
+#ifdef PROFILING
+
+typedef struct {
+ CostCentreStack *ccs;
+} StgProfHeader;
+
+#else /* !PROFILING */
+
+typedef struct {
+ /* empty */
+} StgProfHeader;
+
+#endif /* PROFILING */
+
+/* -----------------------------------------------------------------------------
+ The parallel header
+ -------------------------------------------------------------------------- */
+
+#ifdef GRAN
+
+typedef struct {
+ W_ procs;
+} StgGranHeader;
+
+#else /* !PAR */
+
+typedef struct {
+ /* empty */
+} StgGranHeader;
+
+#endif /* PAR */
+
+/* -----------------------------------------------------------------------------
+ The ticky-ticky header
+
+ Comment from old Ticky.h:
+
+ This is used to record if a closure has been updated but not yet
+ entered. It is set when the closure is updated and cleared when
+ subsequently entered.
+
+ NB: It is {\em not} an ``entry count'', it is an
+ ``entries-after-update count.''
+
+ The commoning up of @CONST@, @CHARLIKE@ and @INTLIKE@ closures is
+ turned off(?) if this is required. This has only been done for 2s
+ collection. It is done using a nasty hack which defines the
+ @_Evacuate@ and @_Scavenge@ code for @CONST@, @CHARLIKE@ and @INTLIKE@
+ info tables to be @_Evacuate_1@ and @_Scavenge_1_0@.
+ -------------------------------------------------------------------------- */
+
+#ifdef TICKY
+
+typedef struct {
+ W_ updated;
+} StgTickyHeader;
+
+#else /* !TICKY */
+
+typedef struct {
+ /* empty */
+} StgTickyHeader;
+
+#endif /* TICKY */
+
+/* -----------------------------------------------------------------------------
+ The full fixed-size closure header
+
+ The size of the fixed header is the sum of the optional parts plus a single
+ word for the entry code pointer.
+ -------------------------------------------------------------------------- */
+
+typedef struct {
+ const struct _StgInfoTable* info;
+ StgProfHeader prof;
+ StgGranHeader par;
+ StgTickyHeader ticky;
+} StgHeader;
+
+#define FIXED_HS (sizeof(StgHeader))
+
+/* -----------------------------------------------------------------------------
+ Closure Types
+
+ For any given closure type (defined in InfoTables.h), there is a
+ corresponding structure defined below. The name of the structure
+ is obtained by concatenating the closure type with '_closure'
+ -------------------------------------------------------------------------- */
+
+/* All closures follow the generic format */
+
+typedef struct StgClosure_ {
+ StgHeader header;
+ struct StgClosure_ *payload[0];
+} StgClosure;
+
+typedef struct {
+ StgHeader header;
+ StgClosure *selectee;
+} StgSelector;
+
+typedef struct {
+ StgHeader header;
+ StgWord n_args;
+ StgClosure *fun;
+ StgPtr payload[0];
+} StgPAP;
+
+typedef struct {
+ StgHeader header;
+ StgWord n_args;
+ StgClosure *fun;
+ StgPtr payload[0];
+} StgAP_UPD;
+
+typedef struct {
+ StgHeader header;
+ StgWord n_ptrs;
+ StgWord n_words;
+ StgWord n_instrs;
+ StgPtr payload[0];
+} StgBCO;
+
+typedef struct {
+ StgHeader header;
+ StgClosure *indirectee;
+} StgInd;
+
+typedef struct {
+ StgHeader header;
+ StgClosure *mut_link;
+ StgClosure *indirectee;
+} StgIndOldGen;
+
+typedef struct {
+ StgHeader header;
+ StgClosure *indirectee;
+ StgClosure *static_link;
+} StgIndStatic;
+
+typedef struct StgCAF_ {
+ StgHeader header;
+ StgClosure *body;
+ StgClosure *value;
+ struct StgCAF_ *link;
+} StgCAF;
+
+typedef struct {
+ StgHeader header;
+ struct StgTSO_ *blocking_queue;
+} StgBlackHole;
+
+typedef struct {
+ StgHeader header;
+ StgWord words;
+ StgWord payload[0];
+} StgArrWords;
+
+typedef struct {
+ StgHeader header;
+ StgWord ptrs;
+ StgClosure *payload[0];
+} StgArrPtrs;
+
+typedef struct {
+ StgHeader header;
+ StgClosure *var;
+} StgMutVar;
+
+typedef struct _StgUpdateFrame {
+ StgHeader header;
+ struct _StgUpdateFrame *link;
+ StgClosure *updatee;
+} StgUpdateFrame;
+
+typedef struct {
+ StgHeader header;
+ struct _StgUpdateFrame *link;
+} StgSeqFrame;
+
+typedef struct {
+ StgHeader header;
+ struct _StgUpdateFrame *link;
+ StgClosure *handler;
+} StgCatchFrame;
+
+typedef struct {
+ StgHeader header;
+} StgStopFrame;
+
+typedef struct {
+ StgHeader header;
+ StgClosure *evacuee;
+} StgEvacuated;
+
+typedef struct {
+ StgHeader header;
+ StgWord data;
+} StgIntCharlikeClosure;
+
+/* statically allocated */
+typedef struct {
+ StgHeader header;
+} StgRetry;
+
+typedef struct _StgForeignObj {
+ StgHeader header;
+ StgAddr data; /* pointer to data in non-haskell-land */
+} StgForeignObj;
+
+typedef struct _StgWeak { /* Weak v */
+ StgHeader header;
+ StgClosure *key;
+ StgClosure *value; /* v */
+ StgClosure *finaliser;
+ struct _StgWeak *link;
+} StgWeak;
+
+/* Dynamic stack frames - these have a liveness mask in the object
+ * itself, rather than in the info table. Useful for generic heap
+ * check code.
+ */
+
+typedef struct {
+ StgHeader header;
+ StgWord liveness;
+ StgWord ret_addr;
+ StgWord payload[0];
+} StgRetDyn;
+
+/* Concurrent communication objects */
+
+typedef struct {
+ StgHeader header;
+ struct StgTSO_* head;
+ struct StgTSO_* tail;
+ StgClosure* value;
+} StgMVar;
+
+/* Parallel FETCH_ME closures */
+#ifdef PAR
+typedef struct {
+ StgHeader header;
+ void *ga; /* type globalAddr is abstract here */
+} StgFetchMe;
+#endif
+
+#endif /* CLOSURES_H */
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: Constants.h,v 1.2 1998/12/02 13:21:03 simonm Exp $
+ *
+ * Constants
+ *
+ * NOTE: this information is used by both the compiler and the RTS,
+ * and *must* be kept up-to-date with respect to the rest of the
+ * world.
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef CONSTANTS_H
+#define CONSTANTS_H
+
+/* -----------------------------------------------------------------------------
+ Header Sizes
+
+ NOTE: keep these in line with the real definitions in Closures.h
+ -------------------------------------------------------------------------- */
+
+#define STD_HDR_SIZE 1
+#define PROF_HDR_SIZE 1
+#define GRAN_HDR_SIZE 1
+#define TICKY_HDR_SIZE 1
+
+#define ARR_HDR_SIZE 1
+
+/* -----------------------------------------------------------------------------
+ Info Table sizes
+
+ The native code generator needs to know these things, and can't use
+ the C sizeof() function.
+
+ NOTE: keep these in line with the real definitions in InfoTables.h
+
+ NOTE: the PROF, GRAN and TICKY values are *wrong* (ToDo)
+ -------------------------------------------------------------------------- */
+
+#define STD_ITBL_SIZE 3
+#define PROF_ITBL_SIZE 1
+#define GRAN_ITBL_SIZE 1
+#define TICKY_ITBL_SIZE 1
+
+/* -----------------------------------------------------------------------------
+ Minimum closure sizes
+
+ Here We define the minimum size for updatable closures. This must be at
+ least 2, to allow for cons cells and linked indirections. All updates
+ will be performed on closures of this size. For non-updatable closures
+ the minimum size is 1 to allow for a forwarding pointer.
+
+ Linked indirections are UPD_OLDGEN things: see Closures.h
+
+ o MIN_UPD_SIZE doesn't apply to stack closures, static closures
+ or non-updateable objects like PAPs or CONSTRs
+ o MIN_UPD_SIZE is big enough to contain any of the following:
+ o EVACUATED
+ o BLACKHOLE
+ o BLOCKING QUEUE
+ o IND, IND_PERM, IND_OLDGEN and IND_OLDGEN_PERM
+ (it need not be big enough for IND_STATIC - but it is)
+ o MIN_NONUPD_SIZE doesn't apply to stack closures, static closures
+ or updateable objects like APs, THUNKS or THUNK_SELECTORs
+ o MIN_NONUPD_SIZE is big enough to contain any of the following:
+ o EVACUATED
+ -------------------------------------------------------------------------- */
+
+#define MIN_UPD_SIZE 2
+#define MIN_NONUPD_SIZE 1
+
+/* -----------------------------------------------------------------------------
+ Constants to do with specialised closure types.
+ -------------------------------------------------------------------------- */
+
+/* We have some pre-compiled selector thunks defined in
+ * StgSelectors.hc in the runtime system. This constant defines the
+ * highest selectee index that we can replace with a reference to the
+ * pre-compiled code.
+ */
+
+#define MAX_SPEC_SELECTEE_SIZE 15
+
+/* Vector-apply thunks. These thunks just push their free variables
+ * on the stack and enter the first one. They're a bit like PAPs, but
+ * don't have a dynamic size. We've pre-compiled a few to save
+ * space.
+ */
+
+#define MAX_SPEC_AP_SIZE 8
+
+/* -----------------------------------------------------------------------------
+ Update Frame Layout
+ -------------------------------------------------------------------------- */
+
+#define NOSCC_UF_SIZE 3
+#define SCC_UF_SIZE 4
+
+#if defined(PROFILING)
+#define UF_SIZE SCC_UF_SIZE
+#else
+#define UF_SIZE NOSCC_UF_SIZE
+#endif
+
+#define UF_RET 0
+#define UF_SU 1
+#define UF_UPDATEE 2
+#define UF_CCS 3
+
+/* -----------------------------------------------------------------------------
+ SEQ frame size
+ -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#define SEQ_FRAME_SIZE 3
+#else
+#define SEQ_FRAME_SIZE 2
+#endif
+
+/* -----------------------------------------------------------------------------
+ STG Registers.
+
+ Note that in MachRegs.h we define how many of these registers are
+ *real* machine registers, and not just offsets in the Register Table.
+ -------------------------------------------------------------------------- */
+
+#define MAX_VANILLA_REG 8
+#define MAX_FLOAT_REG 4
+#define MAX_DOUBLE_REG 2
+/* register is only used for returning (unboxed) 64-bit vals */
+#define MAX_LONG_REG 1
+
+/*---- The size of an StgDouble, in StgWords. */
+
+#if SIZEOF_VOID_P == SIZEOF_DOUBLE
+#define DOUBLE_SIZE 1
+#else
+#define DOUBLE_SIZE 2
+#endif
+
+/*---- The size of Stg{Int,Word}64e, in StgWords. */
+#if SIZEOF_VOID_P == 8
+#define WORD64_SIZE 1
+#define INT64_SIZE 1
+#else
+#define WORD64_SIZE 2
+#define INT64_SIZE 2
+#endif
+
+/*---- Maximum number of constructors in a data type for direct-returns. */
+
+#define MAX_VECTORED_RTN 8
+
+/*---- Range of built-in table of static small int-like closures. */
+
+#define MAX_INTLIKE (16)
+#define MIN_INTLIKE (-16)
+
+/*---- Minimum number of words left in heap after GC to carry on */
+
+#define HEAP_HWM_WORDS 1024
+
+/* -----------------------------------------------------------------------------
+ Semi-Tagging constants
+
+ Old Comments about this stuff:
+
+ Tags for indirection nodes and ``other'' (probably unevaluated) nodes;
+ normal-form values of algebraic data types will have tags 0, 1, ...
+
+ @INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count
+ how often we bang into indirection nodes; that's all. (WDP 95/11)
+
+ ToDo: find out if we need any of this.
+ -------------------------------------------------------------------------- */
+
+#define INFO_OTHER_TAG (-1)
+#define INFO_IND_TAG (-2)
+#define INFO_FIRST_TAG 0
+
+/* -----------------------------------------------------------------------------
+ Context switch timing constants.
+ -------------------------------------------------------------------------- */
+
+#define CS_MAX_FREQUENCY 100 /* context switches per second */
+#define CS_MIN_MILLISECS (1000/CS_MAX_FREQUENCY)/* milliseconds per slice */
+
+/* -----------------------------------------------------------------------------
+ How much C stack to reserve for local temporaries when in the STG
+ world. Used in StgRun.S and StgCRun.c.
+ -------------------------------------------------------------------------- */
+
+#define RESERVED_C_STACK_BYTES (512 * SIZEOF_LONG)
+
+/* -----------------------------------------------------------------------------
+ How much Haskell stack space to reserve for the saving of registers
+ etc. in the case of a stack/heap overflow.
+
+ This must be large enough to accomodate the largest stack frame
+ pushed in one of the heap check fragments in HeapStackCheck.hc
+ (ie. currently the generic heap checks - 19 words).
+ -------------------------------------------------------------------------- */
+
+#define RESERVED_STACK_WORDS 19
+
+/* -----------------------------------------------------------------------------
+ Storage manager constants
+ -------------------------------------------------------------------------- */
+
+/* The size of a block */
+#define BLOCK_SIZE 0x2000
+#define BLOCK_SHIFT 13
+
+/* The size of a megablock */
+#define MBLOCK_SIZE 0x100000
+#define MBLOCK_SHIFT 20
+
+/* the largest size an object can be before we give it a block of its
+ * own and treat it as an immovable object during GC, expressed as a
+ * fraction of BLOCK_SIZE.
+ */
+#define LARGE_OBJECT_THRESHOLD ((nat)(BLOCK_SIZE * 8 / 10))
+
+#endif /* CONSTANTS_H */
+
+++ /dev/null
-%************************************************************************
-%* *
-\section[CostCentre.lh]{Definitions for Cost Centre Profiling}
-%* *
-%************************************************************************
-
-Multi-slurp protection:
-\begin{code}
-#ifndef CostCentre_H
-#define CostCentre_H
-\end{code}
-
-For threaded activity profiling, we need a few bits of the CostCentre
-environment to be defined, despite the fact that we don't have CostCentre
-fields in closures.
-
-\begin{code}
-#if defined(PROFILING) || defined(CONCURRENT)
-
-# define CC_EXTERN(cc_ident) \
- extern struct cc CAT2(cc_ident,_struct); \
- extern CostCentre cc_ident
-
-extern CostCentre CCC; /* the current cost centre */
-
-extern CostCentre Registered_CC;/* registered cost centre list */
-
-CC_EXTERN(CC_MAIN); /* initial MAIN cost centre */
-CC_EXTERN(CC_GC); /* Garbage Collection cost center */
-
-# ifdef PAR
-CC_EXTERN(CC_MSG); /* Communications cost center */
-CC_EXTERN(CC_IDLE); /* Idle-time cost centre */
-# endif
-
-# define REGISTERED_END (CostCentre)4 /* end of list */
- /* That 4 look likes a HACK, Patrick.
- (WDP 94/06) */
-# define NOT_REGISTERED (CostCentre)0 /* not yet registered */
-
-\end{code}
-
-The compiler declares a static block for each @_scc_@ annotation in the
-source using the @CC_DECLARE@ macro where @label@, @module@ and
-@group@ are strings and @ident@ the cost centre identifier.
-
-\begin{code}
-# define CC_IS_CAF 'c'
-# define CC_IS_DICT 'd'
-# define CC_IS_SUBSUMED 's'
-# 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, INIT_CC_STATS}; \
- is_local CostCentre cc_ident = STATIC_CC_REF(cc_ident)
-
-#endif /* defined(PROFILING) || defined(CONCURRENT) */
-\end{code}
-
-Definitions relating to the profiling field as a whole.
-
-\begin{code}
-#define PROF_FIXED_HDR (CC_HDR_SIZE)
-#define PROF_HDR_POSN AFTER_PAR_HDR
-#define AFTER_PROF_HDR (PROF_FIXED_HDR+PROF_HDR_POSN)
-#define SET_PROF_HDR(closure,cc) SET_CC_HDR(closure,cc)
-#define SET_STATIC_PROF_HDR(ident) SET_STATIC_CC_HDR(ident)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[no-cost-centres]{Dummy definitions if no cost centres}
-%* *
-%************************************************************************
-
-The cost-centre profiling is only on if the driver turns on
-@PROFILING@.
-
-These are the {\em dummy} definitions in force if we do {\em NOT}
-turn on @PROFILING@. Get them out of the way....
-
-\begin{code}
-#if !defined(PROFILING)
-
-/*** Declaration Definitions ***/
-
-# define CAT_DECLARE(base_name, kind, descr, type)
-
-# define CC_HDR_SIZE 0 /* No CC in fixed header */
-
-# 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,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_T(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)
-
-/*** Timer and Heap Definitions ***/
-
-# define OR_INTERVAL_EXPIRED /* No || as it is false */
-
-# define CC_ALLOC(cc, size, kind)
-# define HEAP_PROFILE_CLOSURE(closure,size)
-
-# ifndef PAR
-# define START_TIME_PROFILER
-# define RESTART_TIME_PROFILER
-# define STOP_TIME_PROFILER
-# endif
-
-#endif /* !defined(PROFILING) */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[declaring-cost-centres]{Declaring Cost Centres}
-%* *
-%************************************************************************
-
-Now for the cost-centre profiling stuff.
-
-%************************************************************************
-%* *
-\subsection[cost-centres]{Location of Cost Centres}
-%* *
-%************************************************************************
-
-We have a current cost centre, a list of registered cost centres, and
-an additional cost centre field within the fixed header of all
-closures. This is adjacent to the info pointer.
-
-\begin{code}
-#if defined(PROFILING)
-
-CC_EXTERN(CC_SUBSUMED); /* top level fns SUBSUMED cost centre */
-CC_EXTERN(CC_OVERHEAD); /* costs due only to profiling machinery */
-CC_EXTERN(CC_DONTZuCARE); /* placeholder only */
-
-CC_EXTERN(CC_CAFs); /* prelude cost centre (CAFs only) */
-CC_EXTERN(CC_DICTs); /* prelude cost centre (DICTs only) */
-
-# define IS_CAF_OR_DICT_OR_SUB_CC(cc) \
- ((cc)->is_subsumed & ' ') /* tests for lower case character */
-
-\end{code}
-
-Definitions referring to the Cost Centre sub-field of the fixed header.
-\begin{code}
-
-# define CC_HDR_SIZE 1 /* words of header */
- /*R SMinterface.lh */
-
-# define CC_HDR_POSN PROF_HDR_POSN /* position in header */
-
-# define CC_HDR(closure) (((P_)(closure))[CC_HDR_POSN])
-
-# define SET_CC_HDR(closure, cc) \
- CC_HDR(closure) = (W_)(cc) /* Set closures cost centre */
- /*R SMinterface.lh (CCC) */
-\end{code}
-
-For static closures ...
-\begin{code}
-# define SET_STATIC_CC_HDR(cc_ident) \
- , (W_) STATIC_CC_REF(cc_ident) /* static initialisation */
- /*R SMinterface.lh */
-\end{code}
-
-The @/*R @{\em file}@ */@ comments indicate that the macro is used
-regardless in {\em file} so we need a null definition if cost centres
-are not being used.
-
-%************************************************************************
-%* *
-\subsection{Setting the Current Cost Centre}
-%* *
-%************************************************************************
-
-On execution of an @_scc_@ expression a new cost centre is set.
-
-If the new cost centre is different from the CCC we set the CCC and
-count the entry.
-
-If the cost centre is the same as the CCC no action is required. We do
-not count the entry to avoid large counts arising from simple
-recursion. (Huh? WDP 94/07)
-
-\begin{code}
-# 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,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,
-in case we want to do any paranoia-checking here.
-\begin{code}
-# define RESTORE_CCC(cc) \
- do { \
- CCC = (CostCentre) (cc); \
- ASSERT_IS_REGISTERED(CCC,1); \
- } while(0)
-\end{code}
-
-On entry to top level CAFs we count the scc ...
-\begin{code}
-# define ENTER_CC_CAF_X(cc) \
- do { \
- CCC->sub_cafcc_count++; /* inc subcaf count of CCC */ \
- CCC = (CostCentre)(cc); /* set CCC to ident cc */ \
- ASSERT_IS_REGISTERED(CCC,1); \
- 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))
-# define ENTER_CC_CAF_CL(closure) ENTER_CC_CAF_X((CostCentre)CC_HDR(closure))
-\end{code}
-
-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_DETAIL_COUNT(CCC->thunk_count); \
- } while(0)
-
-# define ENTER_CC_TCL(closure) \
- ENTER_CC_T(CC_HDR(closure))
-
-/* Here is our special "hybrid" case when we do *not* set the CCC.
- (a) The closure is a function, not a thunk;
- (b) The CC is CAF/DICT-ish.
-*/
-# define ENTER_CC_F(centre) \
- do { \
- CostCentre cc = (CostCentre) (centre); \
- ASSERT_IS_REGISTERED(cc,1); \
- if ( ! IS_CAF_OR_DICT_OR_SUB_CC(cc) ) { \
- CCC = cc; \
- } else { \
- CCC_DETAIL_COUNT(cc->caffun_subsumed); \
- CCC_DETAIL_COUNT(CCC->subsumed_caf_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) \
- do { \
- CostCentre cc = (CostCentre) (centre); \
- ASSERT_IS_REGISTERED(cc,1); \
- if ( ! IS_CAF_OR_DICT_OR_SUB_CC(cc) ) { \
- CCC = cc; \
- CCC->scc_count++; \
- } else { \
- CCC_DETAIL_COUNT(cc->caffun_subsumed); \
- CCC_DETAIL_COUNT(CCC->subsumed_caf_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}
-
-%************************************************************************
-%* *
-\subsection{``Registering'' cost-centres}
-%* *
-%************************************************************************
-
-Cost centres are registered at startup by calling a registering
-routine in each module. Each module registers its cost centres and
-calls the registering routine for all imported modules. The RTS calls
-the registering routine for the module Main. This registering must be
-done before initialisation since the evaluation required for
-initialisation may use the cost centres.
-
-As the code for each module uses tail calls we use an auxiliary stack
-(in the heap) to record imported modules still to be registered. At
-the bottom of the stack is NULL which indicates that
-@miniInterpretEnd@ should be resumed.
-
-@START_REGISTER@ and @END_REGISTER@ are special macros used to
-delimit the function. @END_REGISTER@ pops the next registering
-routine off the stack and jumps to it. @REGISTER_CC@ registers a cost
-centre. @REGISTER_IMPORT@ pushes a modules registering routine onto
-the register stack.
-
-\begin{code}
-#if defined(PROFILING)
-
-extern F_ _regMain (STG_NO_ARGS);
-extern F_ *register_stack;
-
-# define PUSH_REGISTER_STACK(reg_function) \
- *(register_stack++) = (F_)reg_function
-
-# define POP_REGISTER_STACK \
- *(--register_stack)
-
-# define START_REGISTER_CCS(reg_mod_name) \
- static int _module_registered = 0; \
- STGFUN(reg_mod_name) { \
- FUNBEGIN; \
- if (! _module_registered) { \
- _module_registered = 1
-
-# define START_REGISTER_PRELUDE(reg_mod_name) \
- static int CAT2(reg_mod_name,_done) = 0; \
- STGFUN(reg_mod_name) { \
- FUNBEGIN; \
- if (! CAT2(reg_mod_name,_done)) { \
- CAT2(reg_mod_name,_done) = 1
-
-# define REGISTER_IMPORT(reg_mod_name) \
- do { extern F_ reg_mod_name (STG_NO_ARGS) ; \
- PUSH_REGISTER_STACK(reg_mod_name) ; \
- } while (0)
-
-# define END_REGISTER_CCS() \
- }; \
- do { \
- F_ cont = POP_REGISTER_STACK; \
- if (cont == NULL) { \
- RESUME_(miniInterpretEnd); \
- } else { \
- JMP_(cont); \
- } \
- } while(0); \
- FUNEND; }
-
-#else /* PROFILING */
-
-/* When things are working these shouldn't be emitted when not profiling,
- but it was convenient at one point to have them expand to nothing
- when not profiling. SLPJ Dec 96 */
-
-#define START_REGISTER_CCS(reg_mod_name)
-#define END_REGISTER_CCS()
-
-#endif /* PROFILING */
-\end{code}
-
-We don't want to attribute costs to an unregistered cost-centre:
-\begin{code}
-#if !defined(PROFILING) || !defined(DEBUG)
-# define ASSERT_IS_REGISTERED(cc,chk_not_overhead) /*nothing*/
-#else
-# define ASSERT_IS_REGISTERED(cc,chk_not_overhead) \
- do { /* beware of cc name-capture */ \
- CostCentre c_c = (CostCentre) (cc); \
- if (c_c->registered == NOT_REGISTERED) { \
- fprintf(stderr,"Entering unregistered CC: %s %s\n",c_c->module, c_c->label); \
- /* unsafe c-call, BTW */ \
- } \
- if ( (chk_not_overhead) && c_c == STATIC_CC_REF(CC_OVERHEAD) ) { \
- fprintf(stderr,"CC should not be OVERHEAD!: %s\n",c_c->label); \
- /* unsafe c-call, BTW */ \
- } } while(0)
-#endif
-
-#define REGISTER_CC(cc) \
- do { \
- extern CostCentre cc; \
- if (((CostCentre)(cc))->registered == NOT_REGISTERED) { \
- ((CostCentre)(cc))->registered = Registered_CC; \
- Registered_CC = (CostCentre)(cc); \
- }} while(0)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[declaring-closure-categories]{Declaring Closure Categories}
-%* *
-%************************************************************************
-
-Closure category records are attached to the info table of the
-closure. They are declared with the info table. Hashing will map
-similar categories to the same hash value allowing statistics to be
-grouped by closure category.
-
-The declaration macros expand to nothing if cost centre profiling is
-not required.
-
-Note from ADR: Very dubious Malloc Ptr addition -- should probably just
-reuse @CON_K@ (or something) in runtime/main/StgStartup.lhc.
-Similarily, the SP stuff should probably be the highly uninformative
-@INTERNAL_KIND@.
-
-SOF 4/96: Renamed MallocPtr_K to ForeignObj_K
-
-\begin{code}
-#if defined(PROFILING)
-
-# define CON_K 1
-# define FN_K 2
-# define PAP_K 3
-# define THK_K 4
-# define BH_K 5
-# define ARR_K 6
-
-# ifndef PAR
-# define ForeignObj_K 7 /* Malloc Pointer */
-# define SPT_K 8 /* Stable Pointer Table */
-# endif /* !PAR */
-
-# define INTERNAL_KIND 10
-
-typedef struct ClCat {
- hash_t index_val; /* hashed value */
- I_ selected; /* is this category selected (-1 == not memoised, selected? 0 or 1) */
- I_ kind; /* closure kind -- as above */
- char *descr; /* source derived string detailing closure description */
- char *type; /* source derived string detailing closure type */
-} *ClCategory;
-
-/* We put pointers to these ClCat things in info tables.
- We need these ClCat things because they are mutable,
- whereas info tables are immutable. (WDP 94/11)
-
- We really should not make funny names by appending _CAT.
-*/
-
-# define MK_CAT_IDENT(i) CAT2(i,_CAT)
-# define REF_CAT_IDENT(i) (&MK_CAT_IDENT(i))
-
-# define CAT_DECLARE(base_name, kind, descr, type) \
- static struct ClCat MK_CAT_IDENT(base_name) = {UNHASHED,-1,kind,descr,type};
-
-#endif /* PROFILING */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[timer-interupts]{Processing of Timer Signals}
-%* *
-%************************************************************************
-
-Stuff to do with timer signals:
-\begin{code}
-#if defined(PROFILING) || defined(PAR)
-
-extern I_ time_profiling; /* Flag indicating if timer/serial profiling is required */
-
-extern I_ interval_expired; /* Flag set by signal handler */
-extern I_ current_interval; /* Current interval number -- used as time stamp */
-extern I_ interval_ticks; /* No of ticks in an interval */
-
-extern I_ previous_ticks; /* ticks in previous intervals */
-extern I_ current_ticks; /* ticks in current interval */
-
-extern void set_time_profile_handler(STG_NO_ARGS);
-extern void start_time_profiler(STG_NO_ARGS);
-extern void restart_time_profiler(STG_NO_ARGS);
-extern void stop_time_profiler(STG_NO_ARGS);
-
-# define TICK_FREQUENCY 50 /* ticks per second */
-# define TICK_MILLISECS (1000/TICK_FREQUENCY) /* milli-seconds per tick */
-
-# define DEFAULT_INTERVAL TICK_FREQUENCY /* 1 second */
-
-/* These are never called directly from threaded code */
-# define START_TIME_PROFILER ULTRASAFESTGCALL0(void,(void *),start_time_profiler) /*R StgOverflow.lc */
-# define RESTART_TIME_PROFILER ULTRASAFESTGCALL0(void,(void *),restart_time_profiler) /*R StgOverflow.lc */
-# define STOP_TIME_PROFILER ULTRASAFESTGCALL0(void,(void *),stop_time_profiler) /*R StgOverflow.lc */
-
-# if defined(PROFILING)
-# define OR_INTERVAL_EXPIRED || (interval_expired) /*R StgMacros.h */
-# endif
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[indexing]{Indexing of Cost Centres and Categories}
-%* *
-%************************************************************************
-
-Cost Centres and Closure Categories are hashed to provide indexes
-against which arbitrary information can be stored. These indexes are
-memoised in the appropriate cost centre or category record and
-subsequent hashes avoided by the index routine (it simply returns the
-memoised index).
-
-There are different features which can be hashed allowing information
-to be stored for different groupings. Cost centres have the cost
-centre recorded (using the pointer), module and group. Closure
-categories have the closure description and the type
-description. Records with the same feature will be hashed to the same
-index value.
-
-The initialisation routines, @init_index_<feature>@, allocate a hash
-table in which the cost centre / category records are stored. The
-lower bound for the table size is taken from @max_<feature>_no@. They
-return the actual table size used (the next power of 2). Unused
-locations in the hash table are indicated by a 0 entry. Successive
-@init_index_<feature>@ calls just return the actual table size.
-
-Calls to @index_<feature>@ will insert the cost centre / category
-record in the <feature> hash table, if not already inserted. The hash
-index is memoised in the record and returned.
-
-CURRENTLY ONLY ONE MEMOISATION SLOT IS AVILABLE IN EACH RECORD SO
-HASHING CAN ONLY BE DONE ON ONE FEATURE FOR EACH RECORD. This can be
-easily relaxed at the expense of extra memoisation space or continued
-rehashing.
-
-The initialisation routines must be called before initialisation of
-the stacks and heap as they require to allocate storage. It is also
-expected that the caller may want to allocate additional storage in
-which to store profiling information based on the return table size
-value(s).
-
-\begin{code}
-# if defined(PROFILING)
-
-# define DEFAULT_MAX_CC 4096
-# define DEFAULT_MAX_MOD 256
-# define DEFAULT_MAX_GRP 128
-# define DEFAULT_MAX_DESCR 4096
-# define DEFAULT_MAX_TYPE 1024
-
-extern hash_t max_cc_no; /* Hash on CC ptr */
-extern CostCentre *index_cc_table;
-extern hash_t init_index_cc(STG_NO_ARGS);
-extern hash_t index_cc PROTO((CostCentre cc));
-
-extern hash_t max_mod_no; /* Hash on CC module */
-extern CostCentre *index_mod_table;
-extern hash_t init_index_mod(STG_NO_ARGS);
-extern hash_t index_mod PROTO((CostCentre cc));
-
-extern hash_t max_grp_no; /* Hash on CC group */
-extern CostCentre *index_grp_table;
-extern hash_t init_index_grp(STG_NO_ARGS);
-extern hash_t index_grp PROTO((CostCentre cc));
-
-extern hash_t max_descr_no; /* Hash on closure description */
-extern ClCategory *index_descr_table;
-extern hash_t init_index_descr(STG_NO_ARGS);
-extern hash_t index_descr PROTO((ClCategory clcat));
-
-extern hash_t max_type_no; /* Hash on type description */
-extern ClCategory *index_type_table;
-extern hash_t init_index_type(STG_NO_ARGS);
-extern hash_t index_type PROTO((ClCategory clcat));
-
-# endif /* PROFILING */
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[metering]{Metering of Statistics}
-%* *
-%************************************************************************
-
-@scc_count@ is incremented by the @SetCC@ macro in section
-\ref{manipulating-cost-centres} above. Below we have the time tick and
-memory alloc macros.
-
-\begin{code}
-# 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(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}
-
-
-%************************************************************************
-%* *
-\subsection[cost-centre-profiling]{Cost Centre Profiling}
-%* *
-%************************************************************************
-
-\begin{code}
-I_ init_cc_profiling PROTO((I_ rts_argc, char *rts_argv[], char *prog_argv[]));
-void report_cc_profiling PROTO((I_ final));
-
-void cc_register(STG_NO_ARGS);
-void cc_sort PROTO((CostCentre *sort, char sort_on));
-rtsBool cc_to_ignore PROTO((CostCentre));
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[heap-profiling]{Heap Profiling}
-%* *
-%************************************************************************
-
-\begin{code}
-# if defined(PROFILING)
-
-I_ heap_profile_init PROTO((char *argv[]));
-
-void heap_profile_finish(STG_NO_ARGS);
-
-void heap_profile_setup(STG_NO_ARGS); /* called at start of heap profile */
-void heap_profile_done(STG_NO_ARGS); /* called at end of heap profile */
-
-void (* heap_profile_fn) PROTO((P_ closure,I_ size));
-
-extern I_ earlier_ticks; /* no. of earlier ticks grouped */
-extern hash_t time_intervals; /* no. of time intervals reported -- 18 */
-
-# define HEAP_PROFILE_CLOSURE(closure,size) \
- do { \
- if (heap_profile_fn) { \
- STGCALL2(void,(void *, P_, I_),(*heap_profile_fn),closure,size); \
- }} while(0)
-
-# endif /* PROFILING */
-\end{code}
-
-End multi-slurp protection:
-\begin{code}
-#endif /* PROFILING || PAR */
-
-#endif /* CostCentre_H */
-\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\section[GhcConstants]{Constants known by C code {\em and} by the compiler (hsc)}
-%* *
-%************************************************************************
-
-Multi-slurp protection (start):
-\begin{code}
-#ifndef GHCCONSTANTS_H
-#define GHCCONSTANTS_H
-
-#ifndef PLATFORM_H
-/* OLD: #include "platform.h" */
-#endif
-\end{code}
-
-% BECAUSE THIS FILE IS INCLUDED INTO HASKELL FILES, THERE MUST BE NO C
-% COMMENTS IN THE ``CODE'' BITS.
-
-This file defines constants that are common to diverse parts of the
-Glasgow Haskell compilation system. For example, both the compiler
-proper and some magic runtime-system bits need to know the minimum
-size of an updatable closure.
-
-%************************************************************************
-%* *
-\subsection[updatable-closure-size]{Size of Updatable Closures}
-%* *
-%************************************************************************
-
-We define the minimum size for updatable closures. This must be at
-least 2, to allow for cons cells and linked indirections. All updates
-will be performed on closures of this size. For non-updatable closures
-the minimum size is 1 to allow for a forwarding pointer.
-
-\begin{code}
-#define MIN_UPD_SIZE 2
-#define MIN_NONUPD_SIZE 1
-\end{code}
-
-ToDo: @MIN_STATIC_NONUPD_SIZE@ ???
-
-%************************************************************************
-%* *
-\subsection[double-etc-size]{Sizes of various types}
-%* *
-%************************************************************************
-
-The size of an StgDouble, in StgWords.
-
-\begin{code}
-#if alpha_TARGET_ARCH
-#define DOUBLE_SIZE 1
-#else
-#define DOUBLE_SIZE 2
-#endif
-\end{code}
-
-The size of an Stg{Int,Word}64, in StgWords.
-
-\begin{code}
-#if alpha_TARGET_ARCH
-#define WORD64_SIZE 1
-#define INT64_SIZE 1
-#else
-#define WORD64_SIZE 2
-#define INT64_SIZE 2
-#endif
-\end{code}
-
-Sizes of gmp objects, in StgWords
-
-\begin{code}
-#define MP_STRUCT_SIZE 3
-#define MIN_MP_INT_SIZE 16
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[spec-closure-constraints]{What can be declared as a @SPEC@ closure}
-%* *
-%************************************************************************
-
-The following define what closure layouts can be declared as @SPEC@
-closures.
-
-\begin{code}
-#define MAX_SPEC_ALL_PTRS 12
-#define MAX_SPEC_ALL_NONPTRS 5
-#define MAX_SPEC_OTHER_SIZE 3
-\end{code}
-
-The highest-numbered selectee field that we can do magic on (i.e.,
-do the selection at GC time):
-\begin{code}
-#define MAX_SPEC_SELECTEE_SIZE 12
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[stg-reg-counts]{How many STG registers are there}
-%* *
-%************************************************************************
-
-\begin{code}
-#define MAX_VANILLA_REG 8
-#define MAX_FLOAT_REG 4
-#define MAX_DOUBLE_REG 2
-#define MAX_LONG_REG 2
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[vectored-return]{What number of data type cases can use vectored returns}
-%* *
-%************************************************************************
-
-@MAX_VECTORED_RTN@ defines the largest number of constructors that a
-data type can have and still use a vectored return.
-\begin{code}
-#define MAX_VECTORED_RTN 8
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[intlike-range]{Range of int-like closures}
-%* *
-%************************************************************************
-
-Range of built-in table of static small int-like closures.
-
-\begin{code}
-#define MAX_INTLIKE (16)
-#define MIN_INTLIKE (-16)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[update-frame-size]{Update frame size}
-%* *
-%************************************************************************
-
-The update frames are described in \tr{SMupdate.lh}. All the compiler
-needs to ``know'' is the size of the different frames.
-
-First we define update frame sizes for the compiler. These may vary at
-runtime depending what type of code is being generated so we also
-define the parts which can be put together.
-
-****************************************************************
-*** NB: These update-frame sizes INCLUDE the return address. ***
-****************************************************************
-
-
-The update frame sizes when cost centres are not being used are:
-\begin{code}
-#define NOSCC_STD_UF_SIZE 4
-#define NOSCC_CON_UF_SIZE 2
-\end{code}
-
-If cost-centres are being used we have to add to the above sizes:
-\begin{code}
-#define SCC_STD_UF_SIZE 5
-#define SCC_CON_UF_SIZE 3
-\end{code}
-
-If we are compiling C code the use of cost centres is determined at
-compile time so we use conditional macro definitions.
-\begin{code}
-#if defined(PROFILING)
-#define STD_UF_SIZE SCC_STD_UF_SIZE
-#define CON_UF_SIZE SCC_CON_UF_SIZE
-#else
-#define STD_UF_SIZE NOSCC_STD_UF_SIZE
-#define CON_UF_SIZE NOSCC_CON_UF_SIZE
-#endif
-\end{code}
-
-Sorry. but we can't comment these if's and else's !
-
-Offsets relative to a pointer to the top word (return address) of frame...
-
-Notes: (1)~GC looks at the @UF_RET@ word to determine frame type. (2)
-GC requires that @UF_SUB@ be the same offset in all frames, no matter
-what.
-
-\begin{code}
-#define UF_RET 0
-#define UF_SUB 1
-#define UF_SUA 2
-#define UF_UPDATEE 3
-#define UF_COST_CENTRE 4
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[semi-tagging-constants]{Constants for semi-tagging}
-%* *
-%************************************************************************
-
-Tags for indirection nodes and ``other'' (probably unevaluated) nodes;
-normal-form values of algebraic data types will have tags 0, 1, ...
-
-@INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count
-how often we bang into indirection nodes; that's all. (WDP 95/11)
-
-\begin{code}
-#define INFO_OTHER_TAG (-1)
-#define INFO_IND_TAG (-2)
-#define INFO_FIRST_TAG 0
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[liveness-masks]{Liveness masks for calling GC}
-%* *
-%************************************************************************
-
-We often have to tell the RTS (usually: garbage-collector) what STG
-registers have ``followable'' pointers in them. We used to just say
-{\em how many} there were; but this doesn't work in a semi-tagged
-world---part of the point of semi-tagging is to avoid loading up
-registers needlessly; but if you don't load a register and then you
-tell the GC that it has followable contents....
-
-So we use a {\em liveness mask} (one word) instead. This is probably
-neater anyway. The layout is:
-\begin{verbatim}
---------------------------
-... | Rn | ... | R2 | R1 |
---------------------------
-\end{verbatim}
-
-The \tr{LIVENESS_<reg>} macros are used both in Haskell and C. The
-\tr{IS_LIVE_<reg>} macros (``is this register live according to this
-mask?'') are used only in C [obviously].
-\begin{code}
-#define NO_LIVENESS 0
-#define LIVENESS_R1 1
-#define LIVENESS_R2 2
-#define LIVENESS_R3 4
-#define LIVENESS_R4 8
-#define LIVENESS_R5 16
-#define LIVENESS_R6 32
-#define LIVENESS_R7 64
-#define LIVENESS_R8 128
-
-#define IS_LIVE_R1(mask) (((mask) & LIVENESS_R1) != 0)
-#define IS_LIVE_R2(mask) (((mask) & LIVENESS_R2) != 0)
-#define IS_LIVE_R3(mask) (((mask) & LIVENESS_R3) != 0)
-#define IS_LIVE_R4(mask) (((mask) & LIVENESS_R4) != 0)
-#define IS_LIVE_R5(mask) (((mask) & LIVENESS_R5) != 0)
-#define IS_LIVE_R6(mask) (((mask) & LIVENESS_R6) != 0)
-#define IS_LIVE_R7(mask) (((mask) & LIVENESS_R7) != 0)
-#define IS_LIVE_R8(mask) (((mask) & LIVENESS_R8) != 0)
-\end{code}
-
-Some extra stuff will probably be needed for ``shift bits off the end
-and stop when zero,'' which would be quicker. Later.
-
-Multi-slurp protection (end-of-file):
-\begin{code}
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section{Macros and global declarations for GranSim}
-%* *
-%************************************************************************
-
-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}
-#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_NCG)
-#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 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;
-
-#if (defined(GCap) || defined(GCgn))
-typedef struct clos /* a queue of ex-RBHs (needed for gen GC only) */
-{
- struct clos *prev, *next;
- P_ closure;
-} *closq;
-
-#define CLOS_CLOSURE(clos) (clos->closure)
-#define CLOS_PREV(clos) (clos->prev)
-#define CLOS_NEXT(clos) (clos->next)
-#endif
-
-/* 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_))
-
-/* 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 traverse_eventq_for_gc 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)); */
-
-I_ SaveSparkRoots PROTO((I_));
-I_ SaveEventRoots PROTO((I_));
-
-I_ RestoreSparkRoots PROTO((I_));
-I_ RestoreEventRoots PROTO((I_));
-
-IF_RTS(int init_gr_simulation PROTO((int, char **, int, char **));)
-IF_RTS(void end_gr_simulation(STG_NO_ARGS);)
-
-/* These constants are defaults for the RTS flags of GranSim */
-
-/* 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)
-
-#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 400
-#define REALLOC_SZ 200
-
-/* 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}
+++ /dev/null
-/********************************************************************
-* High Level Communications Header (HLC.h) *
-* *
-* Contains the high-level definitions (i.e. communication *
-* subsystem independent) used by GUM *
-* Phil Trinder, Glasgow University, 12 December 1994 *
-*********************************************************************/
-
-#ifndef __HLC_H
-#define __HLC_H
-#ifdef PAR
-
-#include "LLC.h"
-
-#define NEW_FISH_AGE 0
-#define NEW_FISH_HISTORY 0
-#define NEW_FISH_HUNGER 0
-#define FISH_LIFE_EXPECTANCY 10
-
-void sendFetch PROTO((globalAddr *ga, globalAddr *bqga, int load));
-void sendResume PROTO((globalAddr *bqga, int nelem, P_ data));
-void sendAck PROTO((GLOBAL_TASK_ID task, int ngas, globalAddr *gagamap));
-void sendFish PROTO((GLOBAL_TASK_ID destPE, GLOBAL_TASK_ID origPE, int age, int history, int hunger));
-void sendFree PROTO((GLOBAL_TASK_ID destPE, int nelem, P_ data));
-void sendSchedule PROTO((GLOBAL_TASK_ID origPE, int nelem, P_ data));
-void processMessages(STG_NO_ARGS);
-void processFetches(STG_NO_ARGS);
-
-void prepareFreeMsgBuffers(STG_NO_ARGS);
-void freeRemoteGA PROTO((int pe, globalAddr *ga));
-void sendFreeMessages(STG_NO_ARGS);
-
-void Comms_Harness_Exception PROTO((PACKET packet));
-void STG_Exception PROTO((PACKET));
-
-GLOBAL_TASK_ID choosePE(STG_NO_ARGS);
-
-void WaitForTermination(STG_NO_ARGS);
-
-void DebugPrintGAGAMap PROTO((globalAddr *gagamap, int nGAs));
-
-void CommonUp PROTO((P_, P_));
-
-#endif /* PAR */
-#endif /* __HLC_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Hooks.h,v 1.2 1998/12/02 13:21:08 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern void OnExitHook (void);
+extern void ErrorHdrHook (long fd);
+extern int NoRunnableThreadsHook (void);
+extern void StackOverflowHook (unsigned long stack_size);
+extern void OutOfHeapHook (unsigned long request_size, unsigned long heap_size);
+extern void MallocFailHook (unsigned long request_size /* in bytes */, char *msg);
+extern void PatErrorHdrHook (long fd);
+extern void defaultsHook (void);
+extern void PreTraceHook (long fd);
+extern void PostTraceHook (long fd);
+++ /dev/null
-\section[Info.lh]{Definitions for the Info Pointer Field}
-
-Multi-slurp protection:
-\begin{code}
-#ifndef Info_H
-#define Info_H
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[info-SM]{Storage-mgr interface things for the info ptr}
-%* *
-%************************************************************************
-
-\begin{code}
-#define INFO_FIXED_HDR 1
-#define INFO_HDR_POSN 0
-#define AFTER_INFO_HDR (INFO_HDR_POSN+INFO_FIXED_HDR)
-#define INFO_PTR(closure) (((P_)(closure))[INFO_HDR_POSN])
-#define SET_INFO_PTR(closure,wd) INFO_PTR(closure) = (W_) wd
-#define SET_STATIC_INFO_PTR(wd) (W_) wd
-\end{code}
-
-End multi-slurp protection:
-\begin{code}
-#endif /* Info_H */
-\end{code}
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: InfoMacros.h,v 1.2 1998/12/02 13:21:09 simonm Exp $
+ *
+ * Macros for building and deconstructing info tables.
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef INFOMACROS_H
+#define INFOMACROS_H
+
+#define STD_INFO(type_) \
+ srt : 0, \
+ srt_len : 0, \
+ type : type_, \
+ flags: FLAGS_##type_
+
+#define SRT_INFO(type_,srt_,srt_off_,srt_len_) \
+ srt : (StgSRT *)((StgClosure **)srt_+srt_off_), \
+ srt_len : srt_len_, \
+ type : type_, \
+ flags: FLAGS_##type_
+
+/* function/thunk info tables --------------------------------------------- */
+
+#define \
+INFO_TABLE_SRT(info, /* info-table label */ \
+ entry, /* entry code label */ \
+ ptrs, nptrs, /* closure layout info */\
+ srt_, srt_off_, srt_len_, /* SRT info */ \
+ type, /* closure type */ \
+ info_class, entry_class, /* C storage classes */ \
+ prof_descr, prof_type) /* profiling info */ \
+ entry_class(entry); \
+ info_class StgInfoTable info = { \
+ layout : { payload : {ptrs,nptrs} }, \
+ SRT_INFO(type,srt_,srt_off_,srt_len_), \
+ INIT_ENTRY(entry) \
+ }
+
+
+/* direct-return address info tables --------------------------------------*/
+
+#define \
+INFO_TABLE_SRT_BITMAP(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
+ type, info_class, entry_class, \
+ prof_descr, prof_type) \
+ entry_class(entry); \
+ info_class StgInfoTable info = { \
+ layout : { bitmap : (StgNat32)bitmap_ },\
+ SRT_INFO(type,srt_,srt_off_,srt_len_), \
+ INIT_ENTRY(entry) \
+ }
+
+/* info-table without an SRT -----------------------------------------------*/
+
+#define \
+INFO_TABLE(info, entry, ptrs, nptrs, type, info_class, \
+ entry_class, prof_descr, prof_type) \
+ entry_class(entry); \
+ info_class StgInfoTable info = { \
+ layout : { payload : {ptrs,nptrs} }, \
+ STD_INFO(type), \
+ INIT_ENTRY(entry) \
+ }
+
+/* special selector-thunk info table ---------------------------------------*/
+
+#define \
+INFO_TABLE_SELECTOR(info, entry, offset, info_class, \
+ entry_class, prof_descr, prof_type) \
+ entry_class(entry); \
+ info_class StgInfoTable info = { \
+ layout : { selector_offset : offset }, \
+ STD_INFO(THUNK_SELECTOR), \
+ INIT_ENTRY(entry) \
+ }
+
+/* constructor info table --------------------------------------------------*/
+
+#define \
+INFO_TABLE_CONSTR(info, entry, ptrs, nptrs, tag_,type_,info_class, \
+ entry_class, prof_descr, prof_type) \
+ entry_class(entry); \
+ info_class StgInfoTable info = { \
+ layout : { payload : {ptrs,nptrs} }, \
+ srt_len : tag_, \
+ type : type_, \
+ flags : FLAGS_##type_, \
+ INIT_ENTRY(entry) \
+ }
+
+#define constrTag(con) (get_itbl(con)->srt_len)
+
+/* return-vectors ----------------------------------------------------------*/
+
+/* vectored-return info tables have the vector slammed up against the
+ * start of the info table.
+ *
+ * A vectored-return address always has an SRT and a bitmap-style
+ * layout field, so we only need one macro for these.
+ */
+
+typedef struct {
+ StgFunPtr vec[2];
+ StgInfoTable i;
+} vec_info_2;
+
+typedef struct {
+ StgFunPtr vec[3];
+ StgInfoTable i;
+} vec_info_3;
+
+typedef struct {
+ StgFunPtr vec[4];
+ StgInfoTable i;
+} vec_info_4;
+
+typedef struct {
+ StgFunPtr vec[5];
+ StgInfoTable i;
+} vec_info_5;
+
+typedef struct {
+ StgFunPtr vec[6];
+ StgInfoTable i;
+} vec_info_6;
+
+typedef struct {
+ StgFunPtr vec[7];
+ StgInfoTable i;
+} vec_info_7;
+
+typedef struct {
+ StgFunPtr vec[8];
+ StgInfoTable i;
+} vec_info_8;
+
+#define VEC_INFO_TABLE(bitmap_,srt_,srt_off_,srt_len_,type) \
+ i : { \
+ layout : { bitmap : (StgNat32)bitmap_ }, \
+ SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ }
+
+/* For polymorphic activation records, we need both a direct return
+ * address and a return vector:
+ */
+
+#ifdef USE_MINIINTERPRETER
+typedef StgInfoTable StgPolyInfoTable;
+#define POLY_VEC(nm) \
+ { \
+ (F_) nm##_0_entry, \
+ (F_) nm##_1_entry, \
+ (F_) nm##_2_entry, \
+ (F_) nm##_3_entry, \
+ (F_) nm##_4_entry, \
+ (F_) nm##_5_entry, \
+ (F_) nm##_6_entry, \
+ (F_) nm##_7_entry \
+ }
+#define VEC_POLY_INFO_TABLE(nm,bitmap_,srt_,srt_off_,srt_len_,type) \
+ StgFunPtr nm##_vec[8] = POLY_VEC(nm); \
+ const StgInfoTable nm##_info = { \
+ layout : { bitmap : (StgNat32)bitmap_ }, \
+ SRT_INFO(type,srt_,srt_off_,srt_len_), \
+ vector : &nm##_vec, \
+ INIT_ENTRY(nm##_entry) \
+ }
+#else
+typedef vec_info_8 StgPolyInfoTable;
+#define POLY_VEC(nm) \
+ { \
+ (F_) nm##_7_entry, \
+ (F_) nm##_6_entry, \
+ (F_) nm##_5_entry, \
+ (F_) nm##_4_entry, \
+ (F_) nm##_3_entry, \
+ (F_) nm##_2_entry, \
+ (F_) nm##_1_entry, \
+ (F_) nm##_0_entry \
+ }
+#define VEC_POLY_INFO_TABLE(nm,bitmap_,srt_,srt_off_,srt_len_,type) \
+ const vec_info_8 nm##_info = { \
+ vec : POLY_VEC(nm), \
+ i : { \
+ layout : { bitmap : (StgNat32)bitmap_ }, \
+ SRT_INFO(type,srt_,srt_off_,srt_len_), \
+ INIT_ENTRY(nm##_entry) \
+ } \
+ }
+#endif
+
+#define SRT(lbl) \
+ static const StgSRT lbl = {
+
+#define BITMAP(lbl,size) \
+ static const StgLargeBitmap lbl = { size, {
+
+#endif /* INFOMACROS_H */
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: InfoTables.h,v 1.2 1998/12/02 13:21:10 simonm Exp $
+ *
+ * Info Tables
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef INFOTABLES_H
+#define INFOTABLES_H
+
+/* -----------------------------------------------------------------------------
+ Profiling info
+ -------------------------------------------------------------------------- */
+
+#ifdef PROFILING
+
+#define PROF_INFO_WORDS n
+
+typedef struct {
+ /* nothing yet */
+} StgProfInfo;
+
+#else /* !PROFILING */
+
+#define PROF_INFO_WORDS 0
+
+typedef struct {
+ /* empty */
+} StgProfInfo;
+
+#endif /* PROFILING */
+
+/* -----------------------------------------------------------------------------
+ Parallelism info
+ -------------------------------------------------------------------------- */
+
+#ifdef PAR
+
+#define PAR_INFO_WORDS 0
+
+typedef struct {
+ /* empty */
+} StgParInfo;
+
+#else /* !PAR */
+
+#define PAR_INFO_WORDS 0
+
+typedef struct {
+ /* empty */
+} StgParInfo;
+
+#endif /* PAR */
+
+/* -----------------------------------------------------------------------------
+ Debugging info
+ -------------------------------------------------------------------------- */
+
+#ifdef DEBUG_CLOSURE
+
+#define DEBUG_INFO_WORDS n
+
+typedef struct {
+ ... whatever ...
+} StgDebugInfo;
+
+#else /* !DEBUG_CLOSURE */
+
+#define DEBUG_INFO_WORDS 0
+
+typedef struct {
+ /* empty */
+} StgDebugInfo;
+
+#endif /* DEBUG_CLOSURE */
+
+/* -----------------------------------------------------------------------------
+ Closure Types
+
+ If you add or delete any closure types, don't forget to update
+ ClosureTypes.h for the native code generator. This is a temporary
+ measure (I hope).
+ -------------------------------------------------------------------------- */
+
+typedef enum {
+
+ INVALID_OBJECT /* Object tag 0 raises an internal error */
+ , CONSTR
+ /* CONSTR_p_np */
+ , CONSTR_INTLIKE
+ , CONSTR_CHARLIKE
+ , CONSTR_STATIC
+ , CONSTR_NOCAF_STATIC
+
+ , FUN
+ , FUN_STATIC
+
+ , THUNK
+ /* THUNK_p_np */
+ , THUNK_STATIC
+ , THUNK_SELECTOR
+
+ , BCO
+ , AP_UPD
+
+ , PAP /* should be called AP_NUPD */
+
+ , IND
+ , IND_OLDGEN
+ , IND_PERM
+ , IND_OLDGEN_PERM
+ , IND_STATIC
+
+ , CAF_UNENTERED
+ , CAF_ENTERED
+ , CAF_BLACKHOLE
+
+ , RET_BCO
+ , RET_SMALL
+ , RET_VEC_SMALL
+ , RET_BIG
+ , RET_VEC_BIG
+ , RET_DYN
+ , UPDATE_FRAME
+ , CATCH_FRAME
+ , STOP_FRAME
+ , SEQ_FRAME
+
+ , BLACKHOLE
+ , MVAR
+
+ , ARR_WORDS
+ , ARR_PTRS
+
+ , MUT_ARR_WORDS
+ , MUT_ARR_PTRS
+ , MUT_ARR_PTRS_FROZEN
+ , MUT_VAR
+
+ , WEAK
+ , FOREIGN
+
+ , TSO
+
+ , BLOCKED_FETCH
+ , FETCH_ME
+
+ , EVACUATED
+
+ , N_CLOSURE_TYPES /* number of distinct closure types */
+
+} StgClosureType;
+
+/* The type flags provide quick access to certain properties of a closure. */
+
+#define _HNF (1<<0) /* head normal form? */
+#define _BTM (1<<1) /* bitmap-style layout? */
+#define _NS (1<<2) /* non-sparkable */
+#define _STA (1<<3) /* static? */
+#define _THU (1<<4) /* thunk? */
+#define _MUT (1<<5) /* mutable? */
+#define _UPT (1<<6) /* unpointed? */
+#define _SRT (1<<7) /* has an SRT? */
+
+#define isSTATIC(flags) ((flags)&_STA)
+#define closure_STATIC(closure) ( get_itbl(closure)->flags & _STA)
+#define closure_SHOULD_SPARK(closure) (!(get_itbl(closure)->flags & _NS))
+#define closure_UNPOINTED(closure) ( get_itbl(closure)->flags & _UPT)
+
+/* HNF BTM NS STA THU MUT UPT SRT */
+
+#define FLAGS_CONSTR (_HNF| _NS )
+#define FLAGS_CONSTR_STATIC (_HNF| _NS|_STA )
+#define FLAGS_CONSTR_NOCAF_STATIC (_HNF| _NS|_STA )
+#define FLAGS_FUN (_HNF| _NS| _SRT )
+#define FLAGS_FUN_STATIC (_HNF| _NS|_STA| _SRT )
+#define FLAGS_THUNK ( _BTM| _THU| _SRT )
+#define FLAGS_THUNK_STATIC ( _BTM| _STA|_THU| _SRT )
+#define FLAGS_THUNK_SELECTOR ( _BTM| _THU| _SRT )
+#define FLAGS_BCO (_HNF| _NS )
+#define FLAGS_CAF_UNENTERED 0 /* Do we still use these? */
+#define FLAGS_CAF_ENTERED 0
+#define FLAGS_CAF_BLACKHOLE ( _BTM|_NS| _UPT )
+#define FLAGS_AP_UPD ( _BTM| _THU )
+#define FLAGS_PAP (_HNF| _NS )
+#define FLAGS_IND 0
+#define FLAGS_IND_OLDGEN 0
+#define FLAGS_IND_PERM 0
+#define FLAGS_IND_OLDGEN_PERM 0
+#define FLAGS_IND_STATIC ( _STA )
+#define FLAGS_EVACUATED 0
+#define FLAGS_ARR_WORDS (_HNF| _NS| _UPT )
+#define FLAGS_MUT_ARR_WORDS (_HNF| _NS| _MUT|_UPT )
+#define FLAGS_ARR_PTRS (_HNF| _NS| _UPT )
+#define FLAGS_MUT_ARR_PTRS (_HNF| _NS| _MUT|_UPT )
+#define FLAGS_MUT_ARR_PTRS_FROZEN (_HNF| _NS| _MUT|_UPT )
+#define FLAGS_MUT_VAR (_HNF| _NS| _MUT|_UPT )
+#define FLAGS_FOREIGN (_HNF| _NS| _UPT )
+#define FLAGS_WEAK (_HNF| _NS| _UPT )
+#define FLAGS_BLACKHOLE ( _BTM|_NS| _UPT )
+#define FLAGS_MVAR (_HNF| _NS| _UPT )
+#define FLAGS_FETCH_ME (_HNF| _NS )
+#define FLAGS_TSO 0
+#define FLAGS_RET_BCO ( _BTM )
+#define FLAGS_RET_SMALL ( _BTM| _SRT)
+#define FLAGS_RET_VEC_SMALL ( _BTM| _SRT)
+#define FLAGS_RET_BIG ( _SRT)
+#define FLAGS_RET_VEC_BIG ( _SRT)
+#define FLAGS_RET_DYN ( _SRT)
+#define FLAGS_CATCH_FRAME 0
+#define FLAGS_STOP_FRAME 0
+#define FLAGS_SEQ_FRAME 0
+#define FLAGS_UPDATE_FRAME 0
+
+/* -----------------------------------------------------------------------------
+ Info Tables
+ -------------------------------------------------------------------------- */
+
+/* A large bitmap. Small 32-bit ones live in the info table, but sometimes
+ * 32 bits isn't enough and we have to generate a larger one.
+ */
+
+typedef struct {
+ StgNat32 size;
+ StgNat32 bitmap[0];
+} StgLargeBitmap;
+
+/*
+ * Stuff describing the closure layout. Well, actually, it might
+ * contain the selector index for a THUNK_SELECTOR.
+ */
+
+typedef union {
+
+ StgNat32 bitmap; /* bit pattern, 1 = pointer, 0 = non-pointer */
+
+ StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */
+
+ struct {
+ StgNat16 ptrs; /* number of pointers */
+ StgNat16 nptrs; /* number of non-pointers */
+ } payload;
+
+ StgNat32 selector_offset; /* used in THUNK_SELECTORs */
+
+} StgClosureInfo;
+
+/*
+ * Info tables. All info tables are the same type, to simplify code
+ * generation. However, the mangler removes any unused SRT fields
+ * from the asm to save space (convention: if srt_len is zero, or the
+ * type is a CONSTR_ type, then the SRT field isn't present.
+ */
+
+typedef StgClosure* StgSRT[];
+
+typedef struct _StgInfoTable {
+ StgSRT *srt; /* pointer to the SRT table */
+ StgParInfo par;
+ StgProfInfo prof;
+ StgDebugInfo debug;
+ StgClosureInfo layout; /* closure layout info */
+ StgNat8 flags; /* } */
+ StgClosureType type : 8; /* } These 4 elements fit into 32 bits */
+ StgNat16 srt_len; /* } */
+#if USE_MINIINTERPRETER
+ StgFunPtr (*vector)[];
+ StgFunPtr entry;
+#else
+ StgCode code[0];
+#endif
+} StgInfoTable;
+
+#endif /* INFOTABLES_H */
+++ /dev/null
-/***********************************************************************
-* Low Level Communications Header (LLC.h) *
-* Contains the definitions used by the Low-level Communications *
-* module of the GUM Haskell runtime environment. *
-* Based on the Graph for PVM implementation. *
-* Phil Trinder, Glasgow University, 13th Dec 1994 *
-************************************************************************/
-
-#ifndef __LLC_H
-#define __LLC_H
-#ifdef PAR
-
-#include "rtsdefs.h"
-
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#endif
-
-#ifdef HAVE_TIME_H
-#include <time.h>
-#endif
-
-#include "PEOpCodes.h"
-#define safemalloc malloc
-#include "pvm3.h"
-
-#define ANY_TASK (-1) /* receive messages from any task */
-#define ANY_GLOBAL_TASK ANY_TASK
-#define ANY_OPCODE (-1) /* receive any opcode */
-#define ALL_GROUP (-1) /* wait for barrier from every group member */
-
-#define PEGROUP "PE"
-
-#define MGRGROUP "MGR"
-#define PECTLGROUP "PECTL"
-
-
-#define PETASK "PE"
-
-#define sync(gp,op) do { broadcast(gp,op); pvm_barrier(gp,ALL_GROUP); } while(0)
-#define broadcast(gp,op) do { pvm_initsend(PvmDataDefault); pvm_bcast(gp,op); } while(0)
-#define checkComms(c,s) do {if((c)<0) { pvm_perror(s); EXIT(EXIT_FAILURE); }} while(0)
-
-#define _my_gtid pvm_mytid()
-#define GetPacket() pvm_recv(ANY_TASK,ANY_OPCODE)
-#define PacketsWaiting() (pvm_probe(ANY_TASK,ANY_OPCODE) != 0)
-
-#define HandleException(p) (*ExceptionHandler)(p)
-#define _SetMyExceptionHandler(f) ExceptionHandler = f
-
-#define SPARK_THREAD_DESCRIPTOR 1
-#define GLOBAL_THREAD_DESCRIPTOR 2
-
-#define _extract_jump_field(v) (v)
-
-#define MAX_DATA_WORDS_IN_PACKET 1024
-
-#define PutArg1(a) pvm_pklong(&(a),1,1)
-#define PutArg2(a) pvm_pklong(&(a),1,1)
-#define PutArgN(n,a) pvm_pklong(&(a),1,1)
-#define PutArgs(b,n) pvm_pklong(b,n,1)
-
-#define PutLit(l) { int a = l; PutArgN(?,a); }
-
-#define GetArg1(a) pvm_upklong(&(a),1,1)
-#define GetArg2(a) pvm_upklong(&(a),1,1)
-#define GetArgN(n,a) pvm_upklong(&(a),1,1)
-#define GetArgs(b,n) pvm_upklong(b,n,1)
-
-void SendOp PROTO((OPCODE,GLOBAL_TASK_ID)),
- SendOp1 PROTO((OPCODE,GLOBAL_TASK_ID,StgWord)),
- SendOp2 PROTO((OPCODE,GLOBAL_TASK_ID,StgWord,StgWord)),
- SendOpV PROTO((OPCODE,GLOBAL_TASK_ID,int,...)),
- SendOpN PROTO((OPCODE,GLOBAL_TASK_ID,int,StgWord *)),
- SendOpNV PROTO((OPCODE,GLOBAL_TASK_ID,int,StgWord*,int,...));
-
-char *GetOpName PROTO((unsigned op));
-void NullException(STG_NO_ARGS);
-
-PACKET WaitForPEOp PROTO((OPCODE op, GLOBAL_TASK_ID who));
-OPCODE Opcode PROTO((PACKET p));
-GLOBAL_TASK_ID Sender_Task PROTO((PACKET p));
-void get_opcode_and_sender PROTO((PACKET p, OPCODE *popcode, GLOBAL_TASK_ID *psender_id));
-GLOBAL_TASK_ID *PEStartUp PROTO((unsigned nPEs));
-void PEShutDown(STG_NO_ARGS);
-
-extern void (*ExceptionHandler) PROTO((PACKET));
-
-#endif /*PAR */
-#endif /*defined __LLC_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: MachDeps.h,v 1.2 1998/12/02 13:21:12 simonm Exp $
+ *
+ * (c) The GRASP/AQUA Project, Glasgow University, 1998
+ *
+ * Definitions that characterise machine specific properties of basic
+ * Stg types provided as unboxed types (mirrors the typedefs in
+ * StgTypes.)
+ *
+ * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!
+ * ---------------------------------------------------------------------------*/
+
+#ifndef MACHDEPS_H
+#define MACHDEPS_H
+
+#include "config.h"
+
+#define CHAR_SIZE_IN_BYTES 1
+#define ADDR_SIZE_IN_BYTES SIZEOF_VOID_P
+#define INT_SIZE_IN_BYTES SIZEOF_LONG
+#define WORD_SIZE_IN_BYTES SIZEOF_LONG
+
+#if SIZEOF_DOUBLE == SIZEOF_VOID_P
+#define FLOAT_SIZE_IN_BYTES SIZEOF_DOUBLE
+#define DOUBLE_SIZE_IN_BYTES SIZEOF_DOUBLE
+#else
+#define FLOAT_SIZE_IN_BYTES SIZEOF_FLOAT
+#define DOUBLE_SIZE_IN_BYTES SIZEOF_DOUBLE
+#endif
+
+#endif
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1998
-%
-\section[MachDeps]{Info/sizes of STG types}
-
-NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!
-
-Definitions that characterise machine specific properties
-of basic Stg types provided as unboxed types (mirrors the typedefs in StgTypes.)
-
-\begin{code}
-#ifndef MACHDEPS_H
-#define MACHDEPS_H
-
-#include "config.h"
-
-#define CHAR_SIZE_IN_BYTES 1
-#define ADDR_SIZE_IN_BYTES SIZEOF_VOID_P
-#define INT_SIZE_IN_BYTES SIZEOF_LONG
-#define WORD_SIZE_IN_BYTES SIZEOF_LONG
-
-#if alpha_TARGET_ARCH
-#define FLOAT_SIZE_IN_BYTES SIZEOF_DOUBLE
-#define DOUBLE_SIZE_IN_BYTES SIZEOF_DOUBLE
-#else
-#define FLOAT_SIZE_IN_BYTES SIZEOF_FLOAT
-#define DOUBLE_SIZE_IN_BYTES SIZEOF_DOUBLE
-#endif
-
-#endif
-\end{code}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: MachRegs.h,v 1.2 1998/12/02 13:21:13 simonm Exp $
+ *
+ * Registers used in STG code. Might or might not correspond to
+ * actual machine registers.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef MACHREGS_H
+#define MACHREGS_H
+
+/* This file is #included into Haskell code in the compiler: #defines
+ * only in here please.
+ */
+
+/* define NO_REGS to omit register declarations - used in RTS C code
+ * that needs all the STG definitions but not the global register
+ * settings.
+ */
+#ifndef NO_REGS
+
+/* ----------------------------------------------------------------------------
+ Caller saves and callee-saves regs.
+
+ Caller-saves regs have to be saved around C-calls made from STG
+ land, so this file defines CALLER_SAVES_<reg> for each <reg> that
+ is designated caller-saves in that machine's C calling convention.
+
+ Additionally, the following macros should be defined when
+
+ CALLER_SAVES_USER one or more of R<n>, F, D
+ are caller-saves.
+
+ CALLER_SAVES_SYSTEM one or more of Sp, Su, SpLim, Hp, HpLim
+ are caller-saves.
+
+ This is so that the callWrapper mechanism knows which kind of
+ wrapper to generate for certain types of C call.
+ -------------------------------------------------------------------------- */
+
+/* -----------------------------------------------------------------------------
+ The DEC Alpha register mapping
+
+ Alpha registers
+ \tr{$9}--\tr{$14} are our ``prize'' callee-save registers.
+ \tr{$15} is the frame pointer, and \tr{$16}--\tr{$21} are argument
+ registers. (These are off-limits.) We can steal some of the \tr{$22}-and-up
+ caller-save registers provided we do the appropriate save/restore stuff.
+
+ \tr{$f2}--\tr{$f9} are some callee-save floating-point registers.
+
+ We cannot use \tr{$23} (aka t9), \tr{$24} (aka t10), \tr{$25} (aka
+ t11), \tr{$27} (aka pv), or \tr{$28} (aka at), because they are
+ occasionally required by the assembler to handle non-primitive
+ instructions (e.g. ldb, remq). Sigh!
+
+ Cheat sheet for GDB:
+
+ GDB here Main map
+ === ==== ========
+ s5 $14 R1
+ t1 $2 R2
+ t2 $3 R3
+ t3 $4 R4
+ t4 $5 R5
+ t5 $6 R6
+ t6 $7 R7
+ t7 $8 R8
+ s0 $9 Sp
+ s1 $10 Su
+ s2 $11 SpLim
+ s3 $12 Hp
+ s4 $13 HpLim
+ t8 $22 NCG_reserved
+ t12 $27 NCG_reserved
+ -------------------------------------------------------------------------- */
+
+#if defined(alpha_TARGET_ARCH)
+# define REG(x) __asm__("$" #x)
+
+# define CALLER_SAVES_R2
+# define CALLER_SAVES_R3
+# define CALLER_SAVES_R4
+# define CALLER_SAVES_R5
+# define CALLER_SAVES_R6
+# define CALLER_SAVES_R7
+# define CALLER_SAVES_R8
+
+# define CALLER_SAVES_USER
+
+# define REG_R1 14
+# define REG_R2 2
+# define REG_R3 3
+# define REG_R4 4
+# define REG_R5 5
+# define REG_R6 6
+# define REG_R7 7
+# define REG_R8 8
+
+# define REG_F1 f2
+# define REG_F2 f3
+# define REG_F3 f4
+# define REG_F4 f5
+
+# define REG_D1 f6
+# define REG_D2 f7
+
+# define REG_Sp 9
+# define REG_Su 10
+# define REG_SpLim 11
+
+# define REG_Hp 12
+# define REG_HpLim 13
+
+# define NCG_Reserved_I1 22
+# define NCG_Reserved_I2 27
+# define NCG_Reserved_F1 f29
+# define NCG_Reserved_F2 f30
+
+#endif /* alpha_TARGET_ARCH */
+
+/* -----------------------------------------------------------------------------
+ The HP-PA register mapping
+
+ We cater for HP-PA 1.1.
+
+ \tr{%r0}--\tr{%r1} are special.
+ \tr{%r2} is the return pointer.
+ \tr{%r3} is the frame pointer.
+ \tr{%r4}--\tr{%r18} are callee-save registers.
+ \tr{%r19} is a linkage table register for HPUX 8.0 shared libraries.
+ \tr{%r20}--\tr{%r22} are caller-save registers.
+ \tr{%r23}--\tr{%r26} are parameter registers.
+ \tr{%r27} is a global data pointer.
+ \tr{%r28}--\tr{%r29} are temporaries.
+ \tr{%r30} is the stack pointer.
+ \tr{%r31} is a temporary.
+
+ \tr{%fr12}--\tr{%fr15} are some callee-save floating-point registers.
+ \tr{%fr8}--\tr{%fr11} are some available caller-save fl-pt registers.
+ -------------------------------------------------------------------------- */
+
+#if hppa1_1_TARGET_ARCH
+
+#define REG(x) __asm__("%" #x)
+
+#define REG_R1 r11
+#define REG_R2 r12
+#define REG_R3 r13
+#define REG_R4 r14
+#define REG_R5 r15
+#define REG_R6 r16
+#define REG_R7 r17
+#define REG_R8 r18
+
+#define REG_F1 fr12
+#define REG_F2 fr12R
+#define REG_F3 fr13
+#define REG_F4 fr13R
+
+#define REG_D1 fr20 /* L & R */
+#define REG_D2 fr21 /* L & R */
+
+#define REG_Sp r4
+#define REG_Su r5
+#define REG_SpLim r6
+
+#define REG_Hp r7
+#define REG_HpLim r8
+
+#define NCG_Reserved_I1 r28
+#define NCG_Reserved_I2 r29
+#define NCG_Reserved_F1 fr8
+#define NCG_Reserved_F2 fr8R
+#define NCG_Reserved_D1 fr10
+#define NCG_Reserved_D2 fr11
+
+#endif /* hppa */
+
+/* -----------------------------------------------------------------------------
+ The Intel iX86 register mapping
+
+ Ok, we've only got 6 general purpose registers, a frame pointer and a
+ stack pointer. \tr{%eax} and \tr{%edx} are return values from C functions,
+ hence they get trashed across ccalls and are caller saves. \tr{%ebx},
+ \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.
+
+ Reg STG-Reg
+ ---------------
+ ebx Base
+ ebp Sp
+ esi R1
+ edi Hp
+
+ Leaving Su, SpLim, and HpLim out of the picture.
+ -------------------------------------------------------------------------- */
+
+
+#if i386_TARGET_ARCH
+
+#define REG(x) __asm__("%" #x)
+
+#define REG_Base ebx
+#define REG_Sp ebp
+
+#if STOLEN_X86_REGS >= 3
+# define REG_R1 esi
+#endif
+
+#if STOLEN_X86_REGS >= 4
+# define REG_Hp edi
+#endif
+
+#define MAX_REAL_VANILLA_REG 1 /* always, since it defines the entry conv */
+#define MAX_REAL_FLOAT_REG 0
+#define MAX_REAL_DOUBLE_REG 0
+
+#endif /* iX86 */
+
+/* -----------------------------------------------------------------------------
+ The Motorola 680x0 register mapping
+
+ A Sun3 (mc680x0) has eight address registers, \tr{a0} to \tr{a7}, and
+ eight data registers, \tr{d0} to \tr{d7}. Address operations have to
+ be done through address registers; data registers are used for
+ comparison values and data.
+
+ Here's the register-usage picture for m68k boxes with GCC.
+
+ \begin{tabular}{ll}
+ a0 & used directly by GCC \\
+ a1 & used directly by GCC \\
+ \\
+ a2..a5 & callee-saved: available for STG registers \\
+ & (a5 may be special, ``global'' register for PIC?) \\
+ \\
+ a6 & C-stack frame pointer \\
+ a7 & C-stack pointer \\
+ \\
+ d0 & used directly by GCC \\
+ d1 & used directly by GCC \\
+ d2 & really needed for local optimisation by GCC \\
+ \\
+ d3..d7 & callee-saved: available for STG registers
+ \\
+ fp0 & call-clobbered \\
+ fp1 & call-clobbered \\
+ fp2..fp7 & callee-saved: available for STG registers
+ \end{tabular}
+ -------------------------------------------------------------------------- */
+
+#if m68k_TARGET_ARCH
+
+#define REG(x) __asm__(#x)
+
+#define REG_Base a2
+
+#define REG_Sp a3
+#define REG_Su a4
+#define REG_SpLim d3
+
+#define REG_Hp d4
+#define REG_HpLim d5
+
+#define REG_R1 a5
+#define REG_R2 d6
+#define MAX_REAL_VANILLA_REG 2
+
+#define REG_Ret d7
+
+#define REG_F1 fp2
+#define REG_F2 fp3
+#define REG_F3 fp4
+#define REG_F4 fp5
+
+#define REG_D1 fp6
+#define REG_D2 fp7
+
+#endif /* m68k */
+
+/* -----------------------------------------------------------------------------
+ The DECstation (MIPS) register mapping
+
+ Here's at least some simple stuff about registers on a MIPS.
+
+ \tr{s0}--\tr{s7} are callee-save integer registers; they are our
+ ``prize'' stolen registers. There is also a wad of callee-save
+ floating-point registers, \tr{$f20}--\tr{$f31}; we'll use some of
+ those.
+
+ \tr{t0}--\tr{t9} are caller-save (``temporary?'') integer registers.
+ We can steal some, but we might have to save/restore around ccalls.
+ -------------------------------------------------------------------------- */
+
+#if mipsel_TARGET_ARCH || mipseb_TARGET_ARCH
+
+#define REG(x) __asm__("$" #x)
+
+#define CALLER_SAVES_R1
+#define CALLER_SAVES_R2
+#define CALLER_SAVES_R3
+#define CALLER_SAVES_R4
+#define CALLER_SAVES_R5
+#define CALLER_SAVES_R6
+#define CALLER_SAVES_R7
+#define CALLER_SAVES_R8
+
+#define CALLER_SAVES_USER
+
+#define REG_R1 9
+#define REG_R2 10
+#define REG_R3 11
+#define REG_R4 12
+#define REG_R5 13
+#define REG_R6 14
+#define REG_R7 15
+#define REG_R8 24
+
+#define REG_F1 f20
+#define REG_F2 f22
+#define REG_F3 f24
+#define REG_F4 f26
+
+#define REG_D1 f28
+#define REG_D2 f30
+
+#define REG_Sp 16
+#define REG_Su 17
+#define REG_SpLim 18
+
+#define REG_Hp 19
+#define REG_HpLim 20
+
+#endif /* mipse[lb] */
+
+/* -----------------------------------------------------------------------------
+ The PowerPC register mapping
+
+ 0 system glue? (caller-save, volatile)
+ 1 SP (callee-save, non-volatile)
+ 2 RTOC (callee-save, non-volatile)
+ 3-10 args/return (caller-save, volatile)
+ 11,12 system glue? (caller-save, volatile)
+ 13-31 (callee-save, non-volatile)
+
+ f0 (caller-save, volatile)
+ f1-f13 args/return (caller-save, volatile)
+ f14-f31 (callee-save, non-volatile)
+
+ \tr{13}--\tr{31} are wonderful callee-save registers.
+ \tr{0}--\tr{12} are caller-save registers.
+
+ \tr{%f14}--\tr{%f31} are callee-save floating-point registers.
+
+ I think we can do the Whole Business with callee-save registers only!
+ -------------------------------------------------------------------------- */
+
+#if powerpc_TARGET_ARCH || rs6000_TARGET_ARCH
+
+#define REG(x) __asm__(#x)
+
+#define REG_R1 r14
+#define REG_R2 r15
+#define REG_R3 r16
+#define REG_R4 r17
+#define REG_R5 r18
+#define REG_R6 r19
+#define REG_R7 r20
+#define REG_R8 r21
+
+#define REG_F1 fr14
+#define REG_F2 fr15
+#define REG_F3 fr16
+#define REG_F4 fr17
+
+#define REG_D1 fr18
+#define REG_D2 fr19
+
+#define REG_Sp r22
+#define REG_Su r23
+#define REG_SpLim r24
+
+#define REG_Hp r25
+#define REG_HpLim r26
+
+#endif /* powerpc */
+
+/* -----------------------------------------------------------------------------
+ The Sun SPARC register mapping
+
+ The SPARC register (window) story: Remember, within the Haskell
+ Threaded World, we essentially ``shut down'' the register-window
+ mechanism---the window doesn't move at all while in this World. It
+ *does* move, of course, if we call out to arbitrary~C...
+
+ The %i, %l, and %o registers (8 each) are the input, local, and
+ output registers visible in one register window. The 8 %g (global)
+ registers are visible all the time.
+
+ %o0..%o7 not available; can be zapped by callee
+ (%o6 is C-stack ptr; %o7 hold ret addrs)
+ %i0..%i7 available (except %i6 is used as frame ptr)
+ (and %i7 tends to have ret-addr-ish things)
+ %l0..%l7 available
+ %g0..%g4 not available; prone to stomping by division, etc.
+ %g5..%g7 not available; reserved for the OS
+
+ Note: %g3 is *definitely* clobbered in the builtin divide code (and
+ our save/restore machinery is NOT GOOD ENOUGH for that); discretion
+ being the better part of valor, we also don't take %g4.
+ -------------------------------------------------------------------------- */
+
+#if sparc_TARGET_ARCH
+
+#define REG(x) __asm__("%" #x)
+
+#define CALLER_SAVES_USER
+
+#define CALLER_SAVES_F1
+#define CALLER_SAVES_F2
+#define CALLER_SAVES_F3
+#define CALLER_SAVES_F4
+#define CALLER_SAVES_D1
+#define CALLER_SAVES_D2
+
+#define REG_R1 l1
+#define REG_R2 l2
+#define REG_R3 l3
+#define REG_R4 l4
+#define REG_R5 l5
+#define REG_R6 l6
+#define REG_R7 l7
+#define REG_R8 i5
+
+#define REG_F1 f2
+#define REG_F2 f3
+#define REG_F3 f4
+#define REG_F4 f5
+#define REG_D1 f6
+#define REG_D2 f8
+
+#define REG_Sp i0
+#define REG_Su i1
+#define REG_SpLim i2
+
+#define REG_Hp i3
+#define REG_HpLim i4
+
+#define NCG_Reserved_I1 g1
+#define NCG_Reserved_I2 g2
+#define NCG_Reserved_F1 f14
+#define NCG_Reserved_F2 f15
+#define NCG_Reserved_D1 f16
+#define NCG_Reserved_D2 f18
+
+#endif /* sparc */
+
+/* These constants define how many stg registers are *actually* in
+ * registers: the code generator uses this information to avoid
+ * generating code to load/store registers which are really offsets
+ * from BaseReg.
+ *
+ * Registers above these values might still be used, for instance to
+ * communicate with PrimOps and RTS functions.
+ */
+
+#ifndef MAX_REAL_VANILLA_REG
+#define MAX_REAL_VANILLA_REG 8
+#endif
+
+#ifndef MAX_REAL_FLOAT_REG
+#define MAX_REAL_FLOAT_REG 4
+#endif
+
+#ifndef MAX_REAL_DOUBLE_REG
+#define MAX_REAL_DOUBLE_REG 2
+#endif
+
+#endif /* NO_REGS */
+
+#endif /* MACHREGS_H */
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1994
-%
-\section[MachRegs-decls]{Architecture-specific register mappings}
-
-NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!
-
-\begin{code}
-#ifndef MACHREGS_H
-#define MACHREGS_H
-
-#if defined(__STG_GCC_REGS__) || defined(COMPILING_NCG)
-
-#include "StgMachDeps.h"
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[register-tricks]{Things to watch out for}
-%* *
-%************************************************************************
-
-Here we collect random pieces of lore about register mapping. It is a
-delicate topic.
-
-The best place to get a blow-by-blow account of the register story for
-a particular machine architecture is in the ``main mapping'' section
-(\sectionref{main-mapping-StgRegs}).
-
-%************************************************************************
-%* *
-\subsubsection{Using callee-saves registers}
-%* *
-%************************************************************************
-
-Mostly we map variables to callee-saves registers. These are
-best---the only thing you have to worry about is that whoever starts
-up a wadge of code that uses them does, in fact, save them! (i.e.,
-observes the callee-save convention).
-
-To see what GCC thinks is a callee-save register: Look at the
-\tr{FIXED_REGISTERS} and \tr{CALL_USED_REGISTERS} tables for an
-architecture. A register that is marked as \tr{0} in both tables is
-callee-save.
-
-Of course, whatever you do, it isn't wise to grab {\em all} available
-registers, because then GCC has nothing to use for temporaries, etc.
-
-%************************************************************************
-%* *
-\subsubsection{Using caller-saves registers}
-%* *
-%************************************************************************
-
-Using callee-saves registers only isn't really good enough. For
-example, on a SPARC, {\em none} of the floating-point registers are
-callee-save, so it's caller-save registers or terrible performance...
-Also, modern RISC architectures normally offer about eight callee-save
-registers; we'd really rather steal more machine registers.
-
-We need to be extra careful with stolen caller-save registers. We
-don't want to save them {\em all} across every call to a C function
-(specifically @ccall@s). Here is table of what STG registers {\em
-must} be saved across @ccalls@ if they are held in caller-save
-registers:
-\begin{verbatim}
-SpA, SuA, must be saved *every time* if
-SpB, SuB, Hp, HpLim in a caller-save reg (to be avoided)
-
-TagReg Usually won't be in a register, unless we have a
- register glut. In any event, it needn't be saved;
- it isn't live at ccalls.
- CLAIM: it isn't alive during other PrimOps either!
-
-R1 (Node), R2 ... R8 must be saved if in a caller-save reg *and*
-FltReg1 .. n its value survives over the ccall [rare] (the
-DblReg1 .. n code-generator knows this...)
-LngReg1 .. n
-
-BaseReg, better choices for caller-saves regs than the
-StkStub,... other system regs, since they only need to be
- restored, and never saved. (For PAR, BaseReg
- is not fixed, and must be saved.)
-\end{verbatim}
-
-So: the compiler emits suitable \tr{CALLER_SAVE_<reg-name>} macros
-before a ccall, and corresponding \tr{...RESTORE...}s afterwards. It
-{\em always} emits them for @BaseReg@ and friends; it emits them only
-for the known-to-be-live @R1@, ..., \tr{DoubleRegN} and friends.
-
-Notice that PrimOps like arbitrary-precision arithmetic can trigger
-GC, so everything gets saved on the stack safely.
-
-Special care needs to be taken for ``invisible'' calls to C functions.
-In particular, we freely generate calls to \tr{{PK,UNPK}_{FLT,DBL}},
-to construct and deconstruct floats and doubles. These {\em must} be
-inlined by @gcc@, because otherwise they trash floating point
-registers. So you have to compile with at least @gcc -O@ if you want
-registerisation.
-
-Morals: We try {\em very hard} to keep @BaseReg@ and friends in
-callee-save registers. If we have callee-save registers available for
-@R1@ (@Node@), etc., we use them on the more-heavily-used
-``low-numbered'' registers. As the likelihood of having to do a
-SAVE/RESTORE for @R6@ (for example) is near zero, it's OK to assign it
-a caller-save register.
-
-On machines with register-based calling conventions, never try to steal
-argument or return registers, for two reasons: (1) it breaks the
-callWrapper approach (saves and restores have to be done inline), and
-(2) it means that you have to be extremely careful about setting up
-arguments for calls (and may in fact have to introduce temporaries to
-handle simultaneous assignments to/from the argument registers).
-
-%************************************************************************
-%* *
-\subsubsection[mapping-alpha]{The DEC Alpha register mapping}
-%* *
-%************************************************************************
-
-Alpha registers
-\tr{$9}--\tr{$14} are our ``prize'' callee-save registers.
-\tr{$15} is the frame pointer, and \tr{$16}--\tr{$21} are argument
-registers. (These are off-limits.) We can steal some of the \tr{$22}-and-up
-caller-save registers provided we do the appropriate save/restore stuff.
-
-\tr{$f2}--\tr{$f9} are some callee-save floating-point registers.
-
-We cannot use \tr{$23} (aka t9), \tr{$24} (aka t10), \tr{$25} (aka
-t11), \tr{$27} (aka pv), or \tr{$28} (aka at), because they are
-occasionally required by the assembler to handle non-primitive
-instructions (e.g. ldb, remq). Sigh!
-
-Cheat sheet for GDB:
-\begin{verbatim}
-GDB here Main map
-=== ==== ========
-t0 $1 R1
-t1 $2 R2
-t2 $3 R3
-t3 $4 R4
-t4 $5 R5
-t5 $6 R6
-t6 $7 R7
-t7 $8 R8
-s0 $9 SpA
-s1 $10 SuA
-s2 $11 SpB
-s3 $12 SuB
-s4 $13 Hp
-s5 $14 HpLim
-fp $15 RetReg
-t8 $22 NCG_reserved
-t12 $27 NCG_reserved
-\end{verbatim}
-
-\begin{code}
-
-#if defined(alpha_TARGET_ARCH)
-# define REG(x) __asm__("$" #x)
-
-# if defined(MARK_REG_MAP)
-# define REG_Mark 9
-# define REG_MStack 10
-# define REG_MRoot 11
-# define REG_BitArray 12
-# define REG_HeapBase 13
-# define REG_HeapLim 14
-# else
-# if defined(SCAN_REG_MAP)
-# define REG_Scan 9
-# define REG_New 10
-# define REG_LinkLim 11
-# else
-# if defined(SCAV_REG_MAP)
-# define REG_Scav 9
-# define REG_ToHp 10
-# if defined(GCap) || defined(GCgn)
-# define REG_OldGen 11
-# endif /* GCap || GCgn */
-
-# else /* default: MAIN_REG_MAP */
-/* callee saves */
-# define CALLEE_SAVES_FltReg1
-# define CALLEE_SAVES_FltReg2
-# define CALLEE_SAVES_FltReg3
-# define CALLEE_SAVES_FltReg4
-# define CALLEE_SAVES_DblReg1
-# define CALLEE_SAVES_DblReg2
-# define CALLEE_SAVES_SpA
-# define CALLEE_SAVES_SuA
-# define CALLEE_SAVES_SpB
-# define CALLEE_SAVES_SuB
-# define CALLEE_SAVES_Hp
-# define CALLEE_SAVES_HpLim
-
-# define CALLEE_SAVES_Ret
-
-/* caller saves */
-# define CALLER_SAVES_R1
-# define CALLER_SAVES_R2
-# define CALLER_SAVES_R3
-# define CALLER_SAVES_R4
-# define CALLER_SAVES_R5
-# define CALLER_SAVES_R6
-# define CALLER_SAVES_R7
-# define CALLER_SAVES_R8
-
-# define CALLER_SAVES_USER
-
-# define REG_R1 1
-# define REG_R2 2
-# define REG_R3 3
-# define REG_R4 4
-# define REG_R5 5
-# define REG_R6 6
-# define REG_R7 7
-# define REG_R8 8
-
-# define REG_Flt1 f2
-# define REG_Flt2 f3
-# define REG_Flt3 f4
-# define REG_Flt4 f5
-
-# define REG_Dbl1 f6
-# define REG_Dbl2 f7
-
-# define REG_SpA 9
-# define REG_SuA 10
-# define REG_SpB 11
-# define REG_SuB 12
-
-# define REG_Hp 13
-# define REG_HpLim 14
-
-# define REG_Ret 15
-
-# define NCG_Reserved_I1 22
-# define NCG_Reserved_I2 27
-# define NCG_Reserved_F1 f29
-# define NCG_Reserved_F2 f30
-
-# endif /* !SCAV_REG_MAP */
-# endif /* !SCAN_REG_MAP */
-# endif /* !MARK_REG_MAP */
-
-#endif /* alpha */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[mapping-hpux]{The HP-PA register mapping}
-%* *
-%************************************************************************
-
-We cater for HP-PA 1.1.
-
-\tr{%r0}--\tr{%r1} are special.
-\tr{%r2} is the return pointer.
-\tr{%r3} is the frame pointer.
-\tr{%r4}--\tr{%r18} are callee-save registers.
-\tr{%r19} is a linkage table register for HPUX 8.0 shared libraries.
-\tr{%r20}--\tr{%r22} are caller-save registers.
-\tr{%r23}--\tr{%r26} are parameter registers.
-\tr{%r27} is a global data pointer.
-\tr{%r28}--\tr{%r29} are temporaries.
-\tr{%r30} is the stack pointer.
-\tr{%r31} is a temporary.
-
-\tr{%fr12}--\tr{%fr15} are some callee-save floating-point registers.
-\tr{%fr8}--\tr{%fr11} are some available caller-save fl-pt registers.
-
-\begin{code}
-#if hppa1_1_TARGET_ARCH
-
-#define REG(x) __asm__("%" #x)
-
-#if defined(MARK_REG_MAP)
-#define REG_Mark r4
-#define REG_MStack r5
-#define REG_MRoot r6
-#define REG_BitArray r7
-#define REG_HeapBase r8
-#define REG_HeapLim r9
-#else
-#if defined(SCAN_REG_MAP)
-#define REG_Scan r4
-#define REG_New r5
-#define REG_LinkLim r6
-#else
-#if defined(SCAV_REG_MAP)
-#define REG_Scav r4
-#define REG_ToHp r5
-#if defined(GCap) || defined(GCgn)
-#define REG_OldGen r6
-#endif /* GCap || GCgn */
-#else /* default: MAIN_REG_MAP */
-
-/* callee saves */
-#define CALLEE_SAVES_FltReg1
-#define CALLEE_SAVES_FltReg2
-#define CALLEE_SAVES_FltReg3
-#define CALLEE_SAVES_FltReg4
-#define CALLEE_SAVES_DblReg1
-#define CALLEE_SAVES_DblReg2
-/* ToDo: improve? */
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define CALLEE_SAVES_LngReg1
-#define CALLEE_SAVES_LngReg2
-#endif
-#define CALLEE_SAVES_SpA
-#define CALLEE_SAVES_SuA
-#define CALLEE_SAVES_SpB
-#define CALLEE_SAVES_SuB
-#define CALLEE_SAVES_Hp
-#define CALLEE_SAVES_HpLim
-
-#define CALLEE_SAVES_Ret
-
-#define CALLEE_SAVES_R1
-#define CALLEE_SAVES_R2
-#define CALLEE_SAVES_R3
-#define CALLEE_SAVES_R4
-#define CALLEE_SAVES_R5
-#define CALLEE_SAVES_R6
-#define CALLEE_SAVES_R7
-#define CALLEE_SAVES_R8
-
-/* caller saves -- none */
-
-#define REG_R1 r11
-#define REG_R2 r12
-#define REG_R3 r13
-#define REG_R4 r14
-#define REG_R5 r15
-#define REG_R6 r16
-#define REG_R7 r17
-#define REG_R8 r18
-
-#define REG_Flt1 fr12
-#define REG_Flt2 fr12R
-#define REG_Flt3 fr13
-#define REG_Flt4 fr13R
-
-#define REG_Dbl1 fr20 /* L & R */
-#define REG_Dbl2 fr21 /* L & R */
-
-#define REG_SpA r4
-#define REG_SuA r5
-#define REG_SpB r6
-#define REG_SuB r7
-
-#define REG_Hp r8
-#define REG_HpLim r9
-
-#define REG_Ret r10
-
-/* #define REG_StkStub r2 */
-
-#define NCG_Reserved_I1 r28
-#define NCG_Reserved_I2 r29
-#define NCG_Reserved_F1 fr8
-#define NCG_Reserved_F2 fr8R
-#define NCG_Reserved_D1 fr10
-#define NCG_Reserved_D2 fr11
-
-#endif /* SCAV_REG_MAP */
-#endif /* SCAN_REG_MAP */
-#endif /* MARK_REG_MAP */
-
-#endif /* hppa */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[mapping-iX86]{The Intel iX86 register mapping}
-%* *
-%************************************************************************
-
-Ok, we've only got 6 general purpose registers, a frame pointer and a
-stack pointer. \tr{%eax} and \tr{%edx} are return values from C functions,
-hence they get trashed across ccalls and are caller saves. \tr{%ebx},
-\tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.
-
-\begin{code}
-#if i386_TARGET_ARCH
-
-#define REG(x) __asm__("%" #x)
-
-#if defined(MARK_REG_MAP)
-#define REG_MarkBase ebx
-#define REG_Mark ebp
-#define REG_MStack esi
-#define REG_MRoot edi
-
-#else
-#if defined(SCAN_REG_MAP)
-#define REG_Scan ebx
-#define REG_New ebp
-#define REG_LinkLim esi
-
-#else
-#if defined(SCAV_REG_MAP)
-#define REG_Scav ebx
-#define REG_ToHp ebp
-#if defined(GCap) || defined(GCgn)
-/* NO: -concurrent croaks on SMevac.lc with this
-#define REG_OldGen esi
-*/
-#endif /* GCap || GCgn */
-
-#else /* default: MAIN_REG_MAP */
-
-/* callee saves */
-#define CALLEE_SAVES_Base
-#define CALLEE_SAVES_SpB
-
-/* caller saves -- none */
-
-/* After trying to steal 4 regs, ... crash:
-
- works again if:
- - give back esi
- - give back edi
- - give back edi & ebp
-
- does not work if
- - give back ebp
-*/
-
-/* SpB and R1 are the two heaviest hitters, followed by SpA.
- Hp comes next, followed closely by R2;
- then RetReg, then R3 and R4.
- At least based on some static counts.
- SIGH. WDP 95/09
-*/
-#define REG_Base ebx
-#define REG_SpB ebp
-#if STOLEN_X86_REGS >= 3
-# define REG_R1 esi
-# define CALLEE_SAVES_R1
-#endif
-#if STOLEN_X86_REGS >= 4
-# define REG_SpA edi
-# define CALLEE_SAVES_SpA
-#endif
-#if STOLEN_X86_REGS >= 5
-/*
-# define REG_Hp ecx
-# define CALLER_SAVES_Hp
-# define CALLER_SAVES_SYSTEM
-*/
-/* because we *might* have Hp in a caller-saves register */
-#endif
-
-
-#endif /* SCAV_REG_MAP */
-#endif /* SCAN_REG_MAP */
-#endif /* MARK_REG_MAP */
-
-#endif /* iX86 */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[mapping-m68k]{The Motorola 680x0 register mapping}
-%* *
-%************************************************************************
-
-A Sun3 (mc680x0) has eight address registers, \tr{a0} to \tr{a7}, and
-eight data registers, \tr{d0} to \tr{d7}. Address operations have to
-be done through address registers; data registers are used for
-comparison values and data.
-
-Here's the register-usage picture for m68k boxes with GCC.
-
-\begin{tabular}{ll}
-a0 & used directly by GCC \\
-a1 & used directly by GCC \\
-\\
-a2..a5 & callee-saved: available for STG registers \\
- & (a5 may be special, ``global'' register for PIC?) \\
-\\
-a6 & C-stack frame pointer \\
-a7 & C-stack pointer \\
-\\
-d0 & used directly by GCC \\
-d1 & used directly by GCC \\
-d2 & really needed for local optimisation by GCC \\
-\\
-d3..d7 & callee-saved: available for STG registers
-\\
-fp0 & call-clobbered \\
-fp1 & call-clobbered \\
-fp2..fp7 & callee-saved: available for STG registers
-\end{tabular}
-
-\begin{code}
-#if m68k_TARGET_ARCH
-
-#define REG(x) __asm__(#x)
-
-#if defined(FLUSH_REG_MAP)
-#define REG_FlushP a2
-#define REG_FStack a3
-#define REG_FlushTemp a4
-#else
-#if defined(MARK_REG_MAP)
-#define REG_Mark a2
-#define REG_MStack a3
-#define REG_MRoot a4
-#define REG_BitArray a5
-#define REG_HeapBase d3
-#define REG_HeapLim d4
-#else
-#if defined(SCAN_REG_MAP)
-#define REG_Scan a2
-#define REG_New a3
-#define REG_LinkLim a4
-#else
-#if defined(SCAV_REG_MAP)
-#define REG_Scav a2
-#define REG_ToHp a3
-#if defined(GCap)
-#define REG_OldGen a4
-#else
-#if defined(GCgn)
-#define REG_OldGen a4
-#define REG_AllocGen a5
-#define REG_OldHp d3
-#endif /* GCap */
-#endif /* GCgn */
-#else /* default: MAIN_REG_MAP */
-
-/* callee saves */
-#define CALLEE_SAVES_FltReg1
-#define CALLEE_SAVES_DblReg1
-#if !defined(CONCURRENT)
-# define CALLEE_SAVES_FltReg2
-# define CALLEE_SAVES_FltReg3
-# define CALLEE_SAVES_FltReg4
-# define CALLEE_SAVES_DblReg2
-#endif
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define CALLEE_SAVES_LngReg1
-#define CALLEE_SAVES_LngReg2
-#endif
-#define CALLEE_SAVES_Base
-#define CALLEE_SAVES_SpB
-#define CALLEE_SAVES_SpA
-#define CALLEE_SAVES_Hp
-#define CALLEE_SAVES_SuA
-#define CALLEE_SAVES_SuB
-
-#define CALLEE_SAVES_R1
-#define CALLEE_SAVES_R2
-#define CALLEE_SAVES_Ret
-
-/* caller saves -- none */
-
-#define REG_Base a2
-
-#define REG_SpB a3
-#define REG_SpA a4
-
-#define REG_Hp d3
-#define REG_SuA d4
-#define REG_SuB d5
-
-#define REG_R1 a5
-#define REG_R2 d6
-
-#define REG_Ret d7
-
-#define REG_Flt1 fp2
-#if !defined(CONCURRENT)
-/* The extra float registers are not worth the tradeoff in
- context-switch time for most programs (for now, at least).
-*/
-#define REG_Flt2 fp3
-#define REG_Flt3 fp4
-#define REG_Flt4 fp5
-#endif
-
-#define REG_Dbl1 fp6
-/* The extra double registers are not worth the tradeoff in
- context-switch time for most programs (for now, at least).
-*/
-#if !defined(CONCURRENT)
-#define REG_Dbl2 fp7
-#endif
-
-#endif /* SCAV_REG_MAP */
-#endif /* SCAN_REG_MAP */
-#endif /* MARK_REG_MAP */
-#endif /* FLUSH_REG_MAP */
-
-#endif /* m68k */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[mapping-mipsel]{The DECstation (MIPS) register mapping}
-%* *
-%************************************************************************
-
-Here's at least some simple stuff about registers on a MIPS.
-
-\tr{s0}--\tr{s7} are callee-save integer registers; they are our
-``prize'' stolen registers. There is also a wad of callee-save
-floating-point registers, \tr{$f20}--\tr{$f31}; we'll use some of
-those.
-
-\tr{t0}--\tr{t9} are caller-save (``temporary?'') integer registers.
-We can steal some, but we might have to save/restore around ccalls.
-
-\begin{code}
-#if mipsel_TARGET_ARCH || mipseb_TARGET_ARCH
-
-#define REG(x) __asm__("$" #x)
-
-#if defined(MARK_REG_MAP)
-#define REG_Mark 16
-#define REG_MStack 17
-#define REG_MRoot 18
-#define REG_BitArray 19
-#define REG_HeapBase 20
-#define REG_HeapLim 21
-#else
-#if defined(SCAN_REG_MAP)
-#define REG_Scan 16
-#define REG_New 17
-#define REG_LinkLim 18
-#else
-#if defined(SCAV_REG_MAP)
-#define REG_Scav 16
-#define REG_ToHp 17
-#if defined(GCap) || defined(GCgn)
-#define REG_OldGen 18
-#endif /* GCap || GCgn */
-#else /* default: MAIN_REG_MAP */
-
-/* callee saves */
-#define CALLEE_SAVES_FltReg1
-#define CALLEE_SAVES_FltReg2
-#define CALLEE_SAVES_FltReg3
-#define CALLEE_SAVES_FltReg4
-#define CALLEE_SAVES_DblReg1
-#define CALLEE_SAVES_DblReg2
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define CALLEE_SAVES_LngReg1
-#define CALLEE_SAVES_LngReg2
-#endif
-#define CALLEE_SAVES_SpA
-#define CALLEE_SAVES_SuA
-#define CALLEE_SAVES_SpB
-#define CALLEE_SAVES_SuB
-#define CALLEE_SAVES_Hp
-#define CALLEE_SAVES_HpLim
-
-#define CALLEE_SAVES_Ret
-
-/* caller saves */
-#define CALLER_SAVES_R1
-#define CALLER_SAVES_R2
-#define CALLER_SAVES_R3
-#define CALLER_SAVES_R4
-#define CALLER_SAVES_R5
-#define CALLER_SAVES_R6
-#define CALLER_SAVES_R7
-#define CALLER_SAVES_R8
-
-#define CALLER_SAVES_USER
-
-#define REG_R1 9
-#define REG_R2 10
-#define REG_R3 11
-#define REG_R4 12
-#define REG_R5 13
-#define REG_R6 14
-#define REG_R7 15
-#define REG_R8 24
-
-#define REG_Flt1 f20
-#define REG_Flt2 f22
-#define REG_Flt3 f24
-#define REG_Flt4 f26
-
-#define REG_Dbl1 f28
-#define REG_Dbl2 f30
-
-#define REG_SpA 16
-#define REG_SuA 17
-#define REG_SpB 18
-#define REG_SuB 19
-
-#define REG_Hp 20
-#define REG_HpLim 21
-
-#define REG_Ret 22
-
-#define REG_StkStub 23
-
-#endif /* SCAV_REG_MAP */
-#endif /* SCAN_REG_MAP */
-#endif /* MARK_REG_MAP */
-
-#endif /* mipse[lb] */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[mapping-powerpc]{The PowerPC register mapping}
-%* *
-%************************************************************************
-
-0 system glue? (caller-save, volatile)
-1 SP (callee-save, non-volatile)
-2 RTOC (callee-save, non-volatile)
-3-10 args/return (caller-save, volatile)
-11,12 system glue? (caller-save, volatile)
-13-31 (callee-save, non-volatile)
-
-f0 (caller-save, volatile)
-f1-f13 args/return (caller-save, volatile)
-f14-f31 (callee-save, non-volatile)
-
-\tr{13}--\tr{31} are wonderful callee-save registers.
-\tr{0}--\tr{12} are caller-save registers.
-
-\tr{%f14}--\tr{%f31} are callee-save floating-point registers.
-
-I think we can do the Whole Business with callee-save registers only!
-
-\begin{code}
-#if powerpc_TARGET_ARCH || rs6000_TARGET_ARCH
-
-#define REG(x) __asm__(#x)
-
-#if defined(MARK_REG_MAP)
-#define REG_Mark r22
-#define REG_MStack r23
-#define REG_MRoot r24
-#define REG_BitArray r25
-#define REG_HeapBase r26
-#define REG_HeapLim r27
-#else
-#if defined(SCAN_REG_MAP)
-#define REG_Scan r22
-#define REG_New r23
-#define REG_LinkLim r24
-#else
-#if defined(SCAV_REG_MAP)
-#define REG_Scav r22
-#define REG_ToHp r23
-#if defined(GCap) || defined(GCgn)
-#define REG_OldGen r24
-#endif /* GCap || GCgn */
-#else /* default: MAIN_REG_MAP */
-
-/* callee saves */
-#define CALLEE_SAVES_FltReg1
-#define CALLEE_SAVES_FltReg2
-#define CALLEE_SAVES_FltReg3
-#define CALLEE_SAVES_FltReg4
-#define CALLEE_SAVES_DblReg1
-#define CALLEE_SAVES_DblReg2
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define CALLEE_SAVES_LngReg1
-#define CALLEE_SAVES_LngReg2
-#endif
-#define CALLEE_SAVES_SpA
-#define CALLEE_SAVES_SuA
-#define CALLEE_SAVES_SpB
-#define CALLEE_SAVES_SuB
-#define CALLEE_SAVES_Hp
-#define CALLEE_SAVES_HpLim
-
-#define CALLEE_SAVES_Ret
-
-#define CALLEE_SAVES_R1
-#define CALLEE_SAVES_R2
-#define CALLEE_SAVES_R3
-#define CALLEE_SAVES_R4
-#define CALLEE_SAVES_R5
-#define CALLEE_SAVES_R6
-#define CALLEE_SAVES_R7
-#define CALLEE_SAVES_R8
-
-#define REG_R1 r14
-#define REG_R2 r15
-#define REG_R3 r16
-#define REG_R4 r17
-#define REG_R5 r18
-#define REG_R6 r19
-#define REG_R7 r20
-#define REG_R8 r21
-
-#define REG_Flt1 fr14
-#define REG_Flt2 fr15
-#define REG_Flt3 fr16
-#define REG_Flt4 fr17
-
-#define REG_Dbl1 fr18
-#define REG_Dbl2 fr19
-
-#define REG_SpA r22
-#define REG_SuA r23
-#define REG_SpB r24
-#define REG_SuB r25
-
-#define REG_Hp r26
-#define REG_HpLim r27
-
-#define REG_Ret r28
-
-#define REG_StkStub r29
-
-#endif /* SCAV_REG_MAP */
-#endif /* SCAN_REG_MAP */
-#endif /* MARK_REG_MAP */
-
-#endif /* powerpc */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[mapping-sparc]{The Sun SPARC register mapping}
-%* *
-%************************************************************************
-
-The SPARC register (window) story: Remember, within the Haskell
-Threaded World, we essentially ``shut down'' the register-window
-mechanism---the window doesn't move at all while in this World. It
-{\em does} move, of course, if we call out to arbitrary~C...
-
-The \tr{%i}, \tr{%l}, and \tr{%o} registers (8 each) are the input,
-local, and output registers visible in one register window. The 8
-\tr{%g} (global) registers are visible all the time.
-
-\begin{tabular}{ll}
-\tr{%o0}..\tr{%o7} & not available; can be zapped by callee \\
- & (\tr{%o6} is C-stack ptr; \tr{%o7} hold ret addrs) \\
-\tr{%i0}..\tr{%i7} & available (except \tr{%i6} is used as frame ptr) \\
- & (and \tr{%i7} tends to have ret-addr-ish things) \\
-\tr{%l0}..\tr{%l7} & available \\
-\tr{%g0}..\tr{%g4} & not available; prone to stomping by division, etc.\\
-\tr{%g5}..\tr{%g7} & not available; reserved for the OS \\
-\end{tabular}
-
-Note: \tr{%g3} is {\em definitely} clobbered in the builtin divide
-code (and our save/restore machinery is NOT GOOD ENOUGH for that);
-discretion being the better part of valor, we also don't take
-\tr{%g4}.
-
-\begin{code}
-#if sparc_TARGET_ARCH
-
-#define REG(x) __asm__("%" #x)
-
-#if defined(MARK_REG_MAP)
-#define REG_Mark i0
-#define REG_MStack i1
-#define REG_MRoot i2
-#define REG_BitArray i3
-#define REG_HeapBase i4
-#define REG_HeapLim i5
-#else
-#if defined(SCAN_REG_MAP)
-#define REG_ScanBase g4
-/* NB: *not* defining this (so that everything is done w/ global variables)
- does *not* work; I suspect that the Sca[nv]RegTable is not being
- initialised somewhere... WDP 95/10
-*/
-#else
-#if defined(SCAV_REG_MAP)
-#define REG_ScavBase g4
-/* see comment above */
-#else /* default: MAIN_REG_MAP */
-
-/* callee saves (nothing) */
-
-/* caller saves (fp registers) */
-
-#define CALLER_SAVES_USER
-
-#define CALLER_SAVES_FltReg1
-#define CALLER_SAVES_FltReg2
-#define CALLER_SAVES_FltReg3
-#define CALLER_SAVES_FltReg4
-#define CALLER_SAVES_DblReg1
-#define CALLER_SAVES_DblReg2
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
-#define CALLER_SAVES_LngReg1
-#define CALLER_SAVES_LngReg2
-#endif
-
-#define REG_R1 l1
-#define REG_R2 l2
-#define REG_R3 l3
-#define REG_R4 l4
-#define REG_R5 l5
-#define REG_R6 l6
-#define REG_R7 l7
-
-#define REG_Flt1 f2
-#define REG_Flt2 f3
-#define REG_Flt3 f4
-#define REG_Flt4 f5
-#define REG_Dbl1 f6
-#define REG_Dbl2 f8
-
-#define REG_SpA i0
-#define REG_SuA i1
-#define REG_SpB i2
-#define REG_SuB i3
-
-#define REG_Hp i4
-#define REG_HpLim i5
-
-#define REG_Ret l0
-
-#define REG_StkStub i7
-
-#define NCG_Reserved_I1 g1
-#define NCG_Reserved_I2 g2
-#define NCG_Reserved_F1 f14
-#define NCG_Reserved_F2 f15
-#define NCG_Reserved_D1 f16
-#define NCG_Reserved_D2 f18
-
-#endif /* SCAV_REG_MAP */
-#endif /* SCAN_REG_MAP */
-#endif /* MARK_REG_MAP */
-
-#endif /* sparc */
-\end{code}
-
-Concluding multi-slurp protection:
-\begin{code}
-
-#endif /* __STG_GCC_REGS__ || COMPILING_NCG */
-
-#endif /* MACHREGS_H */
-\end{code}
-
-#
-# ghc/includes
+# -----------------------------------------------------------------------------
+# $Id: Makefile,v 1.11 1998/12/02 13:21:15 simonm Exp $
#
TOP = ..
include $(TOP)/mk/boilerplate.mk
#
-# Just to make sure, no ways stuff in here, please.
+# All header files
#
-override WAYS=
-
-# De-litted header files
-LH_FILES=$(wildcard *.lh)
-
-DELIT_H_FILES = $(patsubst %.lh, %.h, $(LH_FILES))
+H_FILES = $(wildcard *.h)
#
# Header file built from the configure script's findings
#
H_CONFIG = config.h
+all :: $(H_CONFIG) NativeDefs.h
-# Everything else
-H_FILES = stgdefs.h rtsdefs.h StgDirections.h StgMachDeps.h error.h \
- ieee-flpt.h gmp.h LLC.h HLC.h
-
-MKDEPENDC_SRCS=mkNativeHdr.c
-
-ALL_FILES = $(DELIT_H_FILES) $(H_FILES)
-ifeq ($(GhcWithNativeCodeGen),YES)
-ALL_FILES += $(TARGETPLATFORM).h
-endif
-
-
-#
-# In main/Signals we need to distinguish between irix5 and irix6,
-# so we suitably mangle HostOS_FULL to get at the major version.
-# (A hack, for sure - ToDo: consider systematically adding more
-# fine-grained OS info to this Makefile/configure soup )
-
-ifeq "$(HostOS_CPP)" "irix"
-IRIX_MAJOR = $(shell echo $(HostOS_Full) | sed 's/\(irix[^.]*\).*$$/\1/' )
-endif
-
-#
# The fptools configure script creates the configuration header file
# and puts it in fptools/mk/config.h. We copy it down to here, prepending
# some make variables specifying cpp platform variables.
@cat $(FPTOOLS_TOP)/mk/$@ >> $@
@echo "Done."
-$(TARGETPLATFORM).h : mkNativeHdr
- $(RM) $@
- ./mkNativeHdr > $@ || ( rm $@ && exit 1 )
+# ---------------------------------------------------------------------------
+# Make NativeDefs.h for the NCG
-#
-# Building mkNativeHdr using the Haskell compiler
-# to do it (ghc really).
-#
-mkNativeHdr : $(HLIT) $(HFILES) mkNativeHdr.c
- $(CC) -o mkNativeHdr mkNativeHdr.c
+C_PROG = mkNativeHdr
+C_SRCS = mkNativeHdr.c
-all :: $(H_CONFIG) $(ALL_FILES)
+NativeDefs.h : mkNativeHdr
+ ./mkNativeHdr >NativeDefs.h
-#
+CLEAN_FILES += NativeDefs.h
+
+# ---------------------------------------------------------------------------
# boot setup:
#
-# When building the dependencies in runtime/ , lib/ we need to get
-# at the de-litted versions of includes/, hence we arrange the
-# `depend' target to depend on `all'.
+# Need config.h to make dependencies in the runtime system source.
#
boot :: all
# it gives (perhaps) a cleaner binary dist structure..might change.
#
override datadir:=$(libdir)/includes
-INSTALL_DATAS += $(DELIT_H_FILES) $(H_FILES) $(TARGETPLATFORM).h $(H_CONFIG)
+INSTALL_DATAS += $(H_FILES) $(H_CONFIG)
#
# `make clean' settings:
#
-CLEAN_FILES += $(DELIT_H_FILES) $(H_CONFIG) mkNativeHdr.o mkNativeHdr
-
-ifeq ($(GhcWithNativeCodeGen),YES)
-CLEAN_FILES += $(TARGETPLATFORM).h
-endif
+CLEAN_FILES += $(H_CONFIG)
#
# Finally, slurp in the standard targets.
+++ /dev/null
--- This file is created automatically. Do not edit by hand.
-
-
---Base table offsets for the Native Code Generator
-#define OFFSET_Dbl1 0
-#define OFFSET_Dbl2 2
-#define OFFSET_Flt1 4
-#define OFFSET_Flt2 5
-#define OFFSET_Flt3 6
-#define OFFSET_Flt4 7
-#define OFFSET_R1 8
-#define OFFSET_R2 9
-#define OFFSET_R3 10
-#define OFFSET_R4 11
-#define OFFSET_R5 12
-#define OFFSET_R6 13
-#define OFFSET_R7 14
-#define OFFSET_R8 15
-#define OFFSET_SpA 16
-#define OFFSET_SuA 17
-#define OFFSET_SpB 18
-#define OFFSET_SuB 19
-#define OFFSET_Hp -12
-#define OFFSET_HpLim -11
-#define OFFSET_Tag 22
-#define OFFSET_Ret 23
-#define OFFSET_Activity 24
-#define OFFSET_StkO panic "OFFSET_StkO"
-#define OFFSET_Liveness panic "OFFSET_Liveness"
-#define SM_HP 0
-#define SM_HPLIM 1
-#define SM_ROOTNO 2
-#define SM_ROOTS 3
-#define SM_CAFLIST 4
-#define SM_OLDROOTS 5
-#define SM_OLDLIM 6
-#define SM_OLDMUTUPLES 7
-#define SM_MALLOCPTRLIST 8
-#define SM_OLDMALLOCPTRLIST 9
-#define SM_STABLEPOINTERTABLE 10
+++ /dev/null
-%
-% (c) Kevin Hammond, Parade/AQUA Projects, Glasgow University, February 15th. 1995
-%
-% This is for GUM only.
-%
-%************************************************************************
-%* *
-\section[Parallel.lh]{Definitions for parallel machines}
-%* *
-%************************************************************************
-
-Multi-slurp protection:
-\begin{code}
-#ifndef Parallel_H
-#define Parallel_H
-\end{code}
-
-This section contains definitions applicable only to programs compiled
-to run on a parallel machine. Some of these things can probably be
-ripped out now that we don't store GAs in closures, but beware that
-this {\em might} break GranSim, so check first! KH
-
-These basic definitions need to be around, one way or the other:
-\begin{code}
-#define PAR_FIXED_HDR (GA_HDR_SIZE)
-#define PAR_HDR_POSN AFTER_INFO_HDR
-#define AFTER_PAR_HDR (PAR_HDR_POSN+PAR_FIXED_HDR)
-
-#define SET_PAR_HDR(closure,ga) /* nothing */
-#define SET_STATIC_PAR_HDR(closure) /* nothing */
-\end{code}
-
-\begin{code}
-# ifdef PAR
-# define MAX_PES 256 /* Maximum number of processors */
- /* MAX_PES is enforced by SysMan, which does not
- allow more than this many "processors".
- This is important because PackGA [GlobAddr.lc]
- **assumes** that a PE# can fit in 8+ bits.
- */
-
-extern I_ do_sp_profile;
-
-extern P_ PendingFetches;
-extern GLOBAL_TASK_ID *PEs;
-
-extern rtsBool IAmMainThread, GlobalStopPending;
-extern rtsBool fishing;
-extern GLOBAL_TASK_ID SysManTask;
-extern int seed; /*pseudo-random-number generator seed:*/
- /*Initialised in ParInit*/
-extern I_ threadId; /*Number of Threads that have existed on a PE*/
-extern GLOBAL_TASK_ID mytid;
-
-extern int nPEs;
-
-extern rtsBool InGlobalGC; /* Are we in the midst of performing global GC */
-
-extern HashTable *pGAtoGALAtable;
-extern HashTable *LAtoGALAtable;
-extern GALA *freeIndirections;
-extern GALA *liveIndirections;
-extern GALA *freeGALAList;
-extern GALA *liveRemoteGAs;
-extern int thisPE;
-
-void RunParallelSystem PROTO((StgPtr program_closure));
-void initParallelSystem(STG_NO_ARGS);
-void SynchroniseSystem(STG_NO_ARGS);
-
-void registerTask PROTO((GLOBAL_TASK_ID gtid));
-globalAddr *LAGAlookup PROTO((P_ addr));
-P_ GALAlookup PROTO((globalAddr *ga));
-globalAddr *MakeGlobal PROTO((P_ addr, rtsBool preferred));
-globalAddr *setRemoteGA PROTO((P_ addr, globalAddr *ga, rtsBool preferred));
-void splitWeight PROTO((globalAddr *to, globalAddr *from));
-globalAddr *addWeight PROTO((globalAddr *ga));
-void initGAtables(STG_NO_ARGS);
-W_ taskIDtoPE PROTO((GLOBAL_TASK_ID gtid));
-void RebuildLAGAtable(STG_NO_ARGS);
-
-void *lookupHashTable PROTO((HashTable *table, StgWord key));
-void insertHashTable PROTO((HashTable *table, StgWord key, void *data));
-void freeHashTable PROTO((HashTable *table, void (*freeDataFun) PROTO((void *data))));
-HashTable *allocHashTable(STG_NO_ARGS);
-void *removeHashTable PROTO((HashTable *table, StgWord key, void *data));
-
-/*
- Redefining exit is more trouble than its worth, IMO -- SOF
-*/
-extern void myexit PROTO((I_));
-# define EXIT myexit
-/* # define exit : error : Wrong exit! */
-
-# else
-# define EXIT exit
-# endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[anti-parallel-SM]{But if we're {\em not} compiling for a parallel system...}
-%* *
-%************************************************************************
-
-Get this out of the way. These are all null definitions.
-
-\begin{code}
-# if !(defined(GRAN) || defined(PAR))
-
-# define GA_HDR_SIZE 0
-# define GA(closure) /*nothing*/
-
-# define SET_GA(closure,ga) /* nothing */
-# define SET_STATIC_GA(closure) /* nothing */
-# define SET_GRAN_HDR(closure,pe) /* nothing */
-# define SET_STATIC_PROCS(closure) /* nothing */
-
-# define SET_TASK_ACTIVITY(act) /* nothing */
-
-#endif
-
-#if defined(GRAN)
-
-# define GA_HDR_SIZE 1
-
-# define PROCS_HDR_POSN PAR_HDR_POSN
-# define PROCS_HDR_SIZE 1
-
-/* Accessing components of the field */
-# define PROCS(closure) (*((P_)(closure)+PROCS_HDR_POSN))
-
-# define SET_PROCS(closure, procs) \
- PROCS(closure) = (W_)(procs) /* Set closure's location */
-# define SET_GRAN_HDR(closure,pe) SET_PROCS(closure,pe)
-
-# define SET_STATIC_PROCS(closure) , (W_) (Everywhere)
-
-# define SET_TASK_ACTIVITY(act) /* nothing */
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[parallel-GAs]{Parallel-only part of fixed headers (global addresses)}
-%* *
-%************************************************************************
-
-Definitions relating to the entire parallel-only fixed-header field.
-
-On GUM, the global addresses for each local closure are stored in a separate
-hash table, rather then with the closure in the heap. We call @getGA@ to
-look up the global address associated with a local closure (0 is returned
-for local closures that have no global address), and @setGA@ to store a new
-global address for a local closure which did not previously have one.
-
-\begin{code}
-#if defined(PAR)
-
-# define GA_HDR_SIZE 0
-
-# define GA(closure) getGA(closure)
-
-# define SET_GA(closure, ga) setGA(closure,ga)
-# define SET_STATIC_GA(closure)
-# define SET_GRAN_HDR(closure,pe)
-# define SET_STATIC_PROCS(closure)
-
-# define MAX_GA_WEIGHT 0 /* Treat as 2^n */
-
-W_ PackGA PROTO((W_, int));
- /* There was a PACK_GA macro here; but we turned it into the PackGA
- routine [GlobAddr.lc] (because it needs to do quite a bit of
- paranoia checking. Phil & Will (95/08)
- */
-\end{code}
-
-At the moment, there is no activity profiling for GUM. This may change.
-
-\begin{code}
-
-# define SET_TASK_ACTIVITY(act)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[parallel-heap-objs]{Special parallel-only heap objects (`closures')}
-%* *
-%************************************************************************
-
-% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-% NB: The following definitons are BOTH for GUM and GrAnSim -- HWL
-% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-The rest of this file contains definitions for {\it GUM and GrAnSim}.
-Although we don't create FetchMe nodes in GrAnSim (we simulate it by
-bitmask twiddling) we use FetchMe_info when converting nodes into RBHs
-(mainly to keep the code as close to GUM as possible). So, we define all
-the FetchMe related stuff in GrAnSim, too. % -- HWL
-
-%************************************************************************
-%* *
-\subsubsection[FETCHME-closures]{@FETCHME@ heap objects (`closures')}
-%* *
-%************************************************************************
-
-FetchMes are pointers into the global heap. When evaluated, the value
-they point to is read from the global heap.
-
-A FetchMe closure has the form:
-
-\begin{onlylatex}
-\begin{center}
-\end{onlylatex}
-\begin{tabular}{||l|l||}\hline
-\tr{FETCHME_info} & junk \\ \hline
-\end{tabular}
-\begin{onlylatex}
-\end{center}
-\end{onlylatex}
-
-The argument word is a pointer (outside of the heap) to a globalAddr structure...
-in particular, the one corresponding to the object to be fetched. Note that
-we can't just used the LAGA table, because weight-splitting may force us to
-reassign a local GA to the @FetchMe@ so that we can give out new references.
-
-A @FetchMe@ must have a valid @MUT_LINK@ field, because it may act as
-a transition between an RBH on the OldMutables list and a BQ still on
-the OldMutables list.
-
-
-\begin{code}
-# 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 SET_FETCHME_HDR(closure,infolbl,cc,size,ptrs) \
-{ SET_FIXED_HDR(closure,FetchMe_info,<bogus CC>); \
- SET_MUT_RESERVED_WORDS(closure); \
-}
-
-# define FETCHME_GA(closure) (((globalAddr **)(closure))[FETCHME_GA_LOCN])
-
-EXTFUN(FetchMe_entry);
-EXTDATA_RO(FetchMe_info);
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[BlockedFetch-closures]{@BlockedFetch@ heap objects (`closures')}
-%* *
-%************************************************************************
-
-@BlockedFetch@s are inbound fetch messages blocked on local closures.
-They arise as entries in a local blocking queue when a fetch has been
-received for a local black hole. When awakened, we look at their
-contents to figure out where to send a resume.
-
-A @BlockedFetch@ closure has the form:
-
-\begin{onlylatex}
-\begin{center}
-\end{onlylatex}
-\begin{tabular}{||l|l|l||}\hline
-\tr{BF_info} & link & node & gtid & slot & weight \\ \hline
-\end{tabular}
-\begin{onlylatex}
-\end{center}
-\end{onlylatex}
-
-\begin{code}
-# define BF_VHS (GC_MUT_RESERVED_WORDS)
-# define BF_HS (FIXED_HS + BF_VHS)
-
-# define BF_LINK_LOCN (BF_HS)
-# define BF_NODE_LOCN (BF_HS + 1)
-# define BF_GTID_LOCN (BF_HS + 2)
-# define BF_SLOT_LOCN (BF_HS + 3)
-# define BF_WEIGHT_LOCN (BF_HS + 4)
-
-# define BF_CLOSURE_NoPTRS(closure) 2
-# define BF_CLOSURE_NoNONPTRS(closure) 3
-
-# define BF_CLOSURE_SIZE(closure) (BF_VHS + 5)
-
-# define BF_LINK(closure) (((PP_)closure)[BF_LINK_LOCN])
-# define BF_NODE(closure) (((PP_)closure)[BF_NODE_LOCN])
-# define BF_GTID(closure) (((P_)closure)[BF_GTID_LOCN])
-# define BF_SLOT(closure) (((P_)closure)[BF_SLOT_LOCN])
-# define BF_WEIGHT(closure) (((P_)closure)[BF_WEIGHT_LOCN])
-
-# define BF_CLOSURE_PTR(closure, no) (((P_)(closure))[BF_HS + (no) - 1])
-
-/* std start-filling-in macro: */
-# define SET_BF_HDR(closure,infolbl,cc) \
-{ SET_FIXED_HDR(closure,infolbl,cc); \
- SET_MUT_RESERVED_WORDS(closure); \
-}
-
-EXTFUN(BF_entry);
-EXTDATA_RO(BF_info);
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[FMBQ-closures]{@FMBQ@ (FetchMe with blocking queue) heap objects (`closures')}
-%* *
-%************************************************************************
-
-FetchMe's with blocking queues are @Fetchme@ nodes which have been entered
-(and therefore a fetch has been sent), but for which we have not yet received
-a @Resume@ message. They look just like normal blocking queues, but have
-a distinguished info pointer.
-
-\begin{code}
-# define FMBQ_VHS BQ_VHS
-# define FMBQ_HS BQ_HS
-
-# define FMBQ_CLOSURE_SIZE(closure) BQ_CLOSURE_SIZE(closure)
-# define FMBQ_CLOSURE_NoPTRS(closure) BQ_CLOSURE_NoPTRS(closure)
-# define FMBQ_CLOSURE_NoNONPTRS(closure) BQ_CLOSURE_NoNONPTRS(closure)
-# define FMBQ_CLOSURE_PTR(closure, no) BQ_CLOSURE_PTR(closure, no)
-
-# define FMBQ_ENTRIES(closure) BQ_ENTRIES(closure)
-# define FMBQ_LINK(closure) BQ_LINK(closure)
-
-EXTFUN(FMBQ_entry);
-EXTDATA_RO(FMBQ_info);
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[parallel-info-tables]{Special parallel-only info-table stuff}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection[FETCHME_ITBL]{@FETCHME_ITBL@}
-%* *
-%************************************************************************
-
-ToDo: delete FetchMe CAT (because we don't profile and parallelize at
-the same time...) Even better...set things up so that we can profile
-and parallelize at the same time!
-
-\begin{code}
-
-# define FETCHME_ITBL(itbl_name,entry_code) \
- CAT_DECLARE(FetchMe,INTERNAL_KIND,"FetchMe","<FetchMe>") \
- EXTFUN(entry_code); \
- EXTDATA_RO(MK_REP_LBL(FetchMe,,)); \
- const W_ itbl_name[] = { \
- (W_) entry_code \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(FetchMe,,) \
- INCLUDE_PROFILING_INFO(FetchMe) \
- }
-
-# define FETCHME_RTBL() \
- const W_ MK_REP_LBL(FetchMe,,)[] = { \
- INCLUDE_TYPE_INFO(FETCHME) \
- INCLUDE_SIZE_INFO(MIN_UPD_SIZE, 0L) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_FetchMe,_Scavenge_FetchMe) \
- INCLUDE_COMPACTING_INFO(_ScanLink_FetchMe,_PRStart_FetchMe,_ScanMove_FetchMe,_PRIn_Error) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[BF_ITBL]{@BF_ITBL@}
-%* *
-%************************************************************************
-
-The special info table used for thread state objects (BlockedFetchs).
-
-\begin{code}
-
-# define BF_ITBL() \
- CAT_DECLARE(BF,INTERNAL_KIND,"BlockedFetch","<BlockedFetch>") \
- EXTFUN(BF_entry); \
- EXTDATA_RO(MK_REP_LBL(BF,,)); \
- const W_ BF_info[] = { \
- (W_) BF_entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(BF,,) \
- INCLUDE_PROFILING_INFO(BF) \
- }
-
-# define BF_RTBL() \
- const W_ MK_REP_LBL(BF,,)[] = { \
- INCLUDE_TYPE_INFO(BF) \
- INCLUDE_SIZE_INFO(BF_CLOSURE_SIZE(dummy),BF_CLOSURE_NoPTRS(dummy)) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_BF,_Scavenge_BF) \
- INCLUDE_COMPACTING_INFO(_ScanLink_BF,_PRStart_BF,_ScanMove_BF,_PRIn_BF) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[FMBQ_ITBL]{@FMBQ_ITBL@}
-%* *
-%************************************************************************
-
-Special info-table for local blocking queues.
-
-\begin{code}
-# define FMBQ_ITBL() \
- CAT_DECLARE(FMBQ,INTERNAL_KIND,"FMBQ","<FMBQ>") \
- EXTFUN(FMBQ_entry); \
- EXTDATA_RO(MK_REP_LBL(FMBQ,,)); \
- const W_ FMBQ_info[] = { \
- (W_) FMBQ_entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(FMBQ,,) \
- INCLUDE_PROFILING_INFO(FMBQ) \
- }
-
-# define FMBQ_RTBL() \
- const W_ MK_REP_LBL(FMBQ,,)[] = { \
- INCLUDE_TYPE_INFO(FMBQ) \
- INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_BQ,_Scavenge_BQ) \
- SPEC_COMPACTING_INFO(_ScanLink_BQ,_PRStart_BQ,_ScanMove_BQ,_PRIn_BQ) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[parallel-spark-pool-defs]{Parallel-only Spark pool definitions}
-%* *
-%************************************************************************
-
-\begin{code}
-# define HAVE_SPARK ((PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL]) \
- || (PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL]))
-
-# define HAVE_WORK (RUNNING_THREAD || HAVE_SPARK)
-# define RUNNING_THREAD (CurrentTSO != NULL)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[parallel-pack-defs]{Parallel-only Packing definitions}
-%* *
-%************************************************************************
-
-
-Symbolic constants for the packing code.
-
-This constant defines how many words of data we can pack into a single
-packet in the parallel (GUM) system.
-
-\begin{code}
-void InitPackBuffer(STG_NO_ARGS);
-P_ PackTSO PROTO((P_ tso, W_ *size));
-P_ PackStkO PROTO((P_ stko, W_ *size));
-P_ AllocateHeap PROTO((W_ size)); /* Doesn't belong */
-
-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));
-
-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))
-
-extern W_ *PackBuffer; /* size: can be set via option */
-extern long *buffer; /* HWL_ */
-extern W_ *freeBuffer; /* HWL_ */
-extern W_ *packBuffer; /* HWL_ */
-
-extern void InitPackBuffer(STG_NO_ARGS);
-extern void InitMoreBuffers(STG_NO_ARGS);
-extern void InitPendingGABuffer(W_ size);
-extern void AllocClosureQueue(W_ size);
-
-# define MAX_GAS (RTSflags.ParFlags.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 1 /* Words of header in a packet */
-
-# define PACK_PLC_SIZE 2 /* Size of a packed PLC in words */
-
-#endif
-\end{code}
-\begin{code}
-
-#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}
-
-
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Prelude.h,v 1.2 1998/12/02 13:21:18 simonm Exp $
+ *
+ * Prelude identifiers that we sometimes need to refer to in the RTS.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef PRELUDE_H
+#define PRELUDE_H
+
+#ifdef COMPILER
+extern const StgClosure PrelBase_Z91Z93_static_closure;
+extern const StgClosure PrelBase_Z40Z41_static_closure;
+extern const StgClosure PrelBase_True_static_closure;
+extern const StgClosure PrelBase_False_static_closure;
+extern const StgClosure PrelMain_mainIO_closure;
+extern const StgClosure PrelPack_unpackCString_closure;
+
+extern const StgInfoTable PrelBase_CZh_static_info;
+extern const StgInfoTable PrelBase_IZh_static_info;
+extern const StgInfoTable PrelBase_FZh_static_info;
+extern const StgInfoTable PrelBase_DZh_static_info;
+extern const StgInfoTable PrelAddr_AZh_static_info;
+extern const StgInfoTable PrelAddr_WZh_static_info;
+extern const StgInfoTable PrelBase_CZh_con_info;
+extern const StgInfoTable PrelBase_IZh_con_info;
+extern const StgInfoTable PrelBase_FZh_con_info;
+extern const StgInfoTable PrelBase_DZh_con_info;
+extern const StgInfoTable PrelAddr_AZh_con_info;
+extern const StgInfoTable PrelAddr_WZh_con_info;
+extern const StgInfoTable PrelAddr_I64Zh_con_info;
+extern const StgInfoTable PrelAddr_W64Zh_con_info;
+extern const StgInfoTable PrelForeign_StablePtr_static_info;
+extern const StgInfoTable PrelForeign_StablePtr_con_info;
+
+/* Define canonical names so we can abstract away from the actual
+ * module these names are defined in.
+ */
+
+#define Nil_closure PrelBase_Z91Z93_static_closure
+#define Unit_closure PrelBase_Z40Z41_static_closure
+#define True_closure PrelBase_True_static_closure
+#define False_closure PrelBase_False_static_closure
+#define CZh_static_info PrelBase_CZh_static_info
+#define IZh_static_info PrelBase_IZh_static_info
+#define FZh_static_info PrelBase_FZh_static_info
+#define DZh_static_info PrelBase_DZh_static_info
+#define AZh_static_info PrelAddr_AZh_static_info
+#define WZh_static_info PrelAddr_WZh_static_info
+#define CZh_con_info PrelBase_CZh_con_info
+#define IZh_con_info PrelBase_IZh_con_info
+#define FZh_con_info PrelBase_FZh_con_info
+#define DZh_con_info PrelBase_DZh_con_info
+#define AZh_con_info PrelAddr_AZh_con_info
+#define WZh_con_info PrelAddr_WZh_con_info
+#define W64Zh_con_info PrelAddr_W64Zh_con_info
+#define I64Zh_con_info PrelAddr_I64Zh_con_info
+#define StablePtr_static_info PrelForeign_StablePtr_static_info
+#define StablePtr_con_info PrelForeign_StablePtr_con_info
+#define mainIO_closure PrelMain_mainIO_closure
+#define unpackCString_closure PrelPack_unpackCString_closure
+
+#else /* INTERPRETER, I guess */
+
+extern const StgInfoTable CZh_con_info;
+extern const StgInfoTable IZh_con_info;
+extern const StgInfoTable I64Zh_con_info;
+extern const StgInfoTable FZh_con_info;
+extern const StgInfoTable DZh_con_info;
+extern const StgInfoTable AZh_con_info;
+extern const StgInfoTable WZh_con_info;
+extern const StgInfoTable StablePtr_con_info;
+
+extern const StgInfoTable CZh_static_info;
+extern const StgInfoTable IZh_static_info;
+extern const StgInfoTable I64Zh_static_info;
+extern const StgInfoTable FZh_static_info;
+extern const StgInfoTable DZh_static_info;
+extern const StgInfoTable AZh_static_info;
+extern const StgInfoTable WZh_static_info;
+extern const StgInfoTable StablePtr_static_info;
+
+#define W64Zh_con_info I64Zh_con_info
+#define W64Zh_static_info I64Zh_con_info
+
+#endif
+
+#endif /* PRELUDE_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: PrimOps.h,v 1.2 1998/12/02 13:21:18 simonm Exp $
+ *
+ * Macros for primitive operations in STG-ish C code.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef PRIMOPS_H
+#define PRIMOPS_H
+
+/* -----------------------------------------------------------------------------
+ Comparison PrimOps.
+ -------------------------------------------------------------------------- */
+
+#define gtCharZh(r,a,b) r=(I_)((a)> (b))
+#define geCharZh(r,a,b) r=(I_)((a)>=(b))
+#define eqCharZh(r,a,b) r=(I_)((a)==(b))
+#define neCharZh(r,a,b) r=(I_)((a)!=(b))
+#define ltCharZh(r,a,b) r=(I_)((a)< (b))
+#define leCharZh(r,a,b) r=(I_)((a)<=(b))
+
+/* Int comparisons: >#, >=# etc */
+#define ZgZh(r,a,b) r=(I_)((a) >(b))
+#define ZgZeZh(r,a,b) r=(I_)((a)>=(b))
+#define ZeZeZh(r,a,b) r=(I_)((a)==(b))
+#define ZdZeZh(r,a,b) r=(I_)((a)!=(b))
+#define ZlZh(r,a,b) r=(I_)((a) <(b))
+#define ZlZeZh(r,a,b) r=(I_)((a)<=(b))
+
+#define gtWordZh(r,a,b) r=(I_)((a) >(b))
+#define geWordZh(r,a,b) r=(I_)((a)>=(b))
+#define eqWordZh(r,a,b) r=(I_)((a)==(b))
+#define neWordZh(r,a,b) r=(I_)((a)!=(b))
+#define ltWordZh(r,a,b) r=(I_)((a) <(b))
+#define leWordZh(r,a,b) r=(I_)((a)<=(b))
+
+#define gtAddrZh(r,a,b) r=(I_)((a) >(b))
+#define geAddrZh(r,a,b) r=(I_)((a)>=(b))
+#define eqAddrZh(r,a,b) r=(I_)((a)==(b))
+#define neAddrZh(r,a,b) r=(I_)((a)!=(b))
+#define ltAddrZh(r,a,b) r=(I_)((a) <(b))
+#define leAddrZh(r,a,b) r=(I_)((a)<=(b))
+
+#define gtFloatZh(r,a,b) r=(I_)((a)> (b))
+#define geFloatZh(r,a,b) r=(I_)((a)>=(b))
+#define eqFloatZh(r,a,b) r=(I_)((a)==(b))
+#define neFloatZh(r,a,b) r=(I_)((a)!=(b))
+#define ltFloatZh(r,a,b) r=(I_)((a)< (b))
+#define leFloatZh(r,a,b) r=(I_)((a)<=(b))
+
+/* Double comparisons: >##, >=#@ etc */
+#define ZgZhZh(r,a,b) r=(I_)((a) >(b))
+#define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b))
+#define ZeZeZhZh(r,a,b) r=(I_)((a)==(b))
+#define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b))
+#define ZlZhZh(r,a,b) r=(I_)((a) <(b))
+#define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b))
+
+/* used by returning comparison primops, defined in Prims.hc. */
+extern const StgClosure *PrelBase_Bool_closure_tbl[];
+
+/* -----------------------------------------------------------------------------
+ Char# PrimOps.
+ -------------------------------------------------------------------------- */
+
+#define ordZh(r,a) r=(I_)((W_) (a))
+#define chrZh(r,a) r=(StgChar)((W_)(a))
+
+/* -----------------------------------------------------------------------------
+ Int# PrimOps.
+ -------------------------------------------------------------------------- */
+
+I_ stg_div (I_ a, I_ b);
+
+#define ZpZh(r,a,b) r=(a)+(b)
+#define ZmZh(r,a,b) r=(a)-(b)
+#define ZtZh(r,a,b) r=(a)*(b)
+#define quotIntZh(r,a,b) r=(a)/(b)
+#define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
+#define remIntZh(r,a,b) r=(a)%(b)
+#define negateIntZh(r,a) r=-(a)
+
+/* The following operations are the standard add,subtract and multiply
+ * except that they return a carry if the operation overflows.
+ *
+ * They are all defined in terms of 32-bit integers and use the GCC
+ * 'long long' extension to get a 64-bit result. We'd like to use
+ * 64-bit integers on 64-bit architectures, but it seems that gcc's
+ * 'long long' type is set at 64-bits even on a 64-bit machine.
+ */
+
+#ifdef WORDS_BIGENDIAN
+#define C 0
+#define R 1
+#else
+#define C 1
+#define R 0
+#endif
+
+typedef union {
+ StgInt64 l;
+ StgInt32 i[2];
+} long_long_u ;
+
+#define addWithCarryZh(r,c,a,b) \
+{ long_long_u z; \
+ z.l = a + b; \
+ r = z.i[R]; \
+ c = z.i[C]; \
+}
+
+#define subWithCarryZh(r,c,a,b) \
+{ long_long_u z; \
+ z.l = a + b; \
+ r = z.i[R]; \
+ c = z.i[C]; \
+}
+
+#define mulWithCarryZh(r,c,a,b) \
+{ long_long_u z; \
+ z.l = a * b; \
+ r = z.i[R]; \
+ c = z.i[C]; \
+}
+
+/* -----------------------------------------------------------------------------
+ Word PrimOps.
+ -------------------------------------------------------------------------- */
+
+#define quotWordZh(r,a,b) r=((W_)a)/((W_)b)
+#define remWordZh(r,a,b) r=((W_)a)%((W_)b)
+
+#define andZh(r,a,b) r=(a)&(b)
+#define orZh(r,a,b) r=(a)|(b)
+#define xorZh(r,a,b) r=(a)^(b)
+#define notZh(r,a) r=~(a)
+
+#define shiftLZh(r,a,b) r=(a)<<(b)
+#define shiftRLZh(r,a,b) r=(a)>>(b)
+#define iShiftLZh(r,a,b) r=(a)<<(b)
+/* Right shifting of signed quantities is not portable in C, so
+ the behaviour you'll get from using these primops depends
+ on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
+*/
+#define iShiftRAZh(r,a,b) r=(a)>>(b)
+#define iShiftRLZh(r,a,b) r=(a)>>(b)
+
+#define int2WordZh(r,a) r=(W_)(a)
+#define word2IntZh(r,a) r=(I_)(a)
+
+/* -----------------------------------------------------------------------------
+ Addr PrimOps.
+ -------------------------------------------------------------------------- */
+
+#define int2AddrZh(r,a) r=(A_)(a)
+#define addr2IntZh(r,a) r=(I_)(a)
+
+#define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
+#define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
+#define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
+#define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
+#define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
+#define indexStablePtrOffAddrZh(r,a,i) r= ((StgStablePtr *)(a))[i]
+#ifdef SUPPORT_LONG_LONGS
+#define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i]
+#define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
+#endif
+
+#define writeCharOffAddrZh(a,i,v) ((C_ *)(a))[i] = (v)
+#define writeIntOffAddrZh(a,i,v) ((I_ *)(a))[i] = (v)
+#define writeWordOffAddrZh(a,i,v) ((W_ *)(a))[i] = (v)
+#define writeAddrOffAddrZh(a,i,v) ((PP_)(a))[i] = (v)
+#define writeForeignObjOffAddrZh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
+#define writeFloatOffAddrZh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
+#define writeDoubleOffAddrZh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
+#define writeStablePtrOffAddrZh(a,i,v) ((StgStablePtr *)(a))[i] = (v)
+#ifdef SUPPORT_LONG_LONGS
+#define writeInt64OffAddrZh(a,i,v) ((LI_ *)(a))[i] = (v)
+#define writeWord64OffAddrZh(a,i,v) ((LW_ *)(a))[i] = (v)
+#endif
+
+/* -----------------------------------------------------------------------------
+ Float PrimOps.
+ -------------------------------------------------------------------------- */
+
+#define plusFloatZh(r,a,b) r=(a)+(b)
+#define minusFloatZh(r,a,b) r=(a)-(b)
+#define timesFloatZh(r,a,b) r=(a)*(b)
+#define divideFloatZh(r,a,b) r=(a)/(b)
+#define negateFloatZh(r,a) r=-(a)
+
+#define int2FloatZh(r,a) r=(StgFloat)(a)
+#define float2IntZh(r,a) r=(I_)(a)
+
+#define expFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
+#define logFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
+#define sqrtFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
+#define sinFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
+#define cosFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
+#define tanFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
+#define asinFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
+#define acosFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
+#define atanFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
+#define sinhFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
+#define coshFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
+#define tanhFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
+#define powerFloatZh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
+
+/* -----------------------------------------------------------------------------
+ Double PrimOps.
+ -------------------------------------------------------------------------- */
+
+#define ZpZhZh(r,a,b) r=(a)+(b)
+#define ZmZhZh(r,a,b) r=(a)-(b)
+#define ZtZhZh(r,a,b) r=(a)*(b)
+#define ZdZhZh(r,a,b) r=(a)/(b)
+#define negateDoubleZh(r,a) r=-(a)
+
+#define int2DoubleZh(r,a) r=(StgDouble)(a)
+#define double2IntZh(r,a) r=(I_)(a)
+
+#define float2DoubleZh(r,a) r=(StgDouble)(a)
+#define double2FloatZh(r,a) r=(StgFloat)(a)
+
+#define expDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
+#define logDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
+#define sqrtDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
+#define sinDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
+#define cosDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
+#define tanDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
+#define asinDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
+#define acosDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
+#define atanDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
+#define sinhDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
+#define coshDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
+#define tanhDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
+/* Power: **## */
+#define ZtZtZhZh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
+
+/* -----------------------------------------------------------------------------
+ Integer PrimOps.
+ -------------------------------------------------------------------------- */
+
+/* We can do integer2Int and cmpInteger inline, since they don't need
+ * to allocate any memory.
+ */
+
+#define integer2IntZh(r, aa,sa,da) \
+{ MP_INT arg; \
+ \
+ arg._mp_alloc = (aa); \
+ arg._mp_size = (sa); \
+ arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ \
+ (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \
+}
+
+#define integer2WordZh(r, aa,sa,da) \
+{ MP_INT arg; \
+ \
+ arg._mp_alloc = (aa); \
+ arg._mp_size = (sa); \
+ arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ \
+ (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \
+}
+
+#define cmpIntegerZh(r, a1,s1,d1, a2,s2,d2) \
+{ MP_INT arg1; \
+ MP_INT arg2; \
+ \
+ arg1._mp_alloc= (a1); \
+ arg1._mp_size = (s1); \
+ arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
+ arg2._mp_alloc= (a2); \
+ arg2._mp_size = (s2); \
+ arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
+ \
+ (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \
+}
+
+/* A glorious hack: calling mpz_neg would entail allocation and
+ * copying, but by looking at what mpz_neg actually does, we can
+ * derive a better version:
+ */
+
+#define negateIntegerZh(ra, rs, rd, a, s, d) \
+{ \
+ (ra) = (a); \
+ (rs) = -(s); \
+ (rd) = d; \
+}
+
+/* The rest are all out-of-line: -------- */
+
+/* Integer arithmetic */
+EF_(plusIntegerZh_fast);
+EF_(minusIntegerZh_fast);
+EF_(timesIntegerZh_fast);
+EF_(gcdIntegerZh_fast);
+EF_(quotRemIntegerZh_fast);
+EF_(divModIntegerZh_fast);
+
+/* Conversions */
+EF_(int2IntegerZh_fast);
+EF_(word2IntegerZh_fast);
+EF_(addr2IntegerZh_fast);
+
+/* Floating-point encodings/decodings */
+EF_(encodeFloatZh_fast);
+EF_(decodeFloatZh_fast);
+
+EF_(encodeDoubleZh_fast);
+EF_(decodeDoubleZh_fast);
+
+/* -----------------------------------------------------------------------------
+ Word64 PrimOps.
+ -------------------------------------------------------------------------- */
+
+#ifdef SUPPORT_LONG_LONGS
+
+#define integerToWord64Zh(r, aa,sa,da) \
+{ unsigned long int* d; \
+ StgNat64 res; \
+ \
+ d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ if ( (aa) == 0 ) { \
+ res = (LW_)0; \
+ } else if ( (aa) == 1) { \
+ res = (LW_)d[0]; \
+ } else { \
+ res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL; \
+ } \
+ (r) = res; \
+}
+
+#define integerToInt64Zh(r, aa,sa,da) \
+{ unsigned long int* d; \
+ StgInt64 res; \
+ \
+ d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ if ( (aa) == 0 ) { \
+ res = (LI_)0; \
+ } else if ( (aa) == 1) { \
+ res = (LI_)d[0]; \
+ } else { \
+ res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL; \
+ } \
+ (r) = res; \
+}
+
+/* Conversions */
+EF_(int64ToIntegerZh_fast);
+EF_(word64ToIntegerZh_fast);
+
+/* The rest are (way!) out of line, implemented via C entry points.
+ */
+I_ stg_gtWord64 (StgNat64, StgNat64);
+I_ stg_geWord64 (StgNat64, StgNat64);
+I_ stg_eqWord64 (StgNat64, StgNat64);
+I_ stg_neWord64 (StgNat64, StgNat64);
+I_ stg_ltWord64 (StgNat64, StgNat64);
+I_ stg_leWord64 (StgNat64, StgNat64);
+
+I_ stg_gtInt64 (StgInt64, StgInt64);
+I_ stg_geInt64 (StgInt64, StgInt64);
+I_ stg_eqInt64 (StgInt64, StgInt64);
+I_ stg_neInt64 (StgInt64, StgInt64);
+I_ stg_ltInt64 (StgInt64, StgInt64);
+I_ stg_leInt64 (StgInt64, StgInt64);
+
+LW_ stg_remWord64 (StgNat64, StgNat64);
+LW_ stg_quotWord64 (StgNat64, StgNat64);
+
+LI_ stg_remInt64 (StgInt64, StgInt64);
+LI_ stg_quotInt64 (StgInt64, StgInt64);
+LI_ stg_negateInt64 (StgInt64);
+LI_ stg_plusInt64 (StgInt64, StgInt64);
+LI_ stg_minusInt64 (StgInt64, StgInt64);
+LI_ stg_timesInt64 (StgInt64, StgInt64);
+
+LW_ stg_and64 (StgNat64, StgNat64);
+LW_ stg_or64 (StgNat64, StgNat64);
+LW_ stg_xor64 (StgNat64, StgNat64);
+LW_ stg_not64 (StgNat64);
+
+LW_ stg_shiftL64 (StgNat64, StgInt);
+LW_ stg_shiftRL64 (StgNat64, StgInt);
+LI_ stg_iShiftL64 (StgInt64, StgInt);
+LI_ stg_iShiftRL64 (StgInt64, StgInt);
+LI_ stg_iShiftRA64 (StgInt64, StgInt);
+
+LI_ stg_intToInt64 (StgInt);
+I_ stg_int64ToInt (StgInt64);
+LW_ stg_int64ToWord64 (StgInt64);
+
+LW_ stg_wordToWord64 (StgWord);
+W_ stg_word64ToWord (StgNat64);
+LI_ stg_word64ToInt64 (StgNat64);
+#endif
+
+/* -----------------------------------------------------------------------------
+ Array PrimOps.
+ -------------------------------------------------------------------------- */
+
+/* We cast to void* instead of StgChar* because this avoids a warning
+ * about increasing the alignment requirements.
+ */
+#define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
+#define REAL_PTRS_ARR_CTS(a) ((P_) (((StgArrPtrs *)(a))->payload))
+
+#ifdef DEBUG
+#define BYTE_ARR_CTS(a) \
+ ({ ASSERT(GET_INFO(a) == &ARR_WORDS_info); \
+ REAL_BYTE_ARR_CTS(a); })
+#define PTRS_ARR_CTS(a) \
+ ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info) \
+ || (GET_INFO(a) == &MUT_ARR_PTRS_info));\
+ REAL_PTRS_ARR_CTS(a); })
+#else
+#define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
+#define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
+#endif
+
+/* Todo: define... */
+extern I_ genSymZh(void);
+extern I_ resetGenSymZh(void);
+extern I_ incSeqWorldZh(void);
+
+/*--- everything except new*Array is done inline: */
+
+#define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
+#define sameMutableByteArrayZh(r,a,b) r=(I_)((a)==(b))
+
+#define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
+
+#define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#ifdef SUPPORT_LONG_LONGS
+#define readInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+#endif
+
+/* result ("r") arg ignored in write macros! */
+#define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
+
+#define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeWordArrayZh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeFloatArrayZh(a,i,v) \
+ ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
+#define writeDoubleArrayZh(a,i,v) \
+ ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
+#define writeStablePtrArrayZh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
+#ifdef SUPPORT_LONG_LONGS
+#define writeInt64ArrayZh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeWord64ArrayZh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#endif
+
+#define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
+
+#define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#ifdef SUPPORT_LONG_LONGS
+#define indexInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+#endif
+
+#define indexCharOffForeignObjZh(r,fo,i) indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexIntOffForeignObjZh(r,fo,i) indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexWordOffForeignObjZh(r,fo,i) indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexAddrOffForeignObjZh(r,fo,i) indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexFloatOffForeignObjZh(r,fo,i) indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexStablePtrOffForeignObjZh(r,fo,i) indexStablePtrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#ifdef SUPPORT_LONG_LONGS
+#define indexInt64OffForeignObjZh(r,fo,i) indexInt64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexWord64OffForeignObjZh(r,fo,i) indexWord64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#endif
+
+#define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
+#define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
+#define indexWordOffAddrZh(r,a,i) r= ((W_ *)(a))[i]
+#define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
+#define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
+#define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
+#ifdef SUPPORT_LONG_LONGS
+#define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i]
+#define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
+#endif
+
+/* Freezing arrays-of-ptrs requires changing an info table, for the
+ benefit of the generational collector. It needs to scavenge mutable
+ objects, even if they are in old space. When they become immutable,
+ they can be removed from this scavenge list. */
+
+#define unsafeFreezeArrayZh(r,a) \
+ { \
+ SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info); \
+ r = a; \
+ }
+
+#define unsafeFreezeByteArrayZh(r,a) r=(a)
+
+#define sizeofByteArrayZh(r,a) \
+ r = (((StgArrWords *)(a))->words * sizeof(W_))
+#define sizeofMutableByteArrayZh(r,a) \
+ r = (((StgArrWords *)(a))->words * sizeof(W_))
+
+/* and the out-of-line ones... */
+
+EF_(newCharArrayZh_fast);
+EF_(newIntArrayZh_fast);
+EF_(newWordArrayZh_fast);
+EF_(newAddrArrayZh_fast);
+EF_(newFloatArrayZh_fast);
+EF_(newDoubleArrayZh_fast);
+EF_(newStablePtrArrayZh_fast);
+EF_(newArrayZh_fast);
+
+/* encoding and decoding of floats/doubles. */
+
+/* We only support IEEE floating point format */
+#include "ieee-flpt.h"
+
+#if FLOATS_AS_DOUBLES /* i.e. 64-bit machines */
+#define encodeFloatZh(r, aa,sa,da, expon) encodeDoubleZh(r, aa,sa,da, expon)
+#else
+#define encodeFloatZh(r, aa,sa,da, expon) \
+{ MP_INT arg; \
+ /* Does not allocate memory */ \
+ \
+ arg._mp_alloc = aa; \
+ arg._mp_size = sa; \
+ arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ \
+ r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon));\
+}
+#endif /* FLOATS_AS_DOUBLES */
+
+#define encodeDoubleZh(r, aa,sa,da, expon) \
+{ MP_INT arg; \
+ /* Does not allocate memory */ \
+ \
+ arg._mp_alloc = aa; \
+ arg._mp_size = sa; \
+ arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ \
+ r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon));\
+}
+
+/* The decode operations are out-of-line because they need to allocate
+ * a byte array.
+ */
+
+#ifdef FLOATS_AS_DOUBLES
+#define decodeFloatZh_fast decodeDoubleZh_fast
+#else
+EF_(decodeFloatZh_fast);
+#endif
+
+EF_(decodeDoubleZh_fast);
+
+/* grimy low-level support functions defined in StgPrimFloat.c */
+
+extern StgDouble __encodeDouble (MP_INT *s, I_ e);
+extern StgFloat __encodeFloat (MP_INT *s, I_ e);
+extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
+extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt);
+extern StgInt isDoubleNaN(StgDouble d);
+extern StgInt isDoubleInfinite(StgDouble d);
+extern StgInt isDoubleDenormalized(StgDouble d);
+extern StgInt isDoubleNegativeZero(StgDouble d);
+extern StgInt isFloatNaN(StgFloat f);
+extern StgInt isFloatInfinite(StgFloat f);
+extern StgInt isFloatDenormalized(StgFloat f);
+extern StgInt isFloatNegativeZero(StgFloat f);
+
+/* -----------------------------------------------------------------------------
+ Mutable variables
+
+ newMutVar is out of line.
+ -------------------------------------------------------------------------- */
+
+EF_(newMutVarZh_fast);
+
+#define readMutVarZh(r,a) r=(P_)(((StgMutVar *)(a))->var)
+#define writeMutVarZh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
+#define sameMutVarZh(r,a,b) r=(I_)((a)==(b))
+
+/* -----------------------------------------------------------------------------
+ MVar PrimOps.
+
+ All out of line, because they either allocate or may block.
+ -------------------------------------------------------------------------- */
+
+#define sameMVarZh(r,a,b) r=(I_)((a)==(b))
+EF_(newMVarZh_fast);
+EF_(takeMVarZh_fast);
+EF_(putMVarZh_fast);
+
+/* -----------------------------------------------------------------------------
+ Delay/Wait PrimOps
+ -------------------------------------------------------------------------- */
+
+/* Hmm, I'll think about these later. */
+
+/* -----------------------------------------------------------------------------
+ Primitive I/O, error-handling PrimOps
+ -------------------------------------------------------------------------- */
+
+EF_(catchZh_fast);
+EF_(raiseZh_fast);
+
+extern void stg_exit(I_ n) __attribute__ ((noreturn));
+
+/* -----------------------------------------------------------------------------
+ Stable Pointer PrimOps.
+ -------------------------------------------------------------------------- */
+
+#ifndef PAR
+
+extern StgPtr *stable_ptr_table;
+extern StgPtr *stable_ptr_free;
+#define deRefStablePtrZh(r,sp) (r=stable_ptr_table[(sp)])
+#define eqStablePtrZh(r,sp1,sp2) (r=(sp1==sp2))
+
+#define freeStablePointer(stable_ptr) \
+ { \
+ stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; \
+ stable_ptr_free = &stable_ptr_table[stable_ptr]; \
+ }
+
+EF_(makeStablePtrZh_fast);
+
+#else /* PAR */
+#define deRefStablePtrZh(ri,sp) \
+do { \
+ fflush(stdout); \
+ fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
+ stg_exit(EXIT_FAILURE); \
+} while(0)
+
+#define eqStablePtrZh(ri,sp1,sp2) \
+do { \
+ fflush(stdout); \
+ fprintf(stderr, "eqStablePtr#: no stable pointer support.\n"); \
+ stg_exit(EXIT_FAILURE); \
+} while(0)
+
+#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
+do { \
+ fflush(stdout); \
+ fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
+ EXIT(EXIT_FAILURE); \
+} while(0)
+
+#define freeStablePtrZh(stablePtr,liveness,unstablePtr) \
+do { \
+ fflush(stdout); \
+ fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
+ EXIT(EXIT_FAILURE); \
+} while(0)
+#endif
+
+
+/* -----------------------------------------------------------------------------
+ Parallel PrimOps.
+ -------------------------------------------------------------------------- */
+
+EF_(forkZh_fast);
+EF_(killThreadZh_fast);
+EF_(seqZh_fast);
+
+/* Hmm, I'll think about these later. */
+/* -----------------------------------------------------------------------------
+ Pointer equality
+ -------------------------------------------------------------------------- */
+
+/* warning: extremely non-referentially transparent, need to hide in
+ an appropriate monad.
+
+ ToDo: follow indirections.
+*/
+
+#define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
+
+/* -----------------------------------------------------------------------------
+ Weak Pointer PrimOps.
+ -------------------------------------------------------------------------- */
+
+#ifndef PAR
+
+EF_(mkWeakZh_fast);
+EF_(deRefWeakZh_fast);
+#define sameWeakZh(w1,w2) ((w1)==(w2))
+
+#endif
+
+/* -----------------------------------------------------------------------------
+ Foreign Object PrimOps.
+ -------------------------------------------------------------------------- */
+
+#ifndef PAR
+
+#define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
+
+EF_(makeForeignObjZh_fast);
+
+#define writeForeignObjZh(res,datum) \
+ (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
+
+#define eqForeignObj(f1,f2) ((f1)==(f2))
+
+#endif
+
+/* -----------------------------------------------------------------------------
+ Signal processing. Not really primops, but called directly from
+ Haskell.
+ -------------------------------------------------------------------------- */
+
+#define STG_SIG_DFL (-1)
+#define STG_SIG_IGN (-2)
+#define STG_SIG_ERR (-3)
+#define STG_SIG_HAN (-4)
+
+extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
+#define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
+#define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
+#define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
+
+#endif PRIMOPS_H
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Profiling.h,v 1.2 1998/12/02 13:21:19 simonm Exp $
+ *
+ * Cost-Centre Stack Profiling Include
+ * ---------------------------------------------------------------------------*/
+
+
+#ifndef PROFILING_H
+#define PROFILING_H
+
+#if !defined(PROFILING)
+
+#define CCS_ALLOC(ccs, amount) doNothing()
+#define ENTER_CC_PAP_CL(r) doNothing()
+#define ENTER_CCS_PAP_CL(r) doNothing()
+
+#else /* PROFILING... */
+
+/* -----------------------------------------------------------------------------
+ * Constants
+ * ---------------------------------------------------------------------------*/
+
+#define EMPTY_STACK NULL
+#define EMPTY_TABLE NULL
+
+/* Constants used to set sumbsumed flag on CostCentres */
+
+#define CC_IS_CAF 'c' /* 'c' => *is* a CAF cc */
+#define CC_IS_DICT 'd' /* 'd' => *is* a dictionary cc */
+#define CC_IS_SUBSUMED 's' /* 's' => *is* a subsumed cc */
+#define CC_IS_BORING 'B' /* 'B' => *not* a CAF/dict/sub cc */
+
+/* Constants used for abreviated output of data in binary format. The order
+ * is important and corresponds to the "item" elementType in the XML log
+ * description. */
+
+#define END_TAG 0
+#define CC_TAG 1
+#define CCS_TAG 2
+#define TYPE_CON_TAG 3
+#define HEAP_OBJ_TAG 4
+#define TIME_UPDATE_TAG 5
+#define HEAP_UPDATE_TAG 6
+
+
+/* -----------------------------------------------------------------------------
+ * Data Structures
+ * ---------------------------------------------------------------------------*/
+/*
+ * CostCentre
+ */
+
+typedef struct _CostCentre {
+ int ccID;
+
+ char *label;
+ char *module;
+ char *group;
+
+ char is_subsumed;
+
+ struct _CostCentre *link;
+} CostCentre;
+
+
+
+/*
+ * CostCentreStack
+ */
+
+typedef struct _CostCentreStack {
+ int ccsID;
+
+ CostCentre *cc;
+ struct _CostCentreStack *prevStack;
+ struct _IndexTable *indexTable;
+
+ unsigned long scc_count;
+ unsigned long sub_scc_count;
+ unsigned long sub_cafcc_count;
+ unsigned long sub_dictcc_count;
+
+ unsigned long time_ticks;
+ unsigned long mem_alloc;
+
+ char is_subsumed; /* inherits value from is_subsumed flag of top CostCentre */
+} CostCentreStack;
+
+
+
+/*
+ * IndexTable
+ */
+
+typedef struct _IndexTable {
+ CostCentre *cc;
+ CostCentreStack *ccs;
+ struct _IndexTable *next;
+} IndexTable;
+
+
+/*
+ * CCSDeclist
+ */
+
+typedef struct _CCSDecList {
+ CostCentreStack *ccs;
+ struct _CCSDecList *nextList;
+} CCSDecList;
+
+
+/* -----------------------------------------------------------------------------
+ Pre-defined cost centres and cost centre stacks
+ -------------------------------------------------------------------------- */
+
+extern CostCentreStack *CCCS; /* current CCS */
+
+extern CostCentre CC_MAIN[];
+extern CostCentreStack CCS_MAIN[]; /* Top CCS */
+
+extern CostCentre CC_SYSTEM[];
+extern CostCentreStack CCS_SYSTEM[]; /* RTS costs */
+
+extern CostCentre CC_GC[];
+extern CostCentreStack CCS_GC[]; /* Garbage collector costs */
+
+extern CostCentre CC_SUBSUMED[];
+extern CostCentreStack CCS_SUBSUMED[]; /* Costs are subsumed by caller */
+
+extern CostCentre CC_OVERHEAD[];
+extern CostCentreStack CCS_OVERHEAD[]; /* Profiling overhead */
+
+extern CostCentre CC_DONTZuCARE[];
+extern CostCentreStack CCS_DONTZuCARE[]; /* shouldn't ever get set */
+
+extern unsigned int CC_ID; /* global id's */
+extern unsigned int CCS_ID;
+extern unsigned int HP_ID;
+
+extern unsigned int interval_ticks;
+extern unsigned int earlier_ticks;
+
+typedef unsigned int hash_t;
+extern hash_t time_intervals;
+
+/* In RtsFlags.c, these are used to specify how to hash the data for
+ * output. None of this is necessary now since the viewer will be in
+ * charge of ordering and displaying output. */
+extern hash_t max_cc_no; /* Hash on CC ptr */
+extern hash_t max_mod_no; /* Hash on CC module */
+extern hash_t max_grp_no; /* Hash on CC group */
+extern hash_t max_descr_no; /* Hash on closure description */
+extern hash_t max_type_no; /* Hash on type description */
+
+/* -----------------------------------------------------------------------------
+ * Functions
+ * ---------------------------------------------------------------------------*/
+
+CostCentreStack *PushCostCentre ( CostCentreStack *, CostCentre * );
+CostCentreStack *ActualPush ( CostCentreStack *, CostCentre * );
+CostCentreStack *RemoveCC ( CostCentreStack *, CostCentre * );
+
+CostCentreStack *IsInIndexTable ( IndexTable *, CostCentre * );
+IndexTable *AddToIndexTable ( IndexTable *, CostCentreStack *, CostCentre * );
+
+#endif /* PROFILING */
+
+#endif PROFILING_H
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Regs.h,v 1.2 1998/12/02 13:21:20 simonm Exp $
+ *
+ * Registers used in STG code. Might or might not correspond to
+ * actual machine registers.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef REGS_H
+#define REGS_H
+
+/*
+ * This file should do the right thing if we have no machine-registers
+ * defined, i.e. everything lives in the RegTable.
+ */
+
+/*
+ * This is the table that holds shadow-locations for all the STG
+ * registers. The shadow locations are used when:
+ *
+ * 1) the particular register isn't mapped to a real machine
+ * register, probably because there's a shortage of real registers.
+ * 2) caller-saves registers are saved across a CCall
+ */
+
+typedef struct {
+ StgUnion rR1;
+ StgUnion rR2;
+ StgUnion rR3;
+ StgUnion rR4;
+ StgUnion rR5;
+ StgUnion rR6;
+ StgUnion rR7;
+ StgUnion rR8;
+ StgUnion rR9; /* used occasionally by heap/stack checks */
+ StgUnion rR10; /* used occasionally by heap/stack checks */
+ StgFloat rF1;
+ StgFloat rF2;
+ StgFloat rF3;
+ StgFloat rF4;
+ StgDouble rD1;
+ StgDouble rD2;
+ StgNat64 rL1;
+ StgPtr rSp;
+ StgUpdateFrame *rSu;
+ StgPtr rSpLim;
+ StgPtr rHp;
+ StgPtr rHpLim;
+} StgRegTable;
+
+extern StgRegTable MainRegTable;
+
+/*
+ * Registers Hp and HpLim are global across the entire system, and are
+ * copied into the RegTable before executing a thread.
+ *
+ * Registers Sp, Su, and SpLim are saved in the TSO for the
+ * thread, but are copied into the RegTable before executing a thread.
+ *
+ * All other registers are "general purpose", and are used for passing
+ * arguments to functions, and returning values. The code generator
+ * knows how many of these are in real registers, and avoids
+ * generating code that uses non-real registers. General purpose
+ * registers are never saved when returning to the scheduler, instead
+ * we save whatever is live at the time on the stack, and restore it
+ * later. This should reduce the context switch time, amongst other
+ * things.
+ *
+ * For argument passing, the stack will be used in preference to
+ * pseudo-registers if the architecture has too few general purpose
+ * registers.
+ *
+ * Some special RTS functions like newArray and the Integer primitives
+ * expect their arguments to be in registers R1-Rn, so we use these
+ * (pseudo-)registers in those cases.
+ */
+
+/*
+ * Locations for saving per-thread registers.
+ */
+
+#define SAVE_Sp (CurrentTSO->sp)
+#define SAVE_Su (CurrentTSO->su)
+#define SAVE_SpLim (CurrentTSO->splim)
+
+#define SAVE_Hp (MainRegTable.rHp)
+#define SAVE_HpLim (MainRegTable.rHpLim)
+
+/* We sometimes need to save registers across a C-call, eg. if they
+ * are clobbered in the standard calling convention. We define the
+ * save locations for all registers in the register table.
+ */
+
+#define SAVE_R1 (MainRegTable.rR1)
+#define SAVE_R2 (MainRegTable.rR2)
+#define SAVE_R3 (MainRegTable.rR3)
+#define SAVE_R4 (MainRegTable.rR4)
+#define SAVE_R5 (MainRegTable.rR5)
+#define SAVE_R6 (MainRegTable.rR6)
+#define SAVE_R7 (MainRegTable.rR7)
+#define SAVE_R8 (MainRegTable.rR8)
+
+#define SAVE_F1 (MainRegTable.rF1)
+#define SAVE_F2 (MainRegTable.rF2)
+#define SAVE_F3 (MainRegTable.rF3)
+#define SAVE_F4 (MainRegTable.rF4)
+
+#define SAVE_D1 (MainRegTable.rD1)
+#define SAVE_D2 (MainRegTable.rD2)
+
+#define SAVE_L1 (MainRegTable.rL1)
+
+/* -----------------------------------------------------------------------------
+ * Emit the GCC-specific register declarations for each machine
+ * register being used. If any STG register isn't mapped to a machine
+ * register, then map it to an offset from BaseReg.
+ *
+ * First, the general purpose registers. The idea is, if a particular
+ * general-purpose STG register can't be mapped to a real machine
+ * register, it won't be used at all. Instead, we'll use the stack.
+ *
+ * This is an improvement on the way things used to be done, when all
+ * registers were mapped to locations in the register table, and stuff
+ * was being shifted from the stack to the register table and back
+ * again for no good reason (on register-poor architectures).
+ */
+
+#define GLOBAL_REG_DECL(type,name,reg) register type name REG(reg);
+
+#ifdef REG_R1
+GLOBAL_REG_DECL(StgUnion,R1,REG_R1)
+#else
+#define R1 (BaseReg->rR1)
+#endif
+
+#ifdef REG_R2
+GLOBAL_REG_DECL(StgUnion,R2,REG_R2)
+#else
+#define R2 (BaseReg->rR2)
+#endif
+
+#ifdef REG_R3
+GLOBAL_REG_DECL(StgUnion,R3,REG_R3)
+#else
+# define R3 (BaseReg->rR3)
+#endif
+
+#ifdef REG_R4
+GLOBAL_REG_DECL(StgUnion,R4,REG_R4)
+#else
+# define R4 (BaseReg->rR4)
+#endif
+
+#ifdef REG_R5
+GLOBAL_REG_DECL(StgUnion,R5,REG_R5)
+#else
+# define R5 (BaseReg->rR5)
+#endif
+
+#ifdef REG_R6
+GLOBAL_REG_DECL(StgUnion,R6,REG_R6)
+#else
+# define R6 (BaseReg->rR6)
+#endif
+
+#ifdef REG_R7
+GLOBAL_REG_DECL(StgUnion,R7,REG_R7)
+#else
+# define R7 (BaseReg->rR7)
+#endif
+
+#ifdef REG_R8
+GLOBAL_REG_DECL(StgUnion,R8,REG_R8)
+#else
+# define R8 (BaseReg->rR8)
+#endif
+
+#ifdef REG_R9
+GLOBAL_REG_DECL(StgUnion,R9,REG_R9)
+#else
+# define R9 (BaseReg->rR9)
+#endif
+
+#ifdef REG_R10
+GLOBAL_REG_DECL(StgUnion,R10,REG_R10)
+#else
+# define R10 (BaseReg->rR10)
+#endif
+
+#ifdef REG_F1
+GLOBAL_REG_DECL(StgFloat,F1,REG_F1)
+#else
+#define F1 (BaseReg->rF1)
+#endif
+
+#ifdef REG_F2
+GLOBAL_REG_DECL(StgFloat,F2,REG_F2)
+#else
+#define F2 (BaseReg->rF2)
+#endif
+
+#ifdef REG_F3
+GLOBAL_REG_DECL(StgFloat,F3,REG_F3)
+#else
+#define F3 (BaseReg->rF3)
+#endif
+
+#ifdef REG_F4
+GLOBAL_REG_DECL(StgFloat,F4,REG_F4)
+#else
+#define F4 (BaseReg->rF4)
+#endif
+
+#ifdef REG_D1
+GLOBAL_REG_DECL(StgDouble,D1,REG_D1)
+#else
+#define D1 (BaseReg->rD1)
+#endif
+
+#ifdef REG_D2
+GLOBAL_REG_DECL(StgDouble,D2,REG_D2)
+#else
+#define D2 (BaseReg->rD2)
+#endif
+
+#ifdef REG_L1
+GLOBAL_REG_DECL(StgNat64,L1,REG_L1)
+#else
+#define L1 (BaseReg->rL1)
+#endif
+
+/*
+ * If BaseReg isn't mapped to a machine register, just use the global
+ * address of the current register table (CurrentRegTable in
+ * concurrent Haskell, MainRegTable otherwise).
+ */
+
+#ifdef REG_Base
+GLOBAL_REG_DECL(StgRegTable *,BaseReg,REG_Base)
+#else
+#define BaseReg (&MainRegTable)
+#endif
+
+#ifdef REG_Sp
+GLOBAL_REG_DECL(P_,Sp,REG_Sp)
+#else
+#define Sp (BaseReg->rSp)
+#endif
+
+#ifdef REG_Su
+GLOBAL_REG_DECL(StgUpdateFrame *,Su,REG_Su)
+#else
+#define Su (BaseReg->rSu)
+#endif
+
+#ifdef REG_SpLim
+GLOBAL_REG_DECL(P_,SpLim,REG_SpLim)
+#else
+#define SpLim (BaseReg->rSpLim)
+#endif
+
+#ifdef REG_Hp
+GLOBAL_REG_DECL(P_,Hp,REG_Hp)
+#else
+#define Hp (BaseReg->rHp)
+#endif
+
+#ifdef REG_HpLim
+GLOBAL_REG_DECL(P_,HpLim,REG_HpLim)
+#else
+#define HpLim (BaseReg->rHpLim)
+#endif
+
+/* -----------------------------------------------------------------------------
+ For any registers which are denoted "caller-saves" by the C calling
+ convention, we have to emit code to save and restore them across C
+ calls.
+ -------------------------------------------------------------------------- */
+
+#ifdef CALLER_SAVES_R1
+#define CALLER_SAVE_R1 SAVE_R1 = R1;
+#define CALLER_RESTORE_R1 R1 = SAVE_R1;
+#else
+#define CALLER_SAVE_R1 /* nothing */
+#define CALLER_RESTORE_R1 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R2
+#define CALLER_SAVE_R2 SAVE_R2 = R2;
+#define CALLER_RESTORE_R2 R2 = SAVE_R2;
+#else
+#define CALLER_SAVE_R2 /* nothing */
+#define CALLER_RESTORE_R2 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R3
+#define CALLER_SAVE_R3 SAVE_R3 = R3;
+#define CALLER_RESTORE_R3 R3 = SAVE_R3;
+#else
+#define CALLER_SAVE_R3 /* nothing */
+#define CALLER_RESTORE_R3 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R4
+#define CALLER_SAVE_R4 SAVE_R4 = R4;
+#define CALLER_RESTORE_R4 R4 = SAVE_R4;
+#else
+#define CALLER_SAVE_R4 /* nothing */
+#define CALLER_RESTORE_R4 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R5
+#define CALLER_SAVE_R5 SAVE_R5 = R5;
+#define CALLER_RESTORE_R5 R5 = SAVE_R5;
+#else
+#define CALLER_SAVE_R5 /* nothing */
+#define CALLER_RESTORE_R5 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R6
+#define CALLER_SAVE_R6 SAVE_R6 = R6;
+#define CALLER_RESTORE_R6 R6 = SAVE_R6;
+#else
+#define CALLER_SAVE_R6 /* nothing */
+#define CALLER_RESTORE_R6 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R7
+#define CALLER_SAVE_R7 SAVE_R7 = R7;
+#define CALLER_RESTORE_R7 R7 = SAVE_R7;
+#else
+#define CALLER_SAVE_R7 /* nothing */
+#define CALLER_RESTORE_R7 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R8
+#define CALLER_SAVE_R8 SAVE_R8 = R8;
+#define CALLER_RESTORE_R8 R8 = SAVE_R8;
+#else
+#define CALLER_SAVE_R8 /* nothing */
+#define CALLER_RESTORE_R8 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R9
+#define CALLER_SAVE_R9 SAVE_R9 = R9;
+#define CALLER_RESTORE_R9 R9 = SAVE_R9;
+#else
+#define CALLER_SAVE_R9 /* nothing */
+#define CALLER_RESTORE_R9 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_R10
+#define CALLER_SAVE_R10 SAVE_R10 = R10;
+#define CALLER_RESTORE_R10 R10 = SAVE_R10;
+#else
+#define CALLER_SAVE_R10 /* nothing */
+#define CALLER_RESTORE_R10 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_F1
+#define CALLER_SAVE_F1 SAVE_F1 = F1;
+#define CALLER_RESTORE_F1 F1 = SAVE_F1;
+#else
+#define CALLER_SAVE_F1 /* nothing */
+#define CALLER_RESTORE_F1 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_F2
+#define CALLER_SAVE_F2 SAVE_F2 = F2;
+#define CALLER_RESTORE_F2 F2 = SAVE_F2;
+#else
+#define CALLER_SAVE_F2 /* nothing */
+#define CALLER_RESTORE_F2 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_F3
+#define CALLER_SAVE_F3 SAVE_F3 = F3;
+#define CALLER_RESTORE_F3 F3 = SAVE_F3;
+#else
+#define CALLER_SAVE_F3 /* nothing */
+#define CALLER_RESTORE_F3 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_F4
+#define CALLER_SAVE_F4 SAVE_F4 = F4;
+#define CALLER_RESTORE_F4 F4 = SAVE_F4;
+#else
+#define CALLER_SAVE_F4 /* nothing */
+#define CALLER_RESTORE_F4 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_D1
+#define CALLER_SAVE_D1 SAVE_D1 = D1;
+#define CALLER_RESTORE_D1 D1 = SAVE_D1;
+#else
+#define CALLER_SAVE_D1 /* nothing */
+#define CALLER_RESTORE_D1 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_D2
+#define CALLER_SAVE_D2 SAVE_D2 = D2;
+#define CALLER_RESTORE_D2 D2 = SAVE_D2;
+#else
+#define CALLER_SAVE_D2 /* nothing */
+#define CALLER_RESTORE_D2 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_L1
+#define CALLER_SAVE_L1 SAVE_L1 = L1;
+#define CALLER_RESTORE_L1 L1 = SAVE_L1;
+#else
+#define CALLER_SAVE_L1 /* nothing */
+#define CALLER_RESTORE_L1 /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_Sp
+#define CALLER_SAVE_Sp SAVE_Sp = Sp;
+#define CALLER_RESTORE_Sp Sp = SAVE_Sp;
+#else
+#define CALLER_SAVE_Sp /* nothing */
+#define CALLER_RESTORE_Sp /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_Su
+#define CALLER_SAVE_Su SAVE_Su = Su;
+#define CALLER_RESTORE_Su Su = SAVE_Su;
+#else
+#define CALLER_SAVE_Su /* nothing */
+#define CALLER_RESTORE_Su /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_SpLim
+#define CALLER_SAVE_SpLim SAVE_SpLim = SpLim;
+#define CALLER_RESTORE_SpLim SpLim = SAVE_SpLim;
+#else
+#define CALLER_SAVE_SpLim /* nothing */
+#define CALLER_RESTORE_SpLim /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_Hp
+#define CALLER_SAVE_Hp SAVE_Hp = Hp;
+#define CALLER_RESTORE_Hp Hp = SAVE_Hp;
+#else
+#define CALLER_SAVE_Hp /* nothing */
+#define CALLER_RESTORE_Hp /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_HpLim
+#define CALLER_SAVE_HpLim SAVE_HpLim = HpLim;
+#define CALLER_RESTORE_HpLim HpLim = SAVE_HpLim;
+#else
+#define CALLER_SAVE_HpLim /* nothing */
+#define CALLER_RESTORE_HpLim /* nothing */
+#endif
+
+#ifdef CALLER_SAVES_Base
+#define CALLER_SAVE_Base /* nothing */
+#define CALLER_RESTORE_Base BaseReg = &MainRegTable;
+#else
+#define CALLER_SAVE_Base /* nothing */
+#define CALLER_RESTORE_Base /* nothing */
+#endif
+
+/* ----------------------------------------------------------------------------
+ Handy bunches of saves/restores
+ ------------------------------------------------------------------------ */
+
+#define CALLER_SAVE_USER \
+ CALLER_SAVE_R1 \
+ CALLER_SAVE_R2 \
+ CALLER_SAVE_R3 \
+ CALLER_SAVE_R4 \
+ CALLER_SAVE_R5 \
+ CALLER_SAVE_R6 \
+ CALLER_SAVE_R7 \
+ CALLER_SAVE_R8 \
+ CALLER_SAVE_F1 \
+ CALLER_SAVE_F2 \
+ CALLER_SAVE_F3 \
+ CALLER_SAVE_F4 \
+ CALLER_SAVE_D1 \
+ CALLER_SAVE_D2 \
+ CALLER_SAVE_L1
+
+#define CALLER_SAVE_SYSTEM \
+ CALLER_SAVE_Sp \
+ CALLER_SAVE_Su \
+ CALLER_SAVE_SpLim \
+ CALLER_SAVE_Hp \
+ CALLER_SAVE_HpLim
+
+#define CALLER_RESTORE_USER \
+ CALLER_RESTORE_R1 \
+ CALLER_RESTORE_R2 \
+ CALLER_RESTORE_R3 \
+ CALLER_RESTORE_R4 \
+ CALLER_RESTORE_R5 \
+ CALLER_RESTORE_R6 \
+ CALLER_RESTORE_R7 \
+ CALLER_RESTORE_R8 \
+ CALLER_RESTORE_F1 \
+ CALLER_RESTORE_F2 \
+ CALLER_RESTORE_F3 \
+ CALLER_RESTORE_F4 \
+ CALLER_RESTORE_D1 \
+ CALLER_RESTORE_D2 \
+ CALLER_RESTORE_L1
+
+#define CALLER_RESTORE_SYSTEM \
+ CALLER_RESTORE_Base \
+ CALLER_RESTORE_Sp \
+ CALLER_RESTORE_Su \
+ CALLER_RESTORE_SpLim \
+ CALLER_RESTORE_Hp \
+ CALLER_RESTORE_HpLim
+
+#define CALLER_SAVE_ALL \
+ CALLER_SAVE_SYSTEM \
+ CALLER_SAVE_USER
+
+#define CALLER_RESTORE_ALL \
+ CALLER_RESTORE_SYSTEM \
+ CALLER_RESTORE_USER
+
+#endif /* REGS_H */
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Rts.h,v 1.2 1998/12/02 13:21:21 simonm Exp $
+ *
+ * Top-level include file for the RTS itself
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef RTS_H
+#define RTS_H
+
+#ifndef NO_REGS
+#define NO_REGS /* don't define fixed registers */
+#endif
+#include "Stg.h"
+
+/* -----------------------------------------------------------------------------
+ Miscellaneous garbage
+ -------------------------------------------------------------------------- */
+
+#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.
+*/
+#define EXIT_SUCCESS 0
+#define EXIT_FAILURE 1
+#endif
+
+/* declarations for runtime flags/values */
+#define MAX_RTS_ARGS 32
+
+/* -----------------------------------------------------------------------------
+ Useful typedefs
+ -------------------------------------------------------------------------- */
+
+typedef unsigned int nat; /* at least 32 bits (like int) */
+typedef unsigned long lnat; /* at least 32 bits */
+typedef unsigned long long ullong; /* at least 32 bits */
+
+typedef enum {
+ rtsFalse = 0,
+ rtsTrue
+} rtsBool;
+
+/* -----------------------------------------------------------------------------
+ Assertions and Debuggery
+ -------------------------------------------------------------------------- */
+
+#ifndef DEBUG
+#define ASSERT(predicate) /* nothing */
+#else
+
+void _stgAssert (char *, unsigned int);
+
+#define ASSERT(predicate) \
+ if (predicate) \
+ /*null*/; \
+ else \
+ _stgAssert(__FILE__, __LINE__)
+
+#endif /* DEBUG */
+
+#ifndef DEBUG
+#define IF_DEBUG(c,s) doNothing()
+#else
+#define IF_DEBUG(c,s) if (RtsFlags.DebugFlags.c) { s; }
+#endif
+
+/* -----------------------------------------------------------------------------
+ Attributes
+ -------------------------------------------------------------------------- */
+
+#ifdef __GNUC__ /* Avoid spurious warnings */
+#if __GNUC__ >= 2 && __GNUC_MINOR__ >= 7
+#define STG_NORETURN __attribute__ ((noreturn))
+#define STG_UNUSED __attribute__ ((unused))
+#else
+#define STG_NORETURN
+#define STG_UNUSED
+#endif
+#else
+#define STG_NORETURN
+#define STG_UNUSED
+#endif
+
+/* -----------------------------------------------------------------------------
+ Useful macros and inline functions
+ -------------------------------------------------------------------------- */
+
+/*
+ * Use this on the RHS of macros which expand to nothing
+ * to make sure that the macro can be used in a context which
+ * demands a non-empty statement.
+ */
+
+#define doNothing() do { } while (0)
+
+#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })
+#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })
+
+
+#define UNUSED __attribute__((unused))
+
+#endif RTS_H
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: RtsAPI.h,v 1.2 1998/12/02 13:21:21 simonm Exp $
+ *
+ * API for invoking Haskell functions via the RTS
+ *
+ * --------------------------------------------------------------------------*/
+
+#ifndef RTSAPI_H
+#define RTSAPI_H
+
+#include "SchedAPI.h" /* for SchedulerStatus */
+
+typedef StgClosure *HaskellObj;
+
+/* ----------------------------------------------------------------------------
+ Starting up and shutting down the Haskell RTS.
+ ------------------------------------------------------------------------- */
+extern void startupHaskell ( int argc, char *argv[] );
+extern void shutdownHaskell ( void );
+
+/* ----------------------------------------------------------------------------
+ Building Haskell objects from C datatypes.
+ ------------------------------------------------------------------------- */
+HaskellObj rts_mkChar ( char c );
+HaskellObj rts_mkInt ( int i );
+HaskellObj rts_mkInt8 ( int i );
+HaskellObj rts_mkInt16 ( int i );
+HaskellObj rts_mkInt32 ( int i );
+HaskellObj rts_mkInt64 ( long long i );
+HaskellObj rts_mkWord ( unsigned int w );
+HaskellObj rts_mkWord8 ( unsigned int w );
+HaskellObj rts_mkWord16 ( unsigned int w );
+HaskellObj rts_mkWord32 ( unsigned int w );
+HaskellObj rts_mkWord64 ( unsigned long long w );
+HaskellObj rts_mkFloat ( float f );
+HaskellObj rts_mkDouble ( double f );
+HaskellObj rts_mkStablePtr ( StgStablePtr s );
+HaskellObj rts_mkAddr ( void *a );
+HaskellObj rts_mkBool ( int b );
+HaskellObj rts_mkString ( char *s );
+
+HaskellObj rts_apply ( HaskellObj, HaskellObj );
+
+/* ----------------------------------------------------------------------------
+ Deconstructing Haskell objects
+ ------------------------------------------------------------------------- */
+char rts_getChar ( HaskellObj );
+int rts_getInt ( HaskellObj );
+unsigned int rts_getWord ( HaskellObj );
+float rts_getFloat ( HaskellObj );
+double rts_getDouble ( HaskellObj );
+StgStablePtr rts_getStablePtr ( HaskellObj );
+void * rts_getAddr ( HaskellObj );
+int rts_getBool ( HaskellObj );
+
+/* ----------------------------------------------------------------------------
+ Evaluating Haskell expressions
+
+ The versions ending in '_' allow you to specify an initial stack size.
+ ------------------------------------------------------------------------- */
+SchedulerStatus
+rts_eval ( HaskellObj p, /*out*/HaskellObj *ret );
+
+SchedulerStatus
+rts_eval_ ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret );
+
+SchedulerStatus
+rts_evalIO ( HaskellObj p, /*out*/HaskellObj *ret );
+
+SchedulerStatus
+rts_evalIO_ ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret );
+
+void
+rts_checkSchedStatus ( char* site, SchedulerStatus rc);
+
+#endif /* RTSAPI_H */
+++ /dev/null
-\begin{code}
-#ifndef RTSFLAGS_H
-#define RTSFLAGS_H
-\end{code}
-
-For defaults, see the @initRtsFlagsDefaults@ routine.
-
-\begin{code}
-struct GC_FLAGS {
- FILE *statsFile;
- I_ giveStats; /* ToDo: replace with enum type? */
-#define NO_GC_STATS 0
-#define VERBOSE_GC_STATS 1
-
- I_ stksSize; /* this size is stored to record number of *words* */
- I_ heapSize; /* this size is stored to record number of *words* */
- I_ allocAreaSize;
- rtsBool allocAreaSizeGiven;
- I_ specifiedOldGenSize; /* zero => use the rest of the heap */
- double pcFreeHeap;
- I_ minAllocAreaSize; /* derived from: pcFreeHeap, heap-size */
-
- rtsBool force2s; /* force the use of 2-space copying collection;
- forced to rtsTrue if we do *heap* profiling.
- */
- rtsBool forceGC; /* force a major GC every <interval> bytes */
- I_ forcingInterval; /* actually, stored as a number of *words* */
- rtsBool ringBell;
- W_ trace;
- /* bit 1 set: chatty GC summaries
- 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 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_FOREIGNOBJS 16
-#define DEBUG_TRACE_CONCURRENT 32
-
- rtsBool lazyBlackHoling;
- rtsBool doSelectorsAtGC;
- rtsBool squeezeUpdFrames;
-};
-
-struct DEBUG_FLAGS {
-};
-
-#if defined(PROFILING) || defined(PAR)
- /* with PROFILING, full cost-centre stuff (also PROFILING_FLAGS);
- with PAR, just the four fixed cost-centres.
- */
-struct COST_CENTRE_FLAGS {
- W_ doCostCentres;
-# define COST_CENTRES_SUMMARY 1
-# define COST_CENTRES_VERBOSE 2 /* incl. serial time profile */
-# define COST_CENTRES_ALL 3
-
- char sortBy;
-# define SORTCC_LABEL 'C'
-# define SORTCC_TIME 'T'
-# define SORTCC_ALLOC 'A'
-
- I_ ctxtSwitchTicks; /* derived */
- I_ profilerTicks; /* derived */
- I_ msecsPerTick; /* derived */
-};
-#endif
-
-#ifdef PROFILING
-struct PROFILING_FLAGS {
- W_ doHeapProfile;
-# define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */
-# define HEAP_BY_CC 1
-# define HEAP_BY_MOD 2
-# define HEAP_BY_GRP 3
-# define HEAP_BY_DESCR 4
-# define HEAP_BY_TYPE 5
-# define HEAP_BY_TIME 6
-
-# define CCchar 'C'
-# define MODchar 'M'
-# define GRPchar 'G'
-# define DESCRchar 'D'
-# define TYPEchar 'Y'
-# define TIMEchar 'T'
-
- char *ccSelector;
- char *modSelector;
- char *grpSelector;
- char *descrSelector;
- char *typeSelector;
- char *kindSelector;
-};
-#endif
-
-#ifdef CONCURRENT
-struct CONCURRENT_FLAGS {
- I_ ctxtSwitchTime; /* in milliseconds */
- I_ maxThreads;
- I_ stkChunkSize;
- I_ maxLocalSparks;
-};
-#endif /* CONCURRENT */
-
-#ifdef PAR
-struct PAR_FLAGS {
- rtsBool parallelStats; /* Gather parallel statistics */
- rtsBool granSimStats; /* Full .gr profile (rtsTrue) or only END events? */
- rtsBool granSimStats_Binary;
-
- rtsBool outputDisabled; /* Disable output for performance purposes */
-
- W_ packBufferSize;
-};
-
-#endif /* PAR */
-
-#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 */
-
-#ifdef TICKY_TICKY
-struct TICKY_FLAGS {
- rtsBool showTickyStats;
- FILE *tickyFile;
-
- /* see also: doUpdEntryCounts in AllFlags */
-};
-#endif /* TICKY_TICKY */
-\end{code}
-
-Put them together:
-\begin{code}
-struct RTS_FLAGS {
- struct GC_FLAGS GcFlags;
- struct DEBUG_FLAGS DebugFlags; /* unused at present */
-
-#if defined(PROFILING) || defined(PAR)
- struct COST_CENTRE_FLAGS CcFlags;
-#endif
-#ifdef PROFILING
- struct PROFILING_FLAGS ProfFlags;
-#endif
-#ifdef CONCURRENT
- struct CONCURRENT_FLAGS ConcFlags;
-#endif
-#ifdef PAR
- struct PAR_FLAGS ParFlags;
-#endif
-#ifdef GRAN
- struct GRAN_FLAGS GranFlags;
-#endif
-#ifdef TICKY_TICKY
- struct TICKY_FLAGS TickyFlags;
-#endif
-};
-
-extern struct RTS_FLAGS RTSflags;
-\end{code}
-
-Routines that operate-on/to-do-with RTS flags:
-\begin{code}
-void initRtsFlagsDefaults (STG_NO_ARGS);
-void setupRtsFlags PROTO((int *argc, char *argv[],
- int *rts_argc, char *rts_argv[]));
-\end{code}
-
-OLD: This is the maximum identifier length that can be used for a cost
-centre or description string. It includes the terminating null
-character.
-
-The printf formats are here, so we are less likely to make overly-long
-filenames (with disastrous results). No more than 128 chars, please!
-
-\begin{code}
-#define STATS_FILENAME_MAXLEN 128
-
-#define GR_FILENAME_FMT "%0.124s.gr"
-#define GR_FILENAME_FMT_GUM "%0.120s.%03d.%s"
-#define HP_FILENAME_FMT "%0.124s.hp"
-#define LIFE_FILENAME_FMT "%0.122s.life"
-#define PROF_FILENAME_FMT "%0.122s.prof"
-#define PROF_FILENAME_FMT_GUM "%0.118s.%03d.prof"
-#define QP_FILENAME_FMT "%0.124s.qp"
-#define STAT_FILENAME_FMT "%0.122s.stat"
-#define TICKY_FILENAME_FMT "%0.121s.ticky"
-#define TIME_FILENAME_FMT "%0.122s.time"
-#define TIME_FILENAME_FMT_GUM "%0.118s.%03d.time"
-\end{code}
-
-Multi-slurp protection:
-\begin{code}
-#endif /* RTSFLAGS_H */
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section{How data is handled within the RTS}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifndef RTSTYPES_H
-#define RTSTYPES_H
-\end{code}
-
-For all of you boolean crazies out there...
-
-\begin{code}
-
-typedef enum {
- rtsFalse = 0,
- rtsTrue
-} rtsBool;
-
-\end{code}
-
-Hash tables for GUM are ADTs. Peek inside, and I'll have to kill you.
-The same goes for hash list cells.
-
-\begin{code}
-#ifdef PAR
-typedef struct hashtable HashTable;
-typedef struct hashlist HashList;
-
-typedef double REAL_TIME;
-typedef int GLOBAL_TASK_ID;
-typedef int PACKET;
-typedef int OPCODE;
-
-/* Global addresses, in all their glory */
-
-typedef struct {
- union {
- P_ plc;
- struct {
- GLOBAL_TASK_ID gtid;
- int slot;
- } gc;
- } loc;
- unsigned weight;
-} globalAddr;
-
-/* (GA, LA) pairs */
-typedef struct gala {
- globalAddr ga;
- P_ la;
- struct gala *next;
- rtsBool preferred;
-} GALA;
-
-#endif
-
-#if defined(GRAN)
-typedef unsigned long TIME;
-typedef unsigned char PROC;
-typedef unsigned char EVTTYPE;
-#endif
-
-#if defined(PAR)
-typedef W_ TIME;
-typedef GLOBAL_TASK_ID PROC;
-#endif
-
-\end{code}
-
-A cost centre is represented by a pointer to a static structure
-containing the @label@, @module@, @group@, and the statistical meters
-we are collecting.
-
-\begin{code}
-#if defined(PROFILING) || defined(CONCURRENT)
-
-typedef struct cc {
- struct cc *registered; /* list of registered cost centres */
- hash_t index_val; /* hashed index -- initially UNHASHED */
-
- char *label; /* cost centre label */
- char *module; /* name of module in which _scc_ occurs */
- char *group; /* name of group in which _scc_ occurs */
-
- 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_OR_SUB_CC 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_ 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_alloc; /* no of words allocated (excl CC_HDR) */
-
- /* Heap Profiling by Cost Centre */
-
- W_ selected; /* is this cost centre selected */
-
-} *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}
-
-This structure will need to be expanded change as the statistics we
-gather improve.
-
-\begin{code}
-#endif /* ! RTSTYPES_H */
-\end{code}
-
+++ /dev/null
-%************************************************************************
-%* *
-\section[closure-layout]{Closure Layout}
-%* *
-%************************************************************************
-
-We first describes the data structures that are shared by
-both the reducer and storage manager and then go on to describe
-the interface and its implementation.
-
-The heap consists of a contiguous sequence of closures. Each standard
-closure occupies a contiguous sequence of machine words, which is laid
-out as follows:
-
-\begin{rawlatex}
-\begin{center}
-\mbox{\epsffile{closure.ps}}
-\end{center}
-\end{rawlatex}
-
-\begin{onlyinfo}
-\begin{verbatim}
-< fixed-hdr-size> < var-hdr-size >
------------------+-----------------+---------+-------------+
-|info| | | | | | ptrs... | nonptrs ... |
------------------+-----------------+---------+-------------+
-<------------- header ------------>
-\end{verbatim}
-\end{onlyinfo}
-
-The closure starts with a header. Typically, the first word in the
-header is the {\em info pointer}, and points to its {\em info-table}.
-The rest of the header is used for bookkeeping and depends on the
-compiler options used. The fixed header is the same for all closures
-while the variable header may depend on the closure type.
-
-Following the header is a block of words each of which contains a
-pointer to another closure, followed by a block of words containing
-non-pointers. The non-pointers may include an unused portion of
-``slop'' needed to pad the closure. This is to satisfy any minimum
-closure size requirements, primarily for updates in place. The
-distinction between the pointers and non-pointers is that the garbage
-collector must follow the former but not the latter. The pointers are
-placed first to mimimize the number of distinct closure shapes that
-have to be managed by the garbage collector.
-
-There are a few non-standard closures which do not follow the convention
-of placing all pointers first, but they are all administrative closures
-which require their own unique garbage collection code anyway (such as
-@TSO@'s and @STKO@'s in the threaded world).
-
-The heap grows upwards (towards higher addresses), and closures are
-laid out with the info pointer at the lowest address.
-
-During reduction, the heap pointer (@Hp@) points to the last word of
-allocated space (and not to the first word of free space) and the heap
-limit (@HpLim@) points to the last word of available space.
-
-%************************************************************************
-%* *
-\subsection[closure-size]{The ``Size'' of Closures}
-%* *
-%************************************************************************
-
-When we speak of the ``size'' of a closure, we mean {\em the number of
-words in the closure, excluding the fixed header, but including the
-variable header, the pointers, non-pointers and slop, if any}.
-
-All closures which may be updated must have a size of at least
-@MIN_UPD_SIZE@---currently, this is two, so that they may be directly
-overwritten with a small constructor closure, such as a @(:)@ cell or
-an indirection on the ``mutables'' list.
-
-%************************************************************************
-%* *
-\subsection[closure-kinds]{Types of Closure}
-%* *
-%************************************************************************
-
-{\em This section is now hopelessly out-of-date}. This stuff is {\em
-important} if you want newcomers to understand GHC. Am I the only
-person who bothers with documentation?! KH
-
-Yes, Kevin, you are. I've taken a stab at this section. I think {\em
-hopelessly out-of-date} is a bit overboard, especially compared to
-some of the other documentation in this system. If you still don't
-like it, you're welcome to update it.
-
-(Umm... Before we update it, would anyone like to go for a pizza?
-[WDP 95/03])
-
-We identify several kinds of heap closures. Each type of closure
-is treated differently by the storage manager. Different
-info-table macros are used to declare the appropriate info-tables used
-by the storage manager (see section \ref{info-table-macros}).
-
-Note: it is vitally important that every closure has an appropriate
-info-table attached---otherwise chaos results!
-
-\begin{description}
-
-\item[@SPEC@ closures:] These are standard closures which contain
-specialized garbage collection code that ``knows'' the @size@/@ptrs@
-of the closure. It is only possible to use a specialized info-table if
-appropriately specialized garbage collection code is present in the
-runtime system. This implies that the compiler needs to know which
-@size@/@ptr@ combinations have specialized info-tables. A link-time
-error results if the compiler attempts to build a @SPEC@ closure for
-an inappropriate @size@/@ptr@ combination.
-
-\item[@GEN@ closures:] These are normal closures which use generic
-code for garbage collection. This interprets the @size@/@ptrs@
-information stored in the info table. @GEN@ closures can be built for
-any @size@/@ptrs@ combination.
-
-\item[@DYN@ closures:] Dynamic closures have the layout information
-(@size@/@ptrs@) stored within the variable header of the closure
-itself. They are currently only used for partial applications (@PAP@s)
-and the ``stable pointer table.''
-%partain:\begin{center}
-\begin{tabular}{|c|c|c|c|c|c|}
-\hline
-{\em Fixed Hdr} & {\em Size} & {\em No of ptrs} & {\em Pointers\ldots} & {\em Non-pointers\ldots} \\ \hline
-\end{tabular}
-%partain:\end{center}
-
-\item[@TUPLE@ closure:] These are similar to @DYN@ closures but for
-closures which contain only pointers. They are currently used for
-primitive arrays of pointers when mutuples and immutuples do not have
-to be distinguished during garbage collection.
-%partain:\begin{center}
-\begin{tabular}{|c|c|c|c|}
-\hline
-{\em Fixed Hdr} & {\em Size (= No of ptrs + TUPLE\_VHS)} & {\em Pointers\ldots} \\ \hline
-\end{tabular}
-%partain:\end{center}
-
-\item[@DATA@ closures:] These are also similar to @DYN@ closures but
-for closures containing only non-pointers. They are currently used for
-primitive arrays of bytes (arbitrary precision integers and arrays of
-unboxed values, for example).
-%partain:\begin{center}
-\begin{tabular}{|c|c|c|}
-\hline
-{\em Fixed Hdr} & {\em Size (= No of non-ptr words + DATA\_VHS)} & {\em Non-pointers\ldots} \\ \hline
-\end{tabular}
-%partain:\end{center}
-
-\item[@MUTUPLE@ closures:] These are a variant of the @TUPLE@
-closure. They are used when the garbage collection strategy requires a
-distinction between mutable and immutable tuples (i.e. when there is a
-``mutables'' list.) Such an array may be frozen, becoming an @IMMUTUPLE@,
-with a different info-table.
-%partain:\begin{center}
-\begin{tabular}{|c|c|c|c|}
-\hline
-{\em Fixed Hdr} & {\em Size (= No of ptrs + MUTUPLE\_VHS)} & {\em Pointers\ldots} \\ \hline
-\end{tabular}
-%partain:\end{center}
-
-\item[@IMMUTUPLE@ closures:] These are frozen @MUTUPLE@ closures.
-%mattson:\begin{center}
-\begin{tabular}{|c|c|c|c|}
-\hline
-{\em Fixed Hdr} & {\em Size (= No of ptrs + MUTUPLE\_VHS)} & {\em Pointers\ldots} \\ \hline
-\end{tabular}
-%mattson:\end{center}
-
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[special-closure-types]{Special types}
-%* *
-%************************************************************************
-
-Special kinds of closures are required for static closures, ``black
-holes'', indirections, and in-place updates.
-
-When a ``black hole'' is updated it must be updated with a closure of
-size @MIN_UPD_SIZE@ or less. Updates to some specific closure types
-are handled specially, as follows:
-
-\begin{itemize}
-\item
-if the new closure is of zero arity, then the black hole is replaced by
-the corresponding static closure (@CONST@);
-\item
-if the data type of the new closure is isomorphic to Char (one
-constructor, with argument type @Char#@), then the black hole is
-replaced by the corresponding member of the static character table
-(@CHARLIKE@);
-\item
-if the data type of the new closure is isomorphic to Int (one
-constructor, with argument type @Int#@), and the argument is in the
-range of the static small-int table then the black hole is replaced by
-the corresponding member of the integer table (@INTLIKE@).
-\end{itemize}
-
-The special kinds of closure are:
-
-\begin{description}
-
-\item[@STATIC@ closures:] These are closures which are declared
-statically and hence do not reside in the heap. Such closures must not
-contain any heap pointers and must not be updated. @CAF@ closures are
-an exception; see below.
-
-\item[@CONST@ closures:] There need be only one (static) closure for a
-nullary constructor. These are declared static at compile time and all
-references use the static closure (avoiding heap allocation). However,
-dynamic heap-allocated ones will nevertheless arise through updates.
-
-\item[@CHARLIKE@ and @INTLIKE@ closures] There is a similar story for
-constructors which have a single primitive data field such as @Int#@
-or @Char#@. During garbage collection, pointers to these closures can
-be replaced with a known @STATIC@ closure if an appropriate one exists.
-
-\item[@BH@ closures:] Black hole closures are used to overwrite
-closures currently being evaluated. They inform the garbage collector
-that there are no live roots in the closure, thus removing a potential
-space leak. They also become synchronization points in the threaded
-world.
-
-\item[@BQ@ closures:] Blocking queue closures are black holes with a
-list of blocked threads to be awakened when the black hole is updated.
-
-\item[@IND@ closures:] Indirection closures just point to other
-closures. They are introduced when a closure is updated with a closure
-that has to be allocated in the heap. The closure to be updated is
-{\em indirected} to the new closure. Indirections are normally
-removed during garbage collection. However, when profiling, it may be
-necessary to maintain cost center information in an indirection, so
-there are also ``permanent indirections'' which are retained forever.
-
-\item[@CAF@ indirections:] These are statically defined closures which have
-been updated with a heap-allocated result.
-Initially these are exactly the same as a @STATIC@ closure but with
-special entry code. On entering the closure the entry code must:
-\begin{itemize}
-\item Allocate a black hole in the heap which will be updated with
- the result.
-\item Overwrite the static closure with a special @CAF@ indirection.
-
-\item Link the static indirection onto the list of updated @CAF@s.
-\end{itemize}
-The indirection and the link field require the initial @STATIC@
-closure to be of at least size @MIN_UPD_SIZE@ (excluding the fixed
-header).
-
-@CAF@s are treated as special garbage collection roots. These roots
-are explicitly collected by the garbage collector, since they may
-appear in code even if they are not linked with the main heap. They
-consequently represent potentially enormous space-leaks. A @CAF@
-closure retains a fixed location in statically allocated data space.
-When updated, the contents of the @CAF@ indirection are changed to
-reflect the new closure. @CAF@ indirections require special garbage
-collection code.
-
-\item[@FETCHME@ closures:] These are simply references to remote
-objects in the parallel system.
-
-\item[@TSO@ closures:] These are ``thread state objects,'' which are
-used in the threaded world to maintain the context (STG registers,
-PC location when asleep, etc.) for individual threads of computation.
-
-\item[@STKO@ closures:] These are ``stack objects,'' which are
-used in the threaded world as the stack for each thread is allocated
-from the heap in smallish chunks. (The stack in the sequential world
-is allocated outside of the heap.)
-
-\item[@SPEC_RBH@ and @GEN_RBH@ closures:] These are ``revertible black
-holes'' for updatable @SPEC@ (respectively @GEN@) closures. They are
-currently used in the parallel system, but they could also be used for
-speculation. They act like a black hole for thread synchronization,
-but they can also be reverted back to the original @SPEC@
-(respectively @GEN@) form (so they do introduce a space leak).
-
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[closure-layout-macros]{Closure layout macros}
-%* *
-%************************************************************************
-
-\begin{description}
-\item[@FIXED_HS@:]
-This is the number of fixed-header words present in every closures.
-This includes the info pointer---always the first word---and any
-other fixed info. Because this name occurs so often, @_FHS@ is used as
-a shorthand form.
-
-\item[@SET_FIXED_HDR(closure, infolbl, costcentre)@:] Initialize the
-fixed-header part of @closure@, putting @infolbl@ into the first word
-(where the info-table pointer normally lives). Note that @infolbl@
-should be the name of the appropriate info-table. If we are profiling
-on a sequential machine, then the cost centre will be placed in the
-second word of the fixed header.
-
-\item[@<closure-kind>_VHS@:]
-This is the number of words in the variable part of the header. This
-includes the @size@ and/or @ptr@ fields if required for this closure
-type, and any words which are reserved for garbage collection.
-
-@SPEC@, @CONST@, @CHARLIKE@, @INTLIKE@, @BH@ and @IND@ do
-not have variable header parts, hence no @<closure-kind>_VHS@ macro is
-defined for any of these closure types.
-
-\item[@SET_<closure-kind>_HDR(closure,infolbl,costcentre,size,no-of-ptrs)@:]
-This is used to initialize the header of a \tr{<closure-kind>} closure.
-The fixed header is set by using @SET_FIXED_HDR(closure,infolbl,costcentre)@
-macro.
-
-The variable part of the header, if present, uses the
-@size@/@ptrs@ fields. The @size@ should {\em include} any slop
-words in the closure. Any field that is not used may be junk.
-
-The fields actually used depend on the type of the closure (other
-fields are ignored):
-
-%partain:\begin{center}
-\begin{tabular}{|l|l|} \hline
-Closure & Fields Used \\ \hline
- & \\
-\tr{SPEC} & size/nonptrs fields ignored \\
-\tr{GEN} & both fields also ignored \\
-\tr{DYN} & both fields used \\
-\tr{TUPLE} & size used (ptrs = size - \tr{TUPLE_VHS}) \\
-\tr{DATA} & size used (ptrs = 0) \\\hline
-\end{tabular}
-%partain:\end{center}
-
-\item[@<closure-kind>_HS@:]
-Total number of words in the header:
-
-\pl{TOT_HDR = FIXED_HDR + VAR_HDR}.
-
-\item[@<closure-kind>_CLOSURE_SIZE(closure)@:]
-Returns the size of a closure of this kind. This includes any @VAR_HDR@
-words and slop---but excludes the @FIXED_HDR@ words.
-
-\item[@<closure-kind>_CLOSURE_NoPTRS(closure)@:]
-Returns the number of closure pointer words in a closure of this kind.
-
-\item[@<closure-kind>_CLOSURE_NoNONPTRS(closure)@:]
-Returns the number of useful non-pointer words (including slop) in a
-closure of this kind. These follow the pointer words in the closure;
-\pl{NoNONPTRS = SIZE - NoPTRS - VAR_HDR}.
-
-\item[@<closure-kind>_CLOSURE_PTR(closure,nth)@:]
-Returns the $n$th closure pointer in the closure (starting at 1).
-
-If a loop needs to process all the pointers and non-pointers in a closure then
-this macro should be avoided. Instead, have a pointer run over the closure;
-for example (from @StgUpdate.lhc@):
-\begin{pseudocode}
-{ P_ p = PapClosure + FIXED_HS + DYN_VHS;
- I_ NPtrWords = DYN_CLOSURE_NoPTRS(Node);
- I_ NNonPtrWords = DYN_CLOSURE_NoNONPTRS(Node);
- for (i=0; i<NPtrWords; i++) SpA[AREL(i)] = *(p++);
- for (i=0; i<NNonPtrWords; i++) SpB[BREL(i)] = *(p++);
-}
-\end{pseudocode}
-
-\end{description}
-
-
-%************************************************************************
-%* *
-\subsection[SMinterface.h-implementation]{Interface implementation}
-%* *
-%************************************************************************
-
-This section details the implementation of the storage manager
-interface.
-
-NB: Heap objects specific to parallel implementations are not defined
-here, but in \tr{Parallel.lh} instead.
-
-%************************************************************************
-%* *
-\subsubsection[common-to-all-closures]{Bits common to all closures (esp. @FIXED_HS@)}
-%* *
-%************************************************************************
-
-The maximum number of pointers in a generic closure (@GEN@, @DYN@,
-@TUPLE@, @DATA@) is defined here.
-
-Multi-slurp protection:
-\begin{code}
-#ifndef SMClosures_H
-#define SMClosures_H
-\end{code}
-
-Macros to make rep-table names:
-If you change either of these, change .../nativeGen/StixInfo.lhs
-too---or else!
-\begin{code}
-
-#define MK_REP_LBL(n,s,p) CAT6(n,_,s,_,p,_rtbl)
-#define MK_REP_REF(n,s,p) CAT6(n,_,s,_,p,_rtbl)
-
-\end{code}
-
-At the start of a closure is a fixed header. The info-pointer is
-normally the first word of a closure, in the fixed header. Following
-this we may have any of (but occuring in this order): parallel words
-(currently a global address); profiling words (currently a cost
-centre). It is possible to change the ordering of fixed header
-components by changing the @_HDR_POSN@ macros in the appropriate
-files, and the @SET_FIXED_HDR@/@SET_STATIC_FIXED_HDR@ macros below.
-
-The @FIXED_HS@, @SET_FIXED_HDR@ macros and the components
-which are used to define them must all be defined consistently.
-
-\begin{code}
-
-#define FIXED_HS (INFO_FIXED_HDR + PAR_FIXED_HDR + PROF_FIXED_HDR + TICKY_FIXED_HDR)
-
-/* NB: this *defines* the intended order for the pieces of
- the fixed header. Care should be taken to ensure that this
- is followed below and in the component headers.
-*/
-
-#define _FHS FIXED_HS /* shorthand */
-
-#define SET_FIXED_HDR(closure,infolbl,costcentre) \
- SET_INFO_PTR(closure,infolbl); \
- SET_GRAN_HDR(closure,ThisPE); \
- SET_PAR_HDR(closure,LOCAL_GA); \
- SET_PROF_HDR(closure,costcentre); \
- SET_TICKY_HDR(closure,0)
-
-#define UPD_FIXED_HDR(closure,infolbl,costcentre) \
- SET_INFO_PTR(closure,infolbl); \
- SET_PROF_HDR(closure,costcentre); \
- SET_TICKY_HDR(closure,1)
- /* fiddling SET_PAR_HDR would be a bug (says Patrick) */
- /* We set ticky-hdr to 1 because the only place we
- use this macro is when we have just done an update
- (WDP 96/01)
- */
-
-/* These items are comma-separated */
-
-#define SET_STATIC_FIXED_HDR(closure,infolbl,cc_ident) \
- SET_STATIC_INFO_PTR(infolbl) \
- SET_STATIC_PROCS(closure) \
- SET_STATIC_PAR_HDR(closure) \
- SET_STATIC_PROF_HDR(cc_ident) \
- SET_STATIC_TICKY_HDR()
-
-\end{code}
-
-We define @MIN_UPD_SIZE@ to be the minimum size for updatable
-closures. This must be at least 2, to allow for @(:)@ cells and
-indirections on the ``mutables'' list. This is defined in
-\tr{GhcConstants.lh}.
-
-All updates are performed on closures of this size so @BH@ and @IND@
-closures all have this size.
-
-Finally we define the number of words that the storage-manager needs
-to reserve in the variable header for mutable closures:
-
-\begin{code}
-#if defined(GCap) || defined(GCgn)
-# define GC_MUT_REQUIRED
-# define GC_MUT_RESERVED_WORDS 1
-# define MUT_NOT_LINKED 1 /* Assuming 1 is not a valid pointer */
-# define MUT_LINK(closure) (((P_)(closure))[FIXED_HS])
-# define SET_MUT_RESERVED_WORDS(closure) MUT_LINK(closure) = MUT_NOT_LINKED
-# define SET_STATIC_MUT_RESERVED_WORDS , (W_) MUT_NOT_LINKED
-#else
-# define GC_MUT_RESERVED_WORDS 0
-# define SET_STATIC_MUT_RESERVED_WORDS
-#endif
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[SPEC-closures]{@SPEC@ (specialized) closure macros}
-%* *
-%************************************************************************
-
-@SPEC@ closures have no variable header size---it is always 0.
-@SPEC_VHS@ is left undefined, so that if anyone tries to use it,
-they will hear about it soon enough (WDP 95/05).
-
-\begin{code}
-#define SPEC_HS (FIXED_HS)
-
-#define SPEC_SIZE(fields) (FIXED_HS + (fields))
- /*notational convenience; in SMscan.lc + elsewhere */
-
-#define SPEC_CLOSURE_PTR(closure, no) (((P_)(closure))[SPEC_HS + (no) - 1])
-#define SPEC_CLOSURE_SIZE(closure) ((W_)INFO_SIZE(INFO_PTR(closure)))
-#define SPEC_CLOSURE_NoPTRS(closure) ((W_)INFO_NoPTRS(INFO_PTR(closure)))
-#define SPEC_CLOSURE_NoNONPTRS(closure) (SPEC_CLOSURE_SIZE(closure)-SPEC_CLOSURE_NoPTRS(closure)/*-SPEC_VHS*/)
-
-#define SET_SPEC_HDR(closure,infolbl,cc,size,ptrs) \
- SET_FIXED_HDR(closure,infolbl,cc)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[ForeignObj-closures]{@ForeignObj@ closure macros}
-%* *
-%************************************************************************
-
-Here's what a ForeignObj looks like:
-
-\begin{verbatim}
- <Var Hdr>
-+----------+----------+------+-------------+------+
-| Info Ptr | Forward | Data | FreeRoutine | List |
-+----------+----------+------+-------------+------+
-\end{verbatim}
-
-@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 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
-
-[8/97 -- from the p.o.v. of the NCG, it is very convenient if
-the offset to the data field is constant and not dependent on
-what scheme of GC being used by the RTS. So much so, that I'm
-uniformly adding a VHS of 1. For schemes using a copying
-collector, that's the forward field. For the one-space collector,
-it's an unused word.
-
-If the change is reverted back to what it was (conditional on
-the setting of _INFO_COPYING), then MachMisc.foHS
-needs to be changed accordingly. -- SOF]
-
-\begin{code}
-#if !defined(PAR)
-
-/* See comment above */
-# define ForeignObj_VHS 1
-/*
-# if defined(_INFO_COPYING)
-# define ForeignObj_VHS 1
-# else
-# define ForeignObj_VHS 0
-# endif
-*/
-
-# define ForeignObj_HS (FIXED_HS + ForeignObj_VHS)
-# define ForeignObj_SIZE (ForeignObj_VHS + 3)
-
-# 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_ForeignObj_HDR(closure,infolbl,cc,size,ptrs) \
- SET_FIXED_HDR(closure,infolbl,cc)
-\end{code}
-
-And to check that a Foreign ptr closure is valid
-
-\begin{code}
-EXTDATA_RO(ForeignObj_info);
-
-# if defined(DEBUG)
-
-# define CHECK_ForeignObj_CLOSURE( closure ) \
-do { \
- CHECK_ForeignObj_InfoTable( closure ); \
-} while (0)
-
-# define CHECK_ForeignObj_InfoTable( closure ) \
- ASSERT( (*((PP_)(closure))) == ForeignObj_info )
-
-extern void Validate_ForeignObjList( P_ MPlist );
-# define VALIDATE_ForeignObjList( mplist ) Validate_ForeignObjList( mplist )
-
-# else /* !DEBUG */
-
-# define CHECK_ForeignObj_CLOSURE( closure ) /* nothing */
-# define VALIDATE_ForeignObjList( mplist ) /* nothing */
-
-# endif /* !DEBUG */
-#endif /* !PAR */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[SP-table-closures]{@SPTable@ Stable Pointer Table closure macros}
-%* *
-%************************************************************************
-
-
-A stable pointer is a name for a Haskell object which can be passed to
-the external world. It is ``stable'' in the sense that the name does
-not change when the Haskell garbage collector runs---in contrast to
-the address of the object which may well change.
-
-The stable pointer type is parameterized by the type of the thing
-which is named.
-
-\begin{verbatim}
-type StablePtr# a
-\end{verbatim}
-
-A stable pointer is represented by an index into the (unique,
-heap-allocated) @StablePointerTable@. The Haskell garbage collector
-treats the @StablePointerTable@ as a source of roots for GC.
-
-In order to provide efficient access to stable pointers and to be able
-to cope with any number of stable pointers ($0 \ldots 100000$), the
-table of stable pointers is an array stored on the heap and can grow
-when it overflows. (Since we cannot compact the table by moving
-stable pointers about, it seems unlikely that a half-empty table can
-be reduced in size---this could be fixed if neccessary by using a
-hash table of some sort.)
-
-In general a stable pointer table closure looks like this:
-
-\begin{verbatim}
-<------------header--------------->
-+------+------------+------+-------+---+---+---+-----+-----+--+--+--+----+
-| Info | GCReserved | Size | NPtrs |SP0|SP1|...|SPn-1| Top |s0|s1|..|sn-1|
-+------+------------+------+-------+---+---+---+-----+-----+--+--+--+----+
-\end{verbatim}
-
-The fields are:
-\begin{description}
-
-\item[@Size@:] number of words excluding fixed header ($= @DYN_VHS@ + @NPtrs@ + 1 + @NPtrs@$)
-
-\item[@NPtrs@:] number of (stable) pointers.
-
-\item[@SPi@:] ``unstable'' pointer to a closure. This is the pointer
-that gets updated when the garbage collector moves an object we have a
-stable pointer to. If the pointer is not in use, it points to a
-static closure.
-
-\item[@si@:] entry in a stack of unused pointers. Entries in
-use will contain a number in the range $0\ldots n-1$.
-
-\item[@Top@] is the index of the first element above the top of the stack.
-
-\end{description}
-
-For example, with $n = 4$ and pointers @0@ and @3@ in use (pointing to
-@p1@ and @p2@ respectively), the table might look like this:
-
-\begin{verbatim}
-+------+----+---+----+---+---+----+---+---+---+---+---+
-| Info | 11 | 4 | p1 | x | x | p2 | 2 | 2 | 1 | ? | ? |
-+------+----+---+----+---+---+----+---+---+---+---+---+
- +-----------^
-\end{verbatim}
-
-From the above description, it should be clear that this is just a
-special case of a @DYN@ closure. However, a few macros to access the
-various fields would be jolly useful.
-
-Nota Bene: one might think that since the table is mutable, we'd need
-to treat it a bit more like a @MUTUPLE@. This isn't necessary because
-we treat the stable pointer table as a root.
-
-\begin{code}
-#if !defined(PAR)
-\end{code}
-
-\begin{code}
-# define SPT_SIZE(closure) DYN_CLOSURE_SIZE(closure)
-# define SPT_NoPTRS(closure) DYN_CLOSURE_NoPTRS(closure)
-# define SPT_TOP(closure) (((I_ *) closure)[DYN_HS + SPT_NoPTRS(closure)])
-# define SPT_SPTR(closure,index) (((PP_) closure)[DYN_HS + index])
-# define SPT_FREE(closure,index) (((I_ *) closure)[DYN_HS + SPT_NoPTRS(closure) + 1 + index])
-\end{code}
-
-And to implement the stack:
-
-\begin{code}
-# define SPT_FULL(closure) (SPT_TOP(closure) == SPT_NoPTRS(closure))
-# define SPT_EMPTY(closure) (SPT_TOP(closure) == 0)
-
-# define SPT_PUSH(closure,free) SPT_FREE(closure,SPT_TOP(closure)++) = free
-# define SPT_POP(closure) SPT_FREE(closure,--SPT_TOP(closure))
-\end{code}
-
-And to check that an SPT_Closure is what it's supposed to be, we check
-that the size and number of pointers match up and we check that the
-free list and sptr areas are consistent.
-
-Note that we cannot always check the info table since we might be
-halfway through garbage collection when we call these (eg in
-@freeStablePointer@.
-
-\begin{code}
-# if defined(DEBUG)
-
-# define CHECK_SPT_CLOSURE( closure ) \
-do { \
- CHECK_SPT_InfoTable( closure ); \
- CHECK_SPT_Size( closure ); \
- CHECK_SPT_Contents( closure ); \
-} while (0)
-
-EXTDATA_RO(StablePointerTable_info);
-EXTDATA_RO(EmptyStablePointerTable_info);
-EXTDATA(EmptySPTable_closure);
-int ValidateSPTable PROTO(( P_ SPTable ));
-
-# define CHECK_SPT_InfoTable( closure ) \
- ASSERT( (*((PP_) (closure)) == EmptyStablePointerTable_info && (closure == EmptySPTable_closure) ) || \
- (*((PP_) (closure)) == StablePointerTable_info) )
-
-# define CHECK_SPT_Size( closure ) \
- ASSERT( SPT_SIZE( closure ) == DYN_VHS + 2 * SPT_NoPTRS( closure ) + 1 )
-
-# define CHECK_SPT_Contents( closure ) \
- ASSERT( ValidateSPTable( closure ) == 0 )
-
-# else
-
-# define CHECK_SPT_InfoTable( closure ) /* nothing */
-# define CHECK_SPT_Contents( closure ) /* nothing */
-# define CHECK_SPT_Size( closure ) /* nothing */
-# define CHECK_SPT_CLOSURE( closure ) /* nothing */
-
-# endif /* DEBUG */
-#endif /* !PAR */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[GEN-closures]{@GEN@ (generic) closure macros}
-%* *
-%************************************************************************
-
-\begin{code}
-#define GEN_VHS 0
-#define GEN_HS (FIXED_HS + GEN_VHS)
-
-#define GEN_N_VHS GEN_VHS
-#define GEN_N_HS GEN_HS
-
-#define GEN_S_VHS GEN_VHS
-#define GEN_S_HS GEN_HS
-
-#define GEN_U_VHS GEN_VHS
-#define GEN_U_HS GEN_HS
-
-#define GEN_CLOSURE_SIZE(closure) GEN_INFO_SIZE(INFO_PTR(closure))
-#define GEN_CLOSURE_NoPTRS(closure) GEN_INFO_NoPTRS(INFO_PTR(closure))
-
-#define GEN_CLOSURE_NoNONPTRS(closure) (GEN_CLOSURE_SIZE(closure) - GEN_CLOSURE_NoPTRS(closure) - GEN_VHS)
-#define GEN_CLOSURE_PTR(closure, no) (((P_)(closure))[GEN_HS + (no) - 1])
-
-#define SET_GEN_HDR(closure,infolbl,cc,size,ptrs) SET_FIXED_HDR(closure,infolbl,cc)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[DYN-closures]{@DYN@ (dynamic) closure macros}
-%* *
-%************************************************************************
-
-For dynamic closures (with both pointers and data stored within the closure).
-
-\begin{code}
-#define DYN_VHS 2
-#define DYN_HS (FIXED_HS + DYN_VHS)
-
-#define DYN_CLOSURE_SIZE(closure) (((P_)(closure))[FIXED_HS])
-#define DYN_CLOSURE_NoPTRS(closure) (((P_)(closure))[FIXED_HS + 1])
-
-#define DYN_CLOSURE_NoNONPTRS(closure) (DYN_CLOSURE_SIZE(closure) - DYN_CLOSURE_NoPTRS(closure) - DYN_VHS)
-#define DYN_CLOSURE_PTR(closure, no) (((P_)(closure))[DYN_HS + (no) - 1])
-
-#define SET_DYN_HDR(closure,infolbl,cc,size,ptrs) \
- { SET_FIXED_HDR(closure,infolbl,cc); \
- DYN_CLOSURE_NoPTRS(closure) = (W_)(ptrs); \
- DYN_CLOSURE_SIZE(closure) = (W_)(size); }
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[TUPLE-closures]{@TUPLE@ (big purely-pointer) closure macros}
-%* *
-%************************************************************************
-
-For tuple closures (which contain only pointers after the variable header).
-
-\begin{code}
-#define TUPLE_VHS 1
-#define TUPLE_HS (FIXED_HS + TUPLE_VHS)
-
-#define TUPLE_CLOSURE_SIZE(closure) (((P_)(closure))[FIXED_HS])
-
-#define TUPLE_CLOSURE_NoPTRS(closure) (TUPLE_CLOSURE_SIZE(closure) - TUPLE_VHS)
-#define TUPLE_CLOSURE_NoNONPTRS(closure) 0L
-#define TUPLE_CLOSURE_PTR(closure, no) (((P_)(closure))[TUPLE_HS + (no) - 1])
-
-#define SET_TUPLE_HDR(closure,infolbl,cc,size,ptrs) \
- { SET_FIXED_HDR(closure,infolbl,cc); \
- TUPLE_CLOSURE_SIZE(closure) = (W_)(size); }
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[DATA-closures]{@DATA@ (big purely non-pointer) closure macros}
-%* *
-%************************************************************************
-
-For data closures (which contain only raw data (no pointers) after the
-variable header):
-
-\begin{code}
-#define DATA_VHS 1
-#define DATA_HS (FIXED_HS + DATA_VHS)
-
-#define DATA_CLOSURE_SIZE(closure) (((P_)(closure))[FIXED_HS])
-
-#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) \
- { SET_FIXED_HDR(closure,infolbl,cc); \
- DATA_CLOSURE_SIZE(closure) = (W_)(size); }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[MUTUPLE-closures]{@MUTUPLE@ (mutable pointer) closure macros}
-%* *
-%************************************************************************
-
-Mutable closures of pointers have to be treated specially for the
-benefit of generational garbage collection schemes. If the garbage
-collection scheme does not need to treat them specially
-@GC_MUT_REQUIRED@ is undefined and the closures are defined
-identical to @TUPLE@ closures.
-
-\begin{code}
-
-#if defined(GC_MUT_REQUIRED)
-
-# define MUTUPLE_VHS (1 + GC_MUT_RESERVED_WORDS)
-# define MUTUPLE_HS (FIXED_HS + MUTUPLE_VHS)
-
-# define MUTUPLE_CLOSURE_SIZE(closure) (((P_)(closure))[FIXED_HS + GC_MUT_RESERVED_WORDS])
-
-# define MUTUPLE_CLOSURE_NoPTRS(closure) (MUTUPLE_CLOSURE_SIZE(closure) - MUTUPLE_VHS)
-# define MUTUPLE_CLOSURE_NoNONPTRS(closure) 0L
-# define MUTUPLE_CLOSURE_PTR(closure, no) (((P_)(closure))[MUTUPLE_HS + (no) - 1])
-
-# define SET_MUTUPLE_HDR(closure,infolbl,cc,size,ptrs) \
- { SET_FIXED_HDR(closure,infolbl,cc); \
- SET_MUT_RESERVED_WORDS(closure); \
- MUTUPLE_CLOSURE_SIZE(closure) = (W_)(size); }
-
-#else /* ! GC_MUT_REQUIRED---define as TUPLE closure */
-
-# define MUTUPLE_VHS TUPLE_VHS
-# define MUTUPLE_HS TUPLE_HS
-# define MUTUPLE_CLOSURE_SIZE(closure) TUPLE_CLOSURE_SIZE(closure)
-# define MUTUPLE_CLOSURE_NoPTRS(closure) TUPLE_CLOSURE_NoPTRS(closure)
-# define MUTUPLE_CLOSURE_NoNONPTRS(closure) TUPLE_CLOSURE_NoNONPTRS(closure)
-# define MUTUPLE_CLOSURE_PTR(closure, no) TUPLE_CLOSURE_PTR(closure, no)
-# define SET_MUTUPLE_HDR(closure,infolbl,cc,size,ptrs) \
- SET_TUPLE_HDR(closure,infolbl,cc,size,ptrs)
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[STATIC-closures]{@STATIC@ closure macros}
-%* *
-%************************************************************************
-
-Static closures are those that are allocated in text/data space at
-compile time (i.e., not in dynamic heap). The odd-looking macro
-@SET_STATIC_HDR@ depends on the compiler to cooperate---it must drop
-in the closure free-variable words and the concluding @};@! Also note
-that the info-table label is a ``base'' label.
-
-@SET_STATIC_HDR@ is for SPEC-layout closures.
-
-\begin{code}
-#define STATIC_VHS 0
-#define STATIC_HS (FIXED_HS)
-
-#define STATIC_CLOSURE_SIZE(closure) (STATIC_INFO_SIZE(INFO_PTR(closure)))
-#define STATIC_CLOSURE_NoPTRS(closure) (STATIC_INFO_NoPTRS(INFO_PTR(closure)))
-#define STATIC_CLOSURE_NoNONPTRS(closure) (STATIC_CLOSURE_SIZE(closure)-STATIC_CLOSURE_NoPTRS(closure)-STATIC_VHS)
-
-#define SET_STATIC_HDR(closure,infolbl,cc,closure_localness,info_localness_macro) \
- info_localness_macro(infolbl); \
- closure_localness \
- W_ closure[] = {SET_STATIC_FIXED_HDR(&closure[0],infolbl,cc)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[IND-closures]{@IND@ (indirection) closure macros}
-%* *
-%************************************************************************
-
-Indirections are introduced when closures are updated. They are only
-built by the update macros and the special @CAF@ entry macro in
-@SMupdate.lh@.
-
-Indirections also have a fixed size of @IND_CLOSURE_SIZE(closure)@.
-
-Both for @CAF@s and for normal nodes in Appel's collector we have to
-be able to identify and link together lists of indirections which are
-treated specially by the garbage collector. For this purpose we use
-the @MUT_LINK@ field.
-
-@CAF@s (which look like indirections) need to be linked regardless of
-whether or not we're doing generational collection, so we don't rely
-on @MUT_LINK@ being defined.
-
-\begin{code}
-#define IND_VHS (1)
-#define IND_HS (FIXED_HS + IND_VHS)
-
-#define IND_CLOSURE_SIZE(closure) (MIN_UPD_SIZE)
-#define IND_CLOSURE_NoPTRS(closure) 1
-#define IND_CLOSURE_NoNONPTRS(closure) \
- (IND_CLOSURE_SIZE(closure)-IND_CLOSURE_NoPTRS(closure)-IND_VHS)
-\end{code}
-
-Indirections must store a pointer to the closure which is the target
-of the indirection:
-\begin{code}
-#define IND_CLOSURE_PTR(closure) (((P_)(closure))[IND_HS])
-#define IND_CLOSURE_LINK(closure) (((P_)(closure))[FIXED_HS])
-\end{code}
-
-When we are profiling, we occasionally use ``permanent indirections''
-to store cost centres associated in some way with PAPs. Don't ask me
-why. For now, a permanent indirection must have the same shape as a
-regular indirection. The only difference is that it is, well,
-permanent. That is to say, it is never short-circuited. (What is the
-point, anyway?)
-
-Presumably, such objects could shrink as they moved into the old
-generation, but then their header size would change as well (the word
-that they get to lose is the VHS word of a standard indirection), and
-I just don't feel up to it today. --JSM.
-
-\begin{code}
-#if defined(PROFILING) || defined(TICKY_TICKY)
-
-#define PERM_IND_CLOSURE_PTR(closure,dummy) IND_CLOSURE_PTR(closure)
- /* really *must* be the same as IND_CLOSURE_PTR; it is
- merely a "two-argument" variant, to fit in with the
- bizarre goings-on in SMmark.lhc and friends. WDP 95/12
- */
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[BH-closures]{@BH@ (black hole) closure macros}
-%* *
-%************************************************************************
-
-There are two flavours of black holes; one for updatable closures
-(size @MIN_UPD_SIZE@) and one for single entry closures (size
-@MIN_NONUPD_SIZE@). Note that single-entry black holes can never
-become blocking queues, because that would imply multiple entries
-to the closure.
-
-Black holes are introduced either on entering a closure or when
-performing garbage collection (see section
-\ref{black-hole-overwrite}). They indicate that the pointers within
-the closure are no longer needed.
-
-The compiler will also allocate an updatable black hole on entering a
-@CAF@.
-
-\begin{code}
-#define BH_HS (FIXED_HS)
-#define BH_VHS 0L
-
-#define BH_U_SIZE MIN_UPD_SIZE
-#define BH_N_SIZE MIN_NONUPD_SIZE
-
-#define BH_CLOSURE_SIZE(closure) ((W_)INFO_SIZE(INFO_PTR(closure)))
-#define BH_CLOSURE_NoPTRS(closure) 0L
-#define BH_CLOSURE_NoNONPTRS(closure) (BH_CLOSURE_SIZE(closure)-BH_CLOSURE_NoPTRS(closure)-BH_VHS)
-
-#define SET_BH_HDR(closure,infolbl,cc,size,ptrs) \
- SET_FIXED_HDR(closure,infolbl,cc)
- /* most args aren't used, but are required for SET_*_HDR uniformity */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[RBH-closures]{@RBH@ (revertible black hole) closure macros}
-%* *
-%************************************************************************
-
-There are two kinds of revertible black holes, produced from GEN or
-SPEC closures, respectively. There's no @SET_RBH_HDR@ macro -- use
-@convertToRBH@ instead!!
-
-Note that the NoPTRS and NoNONPTRS macros refer to the *original* closure.
-
-\begin{code}
-#define SPEC_RBH_VHS (1L)
-#define SPEC_RBH_HS (FIXED_HS + SPEC_RBH_VHS)
-
-#define SPEC_RBH_CLOSURE_PTR(closure, no) (((P_)(closure))[SPEC_RBH_HS + (no) - 1])
-#define SPEC_RBH_CLOSURE_SIZE(closure) ((W_)INFO_SIZE(REVERT_INFOPTR(INFO_PTR(closure))))
-#define SPEC_RBH_CLOSURE_NoPTRS(closure) ((W_)INFO_NoPTRS(REVERT_INFOPTR(INFO_PTR(closure))))
-#define SPEC_RBH_CLOSURE_NoNONPTRS(closure) (SPEC_RBH_CLOSURE_SIZE(closure)-SPEC_RBH_CLOSURE_NoPTRS(closure))
-
-#define SPEC_RBH_BQ_LOCN (SPEC_RBH_HS)
-#define SPEC_RBH_BQ(closure) (((P_)(closure))[SPEC_RBH_BQ_LOCN])
-
-#define GEN_RBH_VHS (1L)
-#define GEN_RBH_HS (FIXED_HS + GEN_RBH_VHS)
-
-#define GEN_RBH_CLOSURE_PTR(closure, no) (((P_)(closure))[GEN_RBH_HS + (no) - 1])
-#define GEN_RBH_CLOSURE_SIZE(closure) (GEN_INFO_SIZE(REVERT_INFOPTR(INFO_PTR(closure))))
-#define GEN_RBH_CLOSURE_NoPTRS(closure) (GEN_INFO_NoPTRS(REVERT_INFOPTR(INFO_PTR(closure))))
-#define GEN_RBH_CLOSURE_NoNONPTRS(closure) (GEN_RBH_CLOSURE_SIZE(closure)-GEN_RBH_CLOSURE_NoPTRS(closure)-GEN_VHS)
-
-#define GEN_RBH_BQ_LOCN (GEN_RBH_HS)
-#define GEN_RBH_BQ(closure) (((P_)(closure))[GEN_RBH_BQ_LOCN])
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[CONST-closures]{@CONST@ (nullary data-constructor) closure macros}
-%* *
-%************************************************************************
-
-These are never allocated normally---static closures are used
-instead. They arise only as a result of in-place updates which use
-@INPLACE_UPD_HDR@.
-
-\begin{code}
-#define CONST_HS (FIXED_HS)
-#define CONST_VHS (0L)
-
-#define CONST_CLOSURE_SIZE(closure) (0L)
-#define CONST_CLOSURE_NoPTRS(closure) (0L)
-#define CONST_CLOSURE_NoNONPTRS(closure) (0L)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[CHARLIKE-closures]{@CHARLIKE@ closure macros}
-%* *
-%************************************************************************
-
-These are never allocated normally. They are a static array of
-closures indexed by literal characters. As with @CONST@ closures,
-@CHARLIKE@ closures only arise from in-place updates using
-@INPLACE_UPD_HDR@.
-\begin{code}
-#define CHARLIKE_HS (FIXED_HS)
-#define CHARLIKE_VHS (0L)
-
-#define CHARLIKE_CLOSURE_SIZE(closure) (1L)
-#define CHARLIKE_CLOSURE_NoPTRS(closure) (0L)
-#define CHARLIKE_CLOSURE_NoNONPTRS(closure) (1L)
-
-/* Array of static charlike closures */
-#ifndef aix_TARGET_OS /* AIX gives link errors with consts in this file (RO assembler section) */
-extern const W_ CHARLIKE_closures[];
-#else
-extern W_ CHARLIKE_closures[];
-#endif
-
-/* Macro to retrieve static charlike closure */
-#define CHARLIKE_CLOSURE(the_char) \
- (& CHARLIKE_closures[(CHARLIKE_HS+1) * ((W_)(the_char))])
-
-#define CHARLIKE_VALUE(closure) \
- (((P_)(closure))[CHARLIKE_HS])
-
-/* INPLACE_UPD_HDR used for inplace updates */
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[INTLIKE-closures]{@INTLIKE@ closure macros}
-%* *
-%************************************************************************
-
-These may be allocated normally (@SET_INTLIKE_HDR@) or result from
-inplace updates (@INPLACE_UPD_HDR@). They may be converted to a static
-closure during garbage collection.
-
-Note: the garbage collector (@EVAC_FN(IntLike)@) assumes that this has
-the same structure as a @SPEC_1_0@ closure.
-
-\begin{code}
-#define INTLIKE_HS (FIXED_HS)
-#define INTLIKE_VHS (0L)
-
-#define INTLIKE_CLOSURE_SIZE(closure) (1L)
-#define INTLIKE_CLOSURE_NoPTRS(closure) (0L)
-#define INTLIKE_CLOSURE_NoNONPTRS(closure) (1L)
-
-/* Array of static intlike closures */
-extern const P_ INTLIKE_closures;
-
-/* Range of static intlike closures MAX_INTLIKE, MIN_INTLIKE is in GhcConstants.lh */
-
-/* Macro to retrieve static intlike closure */
-#define INTLIKE_CLOSURE(the_int) \
- (INTLIKE_closures + ((INTLIKE_HS+1) * ((I_)(the_int))))
-
-#define INTLIKE_VALUE(closure) \
- ((I_) ((P_)(closure))[INTLIKE_HS])
-
-#define SET_INTLIKE_HDR(closure,infolbl,cc,size,ptrs) \
- SET_FIXED_HDR(closure,infolbl,cc)
-
-/* INPLACE_UPD_HDR used for inplace updates */
-\end{code}
-
-
-End multi-slurp protection:
-\begin{code}
-#endif /* SMClosures_H */
-\end{code}
+++ /dev/null
-%
-% (c) The OBFUSCATION-THROUGH-GRATUITOUS-PREPROCESSOR-ABUSE Project,
-% Glasgow University, 1990-1994
-%
-%************************************************************************
-%* *
-\section[info-table-macros]{Info-table macros}
-%* *
-%************************************************************************
-
-We define {\em info tables} here. First, all the different pieces of
-an info table (entry code, evac code, etc.); then all the different
-kinds of info tables (SPEC, DYN, etc). NB: some of the parallel-only
-kinds are defined in \tr{Parallel.lh}, not here.
-
-An info-table contains several fields. The first field is
-the label of the closure's {\em standard-entry code}. This is used by
-the reducer to ``evaluate'' the closure. The remaining fields are used
-by the garbage collector and other parts of the runtime
-system. Info-tables are declared using the C macros defined below.
-The details of the contents are determined by the storage manager and
-are not of interest outside it.
-
-Info tables may either be {\em reversed} or not. Reversed is normal
-and preferred, but it requires ``assembler mangling'' of the C
-compiler output. (The native-code generator does reversed info-tables
-automagically.) With reversed info tables, (a)~the words are reversed
-[obviously], (b)~the info-table's C label addresses the word {\em just
-after} the info table (where its associated entry code ``happens to be''),
-and (c)~the entry-code word in the info table is omitted (it's
-vestigial).
-
-Info-table reversal is hidden behind the @IREL@ macro.
-
-The following fields are used when defining particular info-tables.
-Some sorts of info-table (e.g. @FETCHME_ITBL@) don't need all these
-fields to be specified.
-
-\begin{description}
-\item[@infolbl@]
-The name used to create labels for the info-table, profiling
-information, etc.
-
-\item[\tr{entry_code}:]
-The function which is called when entering the closure.
-
-\item[\tr{update_code}:]
-The function which is called when updating the closure (constructors only).
-
-\item[\tr{tag}:]
-(So much for the Spineless {\em Tagless} G-Machine...) Used for
-semi-tagging checks.
-
-\item[\tr{type}:]
-Similar-but-different info to the \tr{tag} stuff; the
-parallel world needs more elaborate info.
-
-\item[\tr{size}:]
-The size of the closure (see \tr{SMClosures.lh} for a precise
-definition of ``size''). Used by the garbage-collector, not the
-Haskell reducer.
-
-\item[\tr{ptrs}:]
-The number of pointers in the closure. Used by the garbage-collector,
-not the Haskell reducer.
-
-\item[@localness@]
-Whether the info-table is local to this module or not.
-The field is set to @static@ if the info-table is
-local, and is empty otherwise.
-
-\item[@entry_localness@]
-Whether the @entry_code@ routine is local to this module or not.
-This field can have the following values:
- \begin{description}
- \item [@EXTFUN@]
- The entry code is global.
- \item [@INTFUN@]
- The entry code is local.
- \end{description}
-
-\item[@kind@]
-This identifies the general sort of the closure for profiling purposes.
-It can have the following values (defined in CostCentre.lh):
-
- \begin{description}
- \item[@CON_K@]
- A constructor.
- \item[@FN_K@]
- A literal function.
- \item[@PAP_K@]
- A partial application.
- \item[@THK_K@]
- A thunk, or suspension.
- \item[@BH_K@]
- A black hole.
- \item[@ARR_K@]
- An array.
- \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
- non-demand so it may be worth watching separately? ADR)
- \item[@INTERNAL_KIND@]
- Something internal to the runtime system.
- \end{description}
-
-\item[@descr@]
-This is a string used to identify the closure for profiling purposes.
-\end{description}
-
-So, for example:
-\begin{pseudocode}
-SPEC_N_ITBL(RBH_Save_0_info,RBH_Save_0_entry,UpdErr,0,INFO_OTHER_TAG,2,0,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_0");
-\end{pseudocode}
-
-%************************************************************************
-%* *
-\subsection[info-table-common-up]{The commoned-up info-table world}
-%* *
-%************************************************************************
-
-Since lots of info-tables share the same information (which doesn't
-change at run time) needlessly, we gather this common information
-together into a rep-table.
-
-Conditionally present data (concerning the parallel world, and also
-information for the collectors) are gathered into unique rep-tables,
-which are pointed to from info-tables. This saves several words for
-each closure we build, at the cost of making garbage collection and
-fetching of data from info-tables a little more hairy.
-
-Size and pointers fields go away altogether, save for @GEN@ closures
-where they are tacked on to the end of info-tables.
-
-%************************************************************************
-%* *
-\subsection[info-table-common]{Bits common to all info-tables}
-%* *
-%************************************************************************
-
-The entry code for a closure, its type, its ``size'', and the number
-of pointer-words it contains are the same in every info table. For
-the parallel system, two flush code-entries are also standard.
-
-Multi-slurp protection:
-\begin{code}
-#ifndef SMInfoTables_H
-#define SMInfoTables_H
-\end{code}
-
-\begin{code}
-#ifdef __STG_REV_TBLS__
-
-# define IREL(offset) (-(offset))
-
-/* NB: the ENT_ macro (StgMacros.lh) must also be changed */
-
-# define ENTRY_CODE(infoptr) ((F_)(infoptr))
-
-#else /* boring non-reversed info tables */
-
-# define IREL(offset) (offset)
-
-# define ENTRY_CODE(infoptr) (((FP_)(infoptr))[IREL(0)])
-
-#endif /* non-fixed size info tables */
-\end{code}
-
-\begin{code}
-#define INFO_TAG(infoptr) ((I_) ((P_)(infoptr))[IREL(1)])
-#define EVAL_TAG(infoptr) (INFO_TAG(infoptr) >= 0)
-\end{code}
-
-\begin{code}
-
-#define INFO_INTERNAL (~0L) /* Should never see this */
-
-#define INFO_UNUSED (~0L)
-/* We'd like to see this go away in code pointer fields, with specialized code
- to print out an appropriate error message instead.
- WDP 94/11: At least make it an Obviously Weird Value?
- */
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[info-table-rtbl]{Rep tables in an info table}
-%* *
-%************************************************************************
-
-Common information is pointed to by the rep table pointer. We want to
-use extern declarations almost everywhere except for the single module
-(\tr{Rep.lc}) in which the rep tables are declared locally.
-
-\begin{code}
-#if defined(COMPILING_REP_LC) || defined(COMPILING_NCG)
-# define MAYBE_DECLARE_RTBL(l,s,p)
-#else
-# define MAYBE_DECLARE_RTBL(l,s,p) EXTDATA_RO(MK_REP_REF(l,s,p));
-#endif
-
-#define INFO_RTBL(infoptr) (((PP_)(infoptr))[IREL(2)])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Maybe-there-maybe-not fields in an info table}
-%* *
-%************************************************************************
-
-That's about it for the fixed stuff...entry code, a tag and an RTBL pointer.
-
-\begin{code}
-#define FIXED_INFO_WORDS 3
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Profiling-only fields in an info table}
-%* *
-%************************************************************************
-
-These macros result in the profiling kind and description string being
-included only if required.
-\begin{code}
-#define PROFILING_INFO_OFFSET (FIXED_INFO_WORDS)
-
-#if !defined(PROFILING)
-# define PROFILING_INFO_WORDS 0
-# define INCLUDE_PROFILING_INFO(base_name)
-# define INREGS_PROFILING_INFO
-
-#else
-# define PROFILING_INFO_WORDS 1
-
-# define INCLUDE_PROFILING_INFO(base_name) , (W_)REF_CAT_IDENT(base_name)
-# define INREGS_PROFILING_INFO ,INFO_UNUSED
-
-# define INFO_CAT(infoptr) (((ClCategory *)(infoptr))[IREL(PROFILING_INFO_OFFSET)])
-
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Non-standard fields in an info table: where they'll be}
-%* *
-%************************************************************************
-
-The @UPDATE_CODE@ field is a pointer to the update code for a constructor.
-I believe that constructors are always of the following types:
-
-\begin{itemize}
-\item @CHARLIKE@
-\item @CONST@
-\item @GEN_N@
-\item @INTLIKE@
-\item @SPEC_N@
-\item @STATIC@
-\end{itemize}
-
-Info tables for these types have non-standard update code fields. In addition,
-because @GEN@ closures have further non-standard fields (size, ptrs), the
-info tables for @GEN_U@ closures also have a non-standard update code field
-(which is filled in with @StdErrorCode@).
-
-When we're in the parallel world, we also have to know which registers are
-live when we're returning a constructor in registers, so we have a second
-word for that as well.
-
-\begin{code}
-
-#define UPDATE_INFO_OFFSET (PROFILING_INFO_OFFSET+PROFILING_INFO_WORDS)
-
-#ifndef PAR
-# define UPDATE_INFO_WORDS 1
-# define INCLUDE_UPDATE_INFO(upd,live) ,(W_)upd
-#else
-# define UPDATE_INFO_WORDS 2
-# define INCLUDE_UPDATE_INFO(upd,live) ,(W_)upd,(W_)live
-#endif
-
-#define UPDATE_CODE(infoptr) (((FP_)(infoptr))[IREL(UPDATE_INFO_OFFSET)])
-#define INFO_LIVENESS(infoptr) (((P_)(infoptr))[IREL(UPDATE_INFO_OFFSET+1)])
-\end{code}
-
-@GEN@ closures have the size and number of pointers in the info table
-rather than the rep table. These non-standard fields follow the update
-code field (which is only required for @GEN_N@ closures, but which we
-include in @GEN_U@ closures just to keep this other stuff at a consistent
-offset).
-
-\begin{code}
-#define GEN_INFO_OFFSET (UPDATE_INFO_OFFSET+UPDATE_INFO_WORDS)
-#define GEN_INFO_WORDS 2
-#define INCLUDE_GEN_INFO(size,ptrs) ,(W_)size,(W_)ptrs
-
-#define GEN_INFO_SIZE(infoptr) ((I_)((P_)(infoptr))[IREL(GEN_INFO_OFFSET)])
-#define GEN_INFO_NoPTRS(infoptr) ((I_)((P_)(infoptr))[IREL(GEN_INFO_OFFSET+1)])
-\end{code}
-
-@CONST@ closures have a pointer to a static version of the closure in their
-info tables. This non-standard field follows their update code field.
-
-\begin{code}
-#define CONST_INFO_OFFSET (UPDATE_INFO_OFFSET+UPDATE_INFO_WORDS)
-#define CONST_INFO_WORDS 1
-#define INCLUDE_CONST_INFO(closure) ,(W_)closure
-
-#define CONST_STATIC_CLOSURE(infoptr) (((PP_)(infoptr))[IREL(CONST_INFO_OFFSET)])
-\end{code}
-
-@STATIC@ closures are like @GEN@ closures in that they also have the
-size and number of pointers in the info table rather than the rep
-table. Again, these non-standard fields follow the update code field
-(which I believe is not actually needed for STATIC closures).
-
-\begin{code}
-#define STATIC_INFO_OFFSET (UPDATE_INFO_OFFSET+UPDATE_INFO_WORDS)
-#define STATIC_INFO_WORDS 2
-#define INCLUDE_STATIC_INFO(size,ptrs) ,(W_)size,(W_)ptrs
-
-#define STATIC_INFO_SIZE(infoptr) ((I_)((P_)(infoptr))[IREL(STATIC_INFO_OFFSET)])
-#define STATIC_INFO_NoPTRS(infoptr) ((I_)((P_)(infoptr))[IREL(STATIC_INFO_OFFSET+1)])
-\end{code}
-
-In the parallel system, all updatable closures have corresponding
-revertible black holes. When we are assembly-mangling, we guarantee that
-the revertible black hole code precedes the normal entry code, so that
-the RBH info table resides at a fixed offset from the normal info table.
-Otherwise, we add the RBH info table pointer to the end of the normal
-info table and vice versa.
-
-\begin{code}
-#if defined(PAR) || defined(GRAN)
-# define RBH_INFO_OFFSET (GEN_INFO_OFFSET+GEN_INFO_WORDS)
-
-# define INCLUDE_SPEC_PADDING \
- INCLUDE_UPDATE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_GEN_INFO(INFO_UNUSED,INFO_UNUSED)
-
-# ifdef RBH_MAGIC_OFFSET
-
-# define RBH_INFO_WORDS 0
-# define INCLUDE_RBH_INFO(infoptr)
-
-# define RBH_INFOPTR(infoptr) (((P_)infoptr) - RBH_MAGIC_OFFSET)
-# define REVERT_INFOPTR(infoptr) (((P_)infoptr) + RBH_MAGIC_OFFSET)
-
-# else
-
-# define RBH_INFO_WORDS 1
-# define INCLUDE_RBH_INFO(infoptr) ,(W_)infoptr
-
-# define RBH_INFOPTR(infoptr) (((PP_)(infoptr))[IREL(RBH_INFO_OFFSET)])
-# define REVERT_INFOPTR(infoptr) (((PP_)(infoptr))[IREL(RBH_INFO_OFFSET)])
-
-# endif
-
-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}
-
-%************************************************************************
-%* *
-\subsection{Maybe-there-maybe-not fields in a rep table}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{Type field in a rep table}
-%* *
-%************************************************************************
-
-The @INFO_TYPE@ field in the rep table tells what sort of animal
-the closure is.
-
-\begin{code}
-#define TYPE_INFO_OFFSET 0
-#define TYPE_INFO_WORDS 1
-#define INCLUDE_TYPE_INFO(kind) (W_)CAT3(INFO_,kind,_TYPE)
-
-#define INFO_TYPE(infoptr) (((P_)(INFO_RTBL(infoptr)))[TYPE_INFO_OFFSET])
-\end{code}
-
-The least significant 9 bits of the info-type are used as follows:
-
-\begin{tabular}{||l|l||} \hline
-Bit & Interpretation \\ \hline
-0 & 1 $\Rightarrow$ Head normal form \\
-1 & 1 $\Rightarrow$ Don't spark me (Any HNF will have this set to 1) \\
-2 & 1 $\Rightarrow$ This is a static closure \\
-3 & 1 $\Rightarrow$ Has mutable pointer fields \\
-4 & 1 $\Rightarrow$ May be updated (inconsistent with being a HNF) \\
-5 & 1 $\Rightarrow$ Is a "primitive" array (a BIG structure) \\
-6 & 1 $\Rightarrow$ Is a black hole \\
-7 & 1 $\Rightarrow$ Is an indirection \\
-8 & 1 $\Rightarrow$ Is a thunk \\
-\hline
-\end{tabular}
-
-Updatable structures (@_UP@) are thunks that may be shared. Primitive
-arrays (@_BM@ -- Big Mothers) are structures that are always held
-in-memory (basically extensions of a closure). Because there may be
-offsets into these arrays, a primitive array cannot be handled as a
-FetchMe in the parallel system, but must be shipped in its entirety if
-its parent closure is shipped.
-
-\begin{code}
-#define IP_TAG_BITS 9
-
-#define _NF 0x0001 /* Normal form */
-#define _NS 0x0002 /* Don't spark */
-#define _ST 0x0004 /* Is static */
-#define _MU 0x0008 /* Is mutable */
-#define _UP 0x0010 /* Is updatable (but not mutable) */
-#define _BM 0x0020 /* Is a "primitive" array */
-#define _BH 0x0040 /* Is a black hole */
-#define _IN 0x0080 /* Is an indirection */
-#define _TH 0x0100 /* Is a thunk */
-
-#define IS_NF(infoptr) ((INFO_TYPE(infoptr)&_NF) != 0)
-#define IS_MUTABLE(infoptr) ((INFO_TYPE(infoptr)&_MU) != 0)
-#define IS_STATIC(infoptr) ((INFO_TYPE(infoptr)&_ST) != 0)
-#define IS_UPDATABLE(infoptr) ((INFO_TYPE(infoptr)&_UP) != 0)
-#define IS_BIG_MOTHER(infoptr) ((INFO_TYPE(infoptr)&_BM) != 0)
-#define IS_BLACK_HOLE(infoptr) ((INFO_TYPE(infoptr)&_BH) != 0)
-#define IS_INDIRECTION(infoptr) ((INFO_TYPE(infoptr)&_IN) != 0)
-#define IS_THUNK(infoptr) ((INFO_TYPE(infoptr)&_TH) != 0)
-
-#define SHOULD_SPARK(closure) ((INFO_TYPE(INFO_PTR(closure))&_NS) == 0)
-\end{code}
-
-The other bits in the info-type field simply give a unique bit-pattern
-to identify the closure type.
-
-\begin{code}
-#define IP_TAG_BIT_MASK ((1L<<IP_TAG_BITS)-1)
-
-#define BASE_INFO_TYPE(infoptr) (INFO_TYPE(infoptr) & (~IP_TAG_BIT_MASK)) /* Strips out the tag bits */
-
-#define MAKE_BASE_INFO_TYPE(x) ((x) << IP_TAG_BITS)
-
-#define INFO_SPEC_TYPE (MAKE_BASE_INFO_TYPE(1L))
-#define INFO_GEN_TYPE (MAKE_BASE_INFO_TYPE(2L))
-#define INFO_DYN_TYPE (MAKE_BASE_INFO_TYPE(3L) | _NF | _NS)
-#define INFO_TUPLE_TYPE (MAKE_BASE_INFO_TYPE(4L) | _NF | _NS | _BM)
-#define INFO_DATA_TYPE (MAKE_BASE_INFO_TYPE(5L) | _NF | _NS | _BM)
-#define INFO_MUTUPLE_TYPE (MAKE_BASE_INFO_TYPE(6L) | _NF | _NS | _MU | _BM)
-#define INFO_IMMUTUPLE_TYPE (MAKE_BASE_INFO_TYPE(7L) | _NF | _NS | _BM)
-#define INFO_STATIC_TYPE (MAKE_BASE_INFO_TYPE(8L) | _NS | _ST)
-#define INFO_CONST_TYPE (MAKE_BASE_INFO_TYPE(9L) | _NF | _NS)
-#define INFO_CHARLIKE_TYPE (MAKE_BASE_INFO_TYPE(10L) | _NF | _NS)
-#define INFO_INTLIKE_TYPE (MAKE_BASE_INFO_TYPE(11L) | _NF | _NS)
-#define INFO_BH_TYPE (MAKE_BASE_INFO_TYPE(12L) | _NS | _BH)
-#define INFO_BQ_TYPE (MAKE_BASE_INFO_TYPE(13L) | _NS | _MU | _BH)
-#define INFO_IND_TYPE (MAKE_BASE_INFO_TYPE(14L) | _NS | _IN)
-#define INFO_CAF_TYPE (MAKE_BASE_INFO_TYPE(15L) | _NF | _NS | _ST | _IN)
-#define INFO_FM_TYPE (MAKE_BASE_INFO_TYPE(16L))
-#define INFO_TSO_TYPE (MAKE_BASE_INFO_TYPE(17L) | _MU)
-#define INFO_STKO_TYPE (MAKE_BASE_INFO_TYPE(18L))
-#define INFO_SPEC_RBH_TYPE (MAKE_BASE_INFO_TYPE(19L) | _NS | _MU | _BH)
-#define INFO_GEN_RBH_TYPE (MAKE_BASE_INFO_TYPE(20L) | _NS | _MU | _BH)
-#define INFO_BF_TYPE (MAKE_BASE_INFO_TYPE(21L) | _NS | _MU | _BH)
-#define INFO_INTERNAL_TYPE (MAKE_BASE_INFO_TYPE(22L))
-
-/* S = single-entry thunk
- U = updatable thunk
- N = head normal form */
-
-#define INFO_SPEC_N_TYPE (INFO_SPEC_TYPE | _NF | _NS)
-#define INFO_SPEC_S_TYPE (INFO_SPEC_TYPE | _TH)
-#define INFO_SPEC_U_TYPE (INFO_SPEC_TYPE | _UP | _TH)
-
-#define INFO_GEN_N_TYPE (INFO_GEN_TYPE | _NF | _NS)
-#define INFO_GEN_S_TYPE (INFO_GEN_TYPE | _TH)
-#define INFO_GEN_U_TYPE (INFO_GEN_TYPE | _UP | _TH)
-
-#define INFO_BH_N_TYPE (INFO_BH_TYPE)
-#define INFO_BH_U_TYPE (INFO_BH_TYPE | _UP)
-
-#define INFO_STKO_DYNAMIC_TYPE (INFO_STKO_TYPE | _MU)
-#define INFO_STKO_STATIC_TYPE (INFO_STKO_TYPE | _ST)
-
-#define INFO_FETCHME_TYPE (INFO_FM_TYPE | _MU)
-#define INFO_FMBQ_TYPE (INFO_FM_TYPE | _MU | _BH)
-
-#define MIN_INFO_TYPE 0
-#define MAX_INFO_TYPE INFO_INTERNAL_TYPE
-
-\end{code}
-
-Notes:
-
-An indirection either points to HNF (post update); or is result of
-overwriting a FetchMe, in which case the thing fetched is either
-under evaluation (BH), or by now an HNF. Thus, indirections get @_NS@.
-
-%************************************************************************
-%* *
-\subsubsection{Size/no-of-pointers fields in a rep table}
-%* *
-%************************************************************************
-
-\begin{code}
-#define SIZE_INFO_OFFSET (TYPE_INFO_OFFSET+TYPE_INFO_WORDS)
-#define SIZE_INFO_WORDS 2
-#define INCLUDE_SIZE_INFO(size,ptrs) ,(W_)size, (W_)ptrs
-
-#define INFO_SIZE(infoptr) ((I_)((FP_)(INFO_RTBL(infoptr)))[SIZE_INFO_OFFSET])
-#define INFO_NoPTRS(infoptr) ((I_)((FP_)(INFO_RTBL(infoptr)))[SIZE_INFO_OFFSET+1])
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Parallel-only fields in a rep table}
-%* *
-%************************************************************************
-
-There is now nothing that is specific to the parallel world (GUM), but
-this could change so don't go deleting this little lot! KH
-
-\begin{code}
-# define PAR_INFO_OFFSET (SIZE_INFO_OFFSET+SIZE_INFO_WORDS)
-
-/* now the bits that are either on or off: */
-
-# define PAR_INFO_WORDS 0
-# define INCLUDE_PAR_INFO
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Copying-only fields in a rep table}
-%* *
-%************************************************************************
-
-These macros result in the copying garbage collection code being
-included only if required.
-\begin{code}
-#if defined(_INFO_COPYING)
-# include "SMcopying.h" /* Copying Code Labels */
-# define COPY_INFO_OFFSET (PAR_INFO_OFFSET+PAR_INFO_WORDS)
-# define COPY_INFO_WORDS 2
-# define INCLUDE_COPYING_INFO(evac, scav) ,(W_)evac,(W_)scav
-
-/*
- * use these if you have an unquenchable urge to dig around in
- * info tables (e.g., runtime/.../StgDebug.lc)
- */
-
-# define INFO_EVAC_2S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET])
-# define INFO_SCAV_2S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET + 1])
-
-#else /* ! _INFO_COPYING */
-
-# define COPY_INFO_WORDS 0
-# define INCLUDE_COPYING_INFO(evac, scav)
-
-#endif /* ! _INFO_COPYING */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Compacting-only fields in a rep table}
-%* *
-%************************************************************************
-
-These macros result in the compacting garbage collection code being
-included only if required. This includes the variable length
-specialised marking code.
-
-\begin{code}
-#if !defined(_INFO_COMPACTING)
-
-# define INCLUDE_COMPACTING_INFO(scanlink,prmark,scanmove,marking)
-# define SPEC_COMPACTING_INFO(scanlink,prmark,scanmove,marking)
-
-#else /* defined(_INFO_COMPACTING) */
-
-# include "SMcompact.h" /* Single Space Compacting Code */
-# include "SMmark.h" /* Pointer Reversal Marking Code Labels */
-
-/* For SPEC closures compacting info is variable length -> must come last */
-
-# define COMPACTING_INFO_OFFSET (COPY_INFO_OFFSET+COPY_INFO_WORDS)
-
-# define INCLUDE_COMPACTING_INFO(scanlink,prmark,scanmove,marking) \
- ,(W_)scanlink,(W_)prmark \
- ,(W_)scanmove,(W_)marking
-
-# define SPEC_COMPACTING_INFO(scanlink,prmark,scanmove,prreturn) \
- ,(W_)scanlink,(W_)prmark \
- ,(W_)scanmove, \
- (W_)prreturn
-
-
-# define INFO_SCAN_LINK_1S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET])
-# define INFO_MARK_1S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+1])
-# define INFO_SCAN_MOVE_1S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+2])
-# define INFO_MARKED_1S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+3])
-# define INFO_MARKING_1S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+4])
-
-#ifndef COMPILING_NCG
-extern F_ _Dummy_Static_entry(STG_NO_ARGS);
-extern F_ _Dummy_Ind_entry(STG_NO_ARGS);
-extern F_ _Dummy_Caf_entry(STG_NO_ARGS);
-extern F_ _Dummy_Const_entry(STG_NO_ARGS);
-extern F_ _Dummy_CharLike_entry(STG_NO_ARGS);
-#endif
-
-#endif /* _INFO_COMPACTING */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SPEC_ITBL]{@SPEC_x_ITBL@: @SPEC@ info-tables}
-%* *
-%************************************************************************
-
-Normal-form and updatable (non-normal-form) variants.
-
-\begin{code}
-
-#define SPEC_N_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Spec_N,size,ptrs) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- }
-
-MAYBE_DECLARE_RTBL(Spec_N,1,0)
-MAYBE_DECLARE_RTBL(Spec_N,1,1)
-MAYBE_DECLARE_RTBL(Spec_N,2,0)
-MAYBE_DECLARE_RTBL(Spec_N,2,1)
-MAYBE_DECLARE_RTBL(Spec_N,2,2)
-MAYBE_DECLARE_RTBL(Spec_N,3,0)
-MAYBE_DECLARE_RTBL(Spec_N,3,1)
-MAYBE_DECLARE_RTBL(Spec_N,3,2)
-MAYBE_DECLARE_RTBL(Spec_N,3,3)
-MAYBE_DECLARE_RTBL(Spec_N,4,0)
-MAYBE_DECLARE_RTBL(Spec_N,4,4)
-MAYBE_DECLARE_RTBL(Spec_N,5,0)
-MAYBE_DECLARE_RTBL(Spec_N,5,5)
-MAYBE_DECLARE_RTBL(Spec_N,6,6)
-MAYBE_DECLARE_RTBL(Spec_N,7,7)
-MAYBE_DECLARE_RTBL(Spec_N,8,8)
-MAYBE_DECLARE_RTBL(Spec_N,9,9)
-MAYBE_DECLARE_RTBL(Spec_N,10,10)
-MAYBE_DECLARE_RTBL(Spec_N,11,11)
-MAYBE_DECLARE_RTBL(Spec_N,12,12)
-
-#define SPEC_N_RTBL(size,ptrs) \
- const W_ MK_REP_LBL(Spec_N,size,ptrs)[] = { \
- INCLUDE_TYPE_INFO(SPEC_N) \
- INCLUDE_SIZE_INFO(size,ptrs) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(CAT2(_Evacuate_,size),CAT4(_Scavenge_,size,_,ptrs)) \
- SPEC_COMPACTING_INFO(CAT4(_ScanLink_,size,_,ptrs), \
- CAT2(_PRStart_,ptrs), \
- CAT2(_ScanMove_,size),CAT2(_PRIn_,ptrs)) \
- }
-
-#define SPEC_S_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Spec_S,size,ptrs) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- }
-
-MAYBE_DECLARE_RTBL(Spec_S,1,0)
-MAYBE_DECLARE_RTBL(Spec_S,1,1)
-MAYBE_DECLARE_RTBL(Spec_S,2,0)
-MAYBE_DECLARE_RTBL(Spec_S,2,1)
-MAYBE_DECLARE_RTBL(Spec_S,2,2)
-MAYBE_DECLARE_RTBL(Spec_S,3,0)
-MAYBE_DECLARE_RTBL(Spec_S,3,1)
-MAYBE_DECLARE_RTBL(Spec_S,3,2)
-MAYBE_DECLARE_RTBL(Spec_S,3,3)
-MAYBE_DECLARE_RTBL(Spec_S,4,0)
-MAYBE_DECLARE_RTBL(Spec_S,4,4)
-MAYBE_DECLARE_RTBL(Spec_S,5,0)
-MAYBE_DECLARE_RTBL(Spec_S,5,5)
-MAYBE_DECLARE_RTBL(Spec_S,6,6)
-MAYBE_DECLARE_RTBL(Spec_S,7,7)
-MAYBE_DECLARE_RTBL(Spec_S,8,8)
-MAYBE_DECLARE_RTBL(Spec_S,9,9)
-MAYBE_DECLARE_RTBL(Spec_S,10,10)
-MAYBE_DECLARE_RTBL(Spec_S,11,11)
-MAYBE_DECLARE_RTBL(Spec_S,12,12)
-
-#define SPEC_S_RTBL(size,ptrs) \
- const W_ MK_REP_LBL(Spec_S,size,ptrs)[] = { \
- INCLUDE_TYPE_INFO(SPEC_S) \
- INCLUDE_SIZE_INFO(size,ptrs) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(CAT2(_Evacuate_,size),CAT4(_Scavenge_,size,_,ptrs)) \
- SPEC_COMPACTING_INFO(CAT4(_ScanLink_,size,_,ptrs), \
- CAT2(_PRStart_,ptrs), \
- CAT2(_ScanMove_,size),CAT2(_PRIn_,ptrs)) \
- }
-
-#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[]; \
- localness W_ CAT2(RBH_,infolbl)[] = { \
- (W_) CAT2(RBH_,entry_code) \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(Spec_RBH,size,ptrs) \
- INCLUDE_PROFILING_INFO(RBH) \
- INCLUDE_SPEC_PADDING \
- INCLUDE_RBH_INFO(infolbl) \
- }; \
- STGFUN(CAT2(RBH_,entry_code)) { JMP_(RBH_entry); }\
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Spec_U,size,ptrs) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_SPEC_PADDING \
- INCLUDE_RBH_INFO(CAT2(RBH_,infolbl)) \
- }
-
-MAYBE_DECLARE_RTBL(Spec_RBH,1,0)
-MAYBE_DECLARE_RTBL(Spec_RBH,1,1)
-MAYBE_DECLARE_RTBL(Spec_RBH,2,0)
-MAYBE_DECLARE_RTBL(Spec_RBH,2,1)
-MAYBE_DECLARE_RTBL(Spec_RBH,2,2)
-MAYBE_DECLARE_RTBL(Spec_RBH,3,0)
-MAYBE_DECLARE_RTBL(Spec_RBH,3,1)
-MAYBE_DECLARE_RTBL(Spec_RBH,3,2)
-MAYBE_DECLARE_RTBL(Spec_RBH,3,3)
-MAYBE_DECLARE_RTBL(Spec_RBH,4,0)
-MAYBE_DECLARE_RTBL(Spec_RBH,4,4)
-MAYBE_DECLARE_RTBL(Spec_RBH,5,0)
-MAYBE_DECLARE_RTBL(Spec_RBH,5,5)
-MAYBE_DECLARE_RTBL(Spec_RBH,6,6)
-MAYBE_DECLARE_RTBL(Spec_RBH,7,7)
-MAYBE_DECLARE_RTBL(Spec_RBH,8,8)
-MAYBE_DECLARE_RTBL(Spec_RBH,9,9)
-MAYBE_DECLARE_RTBL(Spec_RBH,10,10)
-MAYBE_DECLARE_RTBL(Spec_RBH,11,11)
-MAYBE_DECLARE_RTBL(Spec_RBH,12,12)
-
-#define SPEC_RBH_RTBL(size,ptrs) \
- const W_ MK_REP_LBL(Spec_RBH,size,ptrs)[] = { \
- INCLUDE_TYPE_INFO(SPEC_RBH) \
- INCLUDE_SIZE_INFO(size,ptrs) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(CAT2(_Evacuate_RBH_,size),CAT4(_Scavenge_RBH_,size,_,ptrs)) \
- SPEC_COMPACTING_INFO(CAT4(_ScanLink_RBH_,size,_,ptrs), \
- CAT2(_PRStart_RBH_,ptrs), \
- CAT2(_ScanMove_RBH_,size),CAT2(_PRIn_RBH_,ptrs)) \
- }
-
-#define _Scavenge_RBH_2_0 _Scavenge_RBH_2_1
-#define _Scavenge_RBH_2_2 _Scavenge_RBH_2_1
-
-#define _Scavenge_RBH_3_0 _Scavenge_RBH_3_1
-#define _Scavenge_RBH_3_2 _Scavenge_RBH_3_1
-
-#define _Scavenge_RBH_4_0 _Scavenge_RBH_4_1
-#define _Scavenge_RBH_5_0 _Scavenge_RBH_5_1
-#define _Scavenge_RBH_6_0 _Scavenge_RBH_6_1
-#define _Scavenge_RBH_7_0 _Scavenge_RBH_7_1
-#define _Scavenge_RBH_8_0 _Scavenge_RBH_8_1
-#define _Scavenge_RBH_9_0 _Scavenge_RBH_9_1
-#define _Scavenge_RBH_10_0 _Scavenge_RBH_10_1
-#define _Scavenge_RBH_11_0 _Scavenge_RBH_11_1
-#define _Scavenge_RBH_12_0 _Scavenge_RBH_12_1
-
-#define _ScanLink_RBH_2_0 _ScanLink_RBH_2_1
-#define _ScanLink_RBH_2_2 _ScanLink_RBH_2_1
-
-#define _ScanLink_RBH_3_0 _ScanLink_RBH_3_1
-#define _ScanLink_RBH_3_2 _ScanLink_RBH_3_1
-
-#define _ScanLink_RBH_4_0 _ScanLink_RBH_4_1
-#define _ScanLink_RBH_5_0 _ScanLink_RBH_5_1
-#define _ScanLink_RBH_6_0 _ScanLink_RBH_6_1
-#define _ScanLink_RBH_7_0 _ScanLink_RBH_7_1
-#define _ScanLink_RBH_8_0 _ScanLink_RBH_8_1
-#define _ScanLink_RBH_9_0 _ScanLink_RBH_9_1
-#define _ScanLink_RBH_10_0 _ScanLink_RBH_10_1
-#define _ScanLink_RBH_11_0 _ScanLink_RBH_11_1
-#define _ScanLink_RBH_12_0 _ScanLink_RBH_12_1
-
-#define _PRStart_RBH_0 _PRStart_RBH_2
-#define _PRStart_RBH_1 _PRStart_RBH_2
-
-#define _PRIn_RBH_0 _PRIn_RBH_2
-#define _PRIn_RBH_1 _PRIn_RBH_2
-
-#else
-
-# define SPEC_U_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Spec_U,size,ptrs) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-#endif
-
-MAYBE_DECLARE_RTBL(Spec_U,1,0)
-MAYBE_DECLARE_RTBL(Spec_U,1,1)
-MAYBE_DECLARE_RTBL(Spec_U,2,0)
-MAYBE_DECLARE_RTBL(Spec_U,2,1)
-MAYBE_DECLARE_RTBL(Spec_U,2,2)
-MAYBE_DECLARE_RTBL(Spec_U,3,0)
-MAYBE_DECLARE_RTBL(Spec_U,3,1)
-MAYBE_DECLARE_RTBL(Spec_U,3,2)
-MAYBE_DECLARE_RTBL(Spec_U,3,3)
-MAYBE_DECLARE_RTBL(Spec_U,4,0)
-MAYBE_DECLARE_RTBL(Spec_U,4,4)
-MAYBE_DECLARE_RTBL(Spec_U,5,0)
-MAYBE_DECLARE_RTBL(Spec_U,5,5)
-MAYBE_DECLARE_RTBL(Spec_U,6,6)
-MAYBE_DECLARE_RTBL(Spec_U,7,7)
-MAYBE_DECLARE_RTBL(Spec_U,8,8)
-MAYBE_DECLARE_RTBL(Spec_U,9,9)
-MAYBE_DECLARE_RTBL(Spec_U,10,10)
-MAYBE_DECLARE_RTBL(Spec_U,11,11)
-MAYBE_DECLARE_RTBL(Spec_U,12,12)
-
-#define SPEC_U_RTBL(size,ptrs) \
- const W_ MK_REP_LBL(Spec_U,size,ptrs)[] = { \
- INCLUDE_TYPE_INFO(SPEC_U) \
- INCLUDE_SIZE_INFO(size,ptrs) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(CAT2(_Evacuate_,size),CAT4(_Scavenge_,size,_,ptrs)) \
- SPEC_COMPACTING_INFO(CAT4(_ScanLink_,size,_,ptrs), \
- CAT2(_PRStart_,ptrs), \
- CAT2(_ScanMove_,size),CAT2(_PRIn_,ptrs)) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SELECT_ITBL]{@SELECT_ITBL@: Special @SPEC_U@ info-table for selectors}
-%* *
-%************************************************************************
-
-These are different only in having slightly-magic GC code. The idea
-is: it is a @MIN_UPD_SIZE@ (==2) thunk with one pointer, which, when
-entered, will select word $i$ from its pointee.
-
-When garbage-collecting such a closure, we ``peek'' at the pointee's
-tag (in its info table). If it is evaluated, then we go ahead and do
-the selection---which is {\em just like an indirection}. If it is not
-evaluated, we carry on {\em exactly as if it is a size-2/1-ptr thunk}.
-
-Copying: only the evacuate routine needs to be special.
-
-Compacting: only the PRStart (marking) routine needs to be special.
-
-\begin{code}
-
-#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[]; \
- localness W_ CAT2(RBH_,infolbl)[] = { \
- (W_) CAT2(RBH_,entry_code) \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(Spec_RBH,size,ptrs) \
- INCLUDE_PROFILING_INFO(RBH) \
- INCLUDE_SPEC_PADDING \
- INCLUDE_RBH_INFO(infolbl) \
- }; \
- STGFUN(CAT2(RBH_,entry_code)) { JMP_(RBH_entry); }\
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Select,,select_word_i) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_SPEC_PADDING \
- INCLUDE_RBH_INFO(CAT2(RBH_,infolbl)) \
- } \
-
-#else
-
-# define SELECT_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,select_word_i,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Select,,select_word_i) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-#endif
-
-MAYBE_DECLARE_RTBL(Select,,0)
-MAYBE_DECLARE_RTBL(Select,,1)
-MAYBE_DECLARE_RTBL(Select,,2)
-MAYBE_DECLARE_RTBL(Select,,3)
-MAYBE_DECLARE_RTBL(Select,,4)
-MAYBE_DECLARE_RTBL(Select,,5)
-MAYBE_DECLARE_RTBL(Select,,6)
-MAYBE_DECLARE_RTBL(Select,,7)
-MAYBE_DECLARE_RTBL(Select,,8)
-MAYBE_DECLARE_RTBL(Select,,9)
-MAYBE_DECLARE_RTBL(Select,,10)
-MAYBE_DECLARE_RTBL(Select,,11)
-MAYBE_DECLARE_RTBL(Select,,12)
-
-#define SELECT_RTBL(size,ptrs,select_word_i) \
- const W_ MK_REP_LBL(Select,,select_word_i)[] = { \
- INCLUDE_TYPE_INFO(SPEC_U) \
- INCLUDE_SIZE_INFO(size,ptrs) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(CAT2(_EvacuateSelector_,select_word_i), \
- CAT4(_Scavenge_,size,_,ptrs)) \
- SPEC_COMPACTING_INFO(CAT4(_ScanLink_,size,_,ptrs), \
- CAT2(_PRStartSelector_,select_word_i), \
- CAT2(_ScanMove_,size), \
- CAT2(_PRIn_,ptrs)) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[GEN_ITBL]{@GEN_x_ITBL@: Generic/general? info-tables}
-%* *
-%************************************************************************
-
-@GEN@ info-table for non-updatable nodes (normal and non-normal forms).
-
-Size/no-of-ptrs are known at compile time, but we don't have GC
-routines wired in for those specific sizes. Hence the size/no-of-ptrs
-is stored in the info-table.
-
-\begin{code}
-
-#define GEN_N_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Gen_N,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- INCLUDE_GEN_INFO(size,ptrs) \
- }
-
-MAYBE_DECLARE_RTBL(Gen_N,,)
-
-#define GEN_N_RTBL() \
- const W_ MK_REP_LBL(Gen_N,,)[] = { \
- INCLUDE_TYPE_INFO(GEN_N) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in info table */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_S,_Scavenge_S_N) \
- INCLUDE_COMPACTING_INFO(_ScanLink_S_N,_PRStart_N,_ScanMove_S,_PRIn_I) \
- }
-
-#define GEN_S_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Gen_S,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- INCLUDE_GEN_INFO(size,ptrs) \
- }
-
-MAYBE_DECLARE_RTBL(Gen_S,,)
-
-#define GEN_S_RTBL() \
- const W_ MK_REP_LBL(Gen_S,,)[] = { \
- INCLUDE_TYPE_INFO(GEN_S) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in info table */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_S,_Scavenge_S_N) \
- INCLUDE_COMPACTING_INFO(_ScanLink_S_N,_PRStart_N,_ScanMove_S,_PRIn_I) \
- }
-
-#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[]; \
- localness W_ CAT2(RBH_,infolbl)[] = { \
- (W_) CAT2(RBH_,entry_code) \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(Gen_RBH,,) \
- INCLUDE_PROFILING_INFO(RBH) \
- INCLUDE_UPDATE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_GEN_INFO(size,ptrs) \
- INCLUDE_RBH_INFO(infolbl) \
- }; \
- STGFUN(CAT2(RBH_,entry_code)) { JMP_(RBH_entry); }\
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Gen_U,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_GEN_INFO(size,ptrs) \
- INCLUDE_RBH_INFO(CAT2(RBH_,infolbl)) \
- }
-
-MAYBE_DECLARE_RTBL(Gen_RBH,,)
-
-# define GEN_RBH_RTBL() \
- const W_ MK_REP_LBL(Gen_RBH,,)[] = { \
- INCLUDE_TYPE_INFO(GEN_RBH) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: no size/no-ptrs! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_RBH_S,_Scavenge_RBH_N) \
- INCLUDE_COMPACTING_INFO(_ScanLink_RBH_N,_PRStart_RBH_N,_ScanMove_RBH_S,_PRIn_RBH_I) \
- }
-
-#else
-
-# define GEN_U_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Gen_U,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_GEN_INFO(size,ptrs) \
- }
-#endif
-
-MAYBE_DECLARE_RTBL(Gen_U,,)
-
-#define GEN_U_RTBL() \
- const W_ MK_REP_LBL(Gen_U,,)[] = { \
- INCLUDE_TYPE_INFO(GEN_U) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: no size/no-ptrs! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_S,_Scavenge_S_N) \
- INCLUDE_COMPACTING_INFO(_ScanLink_S_N,_PRStart_N,_ScanMove_S,_PRIn_I) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[DYN_ITBL]{Dynamic-object info tables}
-%* *
-%************************************************************************
-
-For these, the size/no-of-pointers is not known until runtime. E.g.,
-arrays. Those fields are, therefore, in the closure itself, and not
-in the info table.
-
-All @DYN@ closures are @PAP@s, so they are not updatable.
-
-\begin{code}
-
-#define DYN_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_LBL(Dyn,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(Dyn,,)
-
-#define DYN_RTBL() \
- const W_ MK_REP_LBL(Dyn,,)[] = { \
- INCLUDE_TYPE_INFO(DYN) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* in closure! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Dyn,_Scavenge_Dyn) \
- INCLUDE_COMPACTING_INFO(_ScanLink_Dyn,_PRStart_Dyn,_ScanMove_Dyn,_PRIn_I_Dyn) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TUPLE_ITBL]{``Tuple'' and ``Data'' info-tables}
-%* *
-%************************************************************************
-
-``Tuples'' are essentially DYNs with all pointers (no non-pointers).
-``Data things'' are DYNs with all non-pointers.
-
-\begin{code}
-
-#define TUPLE_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(Tuple,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(Tuple,,)
-
-#define TUPLE_RTBL() \
- const W_ MK_REP_LBL(Tuple,,)[] = { \
- INCLUDE_TYPE_INFO(TUPLE) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in closure */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Tuple,_Scavenge_Tuple) \
- INCLUDE_COMPACTING_INFO(_ScanLink_Tuple,_PRStart_Tuple,_ScanMove_Tuple,_PRIn_I_Tuple) \
- }
-
-#define DATA_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(Data,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(Data,,)
-
-#define DATA_RTBL() \
- const W_ MK_REP_LBL(Data,,)[] = { \
- INCLUDE_TYPE_INFO(DATA) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in closure */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Data,_Scavenge_Data) \
- INCLUDE_COMPACTING_INFO(_ScanLink_Data,_PRStart_Data,_ScanMove_Data,_PRIn_Error) \
- }
-
-/* Here is the decl for the only DATA info table used! */
-#ifndef COMPILING_NCG
-EXTDATA_RO(ArrayOfData_info);
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[MUTUPLE_ITBL]{Info-table for (im)mutable [array-ish] objects}
-%* *
-%************************************************************************
-
-ToDo: Integrate with PAR stuff (Kevin) !!
-If someone bothers to document this I'll see what I can do! KH
-
-\begin{code}
-
-#if defined(GC_MUT_REQUIRED)
-
-# define MUTUPLE_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(MuTuple,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(MuTuple,,)
-
-# define MUTUPLE_RTBL() \
- const W_ MK_REP_LBL(MuTuple,,)[] = { \
- INCLUDE_TYPE_INFO(MUTUPLE) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in closure! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_MuTuple,_Scavenge_MuTuple) \
- INCLUDE_COMPACTING_INFO(_ScanLink_MuTuple,_PRStart_MuTuple,_ScanMove_MuTuple,_PRIn_I_MuTuple) \
- }
-
-# define IMMUTUPLE_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(ImmuTuple,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(ImmuTuple,,)
-
-# define IMMUTUPLE_RTBL() \
- const W_ MK_REP_LBL(ImmuTuple,,)[] = { \
- INCLUDE_TYPE_INFO(IMMUTUPLE) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in closure! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_MuTuple,_Scavenge_MuTuple) \
- INCLUDE_COMPACTING_INFO(_ScanLink_MuTuple,_PRStart_MuTuple,_ScanMove_ImmuTuple,_PRIn_I_MuTuple) \
- }
-
-#else /* ! GC_MUT_REQUIRED --- define as TUPLE closure */
-
-# define MUTUPLE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- TUPLE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type)
-# define IMMUTUPLE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- TUPLE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type)
-
-# define MUTUPLE_RTBL()
-# define IMMUTUPLE_RTBL()
-#endif
-
-/* Here are the decls for the only MUTUPLE info tables used. */
-#ifndef COMPILING_NCG
-EXTDATA_RO(ArrayOfPtrs_info);
-EXTDATA_RO(ImMutArrayOfPtrs_info);
-EXTDATA_RO(EmptySVar_info);
-EXTDATA_RO(FullSVar_info);
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[STATIC_ITBL]{Info tables for static objects (outside the heap)}
-%* *
-%************************************************************************
-
-Size and ptrs fields are used by interpretive code, such as @ghci@,
-the parallel Pack code (@Pack.lc@) and possibly to-be-written debug
-code.
-
-\begin{code}
-#define STATIC_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Static,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- INCLUDE_STATIC_INFO(size,ptrs) \
- }
-
-MAYBE_DECLARE_RTBL(Static,,)
-
-#define STATIC_RTBL() \
- const W_ MK_REP_LBL(Static,,)[] = { \
- INCLUDE_TYPE_INFO(STATIC) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in info table! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Static,_Dummy_Static_entry) \
- INCLUDE_COMPACTING_INFO(_Dummy_Static_entry,_PRStart_Static, \
- _Dummy_Static_entry,_Dummy_Static_entry) \
- }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ForeignObj_ITBL]{@ForeignObj_TBL@: @ForeignObj@ info-table}
-%* *
-%************************************************************************
-
-The following table is a bit like that for @SPEC@ with 0 pointers and
-a small number of non-ptrs. However, the garbage collection routines
-are a bit special.
-
-I'm assuming @SPEC_N@, so that we don't need to pad out the info table. (JSM)
-
-\begin{code}
-#if !defined(PAR)
-
-# 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(ForeignObj,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(ForeignObj,,)
-
-# define ForeignObj_RTBL() \
- const W_ MK_REP_LBL(ForeignObj,,)[] = { \
- INCLUDE_TYPE_INFO(INTERNAL) \
- INCLUDE_SIZE_INFO(ForeignObj_SIZE, 0L) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_ForeignObj,_Scavenge_ForeignObj) \
- SPEC_COMPACTING_INFO(_ScanLink_ForeignObj,_PRStart_ForeignObj,_ScanMove_ForeignObj,_PRIn_0) \
- }
-
-#endif /* !PAR */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BH_ITBL]{Info tables for ``black holes''}
-%* *
-%************************************************************************
-
-Special info-table for black holes. It is possible to describe these
-using @SPEC@ closures but this requires explicit use of the value of
-@MIN_UPD_SIZE@. For now we have a special macro and code.
-
-\begin{code}
-
-#define BH_ITBL(infolbl,bh_code,kind,localness,entry_localness) \
- entry_localness(bh_code); \
- localness W_ infolbl[] = { \
- (W_) bh_code \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(BH,kind,) \
- INCLUDE_PROFILING_INFO(BH) \
- }
-
-MAYBE_DECLARE_RTBL(BH,U,)
-MAYBE_DECLARE_RTBL(BH,N,)
-
-#define BH_RTBL(kind) \
- const W_ MK_REP_LBL(BH,kind,)[] = { \
- INCLUDE_TYPE_INFO(BH) \
- INCLUDE_SIZE_INFO(CAT3(BH_,kind,_SIZE),0L) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(CAT2(_Evacuate_BH_,kind),CAT2(_Scavenge_BH_,kind)) \
- INCLUDE_COMPACTING_INFO(CAT2(_ScanLink_BH_,kind),_PRStart_BH, \
- CAT2(_ScanMove_BH_,kind),_PRIn_Error) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[IND_ITBL]{Info table for indirections}
-%* *
-%************************************************************************
-
-An indirection simply extracts the pointer from the
-@IND_CLOSURE_PTR(closure)@ field. The garbage collection routines will
-short out the indirection (normally).
-\begin{code}
-
-#define IND_ITBL(infolbl,ind_code,localness,entry_localness) \
- CAT_DECLARE(infolbl,INTERNAL_KIND,"IND","IND") \
- entry_localness(ind_code); \
- localness W_ infolbl[] = { \
- (W_) ind_code \
- ,(W_) INFO_IND_TAG \
- ,(W_) MK_REP_REF(Ind,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(Ind,,)
-
-#define IND_RTBL() \
- const W_ MK_REP_LBL(Ind,,)[] = { \
- INCLUDE_TYPE_INFO(IND) \
- INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) /* #ptrs not here! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Ind,_Scavenge_Ind) \
- INCLUDE_COMPACTING_INFO(_Dummy_Ind_entry,_PRStart_Ind, \
- _Dummy_Ind_entry,_Dummy_Ind_entry) \
- }
-
-\end{code}
-
-Lexical-scoped profiling (now more-or-less the default... 94/06)
-requires a special permanent indirection for PAP closures. These
-look exactly like regular indirections, but they are not short-circuited
-on garbage collection.
-
-\begin{code}
-#if defined(PROFILING) || defined(TICKY_TICKY)
-
-# define PERM_IND_ITBL(infolbl,ind_code,localness,entry_localness) \
- entry_localness(ind_code); \
- CAT_DECLARE(infolbl,INTERNAL_KIND,"IND","IND") \
- localness W_ infolbl[] = { \
- (W_) ind_code \
- ,(W_) INFO_IND_TAG \
- ,(W_) MK_REP_REF(Perm_Ind,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(Perm_Ind,,)
-
-# define PERM_IND_RTBL() \
- const W_ MK_REP_LBL(Perm_Ind,,)[] = { \
- INCLUDE_TYPE_INFO(IND) \
- INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) /* #ptrs not here! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_PI,_Scavenge_PI) \
- SPEC_COMPACTING_INFO(_ScanLink_PI,_PRStart_PI, \
- _ScanMove_PI,_PRIn_PI) \
- }
-
-#else
-# define PERM_IND_RTBL()
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CAF_ITBL]{Info table for updated @CAF@s}
-%* *
-%************************************************************************
-
-Garbage collection of @CAF@s is tricky. We have to cope with explicit
-collection from the @CAFlist@ as well as potential references from the
-stack and heap which will cause the @CAF@ evacuation code to be
-called. They are treated like indirections which are shorted out.
-However they must also be updated to point to the new location of the
-new closure as the @CAF@ may still be used by references which
-reside in the code.
-
-\subsubsection{Copying Collection}
-
-A first scheme might use evacuation code which evacuates the reference
-and updates the indirection. This is no good as subsequent evacuations
-will result in an already evacuated closure being evacuated. This will
-leave a forward reference in to-space!
-
-An alternative scheme evacuates the @CAFlist@ first. The closures
-referenced are evacuated and the @CAF@ indirection updated to point to
-the evacuated closure. The @CAF@ evacuation code simply returns the
-updated indirection pointer --- the pointer to the evacuated closure.
-Unfortunately the closure the @CAF@ references may be a static
-closure, in fact, it may be another @CAF@. This will cause the second
-@CAF@'s evacuation code to be called before the @CAF@ has been
-evacuated, returning an unevacuated pointer.
-
-Another scheme leaves updating the @CAF@ indirections to the end of
-the garbage collection. All the references are evacuated and
-scavenged as usual (including the @CAFlist@). Once collection is
-complete the @CAFlist@ is traversed updating the @CAF@ references with
-the result of evacuating the referenced closure again. This will
-immediately return as it must be a forward reference, a static
-closure, or a @CAF@ which will indirect by evacuating its reference.
-
-The crux of the problem is that the @CAF@ evacuation code needs to
-know if its reference has already been evacuated and updated. If not,
-then the reference can be evacuated, updated and returned safely
-(possibly evacuating another @CAF@). If it has, then the updated
-reference can be returned. This can be done using two @CAF@
-info-tables. At the start of a collection the @CAFlist@ is traversed
-and set to an internal {\em evacuate and update} info-table. During
-collection, evacution of such a @CAF@ also results in the info-table
-being reset back to the standard @CAF@ info-table. Thus subsequent
-evacuations will simply return the updated reference. On completion of
-the collection all @CAF@s will have {\em return reference} info-tables
-again.
-
-This is the scheme we adopt. A @CAF@ indirection has evacuation code
-which returns the evacuated and updated reference. During garbage
-collection, all the @CAF@s are overwritten with an internal @CAF@ info
-table which has evacuation code which performs this evacuate and
-update and restores the original @CAF@ code. At some point during the
-collection we must ensure that all the @CAF@s are indeed evacuated.
-
-The only potential problem with this scheme is a cyclic list of @CAF@s
-all directly referencing (possibly via indirections) another @CAF@!
-Evacuation of the first @CAF@ will fail in an infinite loop of @CAF@
-evacuations. This is solved by ensuring that the @CAF@ info-table is
-updated to a {\em return reference} info-table before performing the
-evacuate and update. If this {\em return reference} evacuation code is
-called before the actual evacuation is complete it must be because
-such a cycle of references exists. Returning the still unevacuated
-reference is OK --- all the @CAF@s will now reference the same
-@CAF@ which will reference itself! Construction of such a structure
-indicates the program must be in an infinite loop.
-
-\subsubsection{Compacting Collector}
-
-When shorting out a @CAF@, its reference must be marked. A first
-attempt might explicitly mark the @CAF@s, updating the reference with
-the marked reference (possibly short circuting indirections). The
-actual @CAF@ marking code can indicate that they have already been
-marked (though this might not have actually been done yet) and return
-the indirection pointer so it is shorted out. Unfortunately the @CAF@
-reference might point to an indirection which will be subsequently
-shorted out. Rather than returning the @CAF@ reference we treat the
-@CAF@ as an indirection, calling the mark code of the reference, which
-will return the appropriately shorted reference.
-
-Problem: Cyclic list of @CAF@s all directly referencing (possibly via
-indirections) another @CAF@!
-
-Before compacting, the locations of the @CAF@ references are
-explicitly linked to the closures they reference (if they reference
-heap allocated closures) so that the compacting process will update
-them to the closure's new location. Unfortunately these locations'
-@CAF@ indirections are static. This causes premature termination
-since the test to find the info pointer at the end of the location
-list will match more than one value. This can be solved by using an
-auxiliary dynamic array (on the top of the A stack). One location for
-each @CAF@ indirection is linked to the closure that the @CAF@
-references. Once collection is complete this array is traversed and
-the corresponding @CAF@ is then updated with the updated pointer from
-the auxiliary array.
-
-\begin{code}
-
-#define CAF_ITBL(infolbl,ind_code,localness,entry_localness) \
- CAT_DECLARE(infolbl,INTERNAL_KIND,"CAF","CAF") \
- entry_localness(ind_code); \
- localness W_ infolbl[] = { \
- (W_) ind_code \
- ,(W_) INFO_IND_TAG \
- ,(W_) MK_REP_REF(Caf,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(Caf,,)
-
-#define CAF_RTBL() \
- const W_ MK_REP_LBL(Caf,,)[] = { \
- INCLUDE_TYPE_INFO(CAF) \
- INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) /* #ptrs not here! */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Caf,_Scavenge_Caf) \
- INCLUDE_COMPACTING_INFO(_Dummy_Caf_entry,_PRStart_Caf, \
- _Dummy_Caf_entry,_Dummy_Caf_entry) \
- }
-\end{code}
-
-
-It is possible to use an alternative marking scheme, using a similar
-idea to the copying solution. This scheme avoids the need to update
-the @CAF@ references explicitly. We introduce an auxillary {\em mark
-and update} @CAF@ info-table which is used to update all @CAF@s at the
-start of a collection. The new code marks the @CAF@ reference,
-updating it with the returned reference. The returned reference is
-itself returned so the @CAF@ is shorted out. The code also modifies the
-@CAF@ info-table to be a {\em return reference}. Subsequent attempts to
-mark the @CAF@ simply return the updated reference.
-
-A cyclic @CAF@ reference will result in an attempt to mark the @CAF@
-before the marking has been completed and the reference updated. We
-cannot start marking the @CAF@ as it is already being marked. Nor can
-we return the reference as it has not yet been updated. Neither can we
-treat the CAF as an indirection since the @CAF@ reference has been
-obscured by the pointer reversal stack. All we can do is return the
-@CAF@ itself. This will result in some @CAF@ references not being
-shorted out.
-
-This scheme has not been adopted but has been implemented. The code is
-commented out with @#if 0@.
-
-%************************************************************************
-%* *
-\subsection[CONST_ITBL]{@CONST_ITBL@}
-%* *
-%************************************************************************
-
-This declares an info table for @CONST@ closures (size 0). It is the
-info table for a dynamicaly-allocated closure which will redirect
-references to the corresponding static closure @<infolbl>_closure@
-during garbage collection. A pointer to the static closure is kept in
-the info table. (It is assumed that this closure is declared
-elsewhere.)
-
-Why do such @CONST@ objects ever exist? Why don't we just use the
-static object in the first place? @CONST@ objects are used only for
-updating existing objects. We could use an indirection, but that
-risks costing extra run-time indirections until the next GC shorts it
-out. So we update with a @CONST@, and the next GC gets rid of it.
-
-\begin{code}
-#define CONST_ITBL(infolbl,closurelbl,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); \
- EXTDATA(closurelbl); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) tag \
- ,(W_) MK_REP_REF(Const,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- INCLUDE_CONST_INFO(closurelbl) \
- }
-
-MAYBE_DECLARE_RTBL(Const,,)
-
-#ifdef TICKY_TICKY
- /* we need real routines if we may not be commoning up */
-#define CONST_Scav _Scavenge_0_0
-#define CONST_Link _ScanLink_0_0
-#define CONST_Move _ScanMove_0
-#else
-#define CONST_Scav _Dummy_Const_entry
-#define CONST_Link _Dummy_Const_entry
-#define CONST_Move _Dummy_Const_entry
-#endif
-
-#define CONST_RTBL() \
- const W_ MK_REP_LBL(Const,,)[] = { \
- INCLUDE_TYPE_INFO(CONST) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Const,CONST_Scav) \
- INCLUDE_COMPACTING_INFO(CONST_Link,_PRStart_Const, \
- CONST_Move,_Dummy_Const_entry) \
- }
-\end{code}
-
-This builds an info-table which will have pointers to the closure
-replaced with @closure_lbl@ during garbage collection. @closure_lbl@
-must be the label of a static closure, whose entry code has identical
-behaviour to that in the corresponding @CONST_ITBL@. Usually
-the info pointer of this closure will be the very one defined by this
-macro!
-
-These closures always consist only of an info pointer; that is, its
-size is zero.
-
-A copying collection implements this with evacuation code which
-returns @closure_lbl@, without actually evacuating the object at all.
-A compacting collector uses marking code which returns
-@closure_lbl@, without marking the closure.
-
-%************************************************************************
-%* *
-\subsection[FOOLIKE_ITBL]{``Char-like'' and ``Int-like'' info-tables}
-%* *
-%************************************************************************
-
-Char-like: This builds an info-table which, when GC happens, will have
-pointers to the closure replaced with the appropriate element of the
-@CHARLIKE_closures@ array.
-
-\begin{code}
-#define CHARLIKE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*tag,size,ptrs unused*/ \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) INFO_FIRST_TAG \
- ,(W_) MK_REP_REF(CharLike,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- }
-
-MAYBE_DECLARE_RTBL(CharLike,,)
-
-#ifdef TICKY_TICKY
- /* we need real routines if we may not be commoning up */
-#define CHARLIKE_Scav _Scavenge_1_0
-#define CHARLIKE_Link _ScanLink_1_0
-#define CHARLIKE_Move _ScanMove_1
-#else
-#define CHARLIKE_Scav _Dummy_CharLike_entry
-#define CHARLIKE_Link _Dummy_CharLike_entry
-#define CHARLIKE_Move _Dummy_CharLike_entry
-#endif
-
-#define CHARLIKE_RTBL() \
- const W_ MK_REP_LBL(CharLike,,)[] = { \
- INCLUDE_TYPE_INFO(CHARLIKE) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_CharLike,CHARLIKE_Scav) \
- INCLUDE_COMPACTING_INFO(CHARLIKE_Link,_PRStart_CharLike, \
- CHARLIKE_Move,_PRIn_Error) \
- }
-\end{code}
-
-Int-like: this builds the info-table required for intlike closures.
-The normal heap-allocated info-table for fixed-size integers (size
-@1@); it is used for updates too. At GC, this is redirected to a
-static intlike closure if one is available.
-
-\begin{code}
-#define INTLIKE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*tag,size,ptrs unused*/ \
- CAT_DECLARE(infolbl,kind,descr,type) \
- entry_localness(entry_code); \
- localness W_ infolbl[] = { \
- (W_) entry_code \
- ,(W_) INFO_FIRST_TAG \
- ,(W_) MK_REP_REF(IntLike,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- }
-
-MAYBE_DECLARE_RTBL(IntLike,,)
-
-#define INTLIKE_RTBL() \
- const W_ MK_REP_LBL(IntLike,,)[] = { \
- INCLUDE_TYPE_INFO(INTLIKE) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_IntLike,_Scavenge_1_0) \
- INCLUDE_COMPACTING_INFO(_ScanLink_1_0,_PRStart_IntLike, \
- _ScanMove_1,_PRIn_Error) \
- }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[INREGS_ITBL]{@INREGS_ITBL@s}
-%* *
-%************************************************************************
-
-The emaciated info table for a phantom closure that lives only in regs.
-We don't need any GC information, because these closures never make it into
-the heap (not with this info table, anyway). Similarly, we don't need an
-entry address, because these closures are never entered...they only exist
-during a return.
-
-\begin{code}
-
-#define INREGS_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*mostly unused*/ \
- localness W_ infolbl[] = { \
- (W_) INFO_UNUSED \
- ,(W_) tag \
- ,(W_) INFO_UNUSED \
- INREGS_PROFILING_INFO \
- INCLUDE_UPDATE_INFO(upd_code,liveness) \
- }
-
-/* Declare the phantom info table vectors (just Bool at the moment) */
-#ifndef COMPILING_NCG
-#ifndef aix_TARGET_OS /* AIX gives link errors with this as a const (RO assembler section) */
-EXTDATA_RO(PrelBase_Bool_itblvtbl);
-#else
-extern W_ PrelBase_Bool_itblvtbl[];
-#endif
-#endif
-
-\end{code}
-
-End multi-slurp protection:
-\begin{code}
-#endif /* SMInfoTables_H */
-\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\section[SMcompact]{Code labels for single-space compacting collectors}
-%* *
-%************************************************************************
-Multi-slurp protection:
-\begin{code}
-#ifndef SMCOMPACT_H
-#define SMCOMPACT_H
-\end{code}
-First, some potentially non-portable macros for marking locations.
-During compacting, we use the info pointer field of a closure to
-maintain a list of locations that point to the closure. The actual
-info pointer is saved at the end of the list. When we traverse this
-list, we need to be able to distinguish the info pointer from an
-arbitrary location (possibly in the heap, but possibly elsewhere).
-So, we set a bit on the locations as we add them to the list.
-This has to be a bit that is always going to be clear on an info
-pointer. Since info tables are typically word-aligned, we hope that
-the 0 bit will suffice for most implementations.
-
-\begin{code}
-
-#define CLEAR_PTR_BIT (0)
-
-#define MARKED_LOCATION_MASK (1L<<CLEAR_PTR_BIT)
-
-#define MARK_LOCATION(loc) (((W_)(loc)) | MARKED_LOCATION_MASK)
-#define UNMARK_LOCATION(loc) ((P_)(((W_)(loc)) & ~MARKED_LOCATION_MASK))
-
-#define MARKED_LOCATION(loc) ((((W_)(loc)) & MARKED_LOCATION_MASK) != 0)
-
-\end{code}
-
-A dynamic closure has to be recognizable even after it has lost its
-info pointer as a result of the linking described above. We first test
-to see if its info pointer is a marked location (in which case, it must
-be a dynamic closure), and if it isn't, we check the rep table to see
-if it's not static.
-
-\begin{code}
-
-#define DYNAMIC_CLOSURE(c) (MARKED_LOCATION(INFO_PTR(c)) || !IS_STATIC(INFO_PTR(c)))
-
-\end{code}
-
-\begin{code}
-
-typedef I_ (StgScanFun)(STG_NO_ARGS);
-typedef I_ (*StgScanPtr)(STG_NO_ARGS);
-
-#ifdef TICKY_TICKY
-extern StgScanFun _ScanLink_0_0;
-#endif
-extern StgScanFun _ScanLink_1_0;
-extern StgScanFun _ScanLink_2_0;
-extern StgScanFun _ScanLink_3_0;
-extern StgScanFun _ScanLink_4_0;
-extern StgScanFun _ScanLink_5_0;
-
-extern StgScanFun _ScanLink_2_1; /* 1 ptr, 1 non-ptr */
-extern StgScanFun _ScanLink_3_1; /* 1 ptr, 2 non-ptrs */
-extern StgScanFun _ScanLink_3_2; /* 2 ptrs, 1 non-ptr */
-
-extern StgScanFun _ScanLink_1_1;
-extern StgScanFun _ScanLink_2_2;
-extern StgScanFun _ScanLink_3_3;
-extern StgScanFun _ScanLink_4_4;
-extern StgScanFun _ScanLink_5_5;
-extern StgScanFun _ScanLink_6_6;
-extern StgScanFun _ScanLink_7_7;
-extern StgScanFun _ScanLink_8_8;
-extern StgScanFun _ScanLink_9_9;
-extern StgScanFun _ScanLink_10_10;
-extern StgScanFun _ScanLink_11_11;
-extern StgScanFun _ScanLink_12_12;
-
-extern StgScanFun _ScanLink_S_N;
-extern StgScanFun _ScanLink_Dyn;
-extern StgScanFun _ScanLink_Tuple;
-extern StgScanFun _ScanLink_Data;
-extern StgScanFun _ScanLink_MuTuple;
-
-#if defined(PROFILING) || defined(TICKY_TICKY)
-extern StgScanFun _ScanLink_PI;
-#endif
-
-#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 _ScanLink_RBH_4_1;
-extern StgScanFun _ScanLink_RBH_4_4;
-extern StgScanFun _ScanLink_RBH_5_1;
-extern StgScanFun _ScanLink_RBH_5_5;
-extern StgScanFun _ScanLink_RBH_6_6;
-extern StgScanFun _ScanLink_RBH_7_7;
-extern StgScanFun _ScanLink_RBH_8_8;
-extern StgScanFun _ScanLink_RBH_9_9;
-extern StgScanFun _ScanLink_RBH_10_10;
-extern StgScanFun _ScanLink_RBH_11_11;
-extern StgScanFun _ScanLink_RBH_12_12;
-extern StgScanFun _ScanLink_RBH_N;
-extern StgScanFun _ScanLink_FetchMe;
-extern StgScanFun _ScanLink_BF;
-
-extern StgScanFun _ScanMove_RBH_2;
-extern StgScanFun _ScanMove_RBH_3;
-extern StgScanFun _ScanMove_RBH_4;
-extern StgScanFun _ScanMove_RBH_5;
-extern StgScanFun _ScanMove_RBH_6;
-extern StgScanFun _ScanMove_RBH_7;
-extern StgScanFun _ScanMove_RBH_8;
-extern StgScanFun _ScanMove_RBH_9;
-extern StgScanFun _ScanMove_RBH_10;
-extern StgScanFun _ScanMove_RBH_11;
-extern StgScanFun _ScanMove_RBH_12;
-
-extern StgScanFun _ScanMove_RBH_S;
-#endif /* PAR || GRAN */
-
-#if !defined(PAR) || defined(GRAN)
-extern StgScanFun _ScanLink_ForeignObj;
-#endif
-
-extern StgScanFun _ScanLink_BH_N;
-extern StgScanFun _ScanLink_BH_U;
-
-#if defined(CONCURRENT)
-extern StgScanFun _ScanLink_StkO;
-extern StgScanFun _ScanLink_TSO;
-extern StgScanFun _ScanLink_BQ;
-#endif
-
-#ifdef TICKY_TICKY
-extern StgScanFun _ScanMove_0;
-#endif
-extern StgScanFun _ScanMove_1;
-extern StgScanFun _ScanMove_2;
-extern StgScanFun _ScanMove_3;
-extern StgScanFun _ScanMove_4;
-extern StgScanFun _ScanMove_5;
-extern StgScanFun _ScanMove_6;
-extern StgScanFun _ScanMove_7;
-extern StgScanFun _ScanMove_8;
-extern StgScanFun _ScanMove_9;
-extern StgScanFun _ScanMove_10;
-extern StgScanFun _ScanMove_11;
-extern StgScanFun _ScanMove_12;
-
-extern StgScanFun _ScanMove_S;
-extern StgScanFun _ScanMove_Dyn;
-extern StgScanFun _ScanMove_Tuple;
-extern StgScanFun _ScanMove_Data;
-extern StgScanFun _ScanMove_MuTuple;
-
-#if defined(PROFILING) || defined(TICKY_TICKY)
-extern StgScanFun _ScanMove_PI;
-#endif
-
-#ifndef PAR
-extern StgScanFun _ScanMove_ForeignObj;
-#endif /* !PAR */
-
-extern StgScanFun _ScanMove_ImmuTuple;
-extern StgScanFun _ScanMove_BH_N;
-extern StgScanFun _ScanMove_BH_U;
-
-#if defined(CONCURRENT)
-extern StgScanFun _ScanMove_StkO;
-extern StgScanFun _ScanMove_TSO;
-extern StgScanFun _ScanMove_BQ;
-#if defined(PAR)
-extern StgScanFun _ScanMove_FetchMe;
-extern StgScanFun _ScanMove_BF;
-#endif
-#endif
-\end{code}
-
-End of multi-slurp protection:
-\begin{code}
-#endif /* SMCOMPACT_H */
-\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\section[SMcopying]{Code labels for two-space copying collectors}
-%* *
-%************************************************************************
-Multi-slurp protection:
-\begin{code}
-#ifndef SMCOPYING_H
-#define SMCOPYING_H
-\end{code}
-
-\begin{code}
-typedef P_ (StgEvacFun)PROTO((P_));
-typedef P_ (*StgEvacPtr)PROTO((P_));
-
-typedef void (StgScavFun)(STG_NO_ARGS);
-typedef void (*StgScavPtr)(STG_NO_ARGS);
-
-extern StgEvacFun _Evacuate_1;
-extern StgEvacFun _Evacuate_2;
-extern StgEvacFun _Evacuate_3;
-extern StgEvacFun _Evacuate_4;
-extern StgEvacFun _Evacuate_5;
-extern StgEvacFun _Evacuate_6;
-extern StgEvacFun _Evacuate_7;
-extern StgEvacFun _Evacuate_8;
-extern StgEvacFun _Evacuate_9;
-extern StgEvacFun _Evacuate_10;
-extern StgEvacFun _Evacuate_11;
-extern StgEvacFun _Evacuate_12;
-
-extern StgEvacFun _EvacuateSelector_0; /* 0-origin */
-extern StgEvacFun _EvacuateSelector_1;
-extern StgEvacFun _EvacuateSelector_2;
-extern StgEvacFun _EvacuateSelector_3;
-extern StgEvacFun _EvacuateSelector_4;
-extern StgEvacFun _EvacuateSelector_5;
-extern StgEvacFun _EvacuateSelector_6;
-extern StgEvacFun _EvacuateSelector_7;
-extern StgEvacFun _EvacuateSelector_8;
-extern StgEvacFun _EvacuateSelector_9;
-extern StgEvacFun _EvacuateSelector_10;
-extern StgEvacFun _EvacuateSelector_11;
-extern StgEvacFun _EvacuateSelector_12;
-
-#ifdef TICKY_TICKY
-extern StgScavFun _Scavenge_0_0;
-#endif
-extern StgScavFun _Scavenge_1_0;
-extern StgScavFun _Scavenge_2_0;
-extern StgScavFun _Scavenge_3_0;
-extern StgScavFun _Scavenge_4_0;
-extern StgScavFun _Scavenge_5_0;
-
-extern StgScavFun _Scavenge_2_1; /* 1 ptr, 1 non-ptr */
-extern StgScavFun _Scavenge_3_1; /* 1 ptr, 2 non-ptrs */
-extern StgScavFun _Scavenge_3_2; /* 2 ptrs, 1 non-ptr */
-
-extern StgScavFun _Scavenge_1_1;
-extern StgScavFun _Scavenge_2_2;
-extern StgScavFun _Scavenge_3_3;
-extern StgScavFun _Scavenge_4_4;
-extern StgScavFun _Scavenge_5_5;
-extern StgScavFun _Scavenge_6_6;
-extern StgScavFun _Scavenge_7_7;
-extern StgScavFun _Scavenge_8_8;
-extern StgScavFun _Scavenge_9_9;
-extern StgScavFun _Scavenge_10_10;
-extern StgScavFun _Scavenge_11_11;
-extern StgScavFun _Scavenge_12_12;
-
-extern StgEvacFun _Evacuate_S;
-extern StgScavFun _Scavenge_S_N;
-
-extern StgEvacFun _Evacuate_Dyn;
-extern StgScavFun _Scavenge_Dyn;
-
-extern StgEvacFun _Evacuate_Tuple;
-extern StgScavFun _Scavenge_Tuple;
-
-extern StgEvacFun _Evacuate_Data;
-extern StgScavFun _Scavenge_Data;
-
-extern StgEvacFun _Evacuate_MuTuple;
-extern StgScavFun _Scavenge_MuTuple;
-
-#if defined(PAR) || defined(GRAN)
-extern StgEvacFun _Evacuate_RBH_2;
-extern StgEvacFun _Evacuate_RBH_3;
-extern StgEvacFun _Evacuate_RBH_4;
-extern StgEvacFun _Evacuate_RBH_5;
-extern StgEvacFun _Evacuate_RBH_6;
-extern StgEvacFun _Evacuate_RBH_7;
-extern StgEvacFun _Evacuate_RBH_8;
-extern StgEvacFun _Evacuate_RBH_9;
-extern StgEvacFun _Evacuate_RBH_10;
-extern StgEvacFun _Evacuate_RBH_11;
-extern StgEvacFun _Evacuate_RBH_12;
-extern StgEvacFun _Evacuate_RBH_S;
-extern StgEvacFun _Evacuate_FetchMe;
-extern StgEvacFun _Evacuate_BF;
-
-extern StgScavFun _Scavenge_RBH_2_1;
-extern StgScavFun _Scavenge_RBH_3_1;
-extern StgScavFun _Scavenge_RBH_3_3;
-extern StgScavFun _Scavenge_RBH_4_1;
-extern StgScavFun _Scavenge_RBH_4_4;
-extern StgScavFun _Scavenge_RBH_5_1;
-extern StgScavFun _Scavenge_RBH_5_5;
-extern StgScavFun _Scavenge_RBH_6_6;
-extern StgScavFun _Scavenge_RBH_7_7;
-extern StgScavFun _Scavenge_RBH_8_8;
-extern StgScavFun _Scavenge_RBH_9_9;
-extern StgScavFun _Scavenge_RBH_10_10;
-extern StgScavFun _Scavenge_RBH_11_11;
-extern StgScavFun _Scavenge_RBH_12_12;
-extern StgScavFun _Scavenge_RBH_N;
-extern StgScavFun _Scavenge_FetchMe;
-extern StgScavFun _Scavenge_BF;
-#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;
-
-extern StgEvacFun _Evacuate_BH_U;
-extern StgScavFun _Scavenge_BH_U;
-
-extern StgEvacFun _Evacuate_Static;
-
-extern StgEvacFun _Evacuate_Ind;
-extern StgScavFun _Scavenge_Ind;
-
-extern StgEvacFun _Evacuate_Caf;
-extern StgScavFun _Scavenge_Caf;
-
-#if defined(PROFILING) || defined(TICKY_TICKY)
-extern StgEvacFun _Evacuate_PI;
-extern StgScavFun _Scavenge_PI;
-#endif
-
-extern StgEvacFun _Evacuate_Const;
-
-extern StgEvacFun _Evacuate_CharLike;
-
-extern StgEvacFun _Evacuate_IntLike;
-
-#ifdef CONCURRENT
-extern StgEvacFun _Evacuate_BQ;
-extern StgScavFun _Scavenge_BQ;
-
-extern StgEvacFun _Evacuate_TSO;
-extern StgScavFun _Scavenge_TSO;
-
-extern StgEvacFun _Evacuate_StkO;
-extern StgScavFun _Scavenge_StkO;
-#endif
-\end{code}
-
-\begin{code}
-EXTFUN(Caf_Evac_Upd_entry);
-#if defined(GCgn)
-EXTFUN(Forward_Ref_New_entry);
-EXTFUN(Forward_Ref_Old_entry);
-EXTFUN(OldRoot_Forward_Ref_entry);
-#else
-EXTFUN(Forward_Ref_entry);
-#endif
-
-\end{code}
-
-End of multi-slurp protection:
-\begin{code}
-#endif /* SMCOPYING_H */
-\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\section[SMinterface.lh]{Main storage manager interface}
-%* *
-%************************************************************************
-
-%% I have changed most of the text here, in an attempt to understand
-%% what's going on. Please let me know about any mistakes, so that
-%% I can correct them! KH@15/10/92 (UK)
-
-%% I have also split the original monster into SMinterface.lh,
-%% SMClosures.lh and SMInfoTables.lh. The latter two are
-%% included below.
-
-This describes the interface used between the STG-machine
-reducer and the storage manager. The overriding goal is to isolate
-the implementation details of each from the other.
-
-Multi-slurp protection:
-\begin{code}
-#ifndef SMinterface_H
-#define SMinterface_H
-\end{code}
-
-\begin{rawlatex}
-{}\input{epsf} % Uses encapsulated PostScript diagrams
-\end{rawlatex}
-
-%************************************************************************
-%* *
-\subsection[SM-calling-interface]{Calling interface}
-%* *
-%************************************************************************
-
-The @smInfo@ structure is used to pass all information back and forth
-between the storage manager and the STG world.
-
-WARNING: If you modify this structure, you {\em must} modify the
-native-code generator as well, because the offsets for various fields
-are hard-coded into the NCG. (In nativeGen/StixMacro.lhs).
-
-\begin{code}
-typedef struct {
- P_ hp; /* last successfully allocated word */
- P_ hplim; /* last allocatable word */
-
- I_ rootno; /* No of heap roots stored in roots */
- P_ *roots; /* Array of heap roots -- must be allocated (not static) */
- P_ CAFlist; /* List of updated CAF's */
-
-#if defined(GCap) || defined(GCgn)
- P_ OldMutables; /* List of old generation mutable closures */
- P_ OldLim; /* Ptr to end of the old generation */
-#endif
-
-#ifndef PAR
- P_ ForeignObjList; /* List of all Foreign objects (in new generation) */
-
-#if defined(GCap) || defined(GCgn)
- P_ OldForeignObjList; /* List of all Foreign objects in old generation */
-#endif
-
- P_ StablePointerTable;
- /* Heap allocated table used to store stable pointers in */
-#endif /* !PAR */
-
- I_ hardHpOverflowSize; /* Some slop at the top of the heap which
- (hopefully) provides enough space to let
- us recover from heap overflow exceptions */
-} smInfo;
-
-extern smInfo StorageMgrInfo;
-
-\end{code}
-
-Maximum number of roots storable in the heap roots array.
-Question: Where are the stable pointer roots? (JSM)
-Answer: They're on the heap in a "Stable Pointer Table". (ADR)
-\begin{code}
-#ifndef CONCURRENT
-# define SM_MAXROOTS 9 /* 8 Vanilla Regs + stable pointer table*/
-#else
-# ifndef PAR
-# ifdef GRAN
-# define SM_MAXROOTS (10 + (MAX_PROC*2) + 2 )
- /* unthreaded + hd/tl thread queues + Current/Main TSOs */
-# else
-# define SM_MAXROOTS 6 /* See c-as-asm/HpOverflow.lc */
-# endif
-# else
-# define SM_MAXROOTS 6 /* See c-as-asm/HpOverflow.lc */
-# endif
-#endif
-\end{code}
-
-The storage manager is accessed exclusively through these routines:
-\begin{code}
-IF_RTS(void initSM (STG_NO_ARGS);)
-IF_RTS(rtsBool exitSM PROTO((smInfo *sm));)
-IF_RTS(rtsBool initStacks PROTO((smInfo *sm));)
-IF_RTS(rtsBool initHeap PROTO((smInfo *sm));)
-#ifdef CONCURRENT
-IF_RTS(rtsBool initThreadPools (STG_NO_ARGS);)
-#endif
-#ifdef PAR
-IF_RTS(void init_gr_profiling PROTO((int, char **, int, char **));)
-#endif
-
-I_ collectHeap PROTO((W_ reqsize, smInfo *sm, rtsBool do_full_collection));
-
-IF_RTS(void unmapMiddleStackPage PROTO((char *, int));) /* char * == caddr_t ? */
-
-#if defined(PROFILING) || defined(PAR)
-IF_RTS(void handle_tick_serial(STG_NO_ARGS);)
-IF_RTS(void handle_tick_noserial(STG_NO_ARGS);)
-#endif
-
-/* EXTFUN(_startMarkWorld); */
-
-StgDouble usertime(STG_NO_ARGS);
-StgDouble elapsedtime(STG_NO_ARGS);
-void start_time(STG_NO_ARGS);
-void end_init(STG_NO_ARGS);
-
-#ifdef PAR
-void EvacuateLocalGAs PROTO((rtsBool full));
-void RebuildGAtables PROTO((rtsBool full));
-#endif
-\end{code}
-
-@initSM@ finalizes any runtime parameters of the storage manager.
-
-@exitSM@ does any cleaning up required by the storage manager before
-the program is executed. Its main purpose is to print any summary
-statistics.
-
-@initStacks@ allocates the A and B stacks (sequential only). It
-initialises the @spa@, @spb@, @sua@, and @sub@ fields of @sm@
-appropriately for empty stacks. Successive calls to @initStacks@
-re-initialise the stacks.
-
-@initHeap@ allocates the heap. It initialises the @hp@ and @hplim@
-fields of @sm@ to represent an empty heap for the compiled-in garbage
-collector. It also allocates the @roots@ array for later use within
-@collectHeap@, and initialises @CAFlist@ to be the empty list. The
-@roots@ array must be large enough to hold at least @SM_MAXROOTS@
-roots. If we are using Appel's collector it also initialises the
-@OldLim@ field.
-
-In the sequential system, it also initialises the stable pointer table
-and the @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
-resulted in the overflow. If the garbage collection succeeds, then at
-least @reqsize@ words will be available. @collectHeap@ requires all
-the fields of @sm@ to be initialised appropriately (from the
-STG-machine registers). The following are identified as
-heap roots:
-\begin{itemize}
-\item The @roots@ array.
-\item The updated CAFs recorded in @CAFlist@.
-\item A Stack.
-\item Update frames on the B Stack. These may be ``squeezed'' out
-if they are the only reference to a closure --- thus avoiding the
-update.
-\item The stable pointer table. (In sequential system.)
-\end{itemize}
-
-There are three possible results from a garbage collection:
-\begin{description}
-\item[\tr{GC_HARD_LIMIT_EXCEEDED} (\tr{reqsize > hplim - hp})]
-The heap size exceeds the hard heap limit: we report an error and
-exit.
-
-\item[\tr{GC_SOFT_LIMIT_EXCEEDED} (\tr{reqsize + hardHpOverflowSize > hplim - hp})]
-The heap size exceeds the soft heap limit: set \tr{hardHpOverflowSize}
-to \tr{0} so that we can use the overflow space, unwind the stack and
-call an appropriate piece of Haskell to handle the error.
-
-\item[\tr{GC_SUCCESS} (\tr{reqsize + hardHpOverflowSize <= hplim - hp})]
-The heap size is less than the soft heap limit.
-
-\begin{itemize}
-\item @hp@ and @hplim@ will indicate the new space available for
-allocation. But we'll subtract \tr{hardHpOverflowSize} from
-\tr{hplim} so that we'll GC when we hit the soft limit.
-
-\item The elements of the @roots@ array will point to the new
-locations of the closures.
-
-\item @spb@ and @sub@ will be updated to reflect the new state of the
-B stack arising from any update frame ``squeezing'' [sequential only].
-
-\item The elements of @CAFlist@ and the stable pointers will be
-updated to point to the new locations of the closures they reference.
-
-\item Any members of @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}
-
-\begin{code}
-#define GC_HARD_LIMIT_EXCEEDED 0
-#define GC_SOFT_LIMIT_EXCEEDED 1
-#define GC_SUCCESS 2
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SM-what-really-happens]{``What really happens in a garbage collection?''}
-%* *
-%************************************************************************
-
-This is a brief tutorial on ``what really happens'' going to/from the
-storage manager in a garbage collection.
-
-\begin{description}
-%------------------------------------------------------------------------
-\item[The heap check:]
-
-[OLD-ISH: WDP]
-
-If you gaze into the C output of GHC, you see many macros calls like:
-\begin{verbatim}
-HEAP_CHK_2PtrsLive((_FHS+2));
-\end{verbatim}
-
-This expands into the C (roughly speaking...):
-\begin{verbatim}
-Hp = Hp + (_FHS+2); /* optimistically move heap pointer forward */
-
-GC_WHILE_OR_IF (HEAP_OVERFLOW_OP(Hp, HpLim) OR_INTERVAL_EXPIRED) {
- STGCALL2_GC(PerformGC, <liveness-bits>, (_FHS+2));
- /* Heap full. Call "PerformGC" with 2 arguments, "<liveness>",
- (info about what ptrs are live) and "_FHS+2" (words
- requested), via the magical routine "callWrapper_GC",
- which indicates ``I am calling a routine in which GC
- may happen'' (a safe bet for `PerformGC').
- */
-}
-\end{verbatim}
-
-In the parallel world, where we will need to re-try the heap check,
-@GC_WHILE_OR_IF@ will be a ``while''; in the sequential world, it will
-be an ``if''.
-
-The ``heap lookahead'' checks, which are similar and used for
-multi-precision @Integer@ ops, have some further complications. See
-the commentary there (\tr{StgMacros.lh}).
-
-%------------------------------------------------------------------------
-\item[Into @callWrapper_GC@...:]
-
-When we failed the heap check (above), we were inside the
-GCC-registerised ``threaded world.'' @callWrapper_GC@ is all about
-getting in and out of the threaded world. On SPARCs, with register
-windows, the name of the game is not shifting windows until we have
-what we want out of the old one. In tricky cases like this, it's best
-written in assembly language.
-
-Though the principle of ``save everything away'' is the same in both
-the sequential and parallel worlds, the details are different.
-
-For the sequential world:
-\begin{enumerate}
-\item
-@callWrapper_GC@ saves the return address.
-\item
-It saves the arguments passed to it (so it doesn't get lost).
-\item
-Save the machine registers used in the STG threaded world in their
-\tr{*_SAVE} global-variable backup locations. E.g., register \tr{Hp}
-is saved into \tr{Hp_SAVE}.
-\item
-Call the routine it was asked to call; in this example, call
-@PerformGC@ with arguments \tr{<liveness>}, and @_FHS+2@ (some constant)...
-\end{enumerate}
-
-For the parallel world, a GC means giving up the thread of control.
-So we must fill in the thread-state-object (TSO) [and its associated
-stk object] with enough information for later resumption:
-\begin{enumerate}
-\item
-Save the return address in the TSO's PC field.
-\item
-Save the machine registers used in the STG threaded world in their
-corresponding TSO fields. We also save the pointer-liveness
-information in the TSO.
-\item
-The registers that are not thread-specific, notably \tr{Hp} and
-\tr{HpLim}, are saved in the @StorageMgrInfo@ structure.
-\item
-Call the routine it was asked to call; in this example, call
-@PerformGC@ with arguments \tr{<liveness>} and @_FHS+2@ (some constant)...
-
-(In the parallel world, we don't expect it to return...)
-\end{enumerate}
-
-%------------------------------------------------------------------------
-\item[Into the heap overflow wrapper, @PerformGC@ [sequential]:]
-
-The first argument (\tr{<liveness>}, in our example) say what registers
-are live, i.e., are ``roots'' the storage manager needs to know.
-\begin{verbatim}
-StorageMgrInfo.rootno = 2;
-StorageMgrInfo.roots[0] = (P_) Ret1_SAVE;
-StorageMgrInfo.roots[1] = (P_) Ret2_SAVE;
-\end{verbatim}
-
-We further: (a)~move the heap-pointer back [we had optimistically
-advanced it, in the initial heap check], (b)~load up the @smInfo@ data
-from the STG registers' \tr{*_SAVE} locations, and (c)~FINALLY: call
-@collectHeap@.
-
-IT IS AT THIS POINT THAT THE WORLD IS COMPLETELY TIDY.
-
-%------------------------------------------------------------------------
-\item[Into the heap overflow wrapper, @PerformGC@ [parallel]:]
-
-Parallel execution is only slightly different. Most information has
-already been saved in the TSO.
-
-\begin{enumerate}
-\item
-We still need to set up the storage manager's @roots@ array.
-\item
-We mark on the scheduler's big ``blackboard'' that a GC is
-required.
-\item
-We reschedule, i.e., this thread gives up control. (The scheduler
-will presumably initiate a garbage-collection, but it may have to do
-any number of other things---flushing, for example---before ``normal
-execution'' resumes; and it most certainly may not be this thread that
-resumes at that point!)
-\end{enumerate}
-
-%------------------------------------------------------------------------
-\item[Into/out of @collectHeap@ [sequential only]:]
-
-@collectHeap@ does the business and reports back whether it freed up
-enough space.
-
-%------------------------------------------------------------------------
-\item[Out of the heap overflow wrapper, @PerformGC@ [sequential only]:]
-
-We begin our return back to doing useful work by: (a)~reloading the
-appropriate STG-register \tr{*_SAVE} locations from (presumably
-changed) @smInfo@; (b) re-advance the heap-pointer---which we've been
-trying to do for a week or two---now that there is enough space.
-
-We must further restore appropriate @Ret?@ registers from the storage
-manager's roots array; in this example:
-
-\begin{verbatim}
-Ret1_SAVE = (W_) StorageMgrInfo.roots[0];
-Ret2_SAVE = (W_) StorageMgrInfo.roots[1];
-\end{verbatim}
-
-%------------------------------------------------------------------------
-\item[Out of @callWrapper_GC@ [sequential]:]
-
-We pop out of heap-overflow code and are ready to resume STG
-``threaded world'' stuff.
-
-The main thing is to re-load up the GCC-ised machine registers from
-the relevant \tr{*_SAVE} locations; e.g., \tr{SpA} from \tr{SpA_SAVE}.
-
-To conclude, @callWrapper_GC@ merely {\em jumps} back to the return
-address which it was given originally.
-
-WE'RE BACK IN (SEQUENTIAL) BUSINESS.
-
-%------------------------------------------------------------------------
-\item[Out of @callWrapper_GC@ [parallel]:]
-
-When this thread is finally resumed after GC (and who knows what
-else), it will restart by the normal enter-TSO/enter-stack-object
-sequence, which has the effect of re-loading the registers, etc.,
-(i.e., restoring the state).
-
-Because the address we saved in the TSO's PC field was that at the end
-of the heap check, and because the check is a while-loop in the
-parallel system, we will now loop back around, and make sure there is
-enough space before continuing.
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[SM-stack-info]{Stacks}
-%* *
-%************************************************************************
-
-There are two stacks, as in the STG paper \cite{new-stg-paper}.
-\begin{itemize}
-\item
-The A stack contains only closure pointers.
-\item
-The B stack contains, basic values, return addresses, and update
-frames.
-\end{itemize}
-The A stack and B stack grow towards each other, so they overflow when
-they collide. Currently the A stack grows downward (towards lower
-addresses); the B stack grows upward. (We localise the stuff which
-uses this information within macros defined in @StgDirections.h@)
-
-During reduction, SpA and SpB point to the topmost allocated word of
-the corresponding stack (though they may not be up to date in the
-middle of a basic block).
-
-Each stack also has a {\em stack update pointer}, SuA and SuB, which
-point to the topmost word of the most recent update frame in the
-corresponding stack. (Colloquially, SuA and Sub point to the first
-items on their respective stacks ``that you cannot have.'')
-\begin{rawlatex}
-A standard update frame (on the B stack) looks like this
-(stack grows downward in this picture):
-\begin{center}
-\mbox{\epsffile{update-frame.ps}}
-\end{center}
-The SuB therefore points to the Update return vector component of
-the topmost update frame.
-\end{rawlatex}
-
-A {\em constructor} update frame, which is pushed only by closures
-which know they will evaluate to a data object, looks just the
-same, but without the saved SuA pointer.
-
-We store the following information concerning the stacks in a global
-structure. (sequential only).
-\begin{code}
-#if 1 /* ndef CONCURRENT * /? HWL */
-
-typedef struct {
- PP_ botA; /* Points to bottom-most word of A stack */
- P_ botB; /* Points to bottom-most word of B stack */
-} stackData;
-
-extern stackData stackInfo;
-
-#endif /* !CONCURRENT */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SM-choose-flavour]{Deciding which GC flavour is in force...}
-%* *
-%************************************************************************
-
-Each garbage collector requires different garbage collection entries
-in the info-table.
-
-\begin{code}
-
-#if defined(GCdu) || defined (GCap) || defined (GCgn)
-#define _INFO_COPYING
-#define _INFO_COMPACTING
-#define _INFO_MARKING
-#else
-#if defined(GC2s)
-#define _INFO_COPYING
-
-#else
-#if defined(GC1s)
-#define _INFO_COMPACTING
-#define _INFO_MARKING
-#else
-/* NO_INFO_SPECIFIED (ToDo: an #error ?) */
-#endif
-#endif
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-%\subsection[Info.lh]{Info Pointer Definitions}
-%* *
-%************************************************************************
-
-\downsection
-\input{Info.lh}
-\upsection
-
-%************************************************************************
-%* *
-%\subsection[Parallel.lh]{Parallel Machine Definitions}
-%* *
-%************************************************************************
-
-\downsection
-\input{Parallel.lh}
-\upsection
-
-
-%************************************************************************
-%* *
-%\subsection[CostCentre.lh]{Profiling Definitions}
-%* *
-%************************************************************************
-
-\downsection
-\input{CostCentre.lh}
-\upsection
-
-
-%************************************************************************
-%* *
-%\subsection[SM-closures]{Closure-Related Definitions}
-%* *
-%************************************************************************
-
-\downsection
-\input{SMClosures.lh}
-\upsection
-
-
-
-%************************************************************************
-%* *
-%\subsection[SM-info-tables]{Info-table Related Definitions}
-%* *
-%************************************************************************
-
-\downsection
-\input{SMInfoTables.lh}
-\upsection
-
-
-End multi-slurp protection:
-\begin{code}
-#endif /* SMinterface_H */
-\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\section[SMmark]{Code labels for pointer-reversal marking}
-%* *
-%************************************************************************
-Multi-slurp protection:
-\begin{code}
-#ifndef SMMARK_H
-#define SMMARK_H
-\end{code}
-
-Pointer Reversal Marking:
-\begin{code}
-extern F_ _PRStart_0(STG_NO_ARGS);
-extern F_ _PRStart_1(STG_NO_ARGS);
-extern F_ _PRStart_2(STG_NO_ARGS);
-extern F_ _PRStart_3(STG_NO_ARGS);
-extern F_ _PRStart_4(STG_NO_ARGS);
-extern F_ _PRStart_5(STG_NO_ARGS);
-extern F_ _PRStart_6(STG_NO_ARGS);
-extern F_ _PRStart_7(STG_NO_ARGS);
-extern F_ _PRStart_8(STG_NO_ARGS);
-extern F_ _PRStart_9(STG_NO_ARGS);
-extern F_ _PRStart_10(STG_NO_ARGS);
-extern F_ _PRStart_11(STG_NO_ARGS);
-extern F_ _PRStart_12(STG_NO_ARGS);
-
-extern F_ _PRStartSelector_0(STG_NO_ARGS);
-extern F_ _PRStartSelector_1(STG_NO_ARGS);
-extern F_ _PRStartSelector_2(STG_NO_ARGS);
-extern F_ _PRStartSelector_3(STG_NO_ARGS);
-extern F_ _PRStartSelector_4(STG_NO_ARGS);
-extern F_ _PRStartSelector_5(STG_NO_ARGS);
-extern F_ _PRStartSelector_6(STG_NO_ARGS);
-extern F_ _PRStartSelector_7(STG_NO_ARGS);
-extern F_ _PRStartSelector_8(STG_NO_ARGS);
-extern F_ _PRStartSelector_9(STG_NO_ARGS);
-extern F_ _PRStartSelector_10(STG_NO_ARGS);
-extern F_ _PRStartSelector_11(STG_NO_ARGS);
-extern F_ _PRStartSelector_12(STG_NO_ARGS);
-
-extern F_ _PRStart_N(STG_NO_ARGS);
-extern F_ _PRStart_Dyn(STG_NO_ARGS);
-extern F_ _PRStart_Tuple(STG_NO_ARGS);
-extern F_ _PRStart_Data(STG_NO_ARGS);
-extern F_ _PRStart_MuTuple(STG_NO_ARGS);
-
-#if defined(PROFILING) || defined(TICKY_TICKY)
-extern F_ _PRStart_PI(STG_NO_ARGS);
-#endif
-
-#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_3(STG_NO_ARGS);
-extern F_ _PRStart_RBH_4(STG_NO_ARGS);
-extern F_ _PRStart_RBH_5(STG_NO_ARGS);
-extern F_ _PRStart_RBH_6(STG_NO_ARGS);
-extern F_ _PRStart_RBH_7(STG_NO_ARGS);
-extern F_ _PRStart_RBH_8(STG_NO_ARGS);
-extern F_ _PRStart_RBH_9(STG_NO_ARGS);
-extern F_ _PRStart_RBH_10(STG_NO_ARGS);
-extern F_ _PRStart_RBH_11(STG_NO_ARGS);
-extern F_ _PRStart_RBH_12(STG_NO_ARGS);
-extern F_ _PRStart_RBH_N(STG_NO_ARGS);
-extern F_ _PRStart_FetchMe(STG_NO_ARGS);
-extern F_ _PRStart_BF(STG_NO_ARGS);
-#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_ _PRStart_TSO(STG_NO_ARGS);
-extern F_ _PRStart_BQ(STG_NO_ARGS);
-#endif
-
-extern F_ _PRStart_Caf(STG_NO_ARGS);
-
-extern F_ _PRStart_BH(STG_NO_ARGS);
-extern F_ _PRStart_Ind(STG_NO_ARGS);
-extern F_ _PRStart_Const(STG_NO_ARGS);
-extern F_ _PRStart_CharLike(STG_NO_ARGS);
-extern F_ _PRStart_IntLike(STG_NO_ARGS);
-extern F_ _PRStart_Static(STG_NO_ARGS);
-
-extern F_ _PRIn_0(STG_NO_ARGS);
-extern F_ _PRIn_1(STG_NO_ARGS);
-extern F_ _PRIn_2(STG_NO_ARGS);
-extern F_ _PRIn_3(STG_NO_ARGS);
-extern F_ _PRIn_4(STG_NO_ARGS);
-extern F_ _PRIn_5(STG_NO_ARGS);
-extern F_ _PRIn_6(STG_NO_ARGS);
-extern F_ _PRIn_7(STG_NO_ARGS);
-extern F_ _PRIn_8(STG_NO_ARGS);
-extern F_ _PRIn_9(STG_NO_ARGS);
-extern F_ _PRIn_10(STG_NO_ARGS);
-extern F_ _PRIn_11(STG_NO_ARGS);
-extern F_ _PRIn_12(STG_NO_ARGS);
-
-extern F_ _PRInLast_1(STG_NO_ARGS);
-extern F_ _PRInLast_2(STG_NO_ARGS);
-extern F_ _PRInLast_3(STG_NO_ARGS);
-extern F_ _PRInLast_4(STG_NO_ARGS);
-extern F_ _PRInLast_5(STG_NO_ARGS);
-extern F_ _PRInLast_6(STG_NO_ARGS);
-extern F_ _PRInLast_7(STG_NO_ARGS);
-extern F_ _PRInLast_8(STG_NO_ARGS);
-extern F_ _PRInLast_9(STG_NO_ARGS);
-extern F_ _PRInLast_10(STG_NO_ARGS);
-extern F_ _PRInLast_11(STG_NO_ARGS);
-extern F_ _PRInLast_12(STG_NO_ARGS);
-
-extern F_ _PRIn_I(STG_NO_ARGS);
-extern F_ _PRIn_I_Dyn(STG_NO_ARGS);
-extern F_ _PRIn_I_Tuple(STG_NO_ARGS);
-extern F_ _PRIn_I_MuTuple(STG_NO_ARGS);
-
-#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_2(STG_NO_ARGS);
-extern F_ _PRIn_RBH_3(STG_NO_ARGS);
-extern F_ _PRIn_RBH_4(STG_NO_ARGS);
-extern F_ _PRIn_RBH_5(STG_NO_ARGS);
-extern F_ _PRIn_RBH_6(STG_NO_ARGS);
-extern F_ _PRIn_RBH_7(STG_NO_ARGS);
-extern F_ _PRIn_RBH_8(STG_NO_ARGS);
-extern F_ _PRIn_RBH_9(STG_NO_ARGS);
-extern F_ _PRIn_RBH_10(STG_NO_ARGS);
-extern F_ _PRIn_RBH_11(STG_NO_ARGS);
-extern F_ _PRIn_RBH_12(STG_NO_ARGS);
-extern F_ _PRIn_RBH_I(STG_NO_ARGS);
-#endif /* PAR || GRAN */
-
-#if !defined(PAR) || defined(GRAN)
-extern F_ _PRIn_I_ForeignObj(STG_NO_ARGS);
-#endif
-
-extern F_ _PRIn_Error(STG_NO_ARGS);
-
-#if defined(PROFILING) || defined(TICKY_TICKY)
-extern F_ _PRIn_PI(STG_NO_ARGS);
-#endif
-
-#if defined(CONCURRENT)
-extern F_ _PRIn_StkO(STG_NO_ARGS);
-extern F_ _PRIn_TSO(STG_NO_ARGS);
-extern F_ _PRIn_BQ(STG_NO_ARGS);
-#endif
-
-\end{code}
-
-End of multi-slurp protection:
-\begin{code}
-#endif /* SMMARK_H */
-\end{code}
+++ /dev/null
-\section[SMupdate.h]{Update interface}
-
-This interface provides a second level of abstraction from the storage
-manager hiding all the nasties associated with updates, indirections,
-CAFs and black holes.
-
-\begin{code}
-#ifndef SMUPDATE_H
-#define SMUPDATE_H
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[update-frames]{Pushing Update Frames}
-%* *
-%************************************************************************
-
-If a closure is to be updated with the result of the computation an
-update frame must be pushed onto the B stack.
-
-A {\em Standard update frame} contains (in order from the top of the
-frame):
-\begin{itemize}
-\item The return vector.
-\item The closure to be updated.
-\item Saved @SuB@ (points to the next update frame).
-\item Saved @SuA@.
-\end{itemize}
-
-Note: We used to keep the {\em offsets} smashed into one word, but the
- introduction of strict evaluation meant we could overflow this.
-
-[Don't really believe this cost-centre stuff WDP 94/07]
-
-If we are keeping track of the current cost centre we have to make the
-following additions:
-\begin{enumerate}
-\item
-The current cost centre, @CCC@, is added as an additional field to the
-update frames described above. It is the last field in the frame.
-When the update is executed the cost centre is restored.
-
-\item
-A special restore cost centre frame is introduced which does not
-contain a closure to update, but just a cost centre to restore.
-\end{enumerate}
-
-The different update frame sizes, @STD_UF_SIZE@, @CON_UF_SIZE@ and
-optionally @RCC_UF_SIZE@, and the offsets within a frame (@UF_RET@,
-@UF_UPDATEE@, etc) are declared in \tr{GhcConstants.lh}.
-
-We now have the macros to push update frames. They are passed the
-update @target@ and the A and B stack offsets at which the current top
-of stack is found. E.g. @SpX + SpX_offset@ points to the top word on
-the stack. The update frame is pushed directly above this position on
-the B stack. @SpB + SpB_offset + xxx_UF_SIZE@ gives the topmost word
-of the update frame, from which we subtract the offsets.
-
-``A picture is worth five thousand bytes.''
-\begin{verbatim}
-A stk | |-----------------------|
- v | |
- |-----------------------|
- | |
- |-----------------------|
- | |
- |-----------------------|
- | |
-
-
-
- |=======================| (new update frame)
- | upd code or vector | <- new SuB
- |-----------------------|
- | updatee (target) |
- |-----------------------|
- | SuB (grip: SuB_off) | (SuX_off = abs ( new SuX - prev SuX );e.g., 7 for SuB
- |-----------------------|
- | SuA (grip: SuA_off) |
- |-----------------------|
- | CCC |
- |=======================|
- | | <- SpB now [really (SpB + SpB_offset)]
- |-----------------------|
- | |
- |-----------------------|
- | |
- |=======================| (prev update frame [e.g.])
- | upd code or vector | <- prev SuB
- |-----------------------|
- | its updatee |
- |-----------------------|
- | ... |
- |-----------------------|
- | ... |
- |-----------------------|
- | its cost-centre |
- |=======================|
- | |
- ^ |-----------------------|
-B stk | | |
-\end{verbatim}
-
-\begin{code}
-I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
-
-EXTDATA_RO(vtbl_StdUpdFrame);
-EXTFUN(StdUpdFrameDirectReturn);
-
-EXTFUN(StdErrorCode); /* Where should this go? */
-EXTFUN(UpdErr);
-EXTFUN(IndUpdRetV0);
-EXTFUN(IndUpdRetV1);
-EXTFUN(IndUpdRetV2);
-EXTFUN(IndUpdRetV3);
-EXTFUN(IndUpdRetV4);
-EXTFUN(IndUpdRetV5);
-EXTFUN(IndUpdRetV6);
-EXTFUN(IndUpdRetV7);
-EXTFUN(IndUpdRetDir);
-
-/*
- Note that UNVEC() is used to select whole statements (declarations) as
- well as labels. Please don't put parentheses around the expansion.
- */
-
-#ifdef __STG_REV_TBLS__
-#define RVREL(offset) (-(offset)-1)
-#define DIRECT(target) (target)
-#define UNVEC(direct,vector) direct
-#else
-#define RVREL(offset) (offset)
-#define DIRECT(target) (*(target))
-#define UNVEC(direct,vector) vector
-#endif
-
-#ifdef CONCURRENT
-/* for stack chunking */
-extern const W_ vtbl_Underflow[];
-EXTFUN(UnderflowDirectReturn);
-EXTFUN(UnderflowVect0);
-EXTFUN(UnderflowVect1);
-EXTFUN(UnderflowVect2);
-EXTFUN(UnderflowVect3);
-EXTFUN(UnderflowVect4);
-EXTFUN(UnderflowVect5);
-EXTFUN(UnderflowVect6);
-EXTFUN(UnderflowVect7);
-EXTFUN(StackUnderflowEnterNode);
-EXTFUN(CommonUnderflow);
-EXTFUN(PrimUnderflow);
-#endif /* CONCURRENT */
-
-/* Now, we always use pointers in update frame, even in the threaded world */
-
-#define PUSH_RET(frame, rv) (frame)[BREL(UF_RET)] = (W_)(rv)
-#define PUSH_UPDATEE(frame, updatee) (frame)[BREL(UF_UPDATEE)] = (W_)(updatee)
-#define PUSH_SuB(frame, sub) (frame)[BREL(UF_SUB)] = (W_)(sub)
-#define PUSH_SuA(frame, sua) (frame)[BREL(UF_SUA)] = (W_)(sua)
-
-#if defined(PROFILING)
-#define PUSH_STD_CCC(frame) (frame)[BREL(UF_COST_CENTRE)] = (W_)(CCC)
-#else
-#define PUSH_STD_CCC(frame)
-#endif
-
-/* When GRABing, "frame" pts to an update frame */
-
-#define GRAB_RET(frame) ((void *)((frame)[BREL(UF_RET)]))
-#define GRAB_SuB(frame) ((P_)((frame)[BREL(UF_SUB)]))
-#define GRAB_SuA(frame) ((PP_)((frame)[BREL(UF_SUA)]))
-#define GRAB_UPDATEE(frame) ((P_)((frame)[BREL(UF_UPDATEE)]))
-#define GRAB_COST_CENTRE(frame) ((CostCentre)((frame)[BREL(UF_COST_CENTRE)]))
-
-#define PUSH_STD_UPD_FRAME(target, SpA_offset, SpB_offset) \
- do { \
- P_ __frame; \
- UPDF_STD_PUSHED(); /* ticky-ticky, spat */ \
- __frame = SpB - BREL(SpB_offset + STD_UF_SIZE); \
- PUSH_RET(__frame, RetReg); \
- PUSH_SuB(__frame, SuB); \
- PUSH_SuA(__frame, SuA); \
- PUSH_UPDATEE(__frame, target); \
- PUSH_STD_CCC(__frame); \
- SuB = __frame; \
- SuA = SpA - AREL(SpA_offset); \
- } while(0)
-
-#define POP_STD_UPD_FRAME() \
- do { \
- RetReg = GRAB_RET(SpB); \
- SuB = GRAB_SuB(SpB); \
- SuA = GRAB_SuA(SpB); \
- SpB += BREL(STD_UF_SIZE); \
- } while(0);
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[black-hole-overwrite]{Overwriting with Black Holes}
-%* *
-%************************************************************************
-
-An updatable closure may be overwritten with a black hole so that
-the free variables in the closure being evaluated are not kept alive.
-This may be done on entering the closure or later by the garbage
-collector.
-
-\begin{code}
-EXTDATA_RO(BH_UPD_info);
-EXTFUN(BH_UPD_entry);
-EXTDATA_RO(BH_SINGLE_info);
-EXTFUN(BH_SINGLE_entry);
-
-#define UPD_BH(heapptr,infolbl) INFO_PTR(heapptr) = (W_) infolbl
-\end{code}
-
-The following macros are actually planted by the code generator. They
-allow us to delay the decision about if/when we black hole. It should
-be noted that single entry closures do not have update frames which
-can be traced by the garbage collector. It is only possibly to
-overwrite with a black hole on entry.
-
-In the sequential system, updatable closures are not black-holed until GC.
-When GC occurs, the only active updatable closures are those with update
-frames on the stack, so the GC routine can walk the stack frames to find
-the updatable closures to black hole (primarily for plugging space leaks).
-This approach saves the overhead of black-holing every updatable closure on
-entry.
-
-In the parallel system, however, it is essential that updatable closures
-be black-holed immediately on entry, so that other local threads will
-block when attempting to enter a closure already under evaluation.
-
-\begin{code}
-#if defined(CONCURRENT)
-#define UPD_BH_UPDATABLE(heapptr) UPD_BH(heapptr,BH_UPD_info)
-#else
-#define UPD_BH_UPDATABLE(heapptr) /* nothing -- BHed by GC */
-#endif
-
-#define UPD_BH_SINGLE_ENTRY(heapptr) UPD_BH(heapptr,BH_SINGLE_info)
- /* BHed on entry -- GC cant do it */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[caf-update]{Entering CAFs}
-%* *
-%************************************************************************
-
-When we enter a CAF, we update it with an indirection to a
-heap-allocated black hole. The @UPD_CAF@ macro updates the CAF with an
-@CAF@ indirection to the heap-allocated closure and adds the updated
-CAF to the list of CAFs. It is up to the entry code to allocate the
-black hole.
-
-The @CAF@ info table used is the @Caf_info@ table. It will be
-overwritten at the start of garbage collection with the @Caf_Evac_Upd@
-and then reset to @Caf_info@ during garbage collection.
-
-In the parallel case, the new black hole will be a local node
-(with a GA of 0). This means that the code to update indirections
-does not need to check whether it's updating a CAF: the situation
-simply never arises! If you change how this code works (e.g. to
-update CAFs across the parallel machine), you should check @UPD_IND@
-etc.
-
-\begin{code}
-EXTDATA_RO(Caf_info);
-EXTFUN(Caf_entry);
-
-#define UPD_CAF(cafptr, bhptr) \
- do { \
- SET_INFO_PTR(cafptr, Caf_info); \
- IND_CLOSURE_PTR(cafptr) = (W_) (bhptr); \
- IND_CLOSURE_LINK(cafptr) = (W_) StorageMgrInfo.CAFlist; \
- StorageMgrInfo.CAFlist = (P_) (cafptr); \
- } while(0)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[updating-closures]{Updating Closures}
-%* *
-%************************************************************************
-
-We provide three macros:
-\begin{description}
-
-\item[@UPD_IND(updclosure, heapptr)@]\ \\
-Overwrites the updatable closure @updclosure@ with an indirection to
-@heapptr@.
-
-\item[@UPD_INPLACE_NOPTRS(updclosure, livemask)@]\ \\
-This prepares the closure pointed to by @updclosure@ to be updated
-in-place with a closure of size @MIN_UPD_SIZE@ containing no pointers.
-
-\item[@UPD_INPLACE_PTRS(updclosure, livemask)@]\ \\
-This prepares the closure pointed to by @updclosure@ to be updated
-in-place with a closure of size @MIN_UPD_SIZE@ which may contain
-pointers. It checks whether @updclosure@ is allowed to be updated
-inplace. If it is not it:
-\begin{enumerate}
-\item Allocates space for a new closure of size @MIN_UPD_SIZE@ (by
-calling @HEAP_CHK_RETRY@);
-\item Overwrites @updclosure@ with an indirection to this new closure;
-\item Modifies @updclosure@ to point to the newly-allocated closure.
-\end{enumerate}
-
-All the macros ensure that @updclosure@ points to a closure of size
-@MIN_UPD_SIZE@ ready to be filled in with the result of the update.
-
-The code following @UPDATE_INPLACE@ is responsible for filling it in.
-This requires the header to be set, with @INPLACE_UPD_HDR@, and the
-body to be filled out.
-\end{description}
-
-The @UPD_IND@ and @UPDATE_INPLACE@ macros may have different
-definitions depending on the garbage collection schemes in use.
-
-Before describing the update macros we declare the partial application
-entry and update code (See \tr{StgUpdate.lhc}).
-
-\begin{code}
-EXTDATA_RO(PAP_info);
-EXTFUN(PAP_entry);
-EXTFUN(UpdatePAP);
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[updates-standard]{Implementation of Standard Updates}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef CONCURRENT
-
-/* In the concurrent world, the targed of an update might
- be a black hole with a blocking queue attached. If so,
- it will already be on the mutables list, and we have to be careful
- not to put it on twice else it screws up the list. */
-#define ALREADY_LINKED(closure) \
- (IS_MUTABLE(INFO_PTR(closure)) && MUT_LINK(closure) != MUT_NOT_LINKED)
-
-# if defined(GRAN)
-P_ AwakenBlockingQueue PROTO((P_));
-# else
-void AwakenBlockingQueue PROTO((P_));
-# endif
-
-# ifdef MAIN_REG_MAP
-# define AWAKEN_BQ(updatee) \
-do { if (IS_BQ_CLOSURE(updatee)) \
- STGCALL1(void,(void *, P_), AwakenBlockingQueue, (P_) BQ_ENTRIES(updatee)); \
-} while(0);
-# endif
-
-# ifdef NULL_REG_MAP
-# define AWAKEN_BQ(updatee) \
-do { if (IS_BQ_CLOSURE(updatee)) \
- AwakenBlockingQueue((P_)BQ_ENTRIES(updatee)); \
-} while(0);
-# endif
-
-# define AWAKEN_INPLACE_BQ()
-
-#else /* !CONCURRENT */
-
-# define ALREADY_LINKED(closure) 0 /* NB: see note above in CONCURRENT */
-
-# define AWAKEN_BQ(updatee)
-# define AWAKEN_INPLACE_BQ()
-
-#endif /* CONCURRENT */
-
-EXTDATA_RO(Ind_info);
-EXTFUN(Ind_entry);
-#ifndef TICKY_TICKY
-# define Ind_info_TO_USE Ind_info
-#else
-EXTDATA_RO(Perm_Ind_info);
-EXTFUN(Perm_Ind_entry);
-
-# define Ind_info_TO_USE ((AllFlags.doUpdEntryCounts) ? Perm_Ind_info : Ind_info)
-#endif
-
-#if defined(GC2s) || defined(GC1s) || defined(GCdu)
-
-#define INPLACE_UPD_HDR(closure,infolbl,cc,size,ptrs) \
- UPD_FIXED_HDR(closure,infolbl,cc)
-
-#define UPD_IND(updclosure, heapptr) \
- UPDATED_SET_UPDATED(updclosure); /* ticky */ \
- AWAKEN_BQ(updclosure); \
- SET_INFO_PTR(updclosure, Ind_info_TO_USE); \
- IND_CLOSURE_PTR(updclosure) = (W_)(heapptr)
-
-#define UPD_INPLACE_NOPTRS(livemask) \
- UPDATED_SET_UPDATED(Node); /* ticky */ \
- AWAKEN_BQ(Node);
-
-#define UPD_INPLACE_PTRS(livemask) \
- UPDATED_SET_UPDATED(Node); /* ticky */ \
- AWAKEN_BQ(Node);
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[updates-appel]{Implementation of Appel's Updates}
-%* *
-%************************************************************************
-
-Appel's updates require the identification of old generation closures
-which are updated. They must be updated with an indirection and linked
-onto the list of old generation closures.
-
-\begin{code}
-#else /* !(2s/1s/du) */
-# if defined(GCap) || defined(GCgn)
-
-/* same as before */
-#define INPLACE_UPD_HDR(closure,infolbl,cc,size,ptrs) \
- UPD_FIXED_HDR(closure,infolbl,cc)
-
-/* updclosure is the updatee, heapptr is what to update it with */
-#define UPD_IND(updclosure, heapptr) \
-{ UPDATED_SET_UPDATED(updclosure); /* ticky */ \
- if ( ((P_)(updclosure)) > StorageMgrInfo.OldLim ) { \
- UPD_NEW_IND(); /*ticky*/ \
- } else { \
- UPD_OLD_IND(); /*ticky*/ \
- if(!ALREADY_LINKED(updclosure)) { \
- MUT_LINK(updclosure) = (W_) StorageMgrInfo.OldMutables; \
- StorageMgrInfo.OldMutables = (P_) (updclosure); \
- } \
- } \
- AWAKEN_BQ(updclosure); \
- SET_INFO_PTR(updclosure, Ind_info_TO_USE); \
- IND_CLOSURE_PTR(updclosure) = (W_)(heapptr); \
-}
-
-/*
- * In threaded-land, we have to do the same nonsense as UPD_INPLACE_PTRS if
- * we were a blocking queue on the old mutables list.
- */
-#define UPD_INPLACE_NOPTRS(live_regs_mask) \
- UPDATED_SET_UPDATED(Node); /* ticky */ \
- if ( Node > StorageMgrInfo.OldLim) { \
- UPD_NEW_IN_PLACE_NOPTRS(); /*ticky*/ \
- AWAKEN_BQ(Node); \
- } else { \
- UPD_OLD_IN_PLACE_NOPTRS(); /*ticky*/ \
- if(ALREADY_LINKED(Node)) { \
- /* We are already on the old mutables list, so we \
- can't update in place any more */ \
- HEAP_CHK(live_regs_mask, _FHS+MIN_UPD_SIZE, 0); \
- /* ticky-ticky (NB: was ALLOC_UPD_CON) */ \
- ALLOC_CON(_FHS,1,MIN_UPD_SIZE-1,_FHS+MIN_UPD_SIZE); \
- CC_ALLOC(CCC,_FHS+MIN_UPD_SIZE,CON_K); \
- /* must awaken after any possible GC */ \
- AWAKEN_BQ(Node); \
- SET_INFO_PTR(Node, Ind_info_TO_USE); \
- IND_CLOSURE_PTR(Node) = (W_)(Hp-(_FHS+MIN_UPD_SIZE-1)); \
- Node = Hp-(_FHS+MIN_UPD_SIZE-1); \
- } \
- }
-
-#define UPD_INPLACE_PTRS(live_regs_mask) \
- UPDATED_SET_UPDATED(Node); /* ticky */ \
- if ( Node > StorageMgrInfo.OldLim) { \
- UPD_NEW_IN_PLACE_PTRS(); /*ticky*/ \
- AWAKEN_BQ(Node); \
- } else { \
- /* redirect update with indirection */ \
- UPD_OLD_IN_PLACE_PTRS(); /*ticky*/ \
- /* Allocate */ \
- HEAP_CHK(live_regs_mask, _FHS+MIN_UPD_SIZE, 0); \
- /* ticky-ticky (NB: was ALLOC_UPD_CON) */ \
- ALLOC_CON(_FHS,1,MIN_UPD_SIZE-1,_FHS+MIN_UPD_SIZE); \
- CC_ALLOC(CCC,_FHS+MIN_UPD_SIZE,CON_K); \
- \
- if (!ALREADY_LINKED(Node)) { \
- MUT_LINK(Node) = (W_) StorageMgrInfo.OldMutables; \
- StorageMgrInfo.OldMutables = (P_) (Node); \
- } \
- /* must awaken after any possible GC */ \
- AWAKEN_BQ(Node); \
- SET_INFO_PTR(Node, Ind_info_TO_USE); \
- IND_CLOSURE_PTR(Node) = (W_)(Hp-(_FHS+MIN_UPD_SIZE-1)); \
- Node = Hp-(_FHS+MIN_UPD_SIZE-1); \
- }
-# endif /* GCap || GCgn */
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[freezing-arrays]{Changing Mutable Pointer closures into Immutable Closures}
-%* *
-%************************************************************************
-
-When freezing an array of pointers we change the info table to
-indicate it is now immutable to the garbage collector. The array will
-be removed from the old generation mutable array list by the garbage\
-collector.
-
-This is only required for generational garbage collectors but we always
-do it so better profiling information is provided.
-
-\begin{code}
-#ifdef GC_MUT_REQUIRED
-#define FREEZE_MUT_HDR(freezeclosure,immutinfo) \
- SET_INFO_PTR(freezeclosure, immutinfo)
-#else
-#define FREEZE_MUT_HDR(freezeclosure,immutinfo) \
- SET_INFO_PTR(freezeclosure, immutinfo)
-#endif
-
-#endif /* SMUPDATE_H */
-\end{code}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: SchedAPI.h,v 1.2 1998/12/02 13:21:33 simonm Exp $
+ *
+ * (c) The GHC Team 1998
+ *
+ * External API for the scheduler. For most uses, the functions in
+ * RtsAPI.h should be enough.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef SCHEDAPI_H
+#define SCHEDAPI_H
+
+/*
+ * Running the scheduler
+ */
+
+typedef enum {
+ Success,
+ Killed, /* another thread killed us */
+ Interrupted, /* stopped in response to a call to interruptStgRts */
+ Deadlock,
+ AllBlocked, /* subtly different from Deadlock */
+} SchedulerStatus;
+
+SchedulerStatus schedule(StgTSO *main_thread, /*out*/StgClosure **ret);
+
+/*
+ * Creating thraeds
+ */
+
+StgTSO *createThread (nat stack_size);
+
+static inline void pushClosure (StgTSO *tso, StgClosure *c) {
+ tso->sp--;
+ tso->sp[0] = (W_) c;
+}
+
+static inline void pushRealWorld (StgTSO *tso) {
+ tso->sp--;
+ tso->sp[0] = (W_) REALWORLD_TAG;
+}
+static inline StgTSO *
+createGenThread(nat stack_size, StgClosure *closure) {
+ StgTSO *t;
+ t = createThread(stack_size);
+ pushClosure(t,closure);
+ return t;
+}
+
+static inline StgTSO *
+createIOThread(nat stack_size, StgClosure *closure) {
+ StgTSO *t;
+ t = createThread(stack_size);
+ pushRealWorld(t);
+ pushClosure(t,closure);
+ return t;
+}
+
+/*
+ * Killing threads
+ */
+
+void deleteThread(StgTSO *tso);
+
+/*
+ * Reverting CAFs
+ */
+
+void RevertCAFs(void);
+
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Stg.h,v 1.2 1998/12/02 13:21:33 simonm Exp $
+ *
+ * Top-level include file for everything STG-ish.
+ *
+ * This file is included *automatically* by all .hc files.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STG_H
+#define STG_H
+
+#ifndef NON_POSIX_SOURCE
+#define _POSIX_SOURCE
+#endif
+
+/* Configuration */
+#include "config.h"
+#ifdef __HUGS__ /* vile hack till the GHC folks come on board */
+#include "options.h"
+#endif
+
+/* ToDo: Set this flag properly: COMPILER and INTERPRETER should not be mutually exclusive. */
+#ifndef INTERPRETER
+#define COMPILER 1
+#endif
+
+/* Global type definitions*/
+#include "StgTypes.h"
+
+/* Global constaints */
+#include "Constants.h"
+
+/* Profiling information */
+#include "Profiling.h"
+
+/* Storage format definitions */
+#include "Closures.h"
+#include "InfoTables.h"
+#include "TSO.h"
+
+/* STG/Optimised-C related stuff */
+#include "MachRegs.h"
+#include "Regs.h"
+#include "TailCalls.h"
+
+/**
+ * Added by Ian McDonald 7/5/98
+ * XXX The position of this code is very
+ * important - it must come after the
+ * Regs.h include
+ **/
+#ifdef nemesis_TARGET_OS
+#define _NEMESIS_OS_
+#ifndef __LANGUAGE_C
+#define __LANGUAGE_C
+#endif
+#include <nemesis.h>
+#endif
+
+/* these are all ANSI C headers */
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <assert.h>
+#include <errno.h>
+#include <stdio.h>
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/* GNU mp library */
+#include "gmp.h"
+
+/* Wired-in Prelude identifiers */
+#include "Prelude.h"
+
+/* Storage Manager */
+#include "StgStorage.h"
+
+/* Macros for STG/C code */
+#include "ClosureMacros.h"
+#include "InfoMacros.h"
+#include "StgMacros.h"
+#include "StgProf.h"
+#include "PrimOps.h"
+#include "Updates.h"
+#include "Ticky.h"
+#include "CCall.h"
+
+/* Built-in entry points */
+#include "StgMiscClosures.h"
+
+/* Runtime-system hooks */
+#include "Hooks.h"
+
+/* Misc stuff without a home */
+extern char **prog_argv; /* so we can get at these from Haskell */
+extern int prog_argc;
+
+extern char **environ;
+
+#endif /* STG_H */
+++ /dev/null
-#ifndef STGDIRECTION_H
-#define STGDIRECTION_H
-
-/* Here's where we hide things about heap and stack directions.
-
- NB: The call to "setNewHeapUsage 0 words_required" in CgClosure in
- the code generator is also direction-sensitive.
-*/
-
-/* for now --
- heap: grows upwards
- A stack: grows downwards
- B stack: grows upwards
-*/
-
-/* ALL THE ARITHMETIC IN HERE IS IN UNITS OF WORDS */
-
-
-/****************************************************************
-* *
-* Heapery *
-* *
-* ***************************************************************/
-
-/* HEAP_FRAME_BASE( low-addr, size ) gives the address of the
- first word to be allocated in the heap space
- starting at address low-addr. size is in words.
-
- HEAP_FRAME_LIMIT( low-addr, size ) gives the address of the
- last word to be allocated.
-*/
-#define HEAP_FRAME_BASE(space,size) (space)
-#define HEAP_FRAME_LIMIT(space,size) (((P_) (space)) + (size) - 1)
-
-
-/* Hp + HREL(n) addresses the n'th word into already-allocated space
- from Hp. n=0 addresses the ``most recently allocated'' word.
-
-OBSOLETE BECAUSE WE'VE FIXED THE DIRECTION OF HEAP GROWTH (upwards)
-
-#define HREL(offset) (-(offset))
-*/
-
-
-
-/* HEAP_OVERFLOW_OP( heap-ptr, heap-limit ) is true if the heap has
- overflowed.
-*/
-#define HEAP_OVERFLOW_OP(a,hplim) ((a) > (hplim))
-
-
-/****************************************************************
-* *
-* Stackery *
-* *
-* ***************************************************************/
-
-/* STK_A_FRAME_BASE( low-addr, size ) gives the address of the bottom-most
- word of A stack, given that A and B stack are to be allocated
- from a block of store starting at low-addr. size is in words
-
- STK_B_FRAME_BASE( low-addr, size) does the same for B stack
-*/
-#define STK_A_FRAME_BASE(space,size) (((PP_) (space)) + (size) - 1)
-#define STK_B_FRAME_BASE(space,size) (space)
-
-
-/* SpA + AREL(n) addresses the n'th word from the top of A stack
- (0'th is top one)
- Similarly BREL
-*/
-#define AREL(offset) (offset)
-#define BREL(offset) (-(offset))
-
-
-/* STKS_OVERFLOW_OP( a-stack-space, b-stack-space ) is true if SpA and SpB
- have collided.
-
- We cast SpA to StgPtr, because it is normally an StgPtrPtr.
-*/
-#define STKS_OVERFLOW_OP(a,b) ((P_)(SpA) - AREL((a) + (b)) <= SpB)
-
-/* And a version that generates slightly-worse
- code, but which does not need to know about
- SpA and SpB (used in RTS)
-*/
-#define UNREG_STKS_OVERFLOW_OP(a,b) ((P_)(a) <= (b))
-
-#endif /* ! STGDIRECTION_H */
+++ /dev/null
-#ifndef STGMACHDEPS_H
-#define STGMACHDEPS_H
-
-#define COMMENT__(a)
-
-COMMENT__(The COMMON_ITBLS macro determines whether we use commoned-up
- info tables and rep tables instead of the old info table system.)
-
-#define COMMON_ITBLS 1
-
-
-COMMENT__(This code has to go through a Haskell compiler too)
-
-COMMENT__(We assume 8 bit bytes.)
-#define BITS_PER_BYTE 8
-#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))
-
-#ifdef __STDC__
-#define PROTO(x) x
-#define NON_PROTO(x) /* nothing */
-#define STG_VOLATILE volatile
-#define STG_NO_ARGS void
-#define CAT2(a,b) a##b
-#define CAT3(a,b,c) a##b##c
-#define CAT4(a,b,c,d) a##b##c##d
-#define CAT5(a,b,c,d,e) a##b##c##d##e
-#define CAT6(a,b,c,d,e,f) a##b##c##d##e##f
-
-#else
-#define PROTO(x) ()
-#define NON_PROTO(x) x
-#define STG_VOLATILE /* no volatile */
-#define STG_NO_ARGS /* no such thing either */
-#define CAT2(a,b) a/**/b
-#define CAT3(a,b,c) a/**/b/**/c
-#define CAT4(a,b,c,d) a/**/b/**/c/**/d
-#define CAT5(a,b,c,d,e) a/**/b/**/c/**/d/**/e
-#define CAT6(a,b,c,d,e,f) a/**/b/**/c/**/d/**/e/**/f
-#endif /* ! __STDC__ */
-
-#ifdef __GNUC__
-#define STG_NORETURN __attribute__((noreturn))
-#define STG_INLINE __inline__
-#else
-#define STG_NORETURN /* no such thing */
-#define STG_INLINE /* no inline functions */
-#endif
-
-#if 0
-------------------------------------------------------------------------
- Steve Maguires "Writing Solid Code" suggests that (in the debugging
- version) we should work hard to make bugs show themselves at the
- earliest possible moment.
-
- In particular, it suggests that the memory management system should
- trash memory when it is allocated and when it is deallocated so that
- references to uninitialised memory or to released memory will show up
- as the bugs they are.
-
- By "trashing", I mean writing easily recognisable "nonsense" bit
- patterns over the block of memory. It is worth taking some care to
- choose values which:
-
- 1) Are meaningless pointers (ideally causing memory exceptions)
-
- (eg not word-aligned)
-
- 2) Are "weird-looking" integers (whether treated as 8, 16, 32 or 64
- bits) (A large (definately non-zero) value).
-
- 3) Make strange-looking strings when concatenated.
-
- 4) Are meaningless machine code (ideally causing exceptions)
-
- We should also choose different values for initialisation and
- deallocation to make it easier to identify the source of the bug.
-
- ADR
-------------------------------------------------------------------------
-#endif /* 0 */
-
-
-#if alpha_TARGET_ARCH
-#define DEALLOCATED_TRASH 0xdeadbeefdeadbeef
-#else
-#define DEALLOCATED_TRASH 0xdeadbeef
-#endif
-
-#endif /* ! STGMACHDEPS_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgMacros.h,v 1.2 1998/12/02 13:21:35 simonm Exp $
+ *
+ * Macros used for writing STG-ish C code.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STGMACROS_H
+#define STGMACROS_H
+
+/* -----------------------------------------------------------------------------
+ The following macros create function headers.
+
+ Each basic block is represented by a C function with no arguments.
+ We therefore always begin with either
+
+ extern F_ f(void)
+
+ or
+
+ static F_ f(void)
+
+ The macros can be used either to define the function itself, or to provide
+ prototypes (by following with a ';').
+ --------------------------------------------------------------------------- */
+
+#define STGFUN(f) StgFunPtr f(void)
+#define STATICFUN(f) static StgFunPtr f(void)
+#define EXTFUN(f) extern StgFunPtr f(void)
+
+#define FN_(f) F_ f(void)
+#define IFN_(f) static F_ f(void)
+#define IF_(f) static F_ f(void)
+#define EF_(f) extern F_ f(void)
+#define ED_ extern
+#define ED_RO_ extern const
+#define ID_ extern
+#define ID_RO_ extern const
+#define EI_ extern const StgInfoTable
+#define II_ extern const StgInfoTable
+#define EC_ extern StgClosure
+#define IC_ extern StgClosure
+
+/* -----------------------------------------------------------------------------
+ Stack Tagging.
+
+ For a block of non-pointer words on the stack, we precede the
+ block with a small-integer tag giving the number of non-pointer
+ words in the block.
+ -------------------------------------------------------------------------- */
+
+#ifndef DEBUG_EXTRA
+#define ARGTAG_MAX 16 /* probably arbitrary */
+#define ARG_TAG(n) (n)
+#define ARG_SIZE(n) stgCast(StgWord,n)
+
+typedef enum {
+ REALWORLD_TAG = 0,
+ INT_TAG = sizeofW(StgInt),
+ INT64_TAG = sizeofW(StgInt64),
+ WORD_TAG = sizeofW(StgWord),
+ ADDR_TAG = sizeofW(StgAddr),
+ CHAR_TAG = sizeofW(StgChar),
+ FLOAT_TAG = sizeofW(StgFloat),
+ DOUBLE_TAG = sizeofW(StgDouble),
+ STABLE_TAG = sizeofW(StgWord),
+} StackTag;
+
+#else /* DEBUG_EXTRA */
+
+typedef enum {
+ ILLEGAL_TAG,
+ REALWORLD_TAG,
+ INT_TAG ,
+ INT64_TAG ,
+ WORD_TAG ,
+ ADDR_TAG ,
+ CHAR_TAG ,
+ FLOAT_TAG ,
+ DOUBLE_TAG ,
+ STABLE_TAG ,
+ ARGTAG_MAX = DOUBLE_TAG
+} StackTag;
+
+/* putting this in a .h file generates many copies - but its only a
+ * debugging build.
+ */
+static StgWord stg_arg_size[] = {
+ [REALWORLD_TAG] = 0,
+ [INT_TAG ] = sizeofW(StgInt),
+ [INT64_TAG ] = sizeofW(StgInt64),
+ [WORD_TAG ] = sizeofW(StgWord),
+ [ADDR_TAG ] = sizeofW(StgAddr),
+ [CHAR_TAG ] = sizeofW(StgChar),
+ [FLOAT_TAG ] = sizeofW(StgFloat),
+ [DOUBLE_TAG] = sizeofW(StgDouble),
+ [STABLE_TAG] = sizeofW(StgWord)
+};
+
+#define ARG_SIZE(tag) stg_arg_size[stgCast(StgWord,tag)]
+
+#endif /* DEBUG_EXTRA */
+
+static inline int IS_ARG_TAG( StgWord p );
+static inline int IS_ARG_TAG( StgWord p ) { return p <= ARGTAG_MAX; }
+
+/* -----------------------------------------------------------------------------
+ Argument checks.
+
+ If (Sp + <n_args>) > Su { JMP_(stg_updatePAP); }
+
+ Sp points to the topmost used word on the stack, and Su points to
+ the most recently pushed update frame.
+
+ Remember that <n_args> must include any tagging of unboxed values.
+
+ ARGS_CHK_LOAD_NODE is for top-level functions, whose entry
+ convention doesn't require that Node is loaded with a pointer to
+ the closure. Thus we must load node before calling stg_updatePAP if
+ the argument check fails.
+ -------------------------------------------------------------------------- */
+
+#define ARGS_CHK(n) \
+ if ((P_)(Sp + (n)) > (P_)Su) { \
+ JMP_(stg_update_PAP); \
+ }
+
+#define ARGS_CHK_LOAD_NODE(n,closure) \
+ if ((P_)(Sp + (n)) > (P_)Su) { \
+ R1.p = (P_)closure; \
+ JMP_(stg_update_PAP); \
+ }
+
+/* -----------------------------------------------------------------------------
+ Heap/Stack Checks.
+
+ When failing a check, we save a return address on the stack and
+ jump to a pre-compiled code fragment that saves the live registers
+ and returns to the scheduler.
+
+ The return address in most cases will be the beginning of the basic
+ block in which the check resides, since we need to perform the check
+ again on re-entry because someone else might have stolen the resource
+ in the meantime.
+ ------------------------------------------------------------------------- */
+
+#define STK_CHK(headroom,ret,r,layout,tag_assts) \
+ if (Sp - headroom < SpLim) { \
+ EXTFUN(stg_chk_##layout); \
+ tag_assts \
+ (r) = (P_)ret; \
+ JMP_(stg_chk_##layout); \
+ }
+
+#define HP_CHK(headroom,ret,r,layout,tag_assts) \
+ if ((Hp += headroom) > HpLim) { \
+ EXTFUN(stg_chk_##layout); \
+ tag_assts \
+ (r) = (P_)ret; \
+ JMP_(stg_chk_##layout); \
+ }
+
+#define HP_STK_CHK(stk_headroom,hp_headroom,ret,r,layout,tag_assts) \
+ if (Sp - stk_headroom < SpLim || (Hp += hp_headroom) > HpLim) { \
+ EXTFUN(stg_chk_##layout); \
+ tag_assts \
+ (r) = (P_)ret; \
+ JMP_(stg_chk_##layout); \
+ }
+
+/* -----------------------------------------------------------------------------
+ A Heap Check in a case alternative are much simpler: everything is
+ on the stack and covered by a liveness mask already, and there is
+ even a return address with an SRT info table there as well.
+
+ Just push R1 and return to the scheduler saying 'EnterGHC'
+
+ {STK,HP,HP_STK}_CHK_NP are the various checking macros for
+ bog-standard case alternatives, thunks, and non-top-level
+ functions. In all these cases, node points to a closure that we
+ can just enter to restart the heap check (the NP stands for 'node points').
+
+ HpLim points to the LAST WORD of valid allocation space.
+ -------------------------------------------------------------------------- */
+
+#define STK_CHK_NP(headroom,ptrs,tag_assts) \
+ if ((Sp - (headroom)) < SpLim) { \
+ EXTFUN(stg_gc_enter_##ptrs); \
+ tag_assts \
+ JMP_(stg_gc_enter_##ptrs); \
+ }
+
+#define HP_CHK_NP(headroom,ptrs,tag_assts) \
+ if ((Hp += (headroom)) > HpLim) { \
+ EXTFUN(stg_gc_enter_##ptrs); \
+ tag_assts \
+ JMP_(stg_gc_enter_##ptrs); \
+ }
+
+#define HP_CHK_SEQ_NP(headroom,ptrs,tag_assts) \
+ if ((Hp += (headroom)) > HpLim) { \
+ EXTFUN(stg_gc_seq_##ptrs); \
+ tag_assts \
+ JMP_(stg_gc_seq_##ptrs); \
+ }
+
+#define HP_STK_CHK_NP(stk_headroom, hp_headroom, ptrs, tag_assts) \
+ if ((Sp - (stk_headroom)) < SpLim || (Hp += (hp_headroom)) > HpLim) { \
+ EXTFUN(stg_gc_enter_##ptrs); \
+ tag_assts \
+ JMP_(stg_gc_enter_##ptrs); \
+ }
+
+/* Heap checks for branches of a primitive case / unboxed tuple return */
+
+#define GEN_HP_CHK_ALT(headroom,lbl,tag_assts) \
+ if ((Hp += (headroom)) > HpLim) { \
+ EXTFUN(lbl); \
+ tag_assts \
+ JMP_(lbl); \
+ }
+
+#define HP_CHK_NOREGS(headroom,tag_assts) \
+ GEN_HP_CHK_ALT(headroom,stg_gc_noregs,tag_assts);
+#define HP_CHK_UNPT_R1(headroom,tag_assts) \
+ GEN_HP_CHK_ALT(headroom,stg_gc_unpt_r1,tag_assts);
+#define HP_CHK_UNBX_R1(headroom,tag_assts) \
+ GEN_HP_CHK_ALT(headroom,stg_gc_unbx_r1,tag_assts);
+#define HP_CHK_F1(headroom,tag_assts) \
+ GEN_HP_CHK_ALT(headroom,stg_gc_f1,tag_assts);
+#define HP_CHK_D1(headroom,tag_assts) \
+ GEN_HP_CHK_ALT(headroom,stg_gc_d1,tag_assts);
+
+#define HP_CHK_L1(headroom,tag_assts) \
+ GEN_HP_CHK_ALT(headroom,stg_gc_d1,tag_assts);
+
+#define HP_CHK_UT_ALT(headroom, ptrs, nptrs, r, ret, tag_assts) \
+ GEN_HP_CHK_ALT(headroom, stg_gc_ut_##ptrs##_##nptrs, \
+ tag_assts r = (P_)ret;)
+
+/* -----------------------------------------------------------------------------
+ Generic Heap checks.
+
+ These are slow, but have the advantage of being usable in a variety
+ of situations.
+
+ The one restriction is that any relevant SRTs must already be pointed
+ to from the stack. The return address doesn't need to have an info
+ table attached: hence it can be any old code pointer.
+
+ The liveness mask is a logical 'XOR' of NO_PTRS and zero or more
+ Rn_PTR constants defined below. All registers will be saved, but
+ the garbage collector needs to know which ones contain pointers.
+
+ Good places to use a generic heap check:
+
+ - case alternatives (the return address with an SRT is already
+ on the stack).
+
+ - primitives (no SRT required).
+
+ The stack layout is like this:
+
+ DblReg1-2
+ FltReg1-4
+ R1-8
+ return address
+ liveness mask
+ stg_gen_chk_info
+
+ so the liveness mask depends on the size of an StgDouble (FltRegs
+ and R<n> are guaranteed to be 1 word in size).
+
+ -------------------------------------------------------------------------- */
+
+/* VERY MAGIC CONSTANTS!
+ * must agree with code in HeapStackCheck.c, stg_gen_chk
+ */
+
+#if SIZEOF_DOUBLE > SIZEOF_VOID_P
+#define ALL_NON_PTRS 0xffff
+#else /* SIZEOF_DOUBLE == SIZEOF_VOID_P */
+#define ALL_NON_PTRS 0x3fff
+#endif
+
+#define LIVENESS_MASK(ptr_regs) (ALL_NON_PTRS ^ (ptr_regs))
+
+#define NO_PTRS 0
+#define R1_PTR 1<<0
+#define R2_PTR 1<<1
+#define R3_PTR 1<<2
+#define R4_PTR 1<<3
+#define R5_PTR 1<<4
+#define R6_PTR 1<<5
+#define R7_PTR 1<<6
+#define R8_PTR 1<<7
+
+#define HP_CHK_GEN(headroom,liveness,reentry,tag_assts) \
+ if ((Hp += (headroom)) > HpLim ) { \
+ EF_(stg_gen_chk); \
+ tag_assts \
+ R9.w = (W_)LIVENESS_MASK(liveness); \
+ R10.w = (W_)reentry; \
+ JMP_(stg_gen_chk); \
+ }
+
+#define STK_CHK_GEN(headroom,liveness,reentry,tag_assts) \
+ if ((Sp - (headroom)) < SpLim) { \
+ EF_(stg_gen_chk); \
+ tag_assts \
+ R9.w = (W_)LIVENESS_MASK(liveness); \
+ R10.w = (W_)reentry; \
+ JMP_(stg_gen_chk); \
+ }
+
+#define MAYBE_GC(liveness,reentry) \
+ if (doYouWantToGC()) { \
+ EF_(stg_gen_hp); \
+ R9.w = (W_)LIVENESS_MASK(liveness); \
+ R10.w = (W_)reentry; \
+ JMP_(stg_gen_hp); \
+ }
+
+/* -----------------------------------------------------------------------------
+ Voluntary Yields/Blocks
+
+ We only have a generic version of this at the moment - if it turns
+ out to be slowing us down we can make specialised ones.
+ -------------------------------------------------------------------------- */
+
+#define YIELD(liveness,reentry) \
+ { \
+ EF_(stg_gen_yield); \
+ R9.w = (W_)LIVENESS_MASK(liveness); \
+ R10.w = (W_)reentry; \
+ JMP_(stg_gen_yield); \
+ }
+
+#define BLOCK(liveness,reentry) \
+ { \
+ EF_(stg_gen_block); \
+ R9.w = (W_)LIVENESS_MASK(liveness); \
+ R10.w = (W_)reentry; \
+ JMP_(stg_gen_block); \
+ }
+
+#define BLOCK_NP(ptrs) \
+ { \
+ EF_(stg_bock_##ptrs); \
+ JMP_(stg_block_##ptrs); \
+ }
+
+/* -----------------------------------------------------------------------------
+ CCall_GC needs to push a dummy stack frame containing the contents
+ of volatile registers and variables.
+
+ We use a RET_DYN frame the same as for a dynamic heap check.
+ ------------------------------------------------------------------------- */
+
+EI_(stg_gen_chk_info);
+
+/* -----------------------------------------------------------------------------
+ Vectored Returns
+
+ RETVEC(p,t) where 'p' is a pointer to the info table for a
+ vectored return address, returns the address of the return code for
+ tag 't'.
+
+ Return vectors are placed in *reverse order* immediately before the info
+ table for the return address. Hence the formula for computing the
+ actual return address is (addr - sizeof(InfoTable) - tag - 1).
+ The extra subtraction of one word is because tags start at zero.
+ -------------------------------------------------------------------------- */
+
+#ifdef USE_MINIINTERPRETER
+#define RET_VEC(p,t) ((*(stgCast(StgInfoTable*,p)->vector))[t])
+#else
+#define RET_VEC(p,t) (*((P_)(p) - sizeofW(StgInfoTable) - t - 1))
+#endif
+
+/* -----------------------------------------------------------------------------
+ Misc
+ -------------------------------------------------------------------------- */
+
+/* set the tag register (if we have one) */
+#define SET_TAG(t) /* nothing */
+
+/* don't do eager blackholing for now */
+#define UPD_BH_UPDATABLE(thunk) /* nothing */
+#define UPD_BH_SINGLE_ENTRY(thunk) /* nothing */
+
+/* -----------------------------------------------------------------------------
+ Moving Floats and Doubles
+
+ ASSIGN_FLT is for assigning a float to memory (usually the
+ stack/heap). The memory address is guaranteed to be
+ StgWord aligned (currently == sizeof(long)).
+
+ PK_FLT is for pulling a float out of memory. The memory is
+ guaranteed to be StgWord aligned.
+ -------------------------------------------------------------------------- */
+
+static inline void ASSIGN_FLT (W_ [], StgFloat);
+static inline StgFloat PK_FLT (W_ []);
+
+#if ALIGNMENT_FLOAT <= ALIGNMENT_LONG
+
+static inline void ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }
+static inline StgFloat PK_FLT (W_ p_src[]) { return *(StgFloat *)p_src; }
+
+#else /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */
+
+static inline void ASSIGN_FLT(W_ p_dest[], StgFloat src)
+{
+ float_thing y;
+ y.f = src;
+ *p_dest = y.fu;
+}
+
+static inline StgFloat PK_FLT(W_ p_src[])
+{
+ float_thing y;
+ y.fu = *p_src;
+ return(y.f);
+}
+
+#endif /* ALIGNMENT_FLOAT > ALIGNMENT_LONG */
+
+#if ALIGNMENT_DOUBLE <= ALIGNMENT_LONG
+
+static inline void ASSIGN_DBL (W_ [], StgDouble);
+static inline StgDouble PK_DBL (W_ []);
+
+static inline void ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }
+static inline StgDouble PK_DBL (W_ p_src[]) { return *(StgDouble *)p_src; }
+
+#else /* ALIGNMENT_DOUBLE > ALIGNMENT_LONG */
+
+/* Sparc uses two floating point registers to hold a double. We can
+ * write ASSIGN_DBL and PK_DBL by directly accessing the registers
+ * independently - unfortunately this code isn't writable in C, we
+ * have to use inline assembler.
+ */
+#if sparc_TARGET_ARCH
+
+#define ASSIGN_DBL(dst,src) \
+ __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
+ "=m" (((P_)(dst))[1]) : "f" (src));
+
+#define PK_DBL(src) \
+ ( { register double d; \
+ __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
+ "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
+ } )
+
+#else /* ! sparc_TARGET_ARCH */
+
+static inline void ASSIGN_DBL (W_ [], StgDouble);
+static inline StgDouble PK_DBL (W_ []);
+
+typedef struct
+ { StgWord dhi;
+ StgWord dlo;
+ } unpacked_double;
+
+typedef union
+ { StgDouble d;
+ unpacked_double du;
+ } double_thing;
+
+static inline void ASSIGN_DBL(W_ p_dest[], StgDouble src)
+{
+ double_thing y;
+ y.d = src;
+ p_dest[0] = y.du.dhi;
+ p_dest[1] = y.du.dlo;
+}
+
+/* GCC also works with this version, but it generates
+ the same code as the previous one, and is not ANSI
+
+#define ASSIGN_DBL( p_dest, src ) \
+ *p_dest = ((double_thing) src).du.dhi; \
+ *(p_dest+1) = ((double_thing) src).du.dlo \
+*/
+
+static inline StgDouble PK_DBL(W_ p_src[])
+{
+ double_thing y;
+ y.du.dhi = p_src[0];
+ y.du.dlo = p_src[1];
+ return(y.d);
+}
+
+#endif /* ! sparc_TARGET_ARCH */
+
+#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */
+
+#ifdef SUPPORT_LONG_LONGS
+
+typedef struct
+ { StgWord dhi;
+ StgWord dlo;
+ } unpacked_double_word;
+
+typedef union
+ { StgInt64 i;
+ unpacked_double_word iu;
+ } int64_thing;
+
+typedef union
+ { StgNat64 w;
+ unpacked_double_word wu;
+ } word64_thing;
+
+static inline void ASSIGN_Word64(W_ p_dest[], StgNat64 src)
+{
+ word64_thing y;
+ y.w = src;
+ p_dest[0] = y.wu.dhi;
+ p_dest[1] = y.wu.dlo;
+}
+
+static inline StgNat64 PK_Word64(W_ p_src[])
+{
+ word64_thing y;
+ y.wu.dhi = p_src[0];
+ y.wu.dlo = p_src[1];
+ return(y.w);
+}
+
+static inline void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+ int64_thing y;
+ y.i = src;
+ p_dest[0] = y.iu.dhi;
+ p_dest[1] = y.iu.dlo;
+}
+
+static inline StgInt64 PK_Int64(W_ p_src[])
+{
+ int64_thing y;
+ y.iu.dhi = p_src[0];
+ y.iu.dlo = p_src[1];
+ return(y.i);
+}
+#endif
+
+/* -----------------------------------------------------------------------------
+ Catch frames
+ -------------------------------------------------------------------------- */
+
+extern const StgPolyInfoTable catch_frame_info;
+
+/* -----------------------------------------------------------------------------
+ Seq frames
+
+ A seq frame is very like an update frame, except that it doesn't do
+ an update...
+ -------------------------------------------------------------------------- */
+
+extern const StgPolyInfoTable seq_frame_info;
+
+#define PUSH_SEQ_FRAME(sp) \
+ { \
+ StgSeqFrame *__frame; \
+ TICK_SEQF_PUSHED(); \
+ __frame = (StgSeqFrame *)(sp); \
+ SET_HDR_(__frame,&seq_frame_info,CCCS); \
+ __frame->link = Su; \
+ Su = (StgUpdateFrame *)__frame; \
+ }
+
+/* -----------------------------------------------------------------------------
+ Split markers
+ -------------------------------------------------------------------------- */
+
+#if defined(USE_SPLIT_MARKERS)
+#define __STG_SPLIT_MARKER(n) FN_(__stg_split_marker##n) { }
+#else
+#define __STG_SPLIT_MARKER(n) /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+ Closure and Info Macros with casting.
+
+ We don't want to mess around with casts in the generated C code, so
+ we use these casting versions of the closure/info tables macros.
+ -------------------------------------------------------------------------- */
+
+#define SET_HDR_(c,info,ccs) \
+ SET_HDR((StgClosure *)(c),(StgInfoTable *)(info),ccs)
+
+/* -----------------------------------------------------------------------------
+ Saving context for exit from the STG world, and loading up context
+ on entry to STG code.
+
+ We save all the STG registers (that is, the ones that are mapped to
+ machine registers) in their places in the TSO.
+
+ The stack registers go into the current stack object, and the heap
+ registers are saved in global locations.
+ -------------------------------------------------------------------------- */
+
+static __inline__ void
+SaveThreadState(void)
+{
+ /* Don't need to save REG_Base, it won't have changed. */
+
+ CurrentTSO->sp = Sp;
+ CurrentTSO->su = Su;
+ CurrentTSO->splim = SpLim;
+ CloseNursery(Hp);
+
+#if defined(PROFILING)
+ CurrentTSO->prof.CCCS = CCCS;
+#endif
+}
+
+static __inline__ void
+LoadThreadState (void)
+{
+#ifdef REG_Base
+ BaseReg = &MainRegTable;
+#endif
+
+ Sp = CurrentTSO->sp;
+ Su = CurrentTSO->su;
+ SpLim = CurrentTSO->splim;
+ OpenNursery(Hp,HpLim);
+
+# if defined(PROFILING)
+ CCCS = CurrentTSO->prof.CCCS;
+# endif
+}
+
+#endif /* STGMACROS_H */
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-\section[StgMacros]{C macros used in GHC-generated \tr{.hc} files}
-
-\begin{code}
-#ifndef STGMACROS_H
-#define STGMACROS_H
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[StgMacros-abbrev]{Abbreviatory(?) and general macros}
-%* *
-%************************************************************************
-
-Mere abbreviations:
-\begin{code}
-/* for function declarations */
-#define STGFUN(f) F_ f(STG_NO_ARGS)
-#define STATICFUN(f) static F_ f(STG_NO_ARGS)
-
-/* for functions/data that are really external to this module */
-#define EXTFUN(f) extern F_ f(STG_NO_ARGS)
-#define EXTDATA(d) extern W_ d[]
-#define EXTDATA_RO(d) extern const W_ d[] /* read-only */
-
-/* for fwd decls to functions/data somewhere else in this module */
-/* (identical for the mo') */
-#define INTFUN(f) static F_ f(STG_NO_ARGS)
-#define INTDATA(d) extern W_ d[]
-#define INTDATA_RO(d) extern const W_ d[] /* read-only */
-
-/* short forms of most of the above */
-
-#define FN_(f) F_ f(STG_NO_ARGS)
-#define IFN_(f) static F_ f(STG_NO_ARGS)
-#define EF_(f) extern F_ f(STG_NO_ARGS)
-#define ED_(d) extern W_ d[]
-#define ED_RO_(d) extern const W_ d[] /* read-only */
-#define IF_(f) static F_ f(STG_NO_ARGS)
-
-/* GCC is uncooperative about the next one: */
-/* But, the "extern" prevents initialisation... ADR */
-#if defined(__GNUC__)
-#define ID_(d) extern W_ d[]
-#define ID_RO_(d) extern const W_ d[] /* read-only */
-#else
-#define ID_(d) static W_ d[]
-#define ID_RO_(d) static const W_ d[] /* read-only */
-#endif /* not GCC */
-\end{code}
-
-General things; note: general-but-``machine-dependent'' macros are
-given in \tr{StgMachDeps.lh}.
-\begin{code}
-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
-word and split such a word back into two.
-
-Dependent on machine word size :-)
-*/
-
-#define COMBINE_WORDS(word,short1,short2) \
- do { \
- ((packed_shorts *)&(word))->wu.s1 = short1; \
- ((packed_shorts *)&(word))->wu.s2 = short2; \
- } while(0)
-
-#define SPLIT_WORD(word,short1,short2) \
- do { \
- short1 = ((packed_shorts *)&(word))->wu.s1; \
- short2 = ((packed_shorts *)&(word))->wu.s2; \
- } while(0)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[StgMacros-gen-stg]{General STGish macros}
-%* *
-%************************************************************************
-
-Common sizes of vector-return tables.
-
-Claim: don't need fwd decls for return pts in \tr{VECTBL*}, because
-the AbsC flattener ensures that things come out sufficiently
-``backwards''.
-
-\begin{code}
-#ifdef __STG_REV_TBLS__
-#define UNVECTBL(staticp,label,a) /* nothing */
-#else
-#define UNVECTBL(staticp,label,a) \
-EXTFUN(a); \
-staticp const W_ label[] = { \
- (W_) a \
-};
-#endif
-\end{code}
-
-\begin{code}
-#if defined(USE_SPLIT_MARKERS)
-#define __STG_SPLIT_MARKER(n) FN_(CAT2(__stg_split_marker,n)){ }
-#else
-#define __STG_SPLIT_MARKER(n) /* nothing */
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[StgMacros-exceptions]{Exception-checking macros}
-%* *
-%************************************************************************
-
-Argument-satisfaction check, stack(s) overflow check, heap overflow
-check.
-
-The @SUBTRACT(upper, lower)@ macros return a positive result in words
-indicating the amount by which upper is above lower on the stack.
-
-\begin{code}
-#define SUBTRACT_A_STK( upper, lower ) AREL( (lower) - (upper) )
-#define SUBTRACT_B_STK( upper, lower ) BREL( (lower) - (upper) )
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-arg-satis]{Argument-satisfaction checks}
-%* *
-%************************************************************************
-
-@ARGS_CHK(n)@ sees of there are @n@ words of args on the A/B stack.
-If not, it jumps to @UpdatePAP@.
-
-@ARGS_CHK@ args are pre-directionified.
-Notice that we do the comparisons in the form (x < a+n), for
-some constant n. This generates more efficient code (with GCC at least)
-than (x-a < n).
-
-\begin{code}
-#define ARGS_CHK_A(n) \
- if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
- JMP_( UpdatePAP ); \
- }
-
-#define ARGS_CHK_A_LOAD_NODE(n, closure_addr) \
- if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
- Node = (P_) closure_addr; \
- JMP_( UpdatePAP ); \
- }
-
-#define ARGS_CHK_B(n) \
- if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
- JMP_( UpdatePAP ); \
- }
-
-
-#define ARGS_CHK_B_LOAD_NODE(n, closure_addr) \
- if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
- Node = (P_) closure_addr; \
- JMP_( UpdatePAP ); \
- }
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-stk-chks]{Stack-overflow check}
-%* *
-%************************************************************************
-
-@STK_CHK(a,b)@ [misc args omitted...] checks that we can allocate @a@
-words of A stack and @b@ words of B stack. If not, it calls
-@StackOverflow@ (which dies).
-
-(It will be different in the parallel case.)
-
-NB: args @a@ and @b@ are pre-direction-ified!
-\begin{code}
-I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
-int sanityChk_StkO (P_ stko); /* ToDo: move to a sane place */
-
-#if ! defined(CONCURRENT)
-
-extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
-
-#if STACK_CHECK_BY_PAGE_FAULT
-
-#define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
- /* use memory protection instead; still need ticky-ness */
-
-#else
-
-#define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
- ULTRASAFESTGCALL0(void,(void *),StackOverflow)
-
-#endif /* not using page-faulting */
-
-#else /* threaded */
-
-I_ StackOverflow PROTO((W_, W_));
-
-/*
- * On a uniprocessor, we do *NOT* context switch on a stack overflow
- * (though we may GC). Therefore, we never have to reenter node.
- */
-
-#define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
- DO_STACKOVERFLOW((hda+hdb)<<2|((rtype)<<1)|(reenter),((spa)<<20)|((spb)<<8)|(liveness))
-
-#define STACK_OVERFLOW_HEADROOM(args,y) ((args) >> 2)
-#define STACK_OVERFLOW_PRIM_RETURN(args,y) ((args) & 2)
-#define STACK_OVERFLOW_REENTER(args,y) ((args) & 1)
-
-#define STACK_OVERFLOW_AWORDS(x,args) (((args) >> 20) & 0x0fff)
-#define STACK_OVERFLOW_BWORDS(x,args) (((args) >> 8) & 0x0fff)
-#define STACK_OVERFLOW_LIVENESS(x,args) ((args) & 0xff)
-
-#endif /* CONCURRENT */
-
-#define STK_CHK(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter)\
-do { \
- DO_ASTK_HWM(); /* ticky-ticky profiling */ \
- DO_BSTK_HWM(); \
- if (STKS_OVERFLOW_OP(((a_headroom) + 1), ((b_headroom) + 1))) { \
- STACK_OVERFLOW(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter);\
- } \
-}while(0)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-heap-chks]{Heap-overflow checks}
-%* *
-%************************************************************************
-
-Please see the general discussion/commentary about ``what really
-happens in a GC,'' in \tr{SMinterface.lh}.
-
-\begin{code}
-void PerformGC PROTO((W_));
-void RealPerformGC PROTO((W_ liveness, W_ reqsize, W_ always_reenter_node, rtsBool do_full_collection));
-void checkInCCallGC(STG_NO_ARGS);
-
-#ifndef PAR
-void StgPerformGarbageCollection(STG_NO_ARGS);
-#endif
-
-#ifndef CONCURRENT
-
-#define OR_MSG_PENDING /* never */
-
-#define HEAP_OVERFLOW(liveness,n,reenter) \
- do { \
- DO_GC((((W_)n)<<8)|(liveness)); \
- } while (0)
-
-#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 8 + 1))) - 1)
-#define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 8) & REQSIZE_BITMASK)
-#define HEAP_OVERFLOW_REENTER(args) 0
-#define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
-
-#else /* CONCURRENT */
-
-void ReallyPerformThreadGC PROTO((W_, rtsBool));
-
-#define HEAP_OVERFLOW(liveness,n,reenter) \
- do { \
- DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
- } while (0)
-
-#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 9 + 1))) - 1)
-#define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 9) & REQSIZE_BITMASK)
-#define HEAP_OVERFLOW_REENTER(args) (((args) >> 8) & 0x1)
-#define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
-
-#ifndef PAR
-
-#define OR_MSG_PENDING /* never */
-
-#else
-
-extern int PacketsWaiting; /*Probes for incoming messages*/
-extern int heapChkCounter; /*Not currently used! We check for messages when*/
- /*a thread is resheduled PWT*/
-/* #define OR_MSG_PENDING || (--heapChkCounter == 0 && PacketsWaiting())*/
-#define OR_MSG_PENDING /* never */
-
-#endif /* PAR */
-#endif /* CONCURRENT */
-
-#if 0 /* alpha_TARGET_ARCH */
-#define CACHE_LINE 4 /* words */
-#define LINES_AHEAD 3
-#define PRE_FETCH(n) \
-do { \
- StgInt j; \
- j = ((STG_VOLATILE StgInt *) Hp)[LINES_AHEAD * CACHE_LINE]; \
-} while(0);
-#define EXTRA_HEAP_WORDS (CACHE_LINE * LINES_AHEAD)
-#else
-#define PRE_FETCH(reg)
-#define EXTRA_HEAP_WORDS 0
-#endif
-
-#if defined(GRAN)
-#define HEAP_CHK(liveness_mask,n,reenter) \
- do { \
- /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
- /* THREAD_CONTEXT_SWITCH(liveness_mask,reenter); */ \
- ALLOC_HEAP(n); /* ticky profiling */ \
- GRAN_ALLOC_HEAP(n,liveness_mask); /* Granularity Simulation */ \
- if (((Hp = Hp + (n)) > HpLim)) { \
- /* Old: STGCALL3_GC(PerformGC,liveness_mask,n,StgFalse); */\
- HEAP_OVERFLOW(liveness_mask,n,StgFalse); \
- }}while(0)
-
-#else
-
-#define HEAP_CHK(liveness_mask,n,reenter) \
-do { \
- /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
- PRE_FETCH(n); \
- ALLOC_HEAP(n); /* ticky profiling */ \
- if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
- HEAP_OVERFLOW(liveness_mask,n,reenter); \
- } \
-} while(0)
-
-#endif /* GRAN */
-
-#ifdef CONCURRENT
-
-#define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
-do { \
- /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
- PRE_FETCH(n); \
- ALLOC_HEAP(n); /* ticky profiling */ \
- if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
- HEAP_OVERFLOW(liveness_mask,n,reenter); \
- n = TSO_ARG1(CurrentTSO); \
- }} while(0)
-
-#else
-
-#define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
- HEAP_CHK(liveness_mask,n,reenter)
-
-#endif
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[StgMacros-prim-ops]{Primitive operations}
-%* *
-%************************************************************************
-
-One thing to be {\em very careful about} with these macros that assign
-to results is that the assignment must come {\em last}. Some of the
-other arguments may be in terms of addressing modes that get clobbered
-by the assignment. (Dirty imperative programming RULES!)
-
-The order here is roughly that in \tr{compiler/prelude/PrimOps.lhs}.
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-compare-primops]{Primitive comparison ops on basic types}
-%* *
-%************************************************************************
-
-We cast the chars in case one of them is a literal (so C things work right
-even for 8-bit chars).
-\begin{code}
-#define gtCharZh(r,a,b) r=(I_)((a)> (b))
-#define geCharZh(r,a,b) r=(I_)((a)>=(b))
-#define eqCharZh(r,a,b) r=(I_)((a)==(b))
-#define neCharZh(r,a,b) r=(I_)((a)!=(b))
-#define ltCharZh(r,a,b) r=(I_)((a)< (b))
-#define leCharZh(r,a,b) r=(I_)((a)<=(b))
-
-/* Int comparisons: >#, >=# etc */
-#define ZgZh(r,a,b) r=(I_)((a) >(b))
-#define ZgZeZh(r,a,b) r=(I_)((a)>=(b))
-#define ZeZeZh(r,a,b) r=(I_)((a)==(b))
-#define ZdZeZh(r,a,b) r=(I_)((a)!=(b))
-#define ZlZh(r,a,b) r=(I_)((a) <(b))
-#define ZlZeZh(r,a,b) r=(I_)((a)<=(b))
-
-#define gtWordZh(r,a,b) r=(I_)((a) >(b))
-#define geWordZh(r,a,b) r=(I_)((a)>=(b))
-#define eqWordZh(r,a,b) r=(I_)((a)==(b))
-#define neWordZh(r,a,b) r=(I_)((a)!=(b))
-#define ltWordZh(r,a,b) r=(I_)((a) <(b))
-#define leWordZh(r,a,b) r=(I_)((a)<=(b))
-
-#define gtAddrZh(r,a,b) r=(I_)((a) >(b))
-#define geAddrZh(r,a,b) r=(I_)((a)>=(b))
-#define eqAddrZh(r,a,b) r=(I_)((a)==(b))
-#define neAddrZh(r,a,b) r=(I_)((a)!=(b))
-#define ltAddrZh(r,a,b) r=(I_)((a) <(b))
-#define leAddrZh(r,a,b) r=(I_)((a)<=(b))
-
-#define gtFloatZh(r,a,b) r=(I_)((a)> (b))
-#define geFloatZh(r,a,b) r=(I_)((a)>=(b))
-#define eqFloatZh(r,a,b) r=(I_)((a)==(b))
-#define neFloatZh(r,a,b) r=(I_)((a)!=(b))
-#define ltFloatZh(r,a,b) r=(I_)((a)< (b))
-#define leFloatZh(r,a,b) r=(I_)((a)<=(b))
-
-/* Double comparisons: >##, >=#@ etc */
-#define ZgZhZh(r,a,b) r=(I_)((a) >(b))
-#define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b))
-#define ZeZeZhZh(r,a,b) r=(I_)((a)==(b))
-#define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b))
-#define ZlZhZh(r,a,b) r=(I_)((a) <(b))
-#define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-char-primops]{Primitive @Char#@ ops (and @LitString#@ish things, too)}
-%* *
-%************************************************************************
-
-We cast the chars in case one of them is a literal (so C things work right
-even for 8-bit chars).
-\begin{code}
-#define ordZh(r,a) r=(I_)((W_) (a))
-#define chrZh(r,a) r=(StgChar)((W_)(a))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-int-primops]{Primitive @Int#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-I_ stg_div PROTO((I_ a, I_ b));
-
-#define ZpZh(r,a,b) r=(a)+(b)
-#define ZmZh(r,a,b) r=(a)-(b)
-#define ZtZh(r,a,b) r=(a)*(b)
-#define quotIntZh(r,a,b) r=(a)/(b)
-/* ZdZh not used??? --SDM */
-#define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
-#define remIntZh(r,a,b) r=(a)%(b)
-#define negateIntZh(r,a) r=-(a)
-
-/* Ever used ? -- SOF */
-#define absIntZh(a) r=(( (a) >= 0 ) ? (a) : (-(a)))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-#define quotWordZh(r,a,b) r=((W_)a)/((W_)b)
-#define remWordZh(r,a,b) r=((W_)a)%((W_)b)
-
-#define andZh(r,a,b) r=(a)&(b)
-#define orZh(r,a,b) r=(a)|(b)
-#define xorZh(r,a,b) r=(a)^(b)
-#define notZh(r,a) r=~(a)
-
-#define shiftLZh(r,a,b) r=(a)<<(b)
-#define shiftRLZh(r,a,b) r=(a)>>(b)
-#define iShiftLZh(r,a,b) r=(a)<<(b)
-/* Right shifting of signed quantities is not portable in C, so
- the behaviour you'll get from using these primops depends
- on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98
-*/
-#define iShiftRAZh(r,a,b) r=(a)>>(b)
-#define iShiftRLZh(r,a,b) r=(a)>>(b)
-
-#define int2WordZh(r,a) r=(W_)(a)
-#define word2IntZh(r,a) r=(I_)(a)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-#define int2AddrZh(r,a) r=(A_)(a)
-#define addr2IntZh(r,a) r=(I_)(a)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-#define plusFloatZh(r,a,b) r=(a)+(b)
-#define minusFloatZh(r,a,b) r=(a)-(b)
-#define timesFloatZh(r,a,b) r=(a)*(b)
-#define divideFloatZh(r,a,b) r=(a)/(b)
-#define negateFloatZh(r,a) r=-(a)
-
-#define int2FloatZh(r,a) r=(StgFloat)(a)
-#define float2IntZh(r,a) r=(I_)(a)
-
-#define expFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
-#define logFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
-#define sqrtFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
-#define sinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
-#define cosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
-#define tanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
-#define asinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
-#define acosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
-#define atanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
-#define sinhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
-#define coshFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
-#define tanhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
-#define powerFloatZh(r,a,b) r=(StgFloat) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
-
-/* encoding/decoding given w/ Integer stuff */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-#define ZpZhZh(r,a,b) r=(a)+(b)
-#define ZmZhZh(r,a,b) r=(a)-(b)
-#define ZtZhZh(r,a,b) r=(a)*(b)
-#define ZdZhZh(r,a,b) r=(a)/(b)
-#define negateDoubleZh(r,a) r=-(a)
-
-#define int2DoubleZh(r,a) r=(StgDouble)(a)
-#define double2IntZh(r,a) r=(I_)(a)
-
-#define float2DoubleZh(r,a) r=(StgDouble)(a)
-#define double2FloatZh(r,a) r=(StgFloat)(a)
-
-#define expDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
-#define logDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
-#define sqrtDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
-#define sinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
-#define cosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
-#define tanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
-#define asinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
-#define acosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
-#define atanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
-#define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
-#define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
-#define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
-/* Power: **## */
-#define ZtZtZhZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-64-primops]{Primitive @Int64#@ and @Word64#@ ops}
-%* *
-%************************************************************************
-
-Apart from the Integer casting primops, all primops over 64-bit (i.e., long long)
-@Int64#@ and @Word64#@s are defined out-of-line. We just give the prototype
-of these primops here:
-
-\begin{code}
-#ifdef HAVE_LONG_LONG
-I_ stg_gtWord64 PROTO((StgWord64, StgWord64));
-I_ stg_geWord64 PROTO((StgWord64, StgWord64));
-I_ stg_eqWord64 PROTO((StgWord64, StgWord64));
-I_ stg_neWord64 PROTO((StgWord64, StgWord64));
-I_ stg_ltWord64 PROTO((StgWord64, StgWord64));
-I_ stg_leWord64 PROTO((StgWord64, StgWord64));
-
-I_ stg_gtInt64 PROTO((StgInt64, StgInt64));
-I_ stg_geInt64 PROTO((StgInt64, StgInt64));
-I_ stg_eqInt64 PROTO((StgInt64, StgInt64));
-I_ stg_neInt64 PROTO((StgInt64, StgInt64));
-I_ stg_ltInt64 PROTO((StgInt64, StgInt64));
-I_ stg_leInt64 PROTO((StgInt64, StgInt64));
-
-LW_ stg_remWord64 PROTO((StgWord64, StgWord64));
-LW_ stg_quotWord64 PROTO((StgWord64, StgWord64));
-
-LI_ stg_remInt64 PROTO((StgInt64, StgInt64));
-LI_ stg_quotInt64 PROTO((StgInt64, StgInt64));
-LI_ stg_negateInt64 PROTO((StgInt64));
-LI_ stg_plusInt64 PROTO((StgInt64, StgInt64));
-LI_ stg_minusInt64 PROTO((StgInt64, StgInt64));
-LI_ stg_timesInt64 PROTO((StgInt64, StgInt64));
-
-LW_ stg_and64 PROTO((StgWord64, StgWord64));
-LW_ stg_or64 PROTO((StgWord64, StgWord64));
-LW_ stg_xor64 PROTO((StgWord64, StgWord64));
-LW_ stg_not64 PROTO((StgWord64));
-
-LW_ stg_shiftL64 PROTO((StgWord64, StgInt));
-LW_ stg_shiftRL64 PROTO((StgWord64, StgInt));
-LI_ stg_iShiftL64 PROTO((StgInt64, StgInt));
-LI_ stg_iShiftRL64 PROTO((StgInt64, StgInt));
-LI_ stg_iShiftRA64 PROTO((StgInt64, StgInt));
-
-LI_ stg_intToInt64 PROTO((StgInt));
-I_ stg_int64ToInt PROTO((StgInt64));
-LW_ stg_int64ToWord64 PROTO((StgInt64));
-
-LW_ stg_wordToWord64 PROTO((StgWord));
-W_ stg_word64ToWord PROTO((StgWord64));
-LI_ stg_word64ToInt64 PROTO((StgWord64));
-#endif
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
-%* *
-%************************************************************************
-
-Dirty macros we use for the real business.
-
-INVARIANT: When one of these macros is called, the only live data is
-tidily on the STG stacks or in the STG registers (the code generator
-ensures this). If there are any pointer-arguments, they will be in
-the first \tr{Ret*} registers (e.g., \tr{da} arg of \tr{gmpTake1Return1}).
-
-OK, here are the real macros:
-\begin{code}
-#define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da) \
-{ MP_INT arg; \
- MP_INT result; \
- I_ space = size_chk_macro(sa); \
- \
- /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
- GMP_HEAP_LOOKAHEAD(liveness,space); \
- \
- /* Now we can initialise (post possible GC) */ \
- arg.alloc = (aa); \
- arg.size = (sa); \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
- \
- /* Perform the operation */ \
- SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar) = result.alloc; \
- (sr) = result.size; \
- (dr) = (B_) (result.d - DATA_HS); \
- /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
-}
-
-
-#define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
-{ MP_INT arg1; \
- MP_INT arg2; \
- MP_INT result; \
- I_ space = size_chk_macro(s1,s2); \
- \
- /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
- GMP_HEAP_LOOKAHEAD(liveness,space); \
- \
- /* Now we can initialise (post possible GC) */ \
- arg1.alloc = (a1); \
- arg1.size = (s1); \
- arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2.alloc = (a2); \
- arg2.size = (s2); \
- arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
- \
- /* Perform the operation */ \
- SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar) = result.alloc; \
- (sr) = result.size; \
- (dr) = (B_) (result.d - DATA_HS); \
- /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
-}
-
-#define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
-{ MP_INT arg1; \
- MP_INT arg2; \
- MP_INT result1; \
- MP_INT result2; \
- I_ space = size_chk_macro(s1,s2); \
- \
- /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
- GMP_HEAP_LOOKAHEAD(liveness,space); \
- \
- /* Now we can initialise (post possible GC) */ \
- arg1.alloc = (a1); \
- arg1.size = (s1); \
- arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2.alloc = (a2); \
- arg2.size = (s2); \
- arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1); \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2); \
- \
- /* Perform the operation */ \
- SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar1) = result1.alloc; \
- (sr1) = result1.size; \
- (dr1) = (B_) (result1.d - DATA_HS); \
- (ar2) = result2.alloc; \
- (sr2) = result2.size; \
- (dr2) = (B_) (result2.d - DATA_HS); \
-}
-\end{code}
-
-Some handy size-munging macros: sometimes gratuitously {\em conservative}.
-The \tr{+16} is to allow for the initial allocation of \tr{MP_INT} results.
-The \tr{__abs} stuff is because negative-ness of GMP things is encoded
-in their ``size''...
-\begin{code}
-#define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
-#define GMP_SIZE_ONE() (2 + DATA_HS + 16)
-#define GMP_SAME_SIZE(a) (__abs(a) + DATA_HS + 16)
-#define GMP_MAX_SIZE(a,b) ((__abs(a) > __abs(b) ? __abs(a) : __abs(b)) + 1 + DATA_HS + 16)
- /* NB: the +1 is for the carry (or whatever) */
-#define GMP_2MAX_SIZE(a,b) (2 * GMP_MAX_SIZE(a,b))
-#define GMP_ADD_SIZES(a,b) (__abs(a) + __abs(b) + 1 + DATA_HS + 16)
- /* the +1 may just be paranoia */
-\end{code}
-
-For the Integer/GMP stuff, we have macros that {\em look ahead} for
-some space, but don't actually grab it.
-
-If there are live pointers at the time of the lookahead, the caller
-must make sure they are in \tr{Ret1}, \tr{Ret2}, ..., so they can be
-handled normally. We achieve this by having the code generator {\em
-always} pass args to may-invoke-GC primitives in registers, using the
-normal pointers-first policy. This means that, if we do go to garbage
-collection, everything is already in the Right Place.
-
-Saving and restoring Hp register so the MP allocator can see them. If we are
-performing liftime profiling need to save and restore HpLim as well so that
-it can be bumped if allocation occurs.
-
-The second argument to @GMP_HEAP_LOOKAHEAD@ must be an lvalue so that
-it can be restored from @TSO_ARG1@ after a failed @HEAP_CHK@ in
-threaded land.
-
-\begin{code}
-#define GMP_HEAP_LOOKAHEAD(liveness,n) \
- do { \
- HEAP_CHK_AND_RESTORE_N(liveness,n,0); \
- Hp = Hp - (n); \
- UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
- SAVE_Hp = Hp; /* Hand over the hp */ \
- DEBUG_SetGMPAllocBudget(n) \
- }while(0)
-
-#define GMP_HEAP_HANDBACK() \
- Hp = SAVE_Hp; \
- DEBUG_ResetGMPAllocBudget()
-\end{code}
-
-\begin{code}
-void *stgAllocForGMP PROTO((size_t size_in_bytes));
-void *stgReallocForGMP PROTO((void *ptr, size_t old_size, size_t new_size));
-void stgDeallocForGMP PROTO((void *ptr, size_t size));
-
-#ifdef ALLOC_DEBUG
-extern StgInt DEBUG_GMPAllocBudget;
-#define DEBUG_SetGMPAllocBudget(n) DEBUG_GMPAllocBudget = (n);
-#define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
-#else
-#define DEBUG_SetGMPAllocBudget(n) /*nothing*/
-#define DEBUG_ResetGMPAllocBudget() /*nothing*/
-#endif
-\end{code}
-
-The real business (defining Integer primops):
-\begin{code}
-#define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
- gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
-
-#define plusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_add, ar,sr,dr, a1,s1,d1, a2,s2,d2)
-#define minusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_sub, ar,sr,dr, a1,s1,d1, a2,s2,d2)
-#define timesIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return1(GMP_ADD_SIZES, liveness, mpz_mul, ar,sr,dr, a1,s1,d1, a2,s2,d2)
-
-/* div, mod, quot, rem are defined w/ quotRem & divMod */
-
-#define quotRemIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_divmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
-#define divModIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_mdivmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
-\end{code}
-
-Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
-fellow (returns -ve, 0, or +ve).
-\begin{code}
-#define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */ \
-{ MP_INT arg1; \
- MP_INT arg2; \
- /* Does not allocate memory */ \
- \
- arg1.alloc = (a1); \
- arg1.size = (s1); \
- arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2.alloc = (a2); \
- arg2.size = (s2); \
- arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2); \
-}
-\end{code}
-
-Coercions:
-
-\begin{code}
-#define integer2IntZh(r, hp, aa,sa,da) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg.alloc = (aa); \
- arg.size = (sa); \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_si,&arg); \
-}
-
-/* Since we're forced to know a little bit about MP_INT layout to do this with
- pre-allocated heap, we just inline the whole of mpz_init_set_si here.
- ** DIRE WARNING. if mpz_init_set_si changes, so does this! ***
-*/
-
-#define int2IntegerZh(ar,sr,dr, hp, i) \
-{ StgInt val; /* to snaffle arg to avoid aliasing */ \
- \
- val = (i); /* snaffle... */ \
- \
- SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- \
- if ((val) < 0) { (sr) = -1; (hp)[DATA_HS] = -(val); } \
- else if ((val) > 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
- else /* val==0 */ { (sr) = 0; } \
- (ar) = 1; \
- (dr) = (B_)(hp); /* dr is an StgByteArray */ \
-}
-
-#define word2IntegerZh(ar,sr,dr, hp, i) \
-{ StgWord val; /* to snaffle arg to avoid aliasing */ \
- \
- val = (i); /* snaffle... */ \
- \
- SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- \
- if ((val) != 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
- else /* val==0 */ { (sr) = 0; } \
- (ar) = 1; \
- (dr) = (B_)(hp); /* dr is an StgByteArray */ \
-}
-
-#define integer2WordZh(r, hp, aa,sa,da) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg.alloc = (aa); \
- arg.size = (sa); \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_ui,&arg); \
-}
-
-#define integerToInt64Zh(r, hp, aa,sa,da) \
-{ unsigned long int* d; \
- StgInt64 res; \
- /* Allocates memory. Chummy with gmp rep. */ \
- \
- d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- if ( (aa) == 0) { (res)=(LI_)0; } \
- else if ( (aa) == 1) { (res)=(LI_)d[0]; } \
- else { (res)=(LI_)d[0] + (LI_)d[1] * 0x100000000LL; } \
- (r)=(LI_)( (sa) < 0 ? -res : res); \
-}
-
-#define integerToWord64Zh(r, hp, aa,sa,da) \
-{ unsigned long int* d; \
- StgWord64 res; \
- /* Allocates memory. Chummy with gmp rep. */ \
- \
- d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- if ( (aa) == 0) { (res)=(LW_)0; } \
- else if ( (aa) == 1) { (res)=(LW_)d[0]; } \
- else { (res)=(LW_)d[0] + (LW_)d[1] * 0x100000000ULL; } \
- (r) = (res); \
-}
-
-#define int64ToIntegerZh(ar,sr,dr, hp, li) \
-{ StgInt64 val; /* to snaffle arg to avoid aliasing */ \
- StgWord hi; \
- int neg=0; \
- \
- val = (li); /* snaffle... */ \
- \
- SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- \
- if ( val < 0LL ) { \
- neg = 1; \
- val = -val; \
- } \
- hi = (W_)((LW_)val / 0x100000000ULL); \
- if ((LW_)(val) >= 0x100000000ULL) { (sr) = 2; (ar) = 2; (hp)[DATA_HS] = ((W_)val); (hp)[DATA_HS+1] = (hi); } \
- else if ((val) != 0) { (sr) = 1; (ar) = 1; (hp)[DATA_HS] = ((W_)val); } \
- else /* val==0 */ { (sr) = 0; (ar) = 1; } \
- (sr) = ( neg ? -(sr) : (sr) ); \
- (dr) = (B_)(hp); /* dr is an StgByteArray */ \
-}
-
-#define word64ToIntegerZh(ar,sr,dr, hp, lw) \
-{ StgWord64 val; /* to snaffle arg to avoid aliasing */ \
- StgWord hi; \
- \
- val = (lw); /* snaffle... */ \
- \
- SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- \
- hi = (W_)((LW_)val / 0x100000000ULL); \
- if ((val) >= 0x100000000ULL ) { (sr) = 2; (ar) = 2; (hp)[DATA_HS] = ((W_)val); (hp)[DATA_HS+1] = (hi); } \
- else if ((val) != 0) { (sr) = 1; (ar) = 1; (hp)[DATA_HS] = ((W_)val); } \
- else /* val==0 */ { (sr) = 0; (ar) = 1; } \
- (dr) = (B_)(hp); /* dr is an StgByteArray */ \
-}
-
-
-
-\end{code}
-
-Then there are a few oddments to make life easier:
-\begin{code}
-/*
- DIRE WARNING.
- The "str" argument must be a literal C string.
-
- addr2Integer( ..., "foo") OK!
-
- x = "foo";
- addr2Integer( ..., x) NO! NO!
-*/
-
-#define addr2IntegerZh(ar,sr,dr, liveness, str) \
-{ MP_INT result; \
- /* taking the number of bytes/8 as the number of words of lookahead \
- is plenty conservative */ \
- I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1); \
- \
- GMP_HEAP_LOOKAHEAD(liveness, space); \
- \
- /* Perform the operation */ \
- if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
- abort(); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar) = result.alloc; \
- (sr) = result.size; \
- (dr) = (B_) (result.d - DATA_HS); \
- /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
-}
-\end{code}
-
-Encoding and decoding float-ish things is pretty Integer-ish. We use
-these pretty magical support functions, essentially stolen from Lennart:
-\begin{code}
-StgFloat __encodeFloat PROTO((MP_INT *, I_));
-void __decodeFloat PROTO((MP_INT * /*result1*/,
- I_ * /*result2*/,
- StgFloat));
-
-StgDouble __encodeDouble PROTO((MP_INT *, I_));
-void __decodeDouble PROTO((MP_INT * /*result1*/,
- I_ * /*result2*/,
- StgDouble));
-\end{code}
-
-Some floating-point format info, made with the \tr{enquire} program
-(version~4.3) [comes with gcc].
-\begin{code}
-/* this should be done by CPU architecture, insofar as possible [WDP] */
-
-#if sparc_TARGET_ARCH \
- || alpha_TARGET_ARCH \
- || hppa1_1_TARGET_ARCH \
- || i386_TARGET_ARCH \
- || m68k_TARGET_ARCH \
- || mipsel_TARGET_ARCH \
- || mipseb_TARGET_ARCH \
- || powerpc_TARGET_ARCH \
- || rs6000_TARGET_ARCH
-
-/* yes, it is IEEE floating point */
-#include "ieee-flpt.h"
-
-#if alpha_TARGET_ARCH \
- || i386_TARGET_ARCH \
- || mipsel_TARGET_ARCH
-
-#undef BIGENDIAN /* little-endian weirdos... */
-#else
-#define BIGENDIAN 1
-#endif
-
-#else /* unknown floating-point format */
-
-******* ERROR *********** Any ideas about floating-point format?
-
-#endif /* unknown floating-point */
-\end{code}
-
-\begin{code}
-#if alpha_TARGET_ARCH
-#define encodeFloatZh(r, hp, aa,sa,da, expon) encodeDoubleZh(r, hp, aa,sa,da, expon)
-#else
-#define encodeFloatZh(r, hp, aa,sa,da, expon) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg.alloc = aa; \
- arg.size = sa; \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon)); \
-}
-#endif /* ! alpha */
-
-#define encodeDoubleZh(r, hp, aa,sa,da, expon) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg.alloc = aa; \
- arg.size = sa; \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
-}
-
-#if alpha_TARGET_ARCH
-#define decodeFloatZh(exponr, ar,sr,dr, hp, f) decodeDoubleZh(exponr, ar,sr,dr, hp, f)
-#else
-#define decodeFloatZh(exponr, ar,sr,dr, hp, f) \
-{ MP_INT mantissa; \
- I_ exponent; \
- StgFloat arg = (f); \
- \
- /* Be prepared to tell Lennart-coded __decodeFloat */ \
- /* where mantissa.d can be put (it does not care about the rest) */ \
- SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- mantissa.d = (hp) + DATA_HS; \
- \
- /* Perform the operation */ \
- SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg); \
- exponr= exponent; \
- ar = mantissa.alloc; \
- sr = mantissa.size; \
- dr = (B_)(hp); \
-}
-#endif /* !alpha */
-
-#define decodeDoubleZh(exponr, ar,sr,dr, hp, f) \
-{ MP_INT mantissa; \
- I_ exponent; \
- StgDouble arg = (f); \
- \
- /* Be prepared to tell Lennart-coded __decodeDouble */ \
- /* where mantissa.d can be put (it does not care about the rest) */ \
- SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- mantissa.d = (hp) + DATA_HS; \
- \
- /* Perform the operation */ \
- SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg); \
- exponr= exponent; \
- ar = mantissa.alloc; \
- sr = mantissa.size; \
- dr = (B_)(hp); \
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
-%* *
-%************************************************************************
-
-With GCC, we use magic non-standard inlining; for other compilers, we
-just use functions (see also \tr{runtime/prims/PrimArith.lc}).
-
-(The @OMIT_...@ is only used in compiling some of the RTS, none of
-which uses these anyway.)
-
-\begin{code}
-#if alpha_TARGET_ARCH \
- || i386_TARGET_ARCH \
- || m68k_TARGET_ARCH
-
-#define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
-#define PK_FLT(src) (*(StgFloat *)(src))
-
-#define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
-#define PK_DBL(src) (*(StgDouble *)(src))
-
-#else /* not m68k || alpha || i[34]86 */
-
-/* Special handling for machines with troublesome alignment constraints */
-
-#define FLOAT_ALIGNMENT_TROUBLES TRUE
-
-#if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
-
-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 */
-
-#if sparc_TARGET_ARCH
-
-#define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
-#define PK_FLT(src) (*(StgFloat *)(src))
-
-#define ASSIGN_DBL(dst,src) \
- __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
- "=m" (((P_)(dst))[1]) : "f" (src));
-
-#define PK_DBL(src) \
- ( { register double d; \
- __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
- "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
- } )
-
-#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)
-{
- double_thing y;
- y.d = src;
- p_dest[0] = y.du.dhi;
- p_dest[1] = y.du.dlo;
-}
-
-/* GCC also works with this version, but it generates
- the same code as the previous one, and is not ANSI
-
-#define ASSIGN_DBL( p_dest, src ) \
- *p_dest = ((double_thing) src).du.dhi; \
- *(p_dest+1) = ((double_thing) src).du.dlo \
-*/
-
-extern STG_INLINE
-StgDouble
-PK_DBL(W_ p_src[])
-{
- double_thing y;
- y.du.dhi = p_src[0];
- y.du.dlo = p_src[1];
- return(y.d);
-}
-
-extern STG_INLINE
-void
-ASSIGN_FLT(W_ p_dest[], StgFloat src)
-{
- float_thing y;
- y.f = src;
- *p_dest = y.fu;
-}
-
-extern STG_INLINE
-StgFloat
-PK_FLT(W_ p_src[])
-{
- float_thing y;
- y.fu = *p_src;
- return(y.f);
-}
-
-#endif /* ! sparc */
-
-#endif /* __GNUC__ */
-
-#endif /* not __m68k__ */
-
-#if HAVE_LONG_LONG
-extern STG_INLINE
-void
-ASSIGN_Word64(W_ p_dest[], StgWord64 src)
-{
- word64_thing y;
- y.w = src;
- p_dest[0] = y.wu.dhi;
- p_dest[1] = y.wu.dlo;
-}
-
-extern STG_INLINE
-StgWord64
-PK_Word64(W_ p_src[])
-{
- word64_thing y;
- y.wu.dhi = p_src[0];
- y.wu.dlo = p_src[1];
- return(y.w);
-}
-
-extern STG_INLINE
-void
-ASSIGN_Int64(W_ p_dest[], StgInt64 src)
-{
- int64_thing y;
- y.i = src;
- p_dest[0] = y.iu.dhi;
- p_dest[1] = y.iu.dlo;
-}
-
-extern STG_INLINE
-StgInt64
-PK_Int64(W_ p_src[])
-{
- int64_thing y;
- y.iu.dhi = p_src[0];
- y.iu.dlo = p_src[1];
- return(y.i);
-}
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-array-primops]{Primitive arrays}
-%* *
-%************************************************************************
-
-We regularly use this macro to fish the ``contents'' part
-out of a DATA or TUPLE closure, which is what is used for
-non-ptr and ptr arrays (respectively).
-
-BYTE_ARR_CTS returns a @C_ *@!
-
-We {\em ASSUME} we can use the same macro for both!!
-\begin{code}
-
-#ifdef DEBUG
-#define BYTE_ARR_CTS(a) \
- ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info); \
- ((C_ *) (((StgPtr) (a))+DATA_HS)); })
-#define PTRS_ARR_CTS(a) \
- ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info) \
- || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
- ((a)+MUTUPLE_HS);} )
-#else
-#define BYTE_ARR_CTS(a) ((char *) (((StgPtr) (a))+DATA_HS))
-#define PTRS_ARR_CTS(a) ((a)+MUTUPLE_HS)
-#endif
-
-/* sigh */
-extern I_ genSymZh(STG_NO_ARGS);
-extern I_ resetGenSymZh(STG_NO_ARGS);
-extern I_ incSeqWorldZh(STG_NO_ARGS);
-
-extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
-\end{code}
-
-OK, the easy ops first: (all except \tr{newArr*}:
-
-(OLD:) VERY IMPORTANT! The read/write/index primitive ops
-on @ByteArray#@s index the array using a {\em BYTE} offset, even
-if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
-This is because you might be trying to take apart a C struct, where
-the offset from the start of the struct isn't a multiple of the
-size of the thing you're getting. Hence the @(char *)@ casts.
-
-EVEN MORE IMPORTANT! The above is a lie. The offsets for BlahArrays
-are in Blahs. WDP 95/08
-
-In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
-we cast to @P_@, because you can't index off an uncast \tr{void *}.
-
-In the case of @Array#@ (which contain pointers), the offset is in units
-of one ptr (not bytes).
-
-\begin{code}
-#define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
-#define sameMutableByteArrayZh(r,a,b) r=(I_)((B_)(a)==(B_)(b))
-
-#define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
-
-#define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
-
-/* result ("r") arg ignored in write macros! */
-#define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
-
-#define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeStablePtrArrayZh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeWordArrayZh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeInt64ArrayZh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeWord64ArrayZh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeFloatArrayZh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
-#define writeDoubleArrayZh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
-
-#define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
-
-#define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
-
-#define indexCharOffForeignObjZh(r,fo,i) indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexIntOffForeignObjZh(r,fo,i) indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexStablePtrOffForeignObjZh(r,fo,i) indexStablePtrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWordOffForeignObjZh(r,fo,i) indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexAddrOffForeignObjZh(r,fo,i) indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexFloatOffForeignObjZh(r,fo,i) indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexInt64OffForeignObjZh(r,fo,i) indexInt64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWord64OffForeignObjZh(r,fo,i) indexWord64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
-
-#define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
-#define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
-#define indexStablePtrOffAddrZh(r,a,i) r= ((StgStablePtr *)(a))[i]
-#define indexWordOffAddrZh(r,a,i) r= ((W_ *)(a))[i]
-#define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
-#define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
-#define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
-#define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i]
-#define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
-
-#define writeCharOffAddrZh(a,i,v) ((C_ *)(a))[i] = (v)
-#define writeIntOffAddrZh(a,i,v) ((I_ *)(a))[i] = (v)
-#define writeStablePtrOffAddrZh(a,i,v) ((StgStablePtr *)(a))[i] = (v)
-#define writeWordOffAddrZh(a,i,v) ((W_ *)(a))[i] = (v)
-#define writeAddrOffAddrZh(a,i,v) ((PP_)(a))[i] = (v)
-#define writeForeignObjOffAddrZh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
-#define writeFloatOffAddrZh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
-#define writeDoubleOffAddrZh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
-#define writeInt64OffAddrZh(a,i,v) ((LI_ *)(a))[i] = (v)
-#define writeWord64OffAddrZh(a,i,v) ((LW_ *)(a))[i] = (v)
-
-
-/* Freezing arrays-of-ptrs requires changing an info table, for the
- benefit of the generational collector. It needs to scavenge mutable
- objects, even if they are in old space. When they become immutable,
- they can be removed from this scavenge list. */
-#define unsafeFreezeArrayZh(r,a) \
- do { \
- P_ result; \
- result=(P_) (a); \
- FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info); \
- r = result; \
- }while(0)
-
-#define unsafeFreezeByteArrayZh(r,a) r=(B_)(a)
-
-#define sizeofByteArrayZh(r,a) r=(W_)sizeof(W_)*(W_)(DATA_CLOSURE_SIZE(a)-DATA_VHS)
-#define sizeofMutableByteArrayZh(r,a) r=(W_)sizeof(W_)*(W_)(DATA_CLOSURE_SIZE(a)-DATA_VHS)
-\end{code}
-
-Now the \tr{newArr*} ops:
-
-\begin{code}
-/*
---------------------
-Will: ToDo: we need to find suitable places to put this comment, and the
-"in-general" one which follows.
-
-************ Nota Bene. The "n" in this macro is guaranteed to
-be a register, *not* (say) Node[1]. That means that it is guaranteed
-to survive GC, provided only that the register is kept unaltered.
-This is important, because "n" is used after the HEAP_CHK.
-
-In general, *all* parameters to these primitive-op macros are always
-registers. (Will: For exactly *which* primitive-op macros is this guaranteed?
-Exactly those which can trigger GC?)
-------------------------
-
-NOTE: the above may now be OLD (WDP 94/02/10)
-*/
-\end{code}
-
-For char arrays, the size is in {\em BYTES}.
-
-\begin{code}
-#define newCharArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(C_))
-#define newIntArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(I_))
-#define newStablePtrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgStablePtr))
-#define newWordArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(W_))
-#define newInt64ArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(LI_))
-#define newWord64ArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(LW_))
-#define newAddrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(P_))
-#define newFloatArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgFloat))
-#define newDoubleArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgDouble))
-
-#define newByteArray(r,liveness,n) \
-{ \
- P_ result; \
- I_ size; \
- \
- HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0); \
- size = BYTES_TO_STGWORDS(n); \
- ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */; \
- CC_ALLOC(CCC,DATA_HS+size,ARR_K); \
- \
- result = Hp-(DATA_HS+size)+1; \
- SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0); \
- r = (B_) result; \
-}
-\end{code}
-
-Arrays of pointers need to be initialised; uses \tr{TUPLES}!
-The initialisation value is guaranteed to be in a register,
-and will be indicated by the liveness mask, so it's ok to do
-a \tr{HEAP_CHK}, which may trigger GC.
-
-\begin{code}
-/* The new array initialization routine for the NCG */
-void newArrZh_init PROTO((P_ result, I_ n, P_ init));
-
-#define newArrayZh(r,liveness,n,init) \
-{ \
- P_ p; \
- P_ result; \
- \
- HEAP_CHK(liveness, MUTUPLE_HS+(n),0); \
- ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
- CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */ \
- \
- result = Hp + 1 - (MUTUPLE_HS+(n)); \
- SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
- for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
- *p = (W_) (init); \
- } \
- \
- r = result; \
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
-%* *
-%************************************************************************
-
-\begin{code}
-ED_(PrelBase_Z91Z93_closure);
-
-#define sameMVarZh(r,a,b) r=(I_)((a)==(b))
-
-#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) = PrelBase_Z91Z93_closure; \
- r = hp; \
-}
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-void Yield PROTO((W_));
-
-#define takeMVarZh(r, liveness, node) \
-{ \
- while (INFO_PTR(node) != (W_) FullSVar_info) { \
- if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
- SVAR_HEAD(node) = CurrentTSO; \
- else \
- TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
- SVAR_TAIL(node) = CurrentTSO; \
- DO_YIELD(liveness << 1); \
- } \
- SET_INFO_PTR(node, EmptySVar_info); \
- r = SVAR_VALUE(node); \
- SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
-}
-
-#else
-
-#define takeMVarZh(r, liveness, node) \
-{ \
- if (INFO_PTR(node) != (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "takeMVar#: MVar is empty.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, EmptySVar_info); \
- r = SVAR_VALUE(node); \
- SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
-}
-
-#endif
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-#ifdef GRAN
-
-/* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
-/* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
-/* the CurrentProc. This means we have an implicit context switch after */
-/* putMVar even if unfair scheduling is used in GranSim (default)! -- HWL */
-
-#define putMVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "putMVar#: MVar already full.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, FullSVar_info); \
- SVAR_VALUE(node) = value; \
- tso = SVAR_HEAD(node); \
- if (tso != (P_) PrelBase_Z91Z93_closure) { \
- if (DO_QP_PROF) \
- STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
- ThreadQueueHd = tso; \
- else \
- TSO_LINK(ThreadQueueTl) = tso; \
- ThreadQueueTl = tso; \
- SVAR_HEAD(node) = TSO_LINK(tso); \
- TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
- if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
- SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
- } \
-}
-
-#else /* !GRAN */
-
-#define putMVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "putMVar#: MVar already full.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, FullSVar_info); \
- SVAR_VALUE(node) = value; \
- tso = SVAR_HEAD(node); \
- if (tso != (P_) PrelBase_Z91Z93_closure) { \
- if (DO_QP_PROF) \
- STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
- RunnableThreadsHd = tso; \
- else \
- TSO_LINK(RunnableThreadsTl) = tso; \
- RunnableThreadsTl = tso; \
- SVAR_HEAD(node) = TSO_LINK(tso); \
- TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
- if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
- SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
- } \
-}
-
-#endif /* GRAN */
-
-#else
-
-#define putMVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "putMVar#: MVar already full.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, FullSVar_info); \
- SVAR_VALUE(node) = value; \
-}
-
-#endif
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-#define readIVarZh(r, liveness, node) \
-{ \
- if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
- if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
- SVAR_HEAD(node) = CurrentTSO; \
- else \
- TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
- SVAR_TAIL(node) = CurrentTSO; \
- DO_YIELD(liveness << 1); \
- } \
- r = SVAR_VALUE(node); \
-}
-
-#else
-
-#define readIVarZh(r, liveness, node) \
-{ \
- if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "readIVar#: IVar is empty.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- r = SVAR_VALUE(node); \
-}
-
-#endif
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-#ifdef GRAN
-
-/* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
-/* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
-/* the CurrentProc. This means we have an implicit context switch after */
-/* writeIVar even if unfair scheduling is used in GranSim (default)! -- HWL */
-
-#define writeIVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "writeIVar#: IVar already full.\n");\
- EXIT(EXIT_FAILURE); \
- } \
- tso = SVAR_HEAD(node); \
- if (tso != (P_) PrelBase_Z91Z93_closure) { \
- if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
- ThreadQueueHd = tso; \
- else \
- TSO_LINK(ThreadQueueTl) = tso; \
- while(TSO_LINK(tso) != PrelBase_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); \
- } \
- if (DO_QP_PROF) \
- STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- ThreadQueueTl = tso; \
- } \
- /* Don't use freeze, since it's conditional on GC */ \
- SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
- MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
- SVAR_VALUE(node) = value; \
-}
-
-#else /* !GRAN */
-
-#define writeIVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "writeIVar#: IVar already full.\n");\
- EXIT(EXIT_FAILURE); \
- } \
- tso = SVAR_HEAD(node); \
- if (tso != (P_) PrelBase_Z91Z93_closure) { \
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
- RunnableThreadsHd = tso; \
- else \
- TSO_LINK(RunnableThreadsTl) = tso; \
- while(TSO_LINK(tso) != PrelBase_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); \
- } \
- if (DO_QP_PROF) \
- STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- RunnableThreadsTl = tso; \
- } \
- /* Don't use freeze, since it's conditional on GC */ \
- SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
- MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
- SVAR_VALUE(node) = value; \
-}
-
-#endif /* GRAN */
-
-#else
-
-#define writeIVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "writeIVar#: IVar already full.\n");\
- EXIT(EXIT_FAILURE); \
- } \
- /* Don't use freeze, since it's conditional on GC */ \
- SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
- MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
- SVAR_VALUE(node) = value; \
-}
-
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef CONCURRENT
-
-/* ToDo: for GRAN */
-
-#define delayZh(liveness, us) \
- { \
- if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
- WaitingThreadsHd = CurrentTSO; \
- else \
- TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
- WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
- TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
- DO_YIELD(liveness << 1); \
- }
-
-#else
-
-#define delayZh(liveness, us) \
- { \
- fflush(stdout); \
- fprintf(stderr, "delay#: unthreaded build.\n"); \
- EXIT(EXIT_FAILURE); \
- }
-
-#endif
-
-#ifdef CONCURRENT
-
-/* ToDo: something for GRAN */
-
-#define waitReadZh(liveness, fd) \
- { \
- if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
- WaitingThreadsHd = CurrentTSO; \
- else \
- TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
- WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
- TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \
- DO_YIELD(liveness << 1); \
- }
-
-#else
-
-#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 == PrelBase_Z91Z93_closure) \
- WaitingThreadsHd = CurrentTSO; \
- else \
- TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
- WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
- TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE)); \
- DO_YIELD(liveness << 1); \
- }
-
-#else
-
-#define waitWriteZh(liveness, fd) \
- { \
- fflush(stdout); \
- fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
- EXIT(EXIT_FAILURE); \
- }
-
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
-%* *
-%************************************************************************
-
-\begin{code}
-extern P_ TopClosure;
-EXTFUN(ErrorIO_innards);
-EXTFUN(__std_entry_error__);
-
-#define errorIOZh(a) \
- do { TopClosure=(a); \
- (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
- (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
- JMP_(ErrorIO_innards); \
- } while(0)
-
-/* These are now, I believe, unused. (8/98 SOF) */
-#if !defined(CALLER_SAVES_SYSTEM)
-/* can use the macros */
-#define stg_getc(stream) getc((FILE *) (stream))
-#define stg_putc(c,stream) putc((c),((FILE *) (stream)))
-#else
-/* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
-#define stg_getc(stream) SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
-#define stg_putc(c,stream) SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
-#endif
-
-int initialize_virtual_timer(int us);
-int install_segv_handler(STG_NO_ARGS);
-int install_vtalrm_handler(STG_NO_ARGS);
-void initUserSignals(STG_NO_ARGS);
-void blockUserSignals(STG_NO_ARGS);
-void unblockUserSignals(STG_NO_ARGS);
-IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
-IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
-IF_RTS(void AwaitEvent(I_ delta);)
-
-#if defined(_POSIX_SOURCE) && !defined(nextstep3_TARGET_OS)
- /* For nextstep3_TARGET_OS comment see stgdefs.h. CaS */
-extern I_ sig_install PROTO((I_, I_, sigset_t *));
-#define stg_sig_ignore(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
-#define stg_sig_default(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
-#define stg_sig_catch(s,sp,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
-#else
-extern I_ sig_install PROTO((I_, I_));
-#define stg_sig_ignore(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
-#define stg_sig_default(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
-#define stg_sig_catch(s,sp,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
-#endif
-
-#define STG_SIG_DFL (-1)
-#define STG_SIG_IGN (-2)
-#define STG_SIG_ERR (-3)
-
-StgInt getErrorHandler(STG_NO_ARGS);
-#ifndef PAR
-void raiseError PROTO((StgStablePtr handler));
-StgInt catchError PROTO((StgStablePtr newErrorHandler));
-#endif
-void decrementErrorCount(STG_NO_ARGS);
-
-#define stg_catchError(sp) SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
-#define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
-%* *
-%************************************************************************
-
-
-The type of these should be:
-
-\begin{verbatim}
-makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
-deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
-\end{verbatim}
-
-Since world-tokens are no longer explicitly passed around, the
-implementations have a few less arguments/results.
-
-The simpler one is @deRefStablePointer#@ (which is only a primop
-because it is more polymorphic than is allowed of a ccall).
-
-\begin{code}
-#ifdef PAR
-
-#define deRefStablePtrZh(ri,sp) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-
-#else /* !PAR */
-
-extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
-
-#define deRefStablePtrZh(ri,sp) \
- ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
-\end{code}
-
-Declarations for other stable pointer operations.
-
-\begin{code}
-void freeStablePointer PROTO((I_ stablePtr));
-
-void enterStablePtr PROTO((StgStablePtr, StgFunPtr));
-void performIO PROTO((StgStablePtr));
-I_ enterInt PROTO((StgStablePtr));
-I_ enterFloat PROTO((StgStablePtr));
-P_ deRefStablePointer PROTO((StgStablePtr));
-IF_RTS(I_ catchSoftHeapOverflow PROTO((StgStablePtr, I_));)
-IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
-IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
-IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
-
-EXTFUN(stopPerformIODirectReturn);
-EXTFUN(startPerformIO);
-EXTFUN(stopEnterIntDirectReturn);
-EXTFUN(startEnterInt);
-EXTFUN(stopEnterFloatDirectReturn);
-EXTFUN(startEnterFloat);
-
-void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
-
-char* createAdjustor PROTO((int cc,StgStablePtr hptr, StgFunPtr wptr));
-void freeAdjustor PROTO((void* ptr));
-
-#endif /* !PAR */
-
-IF_RTS(extern I_ ErrorIO_call_count;)
-\end{code}
-
-Somewhat harder is @makeStablePointer#@ --- it is usually simple but
-if we're unlucky, it will have to allocate a new table and copy the
-old bit over. Since we might, very occasionally, have to call the
-garbage collector, this has to be a macro... sigh!
-
-NB @newSP@ is required because it is entirely possible that
-@stablePtr@ and @unstablePtr@ are aliases and so we can't do the
-assignment to @stablePtr@ until we've finished with @unstablePtr@.
-
-Another obscure piece of coding is the recalculation of the size of
-the table. We do this just in case Jim's threads decide they want to
-context switch---in which case any stack-allocated variables may get
-trashed. (If only there was a special heap check which didn't
-consider context switching...)
-
-\begin{code}
-#ifndef PAR
-
-/* Calculate SP Table size from number of pointers */
-#define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
-
-/* Calculate number of pointers in new table from number in old table:
- any strictly increasing expression will do here */
-#define CalcNewNoSPtrs( i ) ((i)*2 + 100)
-
-void enlargeSPTable PROTO((P_, P_));
-
-#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- EXTDATA_RO(StablePointerTable_info); \
- EXTDATA(UnusedSP); \
- StgStablePtr newSP; \
- \
- if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
- { /* Variables used before the heap check */ \
- I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
- I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
- I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
- HEAP_CHK(liveness, _FHS+NewSize, 0); \
- } \
- { /* Variables used after the heap check - same values */ \
- I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
- I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
- I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
- P_ SPTable = Hp + 1 - (_FHS + NewSize); \
- \
- CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
- SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
- SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
- StorageMgrInfo.StablePointerTable = SPTable; \
- } \
- } \
- \
- newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
- SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
- CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \
- stablePtr = newSP; \
-} while (0)
-
-#else
-
-#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-
-#endif /* !PAR */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
-%* *
-%************************************************************************
-
-The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
-can expect three parameters: the two arguments and a "register" to put
-the result into.
-
-Message to Will: This primop breaks referential transparency so badly
-you might want to leave it out. On the other hand, if you hide it
-away in an appropriate monad, it's perfectly safe. [ADR]
-
-Note that this primop is non-deterministic: different results can be
-obtained depending on just what the garbage collector (and code
-optimiser??) has done. However, we can guarantee that if two objects
-are pointer-equal, they have the same denotation --- the converse most
-certainly doesn't hold.
-
-ToDo ADR: The degree of non-determinism could be greatly reduced by
-following indirections.
-
-\begin{code}
-#define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
-%* *
-%************************************************************************
-
-Assuming local sparking in some form, we can now inline the spark request.
-
-We build a doubly-linked list in the heap, so that we can handle FIFO
-or LIFO scheduling as we please.
-
-Anything with tag >= 0 is in WHNF, so we discard it.
-
-\begin{code}
-#ifdef CONCURRENT
-
-ED_(PrelBase_Z91Z93_closure);
-ED_(True_closure);
-
-#if defined(GRAN)
-#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 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 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 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)) { \
- 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 = 1; /* return code for successful spark -- HWL */ \
-}
-
-#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)
-
-#if 1
-
-#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,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 */ \
- } else if (do_qp_prof) { \
- I_ tid = threadId++; \
- SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
- } \
- 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;
-
-#ifdef PAR
-#define COUNT_SPARK TSO_GLOBALSPARKS(CurrentTSO)++; sparksCreated++
-#else
-#define COUNT_SPARK
-#endif
-
-/*
- Note that we must bump the required thread count NOW, rather
- than when the thread is actually created.
- */
-
-#define forkZh(r,liveness,node) \
-{ \
- while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
- DO_YIELD((liveness << 1) | 1); \
- COUNT_SPARK; \
- if (SHOULD_SPARK(node)) { \
- *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node); \
- } else if (DO_QP_PROF) { \
- I_ tid = threadId++; \
- SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
- } \
- required_thread_count++; \
- context_switch = 1; \
- r = 1; /* Should not be necessary */ \
-}
-
-#define parZh(r,node) \
-{ \
- COUNT_SPARK; \
- if (SHOULD_SPARK(node) && \
- PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
- *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node); \
- } else { \
- sparksIgnored++; \
- if (DO_QP_PROF) { \
- I_ tid = threadId++; \
- SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
- } \
- } \
- r = 1; /* Should not be necessary */ \
-}
-
-#endif /* GRAN */
-
-#endif /* CONCURRENT */
-\end{code}
-
-The following seq# code should only be used in unoptimized code.
-Be warned: it's a potential bug-farm.
-[SOF 8/98:
- Yes, it completely fails to work for function values, since a PAP
- closure will be constructed when the arg satisfaction check fails.
- This PAP closure will add the magic values that gets pushed on the B stack
- before entering the 'seqee' (new word!), as Jim is just about to tell
- us about. Let's hear what he's got to say:
-]
-
-First we push two words on the B stack: the current value of RetReg
-(which may or may not be live), and a continuation snatched largely out
-of thin air (it's a point within this code block). Then we set RetReg
-to the special polymorphic return code for seq, load up Node with the
-closure to be evaluated, and we're off. When the eval returns to the
-polymorphic seq return point, the two words are popped off the B stack,
-RetReg is restored, and we jump to the continuation, completing the
-primop and going on our merry way.
-
-[ To workaround the shortcoming of not being able to deal with partially
- applied values, we explicitly prohibit this at the Haskell source level
- (i.e., we don't define an Eval instance for (->) ).
-]
-
-\begin{code}
-
-ED_RO_(vtbl_seq);
-
-#define seqZh(r,liveness,node) \
- ({ \
- __label__ cont; \
- /* 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; \
- Node = node; \
- ENT_VIA_NODE(); \
- InfoPtr = (D_)(INFO_PTR(Node)); \
- JMP_(ENTRY_CODE(InfoPtr)); \
- cont: \
- r = 1; /* Should be unnecessary */ \
- })
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-foreign-objects]{Foreign Objects}
-%* *
-%************************************************************************
-
-[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) 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
-characterize program behavior by ``activity'' -- tail-calling,
-heap-checking, etc. -- see Ticky.lh. It is quite specialized.
-WDP 95/1)
-
-(Swapped first two arguments to make it come into line with what appears
-to be `standard' format, return register then liveness mask. -- SOF 4/96)
-
-\begin{code}
-#ifndef PAR
-
-StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
-StgInt eqStablePtr PROTO((StgStablePtr p1, StgStablePtr p2));
-
-#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 + 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; \
- \
- \
- /*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
- result, \
- result[0],result[1], \
- result[2],result[3]);*/ \
- \
- CHECK_ForeignObj_CLOSURE( result ); \
- VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
- \
- (r) = (P_) result; \
-} while (0)
-
-#define writeForeignObjZh(res,datum) ((PP_) ForeignObj_CLOSURE_DATA(res)) = ((P_)datum)
-
-#else
-#define makeForeignObjZh(r, liveness, mptr, finalise) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-
-#define writeForeignObjZh(res,datum) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "writeForeignObj#: no foreign object support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-
-#endif /* !PAR */
-\end{code}
-
-
-End-of-file's multi-slurp protection:
-\begin{code}
-#endif /* ! STGMACROS_H */
-\end{code}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgMiscClosures.h,v 1.2 1998/12/02 13:21:39 simonm Exp $
+ *
+ * Entry code for various built-in closure types.
+ *
+ * ---------------------------------------------------------------------------*/
+
+/* The naming scheme here follows the naming scheme for closure types
+ * defined in InfoTables.h. The actual info tables and entry code for
+ * these objects can be found in StgMiscClosures.hc.
+ */
+
+/* entry code */
+
+STGFUN(IND_entry);
+STGFUN(IND_STATIC_entry);
+STGFUN(IND_PERM_entry);
+STGFUN(IND_OLDGEN_entry);
+STGFUN(IND_OLDGEN_PERM_entry);
+STGFUN(CAF_UNENTERED_entry);
+STGFUN(CAF_ENTERED_entry);
+STGFUN(CAF_BLACKHOLE_entry);
+STGFUN(BLACKHOLE_entry);
+STGFUN(BCO_entry);
+STGFUN(EVACUATED_entry);
+STGFUN(FOREIGN_entry);
+STGFUN(WEAK_entry);
+STGFUN(DEAD_WEAK_entry);
+STGFUN(TSO_entry);
+STGFUN(FULL_MVAR_entry);
+STGFUN(EMPTY_MVAR_entry);
+STGFUN(ARR_WORDS_entry);
+STGFUN(MUT_ARR_WORDS_entry);
+STGFUN(ARR_PTRS_entry);
+STGFUN(MUT_ARR_PTRS_entry);
+STGFUN(MUT_ARR_PTRS_FROZEN_entry);
+STGFUN(MUT_VAR_entry);
+STGFUN(END_TSO_QUEUE_entry);
+STGFUN(dummy_ret_entry);
+
+/* info tables */
+
+extern const StgInfoTable IND_info;
+extern const StgInfoTable IND_STATIC_info;
+extern const StgInfoTable IND_PERM_info;
+extern const StgInfoTable IND_OLDGEN_info;
+extern const StgInfoTable IND_OLDGEN_PERM_info;
+extern const StgInfoTable CAF_UNENTERED_info;
+extern const StgInfoTable CAF_ENTERED_info;
+extern const StgInfoTable CAF_BLACKHOLE_info;
+extern const StgInfoTable BLACKHOLE_info;
+extern const StgInfoTable BCO_info;
+extern const StgInfoTable EVACUATED_info;
+extern const StgInfoTable FOREIGN_info;
+extern const StgInfoTable WEAK_info;
+extern const StgInfoTable DEAD_WEAK_info;
+extern const StgInfoTable FULL_MVAR_info;
+extern const StgInfoTable EMPTY_MVAR_info;
+extern const StgInfoTable TSO_info;
+extern const StgInfoTable ARR_WORDS_info;
+extern const StgInfoTable MUT_ARR_WORDS_info;
+extern const StgInfoTable ARR_PTRS_info;
+extern const StgInfoTable MUT_ARR_PTRS_info;
+extern const StgInfoTable MUT_ARR_PTRS_FROZEN_info;
+extern const StgInfoTable MUT_VAR_info;
+extern const StgInfoTable END_TSO_QUEUE_info;
+extern const StgInfoTable catch_info;
+extern const StgInfoTable seq_info;
+extern const StgInfoTable dummy_ret_info;
+
+#ifdef INTERPRETER
+
+EXTFUN(Hugs_CONSTR_entry);
+extern const StgInfoTable ret_bco_info;
+
+#endif /* INTERPRETER */
+
+/* closures */
+
+extern const StgClosure END_TSO_QUEUE_closure;
+extern const StgClosure dummy_ret_closure;
+
+extern StgIntCharlikeClosure CHARLIKE_closure[];
+extern StgIntCharlikeClosure INTLIKE_closure[];
+
+/* standard entry points */
+
+extern StgFun stg_error_entry;
+
+/* standard selector thunks */
+
+EI_ __sel_0_upd_info;
+EI_ __sel_1_upd_info;
+EI_ __sel_2_upd_info;
+EI_ __sel_3_upd_info;
+EI_ __sel_4_upd_info;
+EI_ __sel_5_upd_info;
+EI_ __sel_6_upd_info;
+EI_ __sel_7_upd_info;
+EI_ __sel_8_upd_info;
+EI_ __sel_8_upd_info;
+EI_ __sel_9_upd_info;
+EI_ __sel_10_upd_info;
+EI_ __sel_11_upd_info;
+EI_ __sel_12_upd_info;
+EI_ __sel_13_upd_info;
+EI_ __sel_14_upd_info;
+EI_ __sel_15_upd_info;
+
+EI_ __sel_0_noupd_info;
+EI_ __sel_1_noupd_info;
+EI_ __sel_2_noupd_info;
+EI_ __sel_3_noupd_info;
+EI_ __sel_4_noupd_info;
+EI_ __sel_5_noupd_info;
+EI_ __sel_6_noupd_info;
+EI_ __sel_7_noupd_info;
+EI_ __sel_8_noupd_info;
+EI_ __sel_9_noupd_info;
+EI_ __sel_10_noupd_info;
+EI_ __sel_11_noupd_info;
+EI_ __sel_12_noupd_info;
+EI_ __sel_13_noupd_info;
+EI_ __sel_14_noupd_info;
+EI_ __sel_15_noupd_info;
+
+/* standard ap thunks */
+
+EI_ __ap_1_upd_info;
+EI_ __ap_2_upd_info;
+EI_ __ap_3_upd_info;
+EI_ __ap_4_upd_info;
+EI_ __ap_5_upd_info;
+EI_ __ap_6_upd_info;
+EI_ __ap_7_upd_info;
+EI_ __ap_8_upd_info;
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgProf.h,v 1.2 1998/12/02 13:21:39 simonm Exp $
+ *
+ * (c) The GHC Team, 1998
+ *
+ * Macros for profiling operations in STG code
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STGPROF_H
+#define STGPROF_H
+
+#if defined(PROFILING)
+
+/* -----------------------------------------------------------------------------
+ * Registering CCs
+
+ Cost centres are registered at startup by calling a registering
+ routine in each module. Each module registers its cost centres and
+ calls the registering routine for all imported modules. The RTS calls
+ the registering routine for the module Main. This registering must be
+ done before initialisation since the evaluation required for
+ initialisation may use the cost centres.
+
+ As the code for each module uses tail calls we use an auxiliary stack
+ (in the heap) to record imported modules still to be registered. At
+ the bottom of the stack is NULL which indicates that
+ @miniInterpretEnd@ should be resumed.
+
+ @START_REGISTER@ and @END_REGISTER@ are special macros used to
+ delimit the function. @END_REGISTER@ pops the next registering
+ routine off the stack and jumps to it. @REGISTER_CC@ registers a cost
+ centre. @REGISTER_IMPORT@ pushes a modules registering routine onto
+ the register stack.
+
+ -------------------------------------------------------------------------- */
+
+extern F_ *register_stack;
+
+extern CostCentre *CC_LIST; /* registered CC list */
+extern CostCentreStack *CCS_LIST; /* registered CCS list */
+
+# define PUSH_REGISTER_STACK(reg_function) \
+ *(register_stack++) = (F_)reg_function
+
+# define POP_REGISTER_STACK() \
+ *(--register_stack)
+
+# define START_REGISTER_CCS(reg_mod_name) \
+ static int _module_registered = 0; \
+ FN_(reg_mod_name) { \
+ FB_; \
+ if (! _module_registered) { \
+ _module_registered = 1
+
+# define REGISTER_IMPORT(reg_mod_name) \
+ do { EF_(reg_mod_name); \
+ PUSH_REGISTER_STACK(reg_mod_name) ; \
+ } while (0)
+
+# define END_REGISTER_CCS() \
+ }; \
+ JMP_(POP_REGISTER_STACK()); \
+ FE_ }
+
+#define REGISTER_CC(cc) \
+ do { \
+ extern CostCentre cc[]; \
+ if ((cc)->link == (CostCentre *)0) { \
+ (cc)->link = CC_LIST; \
+ CC_LIST = (cc); \
+ (cc)->ccID = CC_ID++; \
+ }} while(0)
+
+#define REGISTER_CCS(ccs) \
+ do { \
+ extern CostCentreStack ccs[]; \
+ if ((ccs)->prevStack == (CostCentreStack *)0) { \
+ (ccs)->prevStack = CCS_LIST; \
+ CCS_LIST = (ccs); \
+ (ccs)->ccsID = CCS_ID++; \
+ }} while(0)
+
+/* -----------------------------------------------------------------------------
+ * Declaring Cost Centres & Cost Centre Stacks.
+ * -------------------------------------------------------------------------- */
+
+# define CC_DECLARE(cc_ident,name,module,group,subsumed,is_local) \
+ is_local CostCentre cc_ident[1] \
+ = {{ 0, \
+ name, \
+ module, \
+ group, \
+ subsumed, \
+ 0 }};
+
+# define CCS_DECLARE(ccs_ident,cc_ident,subsumed,is_local) \
+ is_local CostCentreStack ccs_ident[1] \
+ = {{ ccsID : 0, \
+ cc : cc_ident, \
+ prevStack : NULL, \
+ indexTable : NULL, \
+ scc_count : 0, \
+ sub_scc_count : 0, \
+ sub_cafcc_count : 0, \
+ sub_dictcc_count : 0, \
+ time_ticks : 0, \
+ mem_alloc : 0, \
+ is_subsumed : subsumed, \
+ }};
+
+# define CC_EXTERN(cc_ident) \
+ extern CostCentre cc_ident[];
+
+/* -----------------------------------------------------------------------------
+ * Time / Allocation Macros
+ * ---------------------------------------------------------------------------*/
+
+#define CCS_TICK(ccs) (ccs)->time_ticks++
+
+/* eliminate profiling overhead from allocation costs */
+#define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))
+
+/* For grabbing the cost centre from a closure */
+#define CCS_HDR(closure) ((StgClosure *)(closure))->header.prof.ccs
+
+/* Restore the CCCS from a stack fram.
+ * (addr should always be Sp->header.prof.ccs)
+ */
+#define RESTORE_CCCS(addr) (CCCS = (CostCentreStack *)(addr))
+
+/* -----------------------------------------------------------------------------
+ * Pushing a new cost centre (i.e. for scc annotations)
+ * -------------------------------------------------------------------------- */
+
+# define SET_CCC_X(cc,do_subcc_count,do_subdict_count,do_scc_count) \
+ do { \
+ if (do_subcc_count) { CCCS->sub_scc_count++; } \
+ if (do_subdict_count) { CCCS->sub_dictcc_count++; } \
+ CCCS = PushCostCentre(CCCS,cc); \
+ if (do_scc_count) { CCCS->scc_count++; } \
+ } while(0)
+
+/* We sometimes don't increment the scc_count field, for example when
+ * this scc has been placed by the compiler on an expression it
+ * floated outside the main scc annotation.
+ */
+
+# define SET_CCC(cc_ident,do_scc_count) \
+ SET_CCC_X(cc_ident,do_scc_count,0,do_scc_count)
+
+# define SET_DICT_CCC(cc_ident,do_scc_count) \
+ SET_CCC_X(cc_ident,0,do_scc_count,do_scc_count)
+
+# define SET_CCS_TOP(cc_ident) \
+ SET_CCC_X(cc_ident,0,0,1)
+
+/* -----------------------------------------------------------------------------
+ * Allocating new cost centres / cost centre stacks.
+ * -------------------------------------------------------------------------- */
+
+#define ASSIGN_CC_ID(ccID) \
+ do { \
+ ccID = CC_ID; \
+ CC_ID++; \
+ } while(0)
+
+#define ASSIGN_CCS_ID(ccsID) \
+ do { \
+ ccsID = CCS_ID; \
+ CCS_ID++; \
+ } while(0)
+
+#define ASSIGN_HP_ID(hpID) \
+ do { \
+ hpID = HP_ID; \
+ HP_ID++; \
+ } while(0)
+
+#define SET_STATS_TO_ZERO(stack) \
+ do { \
+ (stack)->scc_count = 0; \
+ (stack)->time_ticks = 0; \
+ (stack)->sub_cafcc_count = 0; \
+ (stack)->sub_dictcc_count = 0; \
+ (stack)->mem_alloc = 0; \
+ } while(0)
+
+/* -----------------------------------------------------------------------------
+ * Setting the cost centre when we enter a closure
+ * -------------------------------------------------------------------------- */
+
+#if defined(PROFILING_DETAIL_COUNTS)
+#define CCCS_DETAIL_COUNT(inc_this) ((inc_this)++)
+#else
+#define CCCS_DETAIL_COUNT(inc_this) /*nothing*/
+#endif
+
+#define IS_CAF_OR_DICT_OR_SUB_CCS(ccs) \
+ /* tests for lower case character */ \
+ ((ccs)->is_subsumed & ' ')
+
+
+/* On entry to top level CAFs we count the scc ...*/
+
+#define ENTER_CCS_CAF_X(ccs) \
+ do { \
+ /* inc subcaf count of CCCS */ \
+ CCCS->sub_cafcc_count++; \
+ /* set CCCS to ident ccs */ \
+ CCCS = (CostCentreStack *)(ccs); \
+ /* inc scc count of CAF ccs */ \
+ CCCS->scc_count++; \
+ } while(0)
+
+#define ENTER_CCS_CAF(ccs_ident) ENTER_CCS_CAF_X(ccs_ident)
+#define ENTER_CCS_CAF_CL(closure) ENTER_CCS_CAF_X(CCS_HDR(closure))
+
+/* ----------------------------------------------------------------------------
+ * Entering a Thunk
+ *
+ * On entering a closure we only count the enter to thunks ...
+ * ------------------------------------------------------------------------- */
+
+#define ENTER_CCS_T(ccs) \
+ do { \
+ CCCS = (CostCentreStack *)(ccs); \
+ CCCS_DETAIL_COUNT(CCCS->thunk_count); \
+ } while(0)
+
+#define ENTER_CCS_TCL(closure) ENTER_CCS_T(CCS_HDR(closure))
+
+/* -----------------------------------------------------------------------------
+ * Entering a function
+ *
+ * Here is our special "hybrid" case when we do *not* set the CCCS.
+ * (a) The closure is a function, not a thunk;
+ * (b) The CCS is CAF/DICT-ish.
+ * -------------------------------------------------------------------------- */
+
+#define ENTER_CCS_F(stack) \
+ do { \
+ CostCentreStack *ccs = (CostCentreStack *) (stack); \
+ if ( ! IS_CAF_OR_DICT_OR_SUB_CCS(ccs) ) { \
+ CCCS = ccs; \
+ } else { \
+ CCCS_DETAIL_COUNT(ccs->caffun_subsumed); \
+ CCCS_DETAIL_COUNT(CCCS->subsumed_caf_count); \
+ } \
+ CCCS_DETAIL_COUNT(CCCS->function_count); \
+ } while(0)
+
+#define ENTER_CCS_FCL(closure) ENTER_CCS_F(CCS_HDR(closure))
+
+/* Entering a top-level function: costs are subsumed by the caller
+ */
+#define ENTER_CCS_FSUB() \
+ do { \
+ CCCS_DETAIL_COUNT(CCCS->subsumed_fun_count); \
+ CCCS_DETAIL_COUNT(CCCS->function_count); \
+ } while(0)
+
+#define ENTER_CCS_FCAF(stack) \
+ do { \
+ CostCentreStack *ccs = (CostCentreStack *) (stack); \
+ CCCS_DETAIL_COUNT(ccs->caffun_subsumed); \
+ CCCS_DETAIL_COUNT(CCCS->subsumed_caf_count); \
+ CCCS_DETAIL_COUNT(CCCS->function_count); \
+ } while(0)
+
+#define ENTER_CCS_FLOAD(ccs) \
+ do { \
+ CCCS = (CostCentreStack *)(ccs); \
+ CCCS_DETAIL_COUNT(CCCS->function_count); \
+ } while(0)
+
+/* These ENTER_CC_PAP things are only used in the RTS */
+
+#define ENTER_CCS_PAP(stack) \
+ do { \
+ CostCentreStack *ccs = (CostCentreStack *) (stack); \
+ if ( ! IS_CAF_OR_DICT_OR_SUB_CCS(ccs) ) { \
+ CCCS = ccs; \
+ } else { \
+ CCCS_DETAIL_COUNT(ccs->caffun_subsumed); \
+ CCCS_DETAIL_COUNT(CCCS->subsumed_caf_count); \
+ } \
+ CCCS_DETAIL_COUNT(CCCS->pap_count); \
+ } while(0)
+
+#define ENTER_CCS_PAP_CL(closure) \
+ ENTER_CCS_PAP((closure)->header.prof.ccs)
+
+ /* temp EW */
+#define STATIC_CCS_REF(ccs) (ccs)
+
+#endif /* PROFILING */
+
+#endif /* STGPROF_H */
+++ /dev/null
-\section[STGRegs]{Macros for saving/restoring STG registers}
-
-\begin{code}
-#ifndef STGREGS_H
-#define STGREGS_H
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[saving-restoring-STG-regs]{Saving/restoring STG registers}
-%* *
-%************************************************************************
-
-These routines will fail on the SPARC if they are allowed to drop out-of-line
-(the wrong register window will be active).
-
-\begin{code}
-
-#if defined(__STG_GCC_REGS__) && defined(MAIN_REG_MAP)
-
-EXTDATA(STK_STUB_closure);
-EXTFUN(STK_STUB_entry);
-EXTDATA_RO(vtbl_StdUpdFrame);
-
-/* Keep -Wmissing-prototypes from complaining */
-void SaveAllStgRegs(STG_NO_ARGS);
-#if i386_TARGET_ARCH
-void SaveAllStgContext(void * /*return address*/);
-#else
-void SaveAllStgContext(STG_NO_ARGS);
-#endif
-void SaveStgStackRegs(STG_NO_ARGS);
-void RestoreAllStgRegs(STG_NO_ARGS);
-void RestoreStackStgRegs(STG_NO_ARGS);
-
-extern STG_INLINE
-void SaveAllStgRegs(STG_NO_ARGS)
-{
-#ifdef REG_Base
-# ifdef CONCURRENT
- /* I do not think so: CurrentRegTable will not have changed
- between entry to and exit from "Haskell land" (WDP 95/12)
- */
- /* CurrentRegTable = BaseReg; */
-# endif
-#endif
-/* Hack!!! slam the current C stack pointer into the reg. table
- in the event that we need to copy a chunk of the C stack
- before entering Haskell via a stable pointer (contact
- <sof> for (gruesome) details!)
-
- Only save this once.
-
- ToDo: support this across platforms.
-*/
-#if 0 && defined(CONCURRENT) && defined(i386_TARGET_ARCH)
- if (CurrentTSO != CurrentTSOinC) {
- __asm__ volatile (" mov %%esp,%0" : "m=" (CurrentRegTable->rCstkptr));
- }
-#endif
-
-#ifdef REG_R1
- SAVE_R1 = R1;
-#endif
-
-#ifdef REG_R2
- SAVE_R2 = R2;
-#endif
-
-#ifdef REG_R3
- SAVE_R3 = R3;
-#endif
-
-#ifdef REG_R4
- SAVE_R4 = R4;
-#endif
-
-#ifdef REG_R5
- SAVE_R5 = R5;
-#endif
-
-#ifdef REG_R6
- SAVE_R6 = R6;
-#endif
-
-#ifdef REG_R7
- SAVE_R7 = R7;
-#endif
-
-#ifdef REG_R8
- SAVE_R8 = R8;
-#endif
-
-#ifdef REG_Flt1
- SAVE_Flt1 = FltReg1;
-#endif
-
-#ifdef REG_Flt2
- SAVE_Flt2 = FltReg2;
-#endif
-
-#ifdef REG_Flt3
- SAVE_Flt3 = FltReg3;
-#endif
-
-#ifdef REG_Flt4
- SAVE_Flt4 = FltReg4;
-#endif
-
-#ifdef REG_Dbl1
- SAVE_Dbl1 = DblReg1;
-#endif
-
-#ifdef REG_Dbl2
- SAVE_Dbl2 = DblReg2;
-#endif
-
-#ifdef REG_Lng1
- SAVE_Lng1 = LngReg1;
-#endif
-
-#ifdef REG_Lng2
- SAVE_Lng2 = LngReg2;
-#endif
-
-#ifdef REG_Tag
- SAVE_Tag = TagReg;
-#endif
-
-#ifdef REG_Ret
- SAVE_Ret = RetReg;
-#endif
-
-#if defined(REG_SpA) || defined(CONCURRENT)
- SAVE_SpA = SpA;
-#endif
-
-#if defined(REG_SuA) || defined(CONCURRENT)
- SAVE_SuA = SuA;
-#endif
-
-#if defined(REG_SpB) || defined(CONCURRENT)
- SAVE_SpB = SpB;
-#endif
-
-#if defined(REG_SuB) || defined(CONCURRENT)
- SAVE_SuB = SuB;
-#endif
-
- SAVE_Hp = Hp; /* always! */
- SAVE_HpLim = HpLim; /* ditto! */
-}
-
-extern STG_INLINE
-void
-#if i386_TARGET_ARCH
-SaveAllStgContext(void * ret_addr)
-#else
-SaveAllStgContext(STG_NO_ARGS)
-#endif
-{
- SaveAllStgRegs();
-#ifdef CONCURRENT
-# if defined(PROFILING) || defined(PAR)
- TSO_CCC(CurrentTSO) = CCC;
- CCC = (CostCentre)STATIC_CC_REF(CC_MAIN);
-# endif
-# if i386_TARGET_ARCH
- SET_RETADDR(TSO_PC2(CurrentTSO), ret_addr)
-# else
- SET_RETADDR(TSO_PC2(CurrentTSO))
-# endif
-#endif
-}
-
-extern STG_INLINE
-void SaveStgStackRegs(STG_NO_ARGS)
-{
-#if defined(REG_SpA) || defined(CONCURRENT)
- SAVE_SpA = SpA;
-#endif
-
-#if defined(REG_SuA) || defined(CONCURRENT)
- SAVE_SuA = SuA;
-#endif
-
-#if defined(REG_SpB) || defined(CONCURRENT)
- SAVE_SpB = SpB;
-#endif
-
-#if defined(REG_SuB) || defined(CONCURRENT)
- SAVE_SuB = SuB;
-#endif
-}
-
-extern STG_INLINE void
-RestoreAllStgRegs (STG_NO_ARGS)
-{
-#ifdef REG_Base
- /* Re-initialise the register table pointer */
-# ifdef CONCURRENT
- BaseReg = CurrentRegTable;
-# else
- BaseReg = &MainRegTable;
-# endif
-#endif
-
-#ifdef REG_R1
- R1 = SAVE_R1;
-#endif
-
-#ifdef REG_R2
- R2 = SAVE_R2;
-#endif
-
-#ifdef REG_R3
- R3 = SAVE_R3;
-#endif
-
-#ifdef REG_R4
- R4 = SAVE_R4;
-#endif
-
-#ifdef REG_R5
- R5 = SAVE_R5;
-#endif
-
-#ifdef REG_R6
- R6 = SAVE_R6;
-#endif
-
-#ifdef REG_R7
- R7 = SAVE_R7;
-#endif
-
-#ifdef REG_R8
- R8 = SAVE_R8;
-#endif
-
-#ifdef REG_Flt1
- FltReg1 = SAVE_Flt1;
-#endif
-
-#ifdef REG_Flt2
- FltReg2 = SAVE_Flt2;
-#endif
-
-#ifdef REG_Flt3
- FltReg3 = SAVE_Flt3;
-#endif
-
-#ifdef REG_Flt4
- FltReg4 = SAVE_Flt4;
-#endif
-
-#ifdef REG_Dbl1
- DblReg1 = SAVE_Dbl1;
-#endif
-
-#ifdef REG_Dbl2
- DblReg2 = SAVE_Dbl2;
-#endif
-
-#ifdef REG_Lng1
- LngReg1 = SAVE_Lng1;
-#endif
-
-#ifdef REG_Lng2
- LngReg2 = SAVE_Lng2;
-#endif
-
-#ifdef REG_Tag
- TagReg = SAVE_Tag;
-#endif
-
-#ifdef REG_Ret
- RetReg = SAVE_Ret;
-#endif
-
-#if defined(REG_StkO) && defined(CONCURRENT)
- StkOReg = SAVE_StkO;
-#endif
-
-#if defined(REG_SpA) || defined(CONCURRENT)
- SpA = SAVE_SpA;
-#endif
-
-#if defined(REG_SuA) || defined(CONCURRENT)
- SuA = SAVE_SuA;
-#endif
-
-#if defined(REG_SpB) || defined(CONCURRENT)
- SpB = SAVE_SpB;
-#endif
-
-#if defined(REG_SuB) || defined(CONCURRENT)
- SuB = SAVE_SuB;
-#endif
-
- Hp = SAVE_Hp; /* always! */
- HpLim = SAVE_HpLim; /* ditto! */
-
-#ifdef REG_StdUpdRetVec
- StdUpdRetVecReg = vtbl_StdUpdFrame;
-#endif
-
-#ifdef REG_StkStub
- StkStubReg = STK_STUB_closure;
-#endif
-
-#if CONCURRENT
-# if defined(PROFILING) || defined(PAR)
- CCC = TSO_CCC(CurrentTSO);
-# endif
-#endif
-}
-
-extern STG_INLINE void
-RestoreStackStgRegs (STG_NO_ARGS)
-{
-#if defined(REG_SpA) || defined(CONCURRENT)
- SpA = SAVE_SpA;
-#endif
-
-#if defined(REG_SuA) || defined(CONCURRENT)
- SuA = SAVE_SuA;
-#endif
-
-#if defined(REG_SpB) || defined(CONCURRENT)
- SpB = SAVE_SpB;
-#endif
-
-#if defined(REG_SuB) || defined(CONCURRENT)
- SuB = SAVE_SuB;
-#endif
-}
-
-#else /* For the unwashed and unregisterized */
-
-#ifdef CONCURRENT
-
-#define SaveAllStgRegs() \
- do { \
- SAVE_Hp = Hp; \
- SAVE_HpLim = HpLim; \
- SAVE_SpA = SpA; \
- SAVE_SuA = SuA; \
- SAVE_SpB = SpB; \
- SAVE_SuB = SuB; \
- } while(0)
-
-#define RestoreAllStgRegs() \
- do { \
- Hp = SAVE_Hp; \
- HpLim = SAVE_HpLim; \
- SpA = SAVE_SpA; \
- SuA = SAVE_SuA; \
- SpB = SAVE_SpB; \
- SuB = SAVE_SuB; \
- } while(0)
-
-#define RestoreStackStgRegs() \
- do { \
- SpA = SAVE_SpA; \
- SuA = SAVE_SuA; \
- SpB = SAVE_SpB; \
- SuB = SAVE_SuB; \
- } while(0)
-
-#else
-
-#define SaveAllStgRegs() do {SAVE_Hp = Hp; SAVE_HpLim = HpLim;} while(0)
-
-#define RestoreAllStgRegs() do {Hp = SAVE_Hp; HpLim = SAVE_HpLim;} while(0)
-#define RestoreStackStgRegs() /* nothing */
-
-#endif /* CONCURRENT */
-
-#define SaveAllStgContext() SaveAllStgRegs()
-
-#endif /* __STG_GCC_REGS__ && MAIN_REG_MAP */
-
-#endif /* STGREGS_H */
-
-\end{code}
-
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgStorage.h,v 1.2 1998/12/02 13:21:41 simonm Exp $
+ *
+ * STG Storage Manger Interface
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STGSTORAGE_H
+#define STGSTORAGE_H
+
+#include "Block.h"
+
+extern bdescr *current_nursery;
+
+/* -----------------------------------------------------------------------------
+ Allocation area for compiled code
+
+ OpenNursery(hp,hplim) Opens the allocation area, and sets hp
+ and hplim appropriately.
+
+ CloseNursery(hp) Closes the allocation area.
+
+ PleaseStopAllocating(void) Arranges that the next call to
+ ExtendNursery() will fail, triggering
+ a return to the scheduler. This is
+ useful for asynchronous interupts etc.
+ -------------------------------------------------------------------------- */
+
+#define OpenNursery(hp,hplim) \
+ (hp = current_nursery->free-1, \
+ hplim = current_nursery->start + BLOCK_SIZE_W - 1)
+
+#define CloseNursery(hp) (current_nursery->free = (P_)(hp)+1)
+
+/* -----------------------------------------------------------------------------
+ Trigger a GC from Haskell land.
+ -------------------------------------------------------------------------- */
+
+extern void performGC(void);
+extern void performGCWithRoots(void (*get_roots)(void));
+
+#endif /* STGSTORAGE_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgTypes.h,v 1.2 1998/12/02 13:21:41 simonm Exp $
+ *
+ * Various C datatypes used in the run-time system.
+
+ * Specifically:
+
+ StgInt8, 16, 32, 64
+ StgNat8, 16, 32, 64
+ StgChar, StgFloat, StgDouble
+
+ ***** All the same size: *****
+ StgPtr Basic pointer type
+ StgWord Unit of heap allocation
+ StgInt Signed version of StgWord
+ StgAddr Generic address type
+
+
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STGTYPES_H
+#define STGTYPES_H
+
+/*
+ * First, platform-dependent definitions of size-specific integers.
+ * Assume for now that the int type is 32 bits.
+ * ToDo: move these into a platform-dependent file.
+ */
+
+typedef signed char StgInt8;
+typedef unsigned char StgNat8;
+
+typedef signed short StgInt16;
+typedef unsigned short StgNat16;
+
+
+#if SIZEOF_UNSIGNED_INT == 4
+typedef signed int StgInt32;
+typedef unsigned int StgNat32;
+#else
+#error GHC untested on this architecture: sizeof(unisgned int) != 4
+#endif
+
+/* This #define controls whether we need to support long longs on a particular
+ * platform.
+ *
+ * ToDo: find a proper home for (derived) configuration information like this.
+ */
+#if HAVE_LONG_LONG && SIZEOF_VOID_P < 8
+#define SUPPORT_LONG_LONGS
+#endif
+
+#ifdef SUPPORT_LONG_LONGS
+/* assume long long is 64 bits */
+typedef unsigned long long int StgNat64;
+typedef signed long long int StgInt64;
+#elif SIZEOF_LONG == 8
+typedef signed long StgInt64;
+typedef unsigned long StgNat64;
+#else
+#error GHC untested on this architecture: sizeof(void *) < 8 and no long longs.
+#endif
+
+
+/*
+ * Define the standard word size we'll use on this machine: make it
+ * big enough to hold a pointer.
+ */
+
+#if SIZEOF_VOID_P == 8
+typedef StgInt64 StgInt;
+typedef StgNat64 StgWord;
+#else
+#if SIZEOF_VOID_P == 4
+typedef StgInt32 StgInt;
+typedef StgNat32 StgWord;
+#else
+#error GHC untested on this architecture: sizeof(void *) != 4 or 8
+#endif
+#endif
+
+typedef void* StgAddr;
+
+/*
+ * Other commonly-used STG datatypes.
+ */
+
+typedef StgNat8 StgChar;
+
+/*
+ * If a double fits in an StgWord, don't bother using floats.
+ */
+
+#if SIZEOF_DOUBLE == SIZEOF_VOID_P
+typedef double StgFloat;
+typedef double StgDouble;
+#define FLOATS_AS_DOUBLES 1
+#else
+typedef float StgFloat;
+typedef double StgDouble;
+#endif
+
+typedef void StgVoid;
+
+typedef struct StgClosure_* StgClosurePtr;
+typedef StgWord* StgPtr; /* pointer into closure */
+typedef StgWord StgOffset; /* byte offset within closure */
+
+typedef struct StgTSO_* StgTSOPtr;
+
+typedef StgWord StgStablePtr;
+typedef void * StgForeignPtr;
+
+typedef StgInt StgStackOffset; /* offset in words! */
+
+typedef StgWord* StgStackPtr;
+
+typedef StgNat8 StgCode; /* close enough */
+typedef StgCode* StgCodePtr;
+
+typedef StgPtr* StgArray; /* the goods of an Array# */
+typedef char* StgByteArray; /* the goods of a ByteArray# */
+
+typedef StgInt64 LI_;
+typedef StgNat64 LW_;
+
+/*
+ Types for the generated C functions
+ take no arguments
+ return a pointer to the next function to be called
+ use: Ptr to Fun that returns a Ptr to Fun which returns Ptr to void
+
+ Note: Neither StgFunPtr not StgFun is quite right (that is,
+ StgFunPtr != StgFun*). So, the functions we define all have type
+ StgFun but we always have to cast them to StgFunPtr when we assign
+ them to something.
+ The only way round this would be to write a recursive type but
+ C only allows that if you're defining a struct or union.
+*/
+
+typedef void *(*(*StgFunPtr)(void))(void);
+typedef StgFunPtr StgFun(void);
+
+typedef union {
+ StgWord w;
+ StgAddr a;
+ StgChar c;
+ StgFloat f;
+ StgInt i;
+ StgPtr p;
+ StgClosurePtr cl;
+ StgStackOffset offset; /* unused? */
+ StgByteArray b;
+ StgTSOPtr t;
+} StgUnion;
+
+/*
+ * Shorthand forms
+ */
+
+typedef StgChar C_;
+typedef StgWord W_;
+typedef StgWord* P_;
+typedef P_* PP_;
+typedef StgInt I_;
+typedef StgAddr A_;
+typedef const StgWord* D_;
+typedef StgFunPtr F_;
+typedef StgByteArray B_;
+typedef StgClosurePtr L_;
+
+/*
+ * We often want to know the size of something in units of an
+ * StgWord... (rounded up, of course!)
+ */
+
+#define sizeofW(t) ((sizeof(t)+sizeof(W_)-1)/sizeof(W_))
+
+/*
+ * It's nice to be able to grep for casts
+ */
+
+#define stgCast(ty,e) ((ty)(e))
+
+#endif STGTYPES_H
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-%************************************************************************
-%* *
-\section{How data is handled, especially floats and doubles}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifndef STGTYPES_H
-#define STGTYPES_H
-\end{code}
-
-Some variables (eg the A stack, the stack pointers, floating point
-registers) can only contain data of a particular (machine type).
-
-%partain:\begin{center}
-\begin{tabular}{|l|l|}
-\hline
-What we call it & The C type which represents it \\ \hline
- & \\
-StgInt & long \\
-StgFloat & float \\
-StgDouble & double \\
-StgChar & unsigned char \\\hline
-StgStablePtr & long \\
-StgForeignObj & (long *) \\
-\end{tabular}
-%partain:\end{center}
-
-Others, notably the heap itself and the B stack, can contain various
-kinds of data; pointers, floats, doubles, chars and so on. These
-structures are given C type @StgWord@, meaning ``I don't know''.
-
-%partain:\begin{center}
-\begin{tabular}{|l|l|}
-\hline
-StgWord & long \\\hline
-\end{tabular}
-%partain:\end{center}
-
-% @StgWord@s only live in {\em memory locations}; there are no registers
-% of type @StgWord@.
-
-When we load/store things in the heap, or on the B stack, we therefore
-have to coerce data in and out of the @StgWord@ type. For @StgInt@
-and @StgChar@ that's no problem; we just use a C cast.
-
-Now here's the rub: we can't cast a @StgFloat@ to @StgWord@ because C
-performs numeric conversions if you do! Worse, we obviously can't
-cast a @StgDouble@ to @StgWord@, because it's the wrong size. The
-solution we adopt is to provide functions/macros with the following
-prototypes
-
-\begin{pseudocode}
- StgFloat PK_FLT( StgWord * )
- void ASSIGN_FLT( StgWord [], StgFloat )
-
- StgDouble PK_DBL( StgWord * )
- void ASSIGN_DBL( StgWord [], StgDouble )
-\end{pseudocode}
-
-The @PK@ functions create a suitable float/double given a pointer to
-some @StgWord@ memory locations; the @ASSIGN@ functions do the
-reverse. Notice that it is a private matter between @PK_DBL@ and
-@ASSIGN_DBL@ how the words are acutally used to store the double (the
-high word could go in the upper or lower memory location).
-
-We implement these operations as inlined C functions; much
-better than macros because they need a local variable which
-macros don't give you. There is probably more than one way
-to implement them; we have cheated the type system using a
-union type.
-
-\begin{code}
-typedef unsigned long StgWord; /* used for heap- and Bstk- words,
- which can be of various types */
-
-/* macro to round a number-of-bytes up to a sufficient number of words: */
-#define BYTES_TO_STGWORDS(no_bytes) (((no_bytes)+sizeof(W_)-1)/sizeof(W_))
-
-typedef unsigned long *StgPtr; /* StgPtr is a ptr to a heap object
- or into the B stack */
-typedef StgPtr *StgPtrPtr; /* used for A stack pointer */
-typedef long StgInt;
-
-#if HAVE_LONG_LONG
-/* These types are only used to allow the passing of
- 64-bit ints from Haskell to ccalls and to ease
- the implementation of the Int64 and Word64 libraries.
-*/
-typedef unsigned long long int StgWord64;
-typedef long long int StgInt64;
-typedef StgInt64 LI_;
-typedef StgWord64 LW_;
-#endif
-
-typedef unsigned char StgChar;
-typedef void *StgAddr;
-
-#if alpha_TARGET_ARCH
-typedef double StgFloat;
-typedef double StgDouble;
-#else
-typedef float StgFloat;
-typedef double StgDouble;
-#endif
-
-/* seven shorthand forms:
- StgChar, StgWord, StgPtr, StgPtrPtr, StgInt, StgAddr, const StgPtr */
-
-typedef StgChar C_;
-typedef StgWord W_;
-typedef StgPtr P_;
-typedef P_ *PP_;
-typedef StgInt I_;
-typedef void *A_;
-typedef const unsigned long *D_;
-
-/* Typedefs for the various sized ints
- (ToDo: better.)
-*/
-
-typedef unsigned char StgWord8;
-typedef signed char StgInt8;
-typedef unsigned short StgWord16;
-typedef short StgInt16;
-typedef unsigned int StgWord32;
-typedef signed int StgInt32;
-
-
-typedef StgPtr StgArray;
-typedef StgChar *StgByteArray;
-typedef StgByteArray B_;
-
-typedef I_ StgStablePtr; /* Index into Stable Pointer Table */
-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
- and collectHeap. (Is there a standard name for them?)
- [ADR]
-
- Why longs? --JSM
- No good reason (bad reason: same as StgInt) -- ADR
- An abomination! Death to StgBool! --JSM
-*/
-#define StgFalse 0
-#define StgTrue 1
-typedef long StgBool;
-
-typedef long StgTag;
-
-typedef StgWord StgInfoEntry;
-typedef StgWord *StgInfoPtr;
-
-\end{code}
-
-Types for the generated C functions
- take no arguments
- return a pointer to the next function to be called
- use: Ptr to Fun that returns a Ptr to Fun which returns Ptr to void
-
-\begin{code}
-typedef void *(*(*StgFunPtr)(STG_NO_ARGS))(STG_NO_ARGS);
-
-typedef StgFunPtr (StgFun)(STG_NO_ARGS);
-typedef StgFunPtr sfp; /* shorthand, for less typing while debugging */
-
-typedef StgFunPtr (*StgFunPtrFunPtr)(STG_NO_ARGS);
-
-typedef StgFunPtr F_;
-typedef StgFunPtrFunPtr *FP_;
-
-typedef D_ StgRetAddr; /* for now ... */
-#if 0
-typedef union {
- StgFunPtr d; /* direct return */
- D_ v; /* vectored return */
-} StgRetAddr;
-#endif
-
-/* new union type, to eventually replace StgWord */
-typedef union word {
- B_ b; /* pointer to byte array */
- W_ c; /* (unsigned) character; *not* StgChar type */
- D_ d; /* read-only data pointer */
- StgFloat f; /* single-precision float */
- StgFunPtr fp; /* function (code) pointer */
- I_ i; /* integer */
- P_ p; /* basic pointer */
- StgRetAddr r; /* return address or vector */
- W_ w; /* arbitrary word (needed?) */
- void *v; /* ??? (AddrKind) */
-} StgUnion;
-
-
-/*
- If a BitWord is anything other than an StgWord, you may have some problems.
- In particular, be sure that the dynamic allocation of a BitWord array from the
- heap is done properly.
- */
-typedef StgWord BitWord; /* Bit marking words */
-
-/* Stuff for hashing */
-typedef StgWord hash_t;
-
-#define UNHASHED (~0L)
-
-/* ullong (64|128-bit) type: only include if needed (not ANSI) */
-#if defined(__GNUC__)
-typedef unsigned long long ullong; /* need prototypes */
-#define LL(x) CAT2(x,LL)
-#else
-typedef unsigned long ullong;
-#define LL(x) CAT2(x,L)
-#endif
-\end{code}
-
-Stuff for packed shorts; used in @StgMacros.h@.
-
-\begin{code}
-typedef struct __uw
- { unsigned short s1;
- unsigned short s2;
- } unpacked_word;
-
-typedef union __ps
- { unsigned int u;
- unpacked_word wu;
- } packed_shorts;
-\end{code}
-
-Stuff for floats/doubles; used in @StgMacros.h@.
-ToDo: looks pretty 64-bit unfriendly to me! [WDP]
-
-\begin{code}
-typedef struct __ud
- { StgWord dhi;
- StgWord dlo;
- } unpacked_double;
-
-typedef union __dt
- { StgDouble d;
- unpacked_double du;
- } double_thing;
-
-typedef StgWord unpacked_float;
-
-typedef union __ft
- { StgFloat f;
- unpacked_float fu;
- } float_thing;
-
-#if HAVE_LONG_LONG
-typedef union __it
- { StgInt64 i;
- unpacked_double iu;
- } int64_thing;
-
-typedef union __wt
- { StgWord64 w;
- unpacked_double wu;
- } word64_thing;
-#endif
-
-\end{code}
-
-Also include the RTS types for the runtime system modules.
-
-\begin{code}
-
-#include "RtsTypes.h"
-
-#endif /* ! STGTYPES_H */
-\end{code}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: TSO.h,v 1.2 1998/12/02 13:21:43 simonm Exp $
+ *
+ * The definitions for Thread State Objects.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef TSO_H
+#define TSO_H
+
+#if defined(PROFILING)
+typedef struct {
+ CostCentreStack *CCCS; /* thread's current CCS */
+} StgTSOProfInfo;
+#else /* !PROFILING */
+typedef struct {
+} StgTSOProfInfo;
+#endif /* PROFILING */
+
+#if defined(PAR)
+typedef struct {
+} StgTSOParInfo;
+#else /* !PAR */
+typedef struct {
+} StgTSOParInfo;
+#endif /* PAR */
+
+#if defined(TICKY)
+typedef struct {
+} StgTSOTickyInfo;
+#else /* !TICKY */
+typedef struct {
+} StgTSOTickyInfo;
+#endif /* TICKY */
+
+typedef enum {
+ tso_state_runnable,
+ tso_state_stopped
+} StgTSOState;
+
+typedef enum {
+ ThreadEnterGHC,
+ ThreadRunGHC,
+ ThreadEnterHugs,
+ ThreadKilled,
+ ThreadComplete
+} StgTSOWhatNext;
+
+/*
+ * We are completely paranoid and make thread IDs 64 bits to avoid
+ * having to worry about overflow. A little calculation shows that
+ * even doing 10^6 forks per second would take 35 million years to
+ * overflow a 64 bit thread ID :-)
+ */
+typedef StgNat64 StgThreadID;
+
+/*
+ * This type is returned to the scheduler by a thread that has
+ * stopped for one reason or another.
+ */
+
+typedef enum {
+ HeapOverflow, /* might also be StackOverflow */
+ StackOverflow,
+ ThreadYielding,
+ ThreadBlocked,
+ ThreadFinished
+} StgThreadReturnCode;
+
+/*
+ * TSOs live on the heap, and therefore look just like heap objects.
+ * Large TSOs will live in their own "block group" allocated by the
+ * storage manager, and won't be copied during garbage collection.
+ */
+
+typedef struct StgTSO_ {
+ StgHeader header;
+ struct StgTSO_* link;
+ StgTSOWhatNext whatNext;
+ StgTSOState state; /* necessary? */
+ StgThreadID id;
+ /* Exception Handlers */
+ StgTSOTickyInfo ticky;
+ StgTSOProfInfo prof;
+ StgTSOParInfo par;
+ /* GranSim Info? */
+
+ /* The thread stack... */
+ StgWord stack_size; /* stack size in *words* */
+ StgWord max_stack_size; /* maximum stack size in *words* */
+ StgPtr sp;
+ StgUpdateFrame* su;
+ StgPtr splim;
+
+ StgWord stack[0];
+} StgTSO;
+
+extern StgTSO *CurrentTSO;
+
+
+/* Workaround for a bug/quirk in gcc on certain architectures.
+ * symptom is that (&tso->stack - &tso->header) /= sizeof(StgTSO)
+ * in other words, gcc pads the structure at the end.
+ */
+
+extern StgTSO dummy_tso;
+
+#define TSO_STRUCT_SIZE \
+ ((int)&(dummy_tso).stack - (int)&(dummy_tso).header)
+
+#define TSO_STRUCT_SIZEW (TSO_STRUCT_SIZE / sizeof(W_))
+
+#endif /* TSO_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: TailCalls.h,v 1.2 1998/12/02 13:21:43 simonm Exp $
+ *
+ * Stuff for implementing proper tail jumps.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef TAILCALLS_H
+#define TAILCALLS_H
+
+/* -----------------------------------------------------------------------------
+ Unmangled tail-jumping: use the mini interpretter.
+ -------------------------------------------------------------------------- */
+
+#ifdef USE_MINIINTERPRETER
+
+#define JMP_(cont) return(stgCast(StgFunPtr,cont))
+#define FB_
+#define FE_
+
+#else
+
+/* -----------------------------------------------------------------------------
+ Tail calling on x86
+ -------------------------------------------------------------------------- */
+
+#if i386_TARGET_ARCH
+
+extern void __DISCARD__(void);
+
+/* Note about discard: possibly there to fool GCC into clearing up
+ before we do the jump eg. if there are some arguments left on the C
+ stack that GCC hasn't popped yet. Also possibly to fool any
+ optimisations (a function call often acts as a barrier). Not sure
+ if any of this is necessary now -- SDM
+ */
+
+/* The goto here seems to cause gcc -O2 to delete all the code after
+ it - including the FE_ marker and the epilogue code - exactly what
+ we want! -- SDM
+ */
+
+#define JMP_(cont) \
+ { \
+ void *target; \
+ __DISCARD__(); \
+ target = (void *)(cont); \
+ goto *target; \
+ }
+
+#endif i386_TARGET_ARCH
+
+/* -----------------------------------------------------------------------------
+ Tail calling on Sparc
+ -------------------------------------------------------------------------- */
+
+#ifdef sparc_TARGET_ARCH
+
+#define JMP_(cont) ((F_) (cont))()
+ /* Oh so happily, the above turns into a "call" instruction,
+ which, on a SPARC, is nothing but a "jmpl" with the
+ return address in %o7 [which we don't care about].
+ */
+
+/* Don't need these for sparc mangling */
+#define FB_
+#define FE_
+
+#endif sparc_TARGET_ARCH
+
+/* -----------------------------------------------------------------------------
+ Tail calling on Alpha
+ -------------------------------------------------------------------------- */
+
+#ifdef alpha_TARGET_ARCH
+
+register void *_procedure __asm__("$27");
+
+#define JMP_(cont) \
+ do { _procedure = (void *)(cont); \
+ goto *_procedure; \
+ } while(0)
+
+/* Don't need these for alpha mangling */
+#define FB_
+#define FE_
+
+#endif alpha_TARGET_ARCH
+
+/*
+ FUNBEGIN and FUNEND.
+
+ These are markers indicating the start and end of Real Code in a
+ function. All instructions between the actual start and end of the
+ function and these markers is shredded by the mangler.
+ */
+
+#ifndef FB_
+#define FB_ __asm__ volatile ("--- BEGIN ---");
+#endif
+
+#ifndef FE_
+#define FE_ __asm__ volatile ("--- END ---");
+#endif
+
+#endif /* !USE_MINIINTERPRETER */
+
+#endif TAILCALLS_H
+
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1994-1995
-%
-\section[Thread]{Thread support macros used in \tr{.hc} files}
-
-\begin{code}
-#ifndef THREADS_H
-#define THREADS_H
-\end{code}
-
-\begin{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
-
-#ifndef CONCURRENT
-
-#define OR_CONTEXT_SWITCH
-
-#else
-
-extern I_ do_gr_sim; /* Are we simulating granularity? */
-extern FILE *gr_file;
-
-extern I_ do_qp_prof; /* Are we quasi-parallel profiling? */
-extern FILE *qp_file;
-
-#ifdef PAR
-#define DO_QP_PROF 0
-#else
-#define DO_QP_PROF do_qp_prof
-#endif
-
-extern I_ context_switch; /* Flag set by signal handler */
-#if defined(i386_TARGET_ARCH)
-extern I_ entersFromC; /* Counter set by enterStablePtr
- (see comments in c-as-asm/StablePtrOps.lc) */
-#endif
-
-#define CS_MAX_FREQUENCY 100 /* context switches per second */
-#define CS_MIN_MILLISECS (1000/CS_MAX_FREQUENCY)/* milliseconds per slice */
-
-#ifdef __STG_GCC_REGS__
-# if defined(i386_TARGET_ARCH)
-# define OR_CONTEXT_SWITCH || (context_switch && !entersFromC)
-# else
-# define OR_CONTEXT_SWITCH || context_switch
-# endif
-#else
-#define OR_CONTEXT_SWITCH /* in miniInterpret */
-#endif
-
-#define REQUIRED_POOL 0
-#define ADVISORY_POOL 1
-#define SPARK_POOLS 2
-
-#if !defined(GRAN)
-
-#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];
-
-extern P_ RunnableThreadsHd, RunnableThreadsTl;
-extern P_ WaitingThreadsHd, WaitingThreadsTl;
-
-#if defined(PAR)
-extern I_ sparksIgnored, sparksCreated;
-#endif
-
-IF_RTS(extern void AwaitEvent(I_);)
-
-#else /* GRAN */
-
-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[];
-
-#define SparkQueueHd PendingSparksHd[CurrentProc][ADVISORY_POOL]
-#define SparkQueueTl PendingSparksTl[CurrentProc][ADVISORY_POOL]
-#define ThreadQueueHd RunnableThreadsHd[CurrentProc]
-#define ThreadQueueTl RunnableThreadsTl[CurrentProc]
-#define WaitingThreadsHd WaitThreadsHd[CurrentProc]
-#define WaitingThreadsTl WaitThreadsTl[CurrentProc]
-
-#endif /* GRAN */
-
-IF_RTS(extern void PruneSparks(STG_NO_ARGS);)
-
-#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 */
-/* reasons */
-#define FIND_THREAD 10
-#define SAME_THREAD 11
-#define NEW_THREAD SAME_THREAD
-#define CHANGE_THREAD 13
-#define END_OF_WORLD 14
-
-extern W_ SparksAvail, SurplusThreads;
-
-extern W_ CurrentTime[];
-extern I_ OutstandingFetches[], OutstandingFishes[];
-extern enum proc_status procStatus[];
-
-# 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_ AvailableStack;
-extern P_ AvailableTSO;
-
-extern I_ threadId;
-
-void ScheduleThreads PROTO((P_ topClosure));
-
-#if defined(GRAN)
-void ReSchedule PROTO((int what_next)) STG_NORETURN;
-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_));
-long qp_elapsed_time(STG_NO_ARGS);
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[thread-heap-objs]{Special threads-only heap objects (`closures')}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection[TSO-closures]{@TSO@ (thread state object) heap objects}
-%* *
-%************************************************************************
-
-We now enter the realm of the Deeply Magical.
-
-Reduction threads come and go, resume and suspend, etc., in the threaded
-world. Obviously, there must be a place to squirrel away state information
-when a thread is suspended. Hence these {\em thread state objects} (TSOs).
-
-Rather than manage TSOs' alloc/dealloc, etc., in some {\em ad hoc} way, we
-instead alloc/dealloc/etc them in the heap; then we can use all the
-standard garbage-collection/fetching/flushing/etc machinery on them.
-So that's why TSOs are ``heap objects,'' albeit very special ones.
-
-We use all the standard heap-object/closure jargon... (e.g.,
-@SET_TSO_HDR@, fixed headers, variable-hdr size, ...).
-
-A TSO is a fixed-size object with (post-header) words arranged like
-the main register table, and enough slop so that the register table
-can be properly aligned. The last header word of the TSO is
-a pointer to the (internal) start of the interesting data.
-
-Note that the heap and stack pointers in the TSO are only valid while
-the thread is executing, and only if the corresponding values are not
-stored in machine registers (i.e. the TSO becomes the backing register
-table for those values).
-
-\begin{code}
-#define TSO_INFO_WORDS 10
-
-#ifdef TICKY_TICKY
-#define TSO_REDN_WORDS 2
-#else
-#define TSO_REDN_WORDS 0
-#endif
-
-#if defined(GRAN) || defined(PAR)
- /* 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_VHS \
- (GC_MUT_RESERVED_WORDS + TSO_INFO_WORDS + TSO_REDN_WORDS + TSO_GRAN_WORDS)
-
-#define TSO_HS (FIXED_HS + TSO_VHS)
-#define TSO_CTS_SIZE (BYTES_TO_STGWORDS(sizeof(STGRegisterTable) + sizeof(StgDouble)))
-
-#define TSO_PTRS (MAX_VANILLA_REG + 2)
-
-/* std start-filling-in macro: */
-#define SET_TSO_HDR(closure,infolbl,cc) \
-{ SET_FIXED_HDR(closure,infolbl,cc); \
- SET_MUT_RESERVED_WORDS(closure); \
-}
-
-#define TSO_INFO_START (FIXED_HS + GC_MUT_RESERVED_WORDS)
-#define TSO_LINK_LOCN (TSO_INFO_START + 0)
-#define TSO_CCC_LOCN (TSO_INFO_START + 1)
-#define TSO_NAME_LOCN (TSO_INFO_START + 2)
-#define TSO_ID_LOCN (TSO_INFO_START + 3)
-#define TSO_TYPE_LOCN (TSO_INFO_START + 4)
-#define TSO_PC1_LOCN (TSO_INFO_START + 5)
-#define TSO_PC2_LOCN (TSO_INFO_START + 6)
-#define TSO_ARG1_LOCN (TSO_INFO_START + 7)
-#define TSO_EVENT_LOCN (TSO_INFO_START + 8)
-#define TSO_SWITCH_LOCN (TSO_INFO_START + 9)
-
-#define TSO_REDN_START (TSO_INFO_START + TSO_INFO_WORDS)
-#ifdef TICKY_TICKY
-#define TSO_AHWM_LOCN (TSO_REDN_START + 0)
-#define TSO_BHWM_LOCN (TSO_REDN_START + 1)
-#endif
-
-#define TSO_GRAN_START (TSO_REDN_START + TSO_REDN_WORDS)
-#if defined(GRAN) || defined(PAR)
-#define TSO_LOCKED_LOCN (TSO_GRAN_START + 0)
-#define TSO_SPARKNAME_LOCN (TSO_GRAN_START + 1)
-#define TSO_STARTEDAT_LOCN (TSO_GRAN_START + 2)
-#define TSO_EXPORTED_LOCN (TSO_GRAN_START + 3)
-#define TSO_BASICBLOCKS_LOCN (TSO_GRAN_START + 4)
-#define TSO_ALLOCS_LOCN (TSO_GRAN_START + 5)
-#define TSO_EXECTIME_LOCN (TSO_GRAN_START + 6)
-#define TSO_FETCHTIME_LOCN (TSO_GRAN_START + 7)
-#define TSO_FETCHCOUNT_LOCN (TSO_GRAN_START + 8)
-#define TSO_BLOCKTIME_LOCN (TSO_GRAN_START + 9)
-#define TSO_BLOCKCOUNT_LOCN (TSO_GRAN_START + 10)
-#define TSO_BLOCKEDAT_LOCN (TSO_GRAN_START + 11)
-#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_CCC(closure) (((CostCentre *)closure)[TSO_CCC_LOCN])
-#define TSO_NAME(closure) (((PP_)closure)[TSO_NAME_LOCN])
-#define TSO_ID(closure) (((P_)closure)[TSO_ID_LOCN])
-#define TSO_TYPE(closure) (((P_)closure)[TSO_TYPE_LOCN])
-#define TSO_PC1(closure) (((FP_)closure)[TSO_PC1_LOCN])
-#define TSO_PC2(closure) (((FP_)closure)[TSO_PC2_LOCN])
-#define TSO_ARG1(closure) (((P_)closure)[TSO_ARG1_LOCN])
-#define TSO_EVENT(closure) (((P_)closure)[TSO_EVENT_LOCN])
-#define TSO_SWITCH(closure) (((FP_)closure)[TSO_SWITCH_LOCN])
-
-#define TSO_AHWM(closure) (((I_ *)closure)[TSO_AHWM_LOCN])
-#define TSO_BHWM(closure) (((I_ *)closure)[TSO_BHWM_LOCN])
-
-#define TSO_LOCKED(closure) (((P_)closure)[TSO_LOCKED_LOCN])
-#define TSO_SPARKNAME(closure) (((P_)closure)[TSO_SPARKNAME_LOCN])
-#define TSO_STARTEDAT(closure) (((P_)closure)[TSO_STARTEDAT_LOCN])
-#define TSO_EXPORTED(closure) (((P_)closure)[TSO_EXPORTED_LOCN])
-#define TSO_BASICBLOCKS(closure) (((P_)closure)[TSO_BASICBLOCKS_LOCN])
-#define TSO_ALLOCS(closure) (((P_)closure)[TSO_ALLOCS_LOCN])
-#define TSO_EXECTIME(closure) (((P_)closure)[TSO_EXECTIME_LOCN])
-#define TSO_FETCHTIME(closure) (((P_)closure)[TSO_FETCHTIME_LOCN])
-#define TSO_FETCHCOUNT(closure) (((P_)closure)[TSO_FETCHCOUNT_LOCN])
-#define TSO_BLOCKTIME(closure) (((P_)closure)[TSO_BLOCKTIME_LOCN])
-#define TSO_BLOCKCOUNT(closure) (((P_)closure)[TSO_BLOCKCOUNT_LOCN])
-#define TSO_BLOCKEDAT(closure) (((P_)closure)[TSO_BLOCKEDAT_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) \
- + TSO_HS + BYTES_TO_STGWORDS(sizeof(StgDouble)))) & ~(sizeof(StgDouble) - 1)))
-
-#if defined(CONCURRENT) && defined(GRAN) /* HWL */
-/* Per definitionem a tso is really awake if it has met a first */
-/* GRAN_RESCHEDULE macro after having been rescheduled. */
-#define REALLY_AWAKE(tso) (TSO_SWITCH(tso) != TSO_PC2(tso))
-#define SET_AWAKE_FLAG(tso) TSO_SWITCH(tso) = NULL
-#define RESET_AWAKE_FLAG(tso) TSO_SWITCH(tso) = TSO_PC2(tso)
-#endif
-
-\end{code}
-
-The types of threads (TSO_TYPE):
-\begin{code}
-#define T_MAIN 0 /* Must be executed locally */
-#define T_REQUIRED 1 /* A required thread -- may be exported */
-#define T_ADVISORY 2 /* An advisory thread -- may be exported */
-#define T_FAIL 3 /* A failure thread -- may be exported */
-\end{code}
-
-The total space required to start a new thread (See NewThread in
-Threads.lc):
-\begin{code}
-#define THREAD_SPACE_REQUIRED (TSO_HS + TSO_CTS_SIZE + STKO_HS + RTSflags.ConcFlags.stkChunkSize)
-\end{code}
-
-Here are the various queues for GrAnSim-type events.
-\begin{code}
-#define Q_RUNNING 'G'
-#define Q_RUNNABLE 'A'
-#define Q_BLOCKED 'R'
-#define Q_FETCHING 'Y'
-#define Q_MIGRATING 'B'
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[spark-closures]{Pending Sparks}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef PAR
-
-P_ FindLocalSpark PROTO((rtsBool forexport));
-
-void DisposeSpark PROTO((P_ spark));
-rtsBool Spark PROTO((P_ closure, rtsBool required));
-
-#endif /*PAR*/
-
-#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 */
-
-#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) (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)
-#endif
-
-#endif /* GRAN */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[STKO-closures]{@STKO@ (stack object) heap objects}
-%* *
-%************************************************************************
-
-We linger in the Deeply Magical...
-
-Each reduction thread has to have its own stack space. As there may
-be many such threads, and as any given one may need quite a big stack,
-a naive give-'em-a-big-stack-and-let-'em-run approach will cost a {\em
-lot} of memory.
-
-Our approach is to give a thread a small stack space, and then link
-on/off extra ``chunks'' as the need arises. Again, this is a
-storage-management problem, and, yet again, we choose to graft the
-whole business onto the existing heap-management machinery. So stack
-objects will live in the heap, be garbage collected, etc., etc..
-
-So, as with TSOs, we use the standard heap-object (`closure') jargon.
-
-Here is the picture of how a stack object is arranged:
-\begin{verbatim}
- <----- var hdr --------> v ---- FirstPtr --- v
----------------------------------------------------------------------
-...|| SpB | SuB | SpA | SuA || B stk -> ... | ... <- A stk || PREV ||
----------------------------------------------------------------------
- XX-> <-YY
-\end{verbatim}
-
-We keep the following state-of-stack info in the {\em variable-header}
-part of a STKO:
-\begin{tabular}{ll}
-SpB, SuB & their {\em offsets} from 1st non-hdr word (marked \tr{XX} above)\\
-SpA, SuA & their {\em offsets} from the next-to-last word (marked \tr{YY} above)\\
-ctr field??? & (GC\_GEN\_WHATNOT may serve instead)\\
-\end{tabular}
-
-The stack-pointer offsets are from the points indicated and are {\em
-non-negative} for pointers to this chunk of the stack space.
-
-At the {\em end} of the stack object, we have a {\em link} to the
-previous part of the overall stack. The link is \tr{NULL} if this is
-the bottom of the overall stack.
-
-After the header, we have @STKO_CHUNK_SIZE-1@ words of actual stack
-stuff. The B-stack part begins at the lowest address and grows
-upwards; the A-stack parts begins at the highest address and grows
-downwards.
-
-From a storage-manager point of view, these are {\em very special}
-objects.
-
-\begin{code}
-#ifdef TICKY_TICKY
-#define STKO_VHS (GC_MUT_RESERVED_WORDS + 9)
-#else
-#define STKO_VHS (GC_MUT_RESERVED_WORDS + 7)
-#endif
-#define STKO_HS (FIXED_HS + STKO_VHS)
-
-#define MIN_STKO_CHUNK_SIZE 16 /* Rather arbitrary */
-
-#define STKO_CLOSURE_SIZE(closure) STKO_SIZE(closure)
-
-#define STKO_CLOSURE_CTS_SIZE(closure) (STKO_CLOSURE_SIZE(closure) - STKO_VHS)
-#define STKO_CLOSURE_PTR(closure, no) (*STKO_CLOSURE_ADDR(closure, no))
-
-#define STKO_CLOSURE_ADDR(s, n) (((P_)(s)) + STKO_HS + (n) - 1)
-#define STKO_CLOSURE_OFFSET(s, p) (((P_)(p) - (P_)(s)) - STKO_HS + 1)
-
-/* std start-filling-in macro: */
-#define SET_STKO_HDR(s,infolbl,cc) \
- { SET_FIXED_HDR(s,infolbl,cc); \
- SET_MUT_RESERVED_WORDS(s); \
- /* the other header words filled in some other way */ }
-
-/* now we have the STKO-specific stuff
-
- Note: The S[pu][AB] registers are put in this order so that
- they will appear in monotonically increasing order in
- the StkO...just as an aid to the poor wee soul who has
- to debug things.
- */
-
-#ifdef TICKY_TICKY
-#define STKO_ADEP_LOCN (STKO_HS - 9)
-#define STKO_BDEP_LOCN (STKO_HS - 8)
-#endif
-#define STKO_SIZE_LOCN (STKO_HS - 7)
-#define STKO_RETURN_LOCN (STKO_HS - 6)
-#define STKO_LINK_LOCN (STKO_HS - 5)
-#define STKO_SuB_LOCN (STKO_HS - 4)
-#define STKO_SpB_LOCN (STKO_HS - 3)
-#define STKO_SpA_LOCN (STKO_HS - 2)
-#define STKO_SuA_LOCN (STKO_HS - 1)
-
-#define STKO_ADEP(s) (((I_ *)(s))[STKO_ADEP_LOCN])
-#define STKO_BDEP(s) (((I_ *)(s))[STKO_BDEP_LOCN])
-#define STKO_SIZE(s) (((P_)(s))[STKO_SIZE_LOCN])
-#define STKO_RETURN(s) (((StgRetAddr *)(s))[STKO_RETURN_LOCN])
-#define STKO_LINK(s) (((PP_)(s))[STKO_LINK_LOCN])
-#define STKO_SpB(s) (((PP_)(s))[STKO_SpB_LOCN])
-#define STKO_SuB(s) (((PP_)(s))[STKO_SuB_LOCN])
-#define STKO_SpA(s) (((PP_ *)(s))[STKO_SpA_LOCN])
-#define STKO_SuA(s) (((PP_ *)(s))[STKO_SuA_LOCN])
-
-#define STKO_BSTK_OFFSET(closure) (STKO_HS)
-#define STKO_ASTK_OFFSET(closure) (FIXED_HS + STKO_CLOSURE_SIZE(closure) - 1)
-#define STKO_BSTK_BOT(closure) (((P_)(closure)) + STKO_BSTK_OFFSET(closure))
-#define STKO_ASTK_BOT(closure) (((PP_)(closure)) + STKO_ASTK_OFFSET(closure))
-\end{code}
-
-These are offsets into the stack object proper (starting at 1 for
-the first word after the header).
-
-\begin{code}
-#define STKO_SpA_OFFSET(s) (STKO_CLOSURE_OFFSET(s,STKO_SpA(s)))
-#define STKO_SuA_OFFSET(s) (STKO_CLOSURE_OFFSET(s,STKO_SuA(s)))
-#define STKO_SpB_OFFSET(s) (STKO_CLOSURE_OFFSET(s,STKO_SpB(s)))
-#define STKO_SuB_OFFSET(s) (STKO_CLOSURE_OFFSET(s,STKO_SuB(s)))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[BQ-closures]{@BQ@ (blocking queue) heap objects (`closures')}
-%* *
-%************************************************************************
-
-Blocking queues are built in the parallel system when a local thread
-enters a non-global node. They are similar to black holes, except
-that when they are updated, the blocking queue must be enlivened
-too. A blocking queue closure thus has the following structure.
-
-\begin{onlylatex}
-\begin{center}
-\end{onlylatex}
-\begin{tabular}{||l|l|l|l||}\hline
-GA & Info ptr. & $\ldots$ & Blocking Queue \\ \hline
-\end{tabular}
-\begin{onlylatex}
-\begin{center}
-\end{onlylatex}
-
-The blocking queue itself is a pointer to a list of blocking queue entries.
-The list is formed from TSO closures. For the generational garbage collectors,
-the BQ must have the same structure as an IND, with the blocking queue hanging
-off of the indirection pointer. (This has to do with treating the BQ as an old
-root if it gets updated while in the old generation.)
-
-\begin{code}
-#define BQ_VHS IND_VHS
-#define BQ_HS IND_HS
-
-#define BQ_CLOSURE_SIZE(closure) IND_CLOSURE_SIZE(closure)
-#define BQ_CLOSURE_NoPTRS(closure) IND_CLOSURE_NoPTRS(closure)
-#define BQ_CLOSURE_NoNONPTRS(closure) IND_CLOSURE_NoNONPTRS(closure)
-#define BQ_CLOSURE_PTR(closure, no) (((P_)(closure))[BQ_HS + (no) - 1])
-\end{code}
-
-Blocking queues store a pointer to a list of blocking queue entries.
-
-\begin{code}
-#define BQ_ENTRIES(closure) IND_CLOSURE_PTR(closure)
-#define BQ_LINK(closure) IND_CLOSURE_LINK(closure)
-\end{code}
-
-We have only one kind of blocking queue closure, so we test the info pointer
-for a specific value rather than looking in the info table for a special bit.
-
-\begin{code}
-EXTDATA_RO(BQ_info);
-EXTFUN(BQ_entry);
-#define IS_BQ_CLOSURE(closure) (INFO_PTR(closure) == (W_) BQ_info)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[TSO_ITBL]{@TSO_ITBL@}
-%* *
-%************************************************************************
-
-The special info table used for thread state objects (TSOs).
-
-\begin{code}
-
-#define TSO_ITBL() \
- CAT_DECLARE(TSO,INTERNAL_KIND,"TSO","<TSO>") \
- EXTFUN(TSO_entry); \
- EXTDATA_RO(MK_REP_LBL(TSO,,)); \
- const W_ TSO_info[] = { \
- (W_) TSO_entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(TSO,,) \
- INCLUDE_PROFILING_INFO(TSO) \
- }
-
-#define TSO_RTBL() \
- const W_ MK_REP_LBL(TSO,,)[] = { \
- INCLUDE_TYPE_INFO(TSO) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_TSO,_Scavenge_TSO) \
- INCLUDE_COMPACTING_INFO(_ScanLink_TSO,_PRStart_TSO,_ScanMove_TSO,_PRIn_TSO) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[STKO_ITBL]{@STKO_ITBL@}
-%* *
-%************************************************************************
-
-The special info table used for stack objects (STKOs).
-
-\begin{code}
-#define STKO_ITBL() \
- CAT_DECLARE(StkO,INTERNAL_KIND,"STKO","<STKO>") \
- EXTFUN(StkO_entry); \
- EXTDATA_RO(MK_REP_LBL(StkO,,)); \
- const W_ StkO_info[] = { \
- (W_) StkO_entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(StkO,,) \
- INCLUDE_PROFILING_INFO(StkO) \
- }
-
-#define STKO_RTBL() \
- const W_ MK_REP_LBL(StkO,,)[] = { \
- INCLUDE_TYPE_INFO(STKO_DYNAMIC) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_StkO,_Scavenge_StkO) \
- INCLUDE_COMPACTING_INFO(_ScanLink_StkO,_PRStart_StkO,_ScanMove_StkO,_PRIn_StkO) \
- }
-
-#define STKO_STATIC_ITBL() \
- CAT_DECLARE(StkO_static,INTERNAL_KIND,"STKO","<STKO>") \
- EXTFUN(StkO_static_entry); \
- EXTDATA_RO(MK_REP_LBL(StkO_static,,)); \
- const W_ StkO_static_info[] = { \
- (W_) StkO_static_entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(StkO_static,,) \
- INCLUDE_PROFILING_INFO(StkO_static) \
- }
-
-#define STKO_STATIC_RTBL() \
- const W_ MK_REP_LBL(StkO_static,,)[] = { \
- INCLUDE_TYPE_INFO(STKO_STATIC) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Static,_Dummy_Static_entry) \
- INCLUDE_COMPACTING_INFO(_Dummy_Static_entry,_PRStart_Static, \
- _Dummy_Static_entry,_PRIn_Error) \
- }
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[BQ_ITBL]{@BQ_ITBL@}
-%* *
-%************************************************************************
-
-Special info-table for local blocking queues.
-
-\begin{code}
-#define BQ_ITBL() \
- CAT_DECLARE(BQ,INTERNAL_KIND,"BQ","<BQ>") \
- EXTFUN(BQ_entry); \
- EXTDATA_RO(MK_REP_LBL(BQ,,)); \
- const W_ BQ_info[] = { \
- (W_) BQ_entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(BQ,,) \
- INCLUDE_PROFILING_INFO(BQ) \
- }
-
-#define BQ_RTBL() \
- const W_ MK_REP_LBL(BQ,,)[] = { \
- INCLUDE_TYPE_INFO(BQ) \
- INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_BQ,_Scavenge_BQ) \
- SPEC_COMPACTING_INFO(_ScanLink_BQ,_PRStart_BQ,_ScanMove_BQ,_PRIn_BQ) \
- }
-
-\end{code}
-
-\begin{code}
-#endif /* CONCURRENT */
-\end{code}
-
-Even the sequential system gets to play with SynchVars, though it really
-doesn't make too much sense (if any). Okay; maybe it makes some sense.
-(See the 1.3 I/O stuff.)
-
-%************************************************************************
-%* *
-\subsubsection[SVar-closures]{@SynchVar@ heap objects}
-%* *
-%************************************************************************
-
-\begin{code}
-#define SVAR_HS (MUTUPLE_HS)
-
-#define SVAR_CLOSURE_SIZE(closure) 3
-
-#define SET_SVAR_HDR(closure,infolbl,cc) \
- SET_MUTUPLE_HDR(closure,infolbl,cc,MUTUPLE_VHS+3,3)
-
-/* The value must come first, because we shrink the other two fields off
- when writing an IVar */
-
-#define SVAR_VALUE_LOCN (SVAR_HS+0)
-#define SVAR_HEAD_LOCN (SVAR_HS+1)
-#define SVAR_TAIL_LOCN (SVAR_HS+2)
-
-#define SVAR_VALUE(closure) ((PP_)(closure))[SVAR_VALUE_LOCN]
-#define SVAR_HEAD(closure) ((PP_)(closure))[SVAR_HEAD_LOCN]
-#define SVAR_TAIL(closure) ((PP_)(closure))[SVAR_TAIL_LOCN]
-\end{code}
-
-End multi-slurp protection:
-
-\begin{code}
-#endif /* THREADS_H */
-\end{code}
-
-
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: Ticky.h,v 1.2 1998/12/02 13:21:45 simonm Exp $
+ *
+ * Closures
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef TICKY_H
+#define TICKY_H
+
+
+#ifndef TICKY
+/* just stubs if no ticky-ticky profiling*/
+#define TICK_ENT_CAF_ENTERED(Node) /* enter CAF */
+#define TICK_ENT_IND(Node) /* enter indirection */
+#define TICK_ENT_VIA_NODE() /* enter node */
+#define TICK_UPD_EXISTING() /* entering an update frame */
+#define TICK_UPD_SQUEEZED() /* squeezed an update frame */
+#define TICK_UPDATED_SET_UPDATED(updclosure) /* updating a closure w/ ind */
+#define TICK_ALLOC_HEAP(words) /* allocate some words on the heap */
+#define TICK_UNALLOC_HEAP(words) /* unallocate some words on the heap */
+#define TICK_ALLOC_UPD_PAP(DYN_HS,NArgWords,N,PapSize)
+#define TICK_ALLOC_PRIM(hdr,args,n,size)
+#define TICK_ENT_PAP(pap) /* entering a PAP */
+#define TICK_UPD_PAP_IN_NEW(NArgWords)
+#define TICK_UPD_PAP_IN_PLACE()
+#define TICK_UPDF_PUSHED()
+#define TICK_SEQF_PUSHED()
+#else
+#error ticky-ticky not implemented!
+#endif
+
+#endif /* TICKY_H */
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%* *
-\section[Ticky.lh]{Interface (and macros) for reduction-count statistics}
-%* *
-%************************************************************************
-
-Multi-slurp protection:
-\begin{code}
-#ifndef TICKY_H
-#define TICKY_H
-\end{code}
-
-There are macros in here for:
-\begin{enumerate}
-\item
-``Ticky-ticky profiling'' (\tr{TICKY_TICKY}), counting the
-number of various STG-events (updates, enters, etc.)
-
-This file goes with \tr{Ticky.lc}, which initialises the counters
-and does the printing [ticky-ticky only].
-
-%************************************************************************
-%* *
-\subsection{Macros for using the `ticky' field in the fixed header}
-%* *
-%************************************************************************
-
-\begin{code}
-#define TICKY_FIXED_HDR (TICKY_HDR_SIZE)
-#define TICKY_HDR_POSN AFTER_PROF_HDR
-#define AFTER_TICKY_HDR (TICKY_FIXED_HDR+TICKY_HDR_POSN)
-\end{code}
-
-\begin{code}
-#ifndef TICKY_TICKY
-
-#define TICKY_HDR_SIZE 0
-#define TICKY_HDR(closure)
-#define SET_TICKY_HDR(closure,to)
-#define SET_STATIC_TICKY_HDR()
-
-#else
-
-#define TICKY_HDR_SIZE 1
-#define TICKY_HDR(closure) (((P_)(closure))[TICKY_HDR_POSN])
-#define SET_TICKY_HDR(closure,to) TICKY_HDR(closure) = (to)
-#define SET_STATIC_TICKY_HDR() ,0
-
-#endif /* TICKY_TICKY */
-\end{code}
-
-Here, we add the Ticky word to the fixed-header part of closures.
-This is used to record indicate if a closure has been updated but not
-yet entered. It is set when the closure is updated and cleared when
-subsequently entered.
-
-NB: It is {\em not} an ``entry count'', it is an
-``entries-after-update count.''
-
-The commoning up of @CONST@, @CHARLIKE@ and @INTLIKE@ closures is
-turned off(?) if this is required. This has only been done for 2s
-collection. It is done using a nasty hack which defines the
-@_Evacuate@ and @_Scavenge@ code for @CONST@, @CHARLIKE@ and @INTLIKE@
-info tables to be @_Evacuate_1@ and @_Scavenge_1_0@.
-
-\begin{code}
-#ifndef TICKY_TICKY
-
-#define UPDATED_SET_UPDATED(n) /* nothing */
-#define ENTERED_CHECK_UPDATED(n) /* nothing */
-
-#else
-
-#define UPDATED_SET_UPDATED(n) do { TICKY_HDR(n) = 1; } while(0)
-
-#define ENT_UPD_HISTO(n) \
- do { I_ __idx; \
- __idx = (n) - 1; \
- \
- /* once 9th enter is recorded, we do not tick anymore;*/\
- /* we want "TotUpdates - <all 9 cols>" to equal */ \
- /* "updates that were never entered" */ \
- if ( __idx <= 8 ) \
- UPD_ENTERED_hst[__idx] += 1; \
- \
- /* now undo tick in previous histo slot ... */ \
- if ( __idx >= 1 && __idx <= 8 ) \
- UPD_ENTERED_hst[(__idx - 1)] -= 1; \
- } while(0)
-
-#define ENTERED_CHECK_UPDATED(n) \
- do { \
- I_ t_hdr = TICKY_HDR(n); \
- \
- if (t_hdr != 0 && AllFlags.doUpdEntryCounts) { \
- ENT_UPD_HISTO(t_hdr); \
- TICKY_HDR(n) += 1; \
- }} while(0)
-
-#endif /* TICKY_TICKY */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ticky-ticky-macros]{Stuff for ``ticky-ticky'' profiling}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef TICKY_TICKY
-\end{code}
-
-Measure what proportion of ...:
-\begin{itemize}
-\item
-... Enters are to data values, function values, thunks.
-\item
-... allocations are for data values, functions values, thunks.
-\item
-... updates are for data values, function values.
-\item
-... updates ``fit''
-\item
-... return-in-heap (dynamic)
-\item
-... vectored return (dynamic)
-\item
-... updates are wasted (never re-entered).
-\item
-... constructor returns get away without hitting an update.
-\end{enumerate}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-stk-heap-use]{Stack and heap usage}
-%* *
-%************************************************************************
-
-Things we are interested in here:
-\begin{itemize}
-\item
-How many times we do a heap check and move @Hp@; comparing this with
-the allocations gives an indication of how many things we get per trip
-to the well:
-\begin{code}
-#define ALLOC_HEAP(n) ALLOC_HEAP_ctr++; ALLOC_HEAP_tot += (n)
-\end{code}
-
-If we do a ``heap lookahead,'' we haven't really allocated any
-heap, so we need to undo the effects of an \tr{ALLOC_HEAP}:
-\begin{code}
-#define UN_ALLOC_HEAP(n) ALLOC_HEAP_ctr--; ALLOC_HEAP_tot -= (n)
-\end{code}
-
-\item
-The stack high-water marks. This is {\em direction-sensitive}!!
-(A stack grows downward, B stack upwards)
-\begin{code}
-#ifndef CONCURRENT
-#define DO_ASTK_HWM() if (SpA < max_SpA) { max_SpA = SpA; }
-#define DO_BSTK_HWM() if (SpB > max_SpB) { max_SpB = SpB; }
-#else
-/*
- * This is not direction sensitive, because we threads people are well-behaved.
- * However, it might be a good idea to cache the constant bits (DEP + BOT and
- * HWM) from the STKO and TSO in more readily accessible places. -- ToDo!
- */
-#define DO_ASTK_HWM() { \
- I_ depth = STKO_ADEP(StkOReg) + AREL((I_) STKO_ASTK_BOT(StkOReg) - (I_) SpA);\
- if (depth > TSO_AHWM(CurrentTSO)) \
- TSO_AHWM(CurrentTSO) = depth; \
-}
-#define DO_BSTK_HWM() { \
- I_ depth = STKO_BDEP(StkOReg) + BREL((I_) STKO_BSTK_BOT(StkOReg) - (I_) SpB);\
- if (depth > TSO_BHWM(CurrentTSO)) \
- TSO_BHWM(CurrentTSO) = depth; \
-}
-#endif
-\end{code}
-
-\item
-Re-use of stack slots, and stubbing of stack slots:
-\begin{code}
-#define A_STK_STUB(n) A_STK_STUB_ctr += (n)
-#define A_STK_REUSE(n) A_STK_REUSE_ctr += (n) /* not used at all? */
-#define B_STK_REUSE(n) B_STK_REUSE_ctr += (n) /* not used at all? */
-\end{code}
-\end{itemize}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-allocs]{Allocations}
-%* *
-%************************************************************************
-
-We count things every time we allocate something in the dynamic heap.
-For each, we count the number of words of (1)~``admin'' (header),
-(2)~good stuff (useful pointers and data), and (3)~``slop'' (extra
-space, in hopes it will allow an in-place update).
-
-The first five macros are inserted when the compiler generates code
-to allocate something; the categories correspond to the @ClosureClass@
-datatype (manifest functions, thunks, constructors, big tuples, and
-partial applications).
-\begin{code}
-#define ALLOC_FUN(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_FUN_ctr++; ALLOC_FUN_adm += (a); \
- ALLOC_FUN_gds += (g); ALLOC_FUN_slp += (s); \
- ALLOC_HISTO(FUN,a,g,s)
-#define ALLOC_THK(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_THK_ctr++; ALLOC_THK_adm += (a); \
- ALLOC_THK_gds += (g); ALLOC_THK_slp += (s); \
- ALLOC_HISTO(THK,a,g,s)
-#define ALLOC_CON(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_CON_ctr++; ALLOC_CON_adm += (a); \
- ALLOC_CON_gds += (g); ALLOC_CON_slp += (s); \
- ALLOC_HISTO(CON,a,g,s)
-#define ALLOC_TUP(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_TUP_ctr++; ALLOC_TUP_adm += (a); \
- ALLOC_TUP_gds += (g); ALLOC_TUP_slp += (s); \
- ALLOC_HISTO(TUP,a,g,s)
-#define ALLOC_BH(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_BH_ctr++; ALLOC_BH_adm += (a); \
- ALLOC_BH_gds += (g); ALLOC_BH_slp += (s); \
- ALLOC_HISTO(BH,a,g,s)
-#if 0
-#define ALLOC_PAP(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_PAP_ctr++; ALLOC_PAP_adm += (a); \
- ALLOC_PAP_gds += (g); ALLOC_PAP_slp += (s); \
- ALLOC_HISTO(PAP,a,g,s)
-#endif
-\end{code}
-
-We may also allocate space when we do an update, and there isn't
-enough space. These macros suffice (for: updating with a partial
-application and a constructor):
-\begin{code}
-#define ALLOC_UPD_PAP(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_UPD_PAP_ctr++; ALLOC_UPD_PAP_adm += (a); \
- ALLOC_UPD_PAP_gds += (g); ALLOC_UPD_PAP_slp += (s); \
- ALLOC_HISTO(UPD_PAP,a,g,s)
-#if 0
-#define ALLOC_UPD_CON(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_UPD_CON_ctr++; ALLOC_UPD_CON_adm += (a); \
- ALLOC_UPD_CON_gds += (g); ALLOC_UPD_CON_slp += (s); \
- ALLOC_HISTO(UPD_CON,a,g,s)
-#endif /* 0 */
-\end{code}
-
-In the threaded world, we allocate space for the spark pool, stack objects,
-and thread state objects.
-
-\begin{code}
-
-#define ALLOC_STK(a,g,s) ALLOC_STK_ctr++; ALLOC_STK_adm += (a); \
- ALLOC_STK_gds += (g); ALLOC_STK_slp += (s); \
- ALLOC_HISTO(STK,a,g,s)
-
-#define ALLOC_TSO(a,g,s) ALLOC_TSO_ctr++; ALLOC_TSO_adm += (a); \
- ALLOC_TSO_gds += (g); ALLOC_TSO_slp += (s); \
- ALLOC_HISTO(TSO,a,g,s)
-
-#define ALLOC_FMBQ(a,g,s) ALLOC_FMBQ_ctr++; ALLOC_FMBQ_adm += (a); \
- ALLOC_FMBQ_gds += (g); ALLOC_FMBQ_slp += (s); \
- ALLOC_HISTO(FMBQ,a,g,s)
-
-#define ALLOC_FME(a,g,s) ALLOC_FME_ctr++; ALLOC_FME_adm += (a); \
- ALLOC_FME_gds += (g); ALLOC_FME_slp += (s); \
- ALLOC_HISTO(FME,a,g,s)
-
-#define ALLOC_BF(a,g,s) ALLOC_BF_ctr++; ALLOC_BF_adm += (a); \
- ALLOC_BF_gds += (g); ALLOC_BF_slp += (s); \
- ALLOC_HISTO(BF,a,g,s)
-
-\end{code}
-
-The histogrammy bit is fairly straightforward; the \tr{-2} is: one for
-0-origin C arrays; the other one because we do {\em no} one-word
-allocations, so we would never inc that histogram slot; so we shift
-everything over by one.
-\begin{code}
-#define ALLOC_HISTO(categ,a,g,s) \
- { I_ __idx; \
- __idx = (a) + (g) + (s) - 2; \
- CAT3(ALLOC_,categ,_hst)[((__idx > 4) ? 4 : __idx)] += 1;}
-\end{code}
-
-Some hard-to-account-for words are allocated by/for primitives,
-includes Integer support. @ALLOC_PRIM2@ tells us about these. We
-count everything as ``goods'', which is not strictly correct.
-(@ALLOC_PRIM@ is the same sort of stuff, but we know the
-admin/goods/slop breakdown.)
-\begin{code}
-#define ALLOC_PRIM(a,g,s,t) ASSERT((t) == (a)+(g)+(s)); \
- ALLOC_PRIM_ctr++; ALLOC_PRIM_adm += (a); \
- ALLOC_PRIM_gds += (g); ALLOC_PRIM_slp += (s); \
- ALLOC_HISTO(PRIM,a,g,s)
-#define ALLOC_PRIM2(w) ALLOC_PRIM_ctr++; ALLOC_PRIM_gds +=(w); \
- ALLOC_HISTO(PRIM,0,w,0)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-enters]{Enters}
-%* *
-%************************************************************************
-
-\begin{code}
-#define ENT_VIA_NODE() ENT_VIA_NODE_ctr++ /* via ENT_ macro */
-
-#define ENT_THK() ENT_THK_ctr++
-#define ENT_FUN_STD() ENT_FUN_STD_ctr++ /* manifest fun; std entry pt */
-
-#define ENT_CON(n) ENTERED_CHECK_UPDATED(n); ENT_CON_ctr++ /* enter code for constructor */
-#define ENT_IND(n) ENTERED_CHECK_UPDATED(n); ENT_IND_ctr++ /* enter indirection */
-#define ENT_PAP(n) ENTERED_CHECK_UPDATED(n); ENT_PAP_ctr++ /* enter partial application */
-\end{code}
-
-We do more magical things with @ENT_FUN_DIRECT@. Besides simply knowing
-how many ``fast-entry-point'' enters there were, we'd like {\em simple}
-information about where those enters were, and the properties thereof.
-\begin{code}
-struct ent_counter {
- unsigned registeredp:16, /* 0 == no, 1 == yes */
- arity:16, /* arity (static info) */
- Astk_args:16, /* # of args off A stack */
- Bstk_args:16; /* # of args off B stack */
- /* (rest of args are in registers) */
- StgChar *f_str; /* name of the thing */
- StgChar *f_arg_kinds; /* info about the args types */
- StgChar *wrap_str; /* name of its wrapper (if any) */
- StgChar *wrap_arg_kinds;/* info about the orig wrapper's arg types */
- I_ ctr; /* the actual counter */
- struct ent_counter *link; /* link to chain them all together */
-};
-
-/* OLD: extern void RegisterEntryPt PROTO((struct ent_counter *)); */
-extern struct ent_counter *ListOfEntryCtrs;
-
-#define ENT_FUN_DIRECT(f_ct,f_str,f_arity,Aargs,Bargs,arg_kinds,wrap,wrap_kinds) \
- { \
- static struct ent_counter f_ct \
- = { 0, \
- (f_arity), (Aargs), (Bargs), (f_str), (arg_kinds),\
- (wrap), (wrap_kinds), \
- 0, NULL }; \
- if ( ! f_ct.registeredp ) { \
- /* hook this one onto the front of the list */ \
- f_ct.link = ListOfEntryCtrs; \
- ListOfEntryCtrs = & (f_ct); \
- \
- /* mark it as "registered" */ \
- f_ct.registeredp = 1; \
- } \
- f_ct.ctr += 1; \
- } \
- ENT_FUN_DIRECT_ctr++ /* the old boring one */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-returns]{Returns}
-%* *
-%************************************************************************
-
-Whenever a ``return'' occurs, it is returning the constituent parts of
-a data constructor. The parts can be returned either in registers, or
-by allocating some heap to put it in (the @ALLOC_*@ macros account for
-the allocation). The constructor can either be an existing one
-(\tr{*OLD*}) or we could have {\em just} figured out this stuff
-(\tr{*NEW*}).
-
-Here's some special magic that Simon wants [edited to match names
-actually used]:
-\begin{display}
-From: Simon L Peyton Jones <simonpj>
-To: partain, simonpj
-Subject: counting updates
-Date: Wed, 25 Mar 92 08:39:48 +0000
-
-I'd like to count how many times we update in place when actually Node
-points to the thing. Here's how:
-
-\tr{RET_OLD_IN_REGS} sets the variable \tr{ReturnInRegsNodeValid} to \tr{True};
-\tr{RET_NEW_IN_REGS} sets it to \tr{False}.
-
-\tr{RET_SEMI_???} sets it to??? ToDo [WDP]
-
-\tr{UPD_CON_IN_PLACE} tests the variable, and increments \tr{UPD_IN_PLACE_COPY_ctr}
-if it is true.
-
-Then we need to report it along with the update-in-place info.
-\end{display}
-
-\begin{code}
-#define RET_HISTO(categ,n,offset) \
- { I_ __idx; \
- __idx = (n) - (offset); \
- CAT3(RET_,categ,_hst)[((__idx > 8) ? 8 : __idx)] += 1;}
-
-/* "slide" histogramming by (__STG_REGS_AVAIL__ - 1) -- usually 7 --
- so we do not collect lots and lots of useless zeros for _IN_HEAP.
- WDP 95/11
-*/
-#define RET_NEW_IN_HEAP(n) RET_NEW_IN_HEAP_ctr++; \
- RET_HISTO(NEW_IN_HEAP,n,__STG_REGS_AVAIL__ - 1)
-#define RET_OLD_IN_HEAP(n) RET_OLD_IN_HEAP_ctr++; \
- RET_HISTO(OLD_IN_HEAP,n,__STG_REGS_AVAIL__ - 1)
-#define RET_SEMI_IN_HEAP(n) RET_SEMI_IN_HEAP_ctr++; \
- RET_HISTO(SEMI_IN_HEAP,n,__STG_REGS_AVAIL__ - 1)
-
-#define RET_NEW_IN_REGS(n) RET_NEW_IN_REGS_ctr++; \
- ReturnInRegsNodeValid = 0; \
- RET_HISTO(NEW_IN_REGS,n,0)
-#define RET_OLD_IN_REGS(n) RET_OLD_IN_REGS_ctr++; \
- ReturnInRegsNodeValid = 1; \
- RET_HISTO(OLD_IN_REGS,n,0)
-#define RET_SEMI_IN_REGS(n,u) RET_SEMI_IN_REGS_ctr++; \
- RET_SEMI_loads_avoided += ((n) - (u)); \
- RET_HISTO(SEMI_IN_REGS,u,0)
-
-#define RET_SEMI_BY_DEFAULT()/*???*/ RET_SEMI_BY_DEFAULT_ctr++
-
-#define RET_SEMI_FAILED(tag) do { \
- if ((tag) == INFO_IND_TAG) \
- RET_SEMI_FAILED_IND_ctr++; \
- else \
- RET_SEMI_FAILED_UNEVAL_ctr++; \
- } while (0)
-
-\end{code}
-
-Of all the returns (sum of four categories above), how many were
-vectored? (The rest were obviously unvectored).
-\begin{code}
-#define VEC_RETURN(n) VEC_RETURN_ctr++; \
- RET_HISTO(VEC_RETURN,n,0)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-update-frames]{Update frames}
-%* *
-%************************************************************************
-
-These macros count up the following update information.
-
-%partain:\begin{center}
-\begin{tabular}{ll} \hline
-Macro & Counts \\ \hline
- & \\
-\tr{UPDF_STD_PUSHED} & Update frame pushed \\
-\tr{UPDF_CON_PUSHED} & Constructor update frame pushed \\
-\tr{UPDF_HOLE_PUSHED} & An update frame to update a black hole \\
-\tr{UPDF_OMITTED} & A thunk decided not to push an update frame \\
- & (all subsets of \tr{ENT_THK}) \\
-\tr{UPDF_RCC_PUSHED} & Cost Centre restore frame pushed \\
-\tr{UPDF_RCC_OMITTED} & Cost Centres not required -- not pushed \\\hline
-\end{tabular}
-%partain:\end{center}
-
-\begin{code}
-#define UPDF_OMITTED() UPDF_OMITTED_ctr++
-
-#define UPDF_STD_PUSHED() UPDF_STD_PUSHED_ctr++
-#define UPDF_CON_PUSHED() UPDF_CON_PUSHED_ctr++
-#define UPDF_HOLE_PUSHED() UPDF_HOLE_PUSHED_ctr++
-
-#define UPDF_RCC_PUSHED() UPDF_RCC_PUSHED_ctr++
-#define UPDF_RCC_OMITTED() UPDF_RCC_OMITTED_ctr++
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-updates]{Updates}
-%* *
-%************************************************************************
-
-These macros record information when we do an update. We always
-update either with a data constructor (CON) or a partial application
-(PAP).
-
-%partain:\begin{center}
-\begin{tabular}{|l|l|}\hline
-Macro & Where \\ \hline
- & \\
-\tr{UPD_EXISTING} & Updating with an indirection to something \\
- & already in the heap \\
-\tr{UPD_SQUEEZED} & Same as \tr{UPD_EXISTING} but because \\
- & of stack-squeezing \\
-\tr{UPD_CON_W_NODE} & Updating with a CON: by indirecting to Node \\
-\tr{UPD_CON_IN_PLACE} & Ditto, but in place \\
-\tr{UPD_CON_IN_NEW} & Ditto, but allocating the object \\
-\tr{UPD_PAP_IN_PLACE} & Same, but updating w/ a PAP \\
-\tr{UPD_PAP_IN_NEW} & \\\hline
-\end{tabular}
-%partain:\end{center}
-
-\begin{code}
-#define UPD_HISTO(categ,n) \
- { I_ __idx; \
- __idx = (n); \
- CAT3(UPD_,categ,_hst)[((__idx > 8) ? 8 : __idx)] += 1;}
-
-#define UPD_EXISTING() UPD_EXISTING_ctr++
-#define UPD_SQUEEZED() UPD_SQUEEZED_ctr++
-
-#define UPD_CON_W_NODE() UPD_CON_W_NODE_ctr++
-
-#define UPD_CON_IN_NEW(n) UPD_CON_IN_NEW_ctr++ ; \
- UPD_HISTO(CON_IN_NEW,n)
-#define UPD_PAP_IN_NEW(n) UPD_PAP_IN_NEW_ctr++ ; \
- UPD_HISTO(PAP_IN_NEW,n)
-/* ToDo: UPD_NEW_COPY_ctr, as below */
-
-#define UPD_CON_IN_PLACE(n) UPD_CON_IN_PLACE_ctr++ ; \
- UPD_IN_PLACE_COPY_ctr += ReturnInRegsNodeValid ; \
- /* increments if True; otherwise, no */ \
- UPD_HISTO(CON_IN_PLACE,n)
-#define UPD_PAP_IN_PLACE() UPD_PAP_IN_PLACE_ctr++ ; \
- UPD_IN_PLACE_COPY_ctr += ReturnInRegsNodeValid
- /* increments if True; otherwise, no */
-\end{code}
-
-For a generational collector:
-\begin{code}
-#define UPD_NEW_IND() UPD_NEW_IND_ctr++;
-#define UPD_NEW_IN_PLACE_PTRS() UPD_NEW_IN_PLACE_PTRS_ctr++;
-#define UPD_NEW_IN_PLACE_NOPTRS() UPD_NEW_IN_PLACE_NOPTRS_ctr++;
-#define UPD_OLD_IND() UPD_OLD_IND_ctr++;
-#define UPD_OLD_IN_PLACE_PTRS() UPD_OLD_IN_PLACE_PTRS_ctr++;
-#define UPD_OLD_IN_PLACE_NOPTRS() UPD_OLD_IN_PLACE_NOPTRS_ctr++;
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-selectors]{Doing selectors at GC time}
-%* *
-%************************************************************************
-
-@GC_SEL_ABANDONED@: we could've done the selection, but we gave up
-(e.g., to avoid overflowing the C stack); @GC_SEL_MINOR@: did a
-selection in a minor GC; @GC_SEL_MAJOR@: ditto, but major GC.
-
-\begin{code}
-#define GC_SEL_ABANDONED() GC_SEL_ABANDONED_ctr++;
-#define GC_SEL_MINOR() GC_SEL_MINOR_ctr++;
-#define GC_SEL_MAJOR() GC_SEL_MAJOR_ctr++;
-
-#define GC_SHORT_IND() GC_SHORT_IND_ctr++;
-#define GC_SHORT_CAF() GC_SHORT_CAF_ctr++;
-#define GC_COMMON_CHARLIKE() GC_COMMON_CHARLIKE_ctr++;
-#define GC_COMMON_INTLIKE() GC_COMMON_INTLIKE_ctr++;
-#define GC_COMMON_INTLIKE_FAIL() GC_COMMON_INTLIKE_FAIL_ctr++;
-#define GC_COMMON_CONST() GC_COMMON_CONST_ctr++;
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[ticky-counters]{The accumulators (extern decls)}
-%* *
-%************************************************************************
-
-\begin{code}
-extern I_ ALLOC_HEAP_ctr;
-extern I_ ALLOC_HEAP_tot;
-
-extern PP_ max_SpA;
-extern P_ max_SpB;
-
-extern I_ A_STK_STUB_ctr;
-/* not used at all?
-extern I_ A_STK_REUSE_ctr;
-extern I_ B_STK_REUSE_ctr;
-*/
-
-extern I_ ALLOC_FUN_ctr;
-extern I_ ALLOC_FUN_adm;
-extern I_ ALLOC_FUN_gds;
-extern I_ ALLOC_FUN_slp;
-extern I_ ALLOC_FUN_hst[5];
-extern I_ ALLOC_THK_ctr;
-extern I_ ALLOC_THK_adm;
-extern I_ ALLOC_THK_gds;
-extern I_ ALLOC_THK_slp;
-extern I_ ALLOC_THK_hst[5];
-extern I_ ALLOC_CON_ctr;
-extern I_ ALLOC_CON_adm;
-extern I_ ALLOC_CON_gds;
-extern I_ ALLOC_CON_slp;
-extern I_ ALLOC_CON_hst[5];
-extern I_ ALLOC_TUP_ctr;
-extern I_ ALLOC_TUP_adm;
-extern I_ ALLOC_TUP_gds;
-extern I_ ALLOC_TUP_slp;
-extern I_ ALLOC_TUP_hst[5];
-extern I_ ALLOC_BH_ctr;
-extern I_ ALLOC_BH_adm;
-extern I_ ALLOC_BH_gds;
-extern I_ ALLOC_BH_slp;
-extern I_ ALLOC_BH_hst[5];
-/*
-extern I_ ALLOC_PAP_ctr;
-extern I_ ALLOC_PAP_adm;
-extern I_ ALLOC_PAP_gds;
-extern I_ ALLOC_PAP_slp;
-extern I_ ALLOC_PAP_hst[5];
-*/
-/*
-extern I_ ALLOC_UPD_CON_ctr;
-extern I_ ALLOC_UPD_CON_adm;
-extern I_ ALLOC_UPD_CON_gds;
-extern I_ ALLOC_UPD_CON_slp;
-extern I_ ALLOC_UPD_CON_hst[5];
-*/
-extern I_ ALLOC_UPD_PAP_ctr;
-extern I_ ALLOC_UPD_PAP_adm;
-extern I_ ALLOC_UPD_PAP_gds;
-extern I_ ALLOC_UPD_PAP_slp;
-extern I_ ALLOC_UPD_PAP_hst[5];
-extern I_ ALLOC_PRIM_ctr;
-extern I_ ALLOC_PRIM_adm;
-extern I_ ALLOC_PRIM_gds;
-extern I_ ALLOC_PRIM_slp;
-extern I_ ALLOC_PRIM_hst[5];
-
-#ifdef CONCURRENT
-extern I_ ALLOC_STK_ctr;
-extern I_ ALLOC_STK_adm;
-extern I_ ALLOC_STK_gds;
-extern I_ ALLOC_STK_slp;
-extern I_ ALLOC_STK_hst[5];
-extern I_ ALLOC_TSO_ctr;
-extern I_ ALLOC_TSO_adm;
-extern I_ ALLOC_TSO_gds;
-extern I_ ALLOC_TSO_slp;
-extern I_ ALLOC_TSO_hst[5];
-#ifdef PAR
-extern I_ ALLOC_FMBQ_ctr;
-extern I_ ALLOC_FMBQ_adm;
-extern I_ ALLOC_FMBQ_gds;
-extern I_ ALLOC_FMBQ_slp;
-extern I_ ALLOC_FMBQ_hst[5];
-extern I_ ALLOC_FME_ctr;
-extern I_ ALLOC_FME_adm;
-extern I_ ALLOC_FME_gds;
-extern I_ ALLOC_FME_slp;
-extern I_ ALLOC_FME_hst[5];
-extern I_ ALLOC_BF_ctr;
-extern I_ ALLOC_BF_adm;
-extern I_ ALLOC_BF_gds;
-extern I_ ALLOC_BF_slp;
-extern I_ ALLOC_BF_hst[5];
-#endif
-#endif
-
-extern I_ ENT_VIA_NODE_ctr;
-
-extern I_ ENT_CON_ctr;
-extern I_ ENT_FUN_STD_ctr;
-extern I_ ENT_FUN_DIRECT_ctr;
-extern I_ ENT_IND_ctr;
-extern I_ ENT_PAP_ctr;
-extern I_ ENT_THK_ctr;
-
-extern I_ UPD_ENTERED_hst[9];
-
-extern I_ RET_NEW_IN_HEAP_ctr;
-extern I_ RET_NEW_IN_REGS_ctr;
-extern I_ RET_OLD_IN_HEAP_ctr;
-extern I_ RET_OLD_IN_REGS_ctr;
-extern I_ RET_SEMI_BY_DEFAULT_ctr;
-extern I_ RET_SEMI_IN_HEAP_ctr;
-extern I_ RET_SEMI_IN_REGS_ctr;
-extern I_ VEC_RETURN_ctr;
-
-extern I_ RET_SEMI_FAILED_IND_ctr;
-extern I_ RET_SEMI_FAILED_UNEVAL_ctr;
-
-extern I_ RET_SEMI_loads_avoided;
-
-extern I_ RET_NEW_IN_HEAP_hst[9];
-extern I_ RET_NEW_IN_REGS_hst[9];
-extern I_ RET_OLD_IN_HEAP_hst[9];
-extern I_ RET_OLD_IN_REGS_hst[9];
-/*no such thing: extern I_ RET_SEMI_BY_DEFAULT_hst[9]; */
-extern I_ RET_SEMI_IN_HEAP_hst[9];
-extern I_ RET_SEMI_IN_REGS_hst[9];
-extern I_ RET_VEC_RETURN_hst[9];
-
-extern I_ ReturnInRegsNodeValid; /* see below */
-
-extern I_ UPDF_OMITTED_ctr;
-extern I_ UPDF_STD_PUSHED_ctr;
-extern I_ UPDF_CON_PUSHED_ctr;
-extern I_ UPDF_HOLE_PUSHED_ctr;
-
-extern I_ UPDF_RCC_PUSHED_ctr;
-extern I_ UPDF_RCC_OMITTED_ctr;
-
-extern I_ UPD_EXISTING_ctr;
-extern I_ UPD_SQUEEZED_ctr;
-extern I_ UPD_CON_W_NODE_ctr;
-extern I_ UPD_CON_IN_PLACE_ctr;
-extern I_ UPD_PAP_IN_PLACE_ctr;
-extern I_ UPD_CON_IN_NEW_ctr;
-extern I_ UPD_PAP_IN_NEW_ctr;
-
-extern I_ UPD_CON_IN_PLACE_hst[9];
-extern I_ UPD_CON_IN_NEW_hst[9];
-extern I_ UPD_PAP_IN_NEW_hst[9];
-
-extern I_ UPD_NEW_IND_ctr;
-extern I_ UPD_NEW_IN_PLACE_PTRS_ctr;
-extern I_ UPD_NEW_IN_PLACE_NOPTRS_ctr;
-extern I_ UPD_OLD_IND_ctr;
-extern I_ UPD_OLD_IN_PLACE_PTRS_ctr;
-extern I_ UPD_OLD_IN_PLACE_NOPTRS_ctr;
-
-extern I_ UPD_IN_PLACE_COPY_ctr; /* see below */
-
-extern I_ GC_SEL_ABANDONED_ctr;
-extern I_ GC_SEL_MINOR_ctr;
-extern I_ GC_SEL_MAJOR_ctr;
-extern I_ GC_SHORT_IND_ctr;
-extern I_ GC_SHORT_CAF_ctr;
-extern I_ GC_COMMON_CHARLIKE_ctr;
-extern I_ GC_COMMON_INTLIKE_ctr;
-extern I_ GC_COMMON_INTLIKE_FAIL_ctr;
-extern I_ GC_COMMON_CONST_ctr;
-
-#endif /* TICKY_TICKY */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Ticky-nonmacros]{Un-macros for ``none of the above''}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifndef TICKY_TICKY
-
-#define ALLOC_HEAP(n) /* nothing */
-#define UN_ALLOC_HEAP(n) /* nothing */
-#define DO_ASTK_HWM() /* nothing */
-#define DO_BSTK_HWM() /* nothing */
-
-#define A_STK_STUB(n) /* nothing */
-#define A_STK_REUSE(n) /* not used at all */
-#define B_STK_REUSE(n) /* not used at all */
-
-#define ALLOC_FUN(a,g,s,t) /* nothing */
-#define ALLOC_THK(a,g,s,t) /* nothing */
-#define ALLOC_CON(a,g,s,t) /* nothing */
-#define ALLOC_TUP(a,g,s,t) /* nothing */
-#define ALLOC_BH(a,g,s,t) /* nothing */
-/*#define ALLOC_PAP(a,g,s,t) /? nothing */
-#define ALLOC_PRIM(a,g,s,t) /* nothing */
-#define ALLOC_PRIM2(w) /* nothing */
-#define ALLOC_UPD_PAP(a,g,s,t) /* nothing */
-/*#define ALLOC_UPD_CON(a,g,s,t) /? nothing */
-#define ALLOC_STK(a,g,s) /* nothing */
-#define ALLOC_TSO(a,g,s) /* nothing */
-#define ALLOC_FMBQ(a,g,s) /* nothing */
-#define ALLOC_FME(a,g,s) /* nothing */
-#define ALLOC_BF(a,g,s) /* nothing */
-
-#define ENT_VIA_NODE() /* nothing */
-#define ENT_THK() /* nothing */
-#define ENT_FUN_STD() /* nothing */
-#define ENT_FUN_DIRECT(f,f_str,f_arity,Aargs,Bargs,arg_kinds,wrap,wrap_kinds) \
- /* nothing */
-#define ENT_CON(n) /* nothing */
-#define ENT_IND(n) /* nothing */
-#define ENT_PAP(n) /* nothing */
-
-#define RET_NEW_IN_HEAP(n) /* nothing */
-#define RET_NEW_IN_REGS(n) /* nothing */
-#define RET_OLD_IN_HEAP(n) /* nothing */
-#define RET_OLD_IN_REGS(n) /* nothing */
-#define RET_SEMI_BY_DEFAULT() /* nothing */
-#define RET_SEMI_IN_HEAP(n) /* nothing */
-#define RET_SEMI_IN_REGS(n,u) /* nothing */
-#define RET_SEMI_FAILED(t) /* nothing */
-#define VEC_RETURN(n) /* nothing */
-
-#define UPDF_OMITTED() /* nothing */
-#define UPDF_STD_PUSHED() /* nothing */
-#define UPDF_CON_PUSHED() /* nothing */
-#define UPDF_HOLE_PUSHED() /* nothing */
-
-#define UPDF_RCC_PUSHED() /* nothing */
-#define UPDF_RCC_OMITTED() /* nothing */
-
-#define UPD_EXISTING() /* nothing */
-#define UPD_SQUEEZED() /* nothing */
-#define UPD_CON_W_NODE() /* nothing */
-#define UPD_CON_IN_PLACE(n) /* nothing */
-#define UPD_PAP_IN_PLACE() /* nothing */
-#define UPD_CON_IN_NEW(n) /* nothing */
-#define UPD_PAP_IN_NEW(n) /* nothing */
-
-#define GC_SEL_ABANDONED() /* nothing */
-#define GC_SEL_MINOR() /* nothing */
-#define GC_SEL_MAJOR() /* nothing */
-
-#define GC_SHORT_IND() /* nothing */
-#define GC_SHORT_CAF() /* nothing */
-#define GC_COMMON_CHARLIKE() /* nothing */
-#define GC_COMMON_INTLIKE() /* nothing */
-#define GC_COMMON_INTLIKE_FAIL()/* nothing */
-#define GC_COMMON_CONST() /* nothing */
-\end{code}
-
-For a generational collector:
-\begin{code}
-#define UPD_NEW_IND() /* nothing */
-#define UPD_NEW_IN_PLACE_PTRS() /* nothing */
-#define UPD_NEW_IN_PLACE_NOPTRS() /* nothing */
-#define UPD_OLD_IND() /* nothing */
-#define UPD_OLD_IN_PLACE_PTRS() /* nothing */
-#define UPD_OLD_IN_PLACE_NOPTRS() /* nothing */
-
-#endif /* <none-of-the-above> */
-\end{code}
-
-End of file multi-slurp protection:
-\begin{code}
-#endif /* ! TICKY_H */
-\end{code}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Updates.h,v 1.2 1998/12/02 13:21:47 simonm Exp $
+ *
+ * Definitions related to updates.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef UPDATES_H
+#define UPDATES_H
+
+/*
+ ticky-ticky wants to use permanent indirections when it's doing
+ update entry counts.
+ */
+
+#ifndef TICKY_TICKY
+# define Ind_info_TO_USE &IND_info
+#else
+# define Ind_info_TO_USE ((AllFlags.doUpdEntryCounts) ? &IND_PERM_info : &IND_info
+)
+#endif
+
+/* -----------------------------------------------------------------------------
+ Update a closure with an indirection. This may also involve waking
+ up a queue of blocked threads waiting on the result of this
+ computation.
+ -------------------------------------------------------------------------- */
+
+/* ToDo: overwrite slop words with something safe in case sanity checking
+ * is turned on.
+ * (I think the fancy version of the GC is supposed to do this too.)
+ */
+
+#define UPD_IND(updclosure, heapptr) \
+ TICK_UPDATED_SET_UPDATED(updclosure); \
+ AWAKEN_BQ(updclosure); \
+ SET_INFO((StgInd*)updclosure,Ind_info_TO_USE); \
+ ((StgInd *)updclosure)->indirectee = (StgClosure *)(heapptr)
+
+/* -----------------------------------------------------------------------------
+ Update a closure inplace with an infotable that expects 1 (closure)
+ argument.
+ Also may wake up BQs.
+ -------------------------------------------------------------------------- */
+
+#define UPD_INPLACE1(updclosure,info,c0) \
+ TICK_UPDATED_SET_UPDATED(updclosure); \
+ AWAKEN_BQ(updclosure); \
+ SET_INFO(updclosure,info); \
+ payloadCPtr(updclosure,0) = (c0)
+
+/* -----------------------------------------------------------------------------
+ Awaken any threads waiting on this computation
+ -------------------------------------------------------------------------- */
+
+extern void awaken_blocked_queue(StgTSO *q);
+
+#define AWAKEN_BQ(closure) \
+ if (closure->header.info == &BLACKHOLE_info) { \
+ StgTSO *bq = ((StgBlackHole *)closure)->blocking_queue; \
+ if (bq != (StgTSO *)&END_TSO_QUEUE_closure) { \
+ STGCALL1(awaken_blocked_queue, bq); \
+ } \
+ }
+
+
+/* -----------------------------------------------------------------------------
+ Push an update frame on the stack.
+ -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#define PUSH_STD_CCCS(frame) frame->header.prof.ccs = CCCS
+#else
+#define PUSH_STD_CCCS(frame)
+#endif
+
+extern const StgPolyInfoTable Upd_frame_info;
+
+#define PUSH_UPD_FRAME(target, Sp_offset) \
+ { \
+ StgUpdateFrame *__frame; \
+ TICK_UPDF_PUSHED(); \
+ __frame = stgCast(StgUpdateFrame*,Sp + (Sp_offset)) - 1; \
+ SET_INFO(__frame,stgCast(StgInfoTable*,&Upd_frame_info)); \
+ __frame->link = Su; \
+ __frame->updatee = (StgClosure *)(target); \
+ PUSH_STD_CCCS(__frame); \
+ Su = __frame; \
+ }
+
+/* -----------------------------------------------------------------------------
+ Entering CAFs
+
+ When a CAF is first entered, it creates a black hole in the heap,
+ and updates itself with an indirection to this new black hole.
+
+ We update the CAF with an indirection to a newly-allocated black
+ hole in the heap. We also set the blocking queue on the newly
+ allocated black hole to be empty.
+
+ Why do we make a black hole in the heap when we enter a CAF?
+
+ - for a generational garbage collector, which needs a fast
+ test for whether an updatee is in an old generation or not
+
+ - for the parallel system, which can implement updates more
+ easily if the updatee is always in the heap. (allegedly).
+ -------------------------------------------------------------------------- */
+
+EI_(Caf_info);
+EF_(Caf_entry);
+
+/* ToDo: only call newCAF when debugging. */
+
+extern void newCAF(StgClosure*);
+
+#define UPD_CAF(cafptr, bhptr) \
+ { \
+ SET_INFO((StgInd *)cafptr,&IND_STATIC_info); \
+ ((StgInd *)cafptr)->indirectee = (StgClosure *)(bhptr); \
+ ((StgBlackHole *)(bhptr))->blocking_queue = \
+ (StgTSO *)&END_TSO_QUEUE_closure; \
+ STGCALL1(newCAF,(StgClosure *)cafptr); \
+ }
+
+/* -----------------------------------------------------------------------------
+ Update-related prototypes
+ -------------------------------------------------------------------------- */
+
+extern STGFUN(Upd_frame_entry);
+
+extern const StgInfoTable PAP_info;
+STGFUN(PAP_entry);
+
+EXTFUN(stg_update_PAP);
+
+extern const StgInfoTable AP_UPD_info;
+STGFUN(AP_UPD_entry);
+
+extern const StgInfoTable raise_info;
+
+#endif /* UPDATES_H */
+++ /dev/null
-%!PS-Adobe-2.0 EPSF-1.2
-%%DocumentFonts: Times-Roman
-%%Pages: 1
-%%BoundingBox: 156 420 403 620
-%%EndComments
-
-50 dict begin
-
-/arrowHeight 8 def
-/arrowWidth 4 def
-/none null def
-/numGraphicParameters 17 def
-/stringLimit 65535 def
-
-/Begin {
-save
-numGraphicParameters dict begin
-} def
-
-/End {
-end
-restore
-} def
-
-/SetB {
-dup type /nulltype eq {
-pop
-false /brushRightArrow idef
-false /brushLeftArrow idef
-true /brushNone idef
-} {
-/brushDashOffset idef
-/brushDashArray idef
-0 ne /brushRightArrow idef
-0 ne /brushLeftArrow idef
-/brushWidth idef
-false /brushNone idef
-} ifelse
-} def
-
-/SetCFg {
-/fgblue idef
-/fggreen idef
-/fgred idef
-} def
-
-/SetCBg {
-/bgblue idef
-/bggreen idef
-/bgred idef
-} def
-
-/SetF {
-/printSize idef
-/printFont idef
-} def
-
-/SetP {
-dup type /nulltype eq {
-pop true /patternNone idef
-} {
-dup -1 eq {
-/patternGrayLevel idef
-/patternString idef
-} {
-/patternGrayLevel idef
-} ifelse
-false /patternNone idef
-} ifelse
-} def
-
-/BSpl {
-0 begin
-storexyn
-newpath
-n 1 gt {
-0 0 0 0 0 0 1 1 true subspline
-n 2 gt {
-0 0 0 0 1 1 2 2 false subspline
-1 1 n 3 sub {
-/i exch def
-i 1 sub dup i dup i 1 add dup i 2 add dup false subspline
-} for
-n 3 sub dup n 2 sub dup n 1 sub dup 2 copy false subspline
-} if
-n 2 sub dup n 1 sub dup 2 copy 2 copy false subspline
-patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if
-brushNone not { istroke } if
-0 0 1 1 leftarrow
-n 2 sub dup n 1 sub dup rightarrow
-} if
-end
-} dup 0 4 dict put def
-
-/Circ {
-newpath
-0 360 arc
-patternNone not { ifill } if
-brushNone not { istroke } if
-} def
-
-/CBSpl {
-0 begin
-dup 2 gt {
-storexyn
-newpath
-n 1 sub dup 0 0 1 1 2 2 true subspline
-1 1 n 3 sub {
-/i exch def
-i 1 sub dup i dup i 1 add dup i 2 add dup false subspline
-} for
-n 3 sub dup n 2 sub dup n 1 sub dup 0 0 false subspline
-n 2 sub dup n 1 sub dup 0 0 1 1 false subspline
-patternNone not { ifill } if
-brushNone not { istroke } if
-} {
-Poly
-} ifelse
-end
-} dup 0 4 dict put def
-
-/Elli {
-0 begin
-newpath
-4 2 roll
-translate
-scale
-0 0 1 0 360 arc
-patternNone not { ifill } if
-brushNone not { istroke } if
-end
-} dup 0 1 dict put def
-
-/Line {
-0 begin
-2 storexyn
-newpath
-x 0 get y 0 get moveto
-x 1 get y 1 get lineto
-brushNone not { istroke } if
-0 0 1 1 leftarrow
-0 0 1 1 rightarrow
-end
-} dup 0 4 dict put def
-
-/MLine {
-0 begin
-storexyn
-newpath
-n 1 gt {
-x 0 get y 0 get moveto
-1 1 n 1 sub {
-/i exch def
-x i get y i get lineto
-} for
-patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if
-brushNone not { istroke } if
-0 0 1 1 leftarrow
-n 2 sub dup n 1 sub dup rightarrow
-} if
-end
-} dup 0 4 dict put def
-
-/Poly {
-3 1 roll
-newpath
-moveto
--1 add
-{ lineto } repeat
-closepath
-patternNone not { ifill } if
-brushNone not { istroke } if
-} def
-
-/Rect {
-0 begin
-/t exch def
-/r exch def
-/b exch def
-/l exch def
-newpath
-l b moveto
-l t lineto
-r t lineto
-r b lineto
-closepath
-patternNone not { ifill } if
-brushNone not { istroke } if
-end
-} dup 0 4 dict put def
-
-/Text {
-ishow
-} def
-
-/idef {
-dup where { pop pop pop } { exch def } ifelse
-} def
-
-/ifill {
-0 begin
-gsave
-patternGrayLevel -1 ne {
-fgred bgred fgred sub patternGrayLevel mul add
-fggreen bggreen fggreen sub patternGrayLevel mul add
-fgblue bgblue fgblue sub patternGrayLevel mul add setrgbcolor
-eofill
-} {
-eoclip
-originalCTM setmatrix
-pathbbox /t exch def /r exch def /b exch def /l exch def
-/w r l sub ceiling cvi def
-/h t b sub ceiling cvi def
-/imageByteWidth w 8 div ceiling cvi def
-/imageHeight h def
-bgred bggreen bgblue setrgbcolor
-eofill
-fgred fggreen fgblue setrgbcolor
-w 0 gt h 0 gt and {
-l b translate w h scale
-w h true [w 0 0 h neg 0 h] { patternproc } imagemask
-} if
-} ifelse
-grestore
-end
-} dup 0 8 dict put def
-
-/istroke {
-gsave
-brushDashOffset -1 eq {
-[] 0 setdash
-1 setgray
-} {
-brushDashArray brushDashOffset setdash
-fgred fggreen fgblue setrgbcolor
-} ifelse
-brushWidth setlinewidth
-originalCTM setmatrix
-stroke
-grestore
-} def
-
-/ishow {
-0 begin
-gsave
-fgred fggreen fgblue setrgbcolor
-/fontDict printFont findfont printSize scalefont dup setfont def
-/descender fontDict begin 0 [FontBBox] 1 get FontMatrix end
-transform exch pop def
-/vertoffset 0 descender sub printSize sub printFont /Courier ne
-printFont /Courier-Bold ne and { 1 add } if def {
-0 vertoffset moveto show
-/vertoffset vertoffset printSize sub def
-} forall
-grestore
-end
-} dup 0 3 dict put def
-
-/patternproc {
-0 begin
-/patternByteLength patternString length def
-/patternHeight patternByteLength 8 mul sqrt cvi def
-/patternWidth patternHeight def
-/patternByteWidth patternWidth 8 idiv def
-/imageByteMaxLength imageByteWidth imageHeight mul
-stringLimit patternByteWidth sub min def
-/imageMaxHeight imageByteMaxLength imageByteWidth idiv patternHeight idiv
-patternHeight mul patternHeight max def
-/imageHeight imageHeight imageMaxHeight sub store
-/imageString imageByteWidth imageMaxHeight mul patternByteWidth add string def
-0 1 imageMaxHeight 1 sub {
-/y exch def
-/patternRow y patternByteWidth mul patternByteLength mod def
-/patternRowString patternString patternRow patternByteWidth getinterval def
-/imageRow y imageByteWidth mul def
-0 patternByteWidth imageByteWidth 1 sub {
-/x exch def
-imageString imageRow x add patternRowString putinterval
-} for
-} for
-imageString
-end
-} dup 0 12 dict put def
-
-/min {
-dup 3 2 roll dup 4 3 roll lt { exch } if pop
-} def
-
-/max {
-dup 3 2 roll dup 4 3 roll gt { exch } if pop
-} def
-
-/arrowhead {
-0 begin
-transform originalCTM itransform
-/taily exch def
-/tailx exch def
-transform originalCTM itransform
-/tipy exch def
-/tipx exch def
-/dy tipy taily sub def
-/dx tipx tailx sub def
-/angle dx 0 ne dy 0 ne or { dy dx atan } { 90 } ifelse def
-gsave
-originalCTM setmatrix
-tipx tipy translate
-angle rotate
-newpath
-0 0 moveto
-arrowHeight neg arrowWidth 2 div lineto
-arrowHeight neg arrowWidth 2 div neg lineto
-closepath
-patternNone not {
-originalCTM setmatrix
-/padtip arrowHeight 2 exp 0.25 arrowWidth 2 exp mul add sqrt brushWidth mul
-arrowWidth div def
-/padtail brushWidth 2 div def
-tipx tipy translate
-angle rotate
-padtip 0 translate
-arrowHeight padtip add padtail add arrowHeight div dup scale
-arrowheadpath
-ifill
-} if
-brushNone not {
-originalCTM setmatrix
-tipx tipy translate
-angle rotate
-arrowheadpath
-istroke
-} if
-grestore
-end
-} dup 0 9 dict put def
-
-/arrowheadpath {
-newpath
-0 0 moveto
-arrowHeight neg arrowWidth 2 div lineto
-arrowHeight neg arrowWidth 2 div neg lineto
-closepath
-} def
-
-/leftarrow {
-0 begin
-y exch get /taily exch def
-x exch get /tailx exch def
-y exch get /tipy exch def
-x exch get /tipx exch def
-brushLeftArrow { tipx tipy tailx taily arrowhead } if
-end
-} dup 0 4 dict put def
-
-/rightarrow {
-0 begin
-y exch get /tipy exch def
-x exch get /tipx exch def
-y exch get /taily exch def
-x exch get /tailx exch def
-brushRightArrow { tipx tipy tailx taily arrowhead } if
-end
-} dup 0 4 dict put def
-
-/midpoint {
-0 begin
-/y1 exch def
-/x1 exch def
-/y0 exch def
-/x0 exch def
-x0 x1 add 2 div
-y0 y1 add 2 div
-end
-} dup 0 4 dict put def
-
-/thirdpoint {
-0 begin
-/y1 exch def
-/x1 exch def
-/y0 exch def
-/x0 exch def
-x0 2 mul x1 add 3 div
-y0 2 mul y1 add 3 div
-end
-} dup 0 4 dict put def
-
-/subspline {
-0 begin
-/movetoNeeded exch def
-y exch get /y3 exch def
-x exch get /x3 exch def
-y exch get /y2 exch def
-x exch get /x2 exch def
-y exch get /y1 exch def
-x exch get /x1 exch def
-y exch get /y0 exch def
-x exch get /x0 exch def
-x1 y1 x2 y2 thirdpoint
-/p1y exch def
-/p1x exch def
-x2 y2 x1 y1 thirdpoint
-/p2y exch def
-/p2x exch def
-x1 y1 x0 y0 thirdpoint
-p1x p1y midpoint
-/p0y exch def
-/p0x exch def
-x2 y2 x3 y3 thirdpoint
-p2x p2y midpoint
-/p3y exch def
-/p3x exch def
-movetoNeeded { p0x p0y moveto } if
-p1x p1y p2x p2y p3x p3y curveto
-end
-} dup 0 17 dict put def
-
-/storexyn {
-/n exch def
-/y n array def
-/x n array def
-n 1 sub -1 0 {
-/i exch def
-y i 3 2 roll put
-x i 3 2 roll put
-} for
-} def
-
-%%EndProlog
-
-%I Idraw 7 Grid 5
-
-%%Page: 1 1
-
-Begin
-%I b u
-%I cfg u
-%I cbg u
-%I f u
-%I p u
-%I t
-[ 0.8 0 0 0.8 0 0 ] concat
-/originalCTM matrix currentmatrix def
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 134 274 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Rect
-none SetB %I b n
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 108 196 ] concat
-%I
-176 538 213 575 Rect
-End
-
-Begin %I Rect
-%I b 65535
-1 0 1 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 0.902778 0 0 1 90.7851 197 ] concat
-%I
-120 544 263 569 Rect
-End
-
-Begin %I Rect
-%I b 65535
-1 0 1 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 0.590278 0 0 1 255.973 197 ] concat
-%I
-120 544 263 569 Rect
-End
-
-Begin %I Rect
-none SetB %I b n
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 173 197 ] concat
-%I
-176 538 213 575 Rect
-End
-
-Begin %I Rect
-%I b 65535
-1 0 1 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 0.590278 0 0 1 337.973 197 ] concat
-%I
-120 544 263 569 Rect
-End
-
-Begin %I Rect
-none SetB %I b n
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 255 197 ] concat
-%I
-176 538 213 575 Rect
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 134 173 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 286 546 ] concat
-%I
-[
-(Other Info ...)
-] Text
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 134 197 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 134 300 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 413 758 ] concat
-%I
-[
-(Non Ptr Words)
-] Text
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 343 758 ] concat
-%I
-[
-(Ptr Words)
-] Text
-End
-
-Begin %I Line
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 0.88 118 255.84 ] concat
-%I
-89 556 89 507 Line
-End
-
-Begin %I Line
-%I b 65535
-1 0 1 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-0 SetP
-%I t
-[ 1.2963 0 0 1 92.3731 195 ] concat
-%I
-89 507 138 507 Line
-End
-
-Begin %I Line
-%I b 65535
-1 0 1 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-0 SetP
-%I t
-[ 1 0 0 1 134 196 ] concat
-%I
-182 507 269 507 Line
-End
-
-Begin %I Line
-%I b 65535
-1 0 1 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-0 SetP
-%I t
-[ 1 0 0 1 134 91 ] concat
-%I
-182 507 269 507 Line
-End
-
-Begin %I Line
-%I b 65535
-1 0 1 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-0 SetP
-%I t
-[ 1 0 0 1 134 67 ] concat
-%I
-182 507 269 507 Line
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 416 709 ] concat
-%I
-[
-(Entry Code)
-] Text
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 416 604 ] concat
-%I
-[
-(Evacuation Code)
-] Text
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 416 580 ] concat
-%I
-[
-(Scavenge Code)
-] Text
-End
-
-Begin %I Line
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 134.5 194 ] concat
-%I
-145 519 219 519 Line
-End
-
-Begin %I Line
-%I b 13107
-1 0 0 [2 2 2 2 2 2 2 2] 15 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 254 197 ] concat
-%I
-176 544 213 544 Line
-End
-
-Begin %I Line
-%I b 13107
-1 0 0 [2 2 2 2 2 2 2 2] 15 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 256 222 ] concat
-%I
-176 544 213 544 Line
-End
-
-Begin %I Line
-%I b 13107
-1 0 0 [2 2 2 2 2 2 2 2] 15 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 172 197 ] concat
-%I
-176 544 213 544 Line
-End
-
-Begin %I Line
-%I b 13107
-1 0 0 [2 2 2 2 2 2 2 2] 15 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 174 222 ] concat
-%I
-176 544 213 544 Line
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 204 757 ] concat
-%I
-[
-(Fixed Hdr)
-] Text
-End
-
-Begin %I Line
-%I b 13107
-1 0 0 [2 2 2 2 2 2 2 2] 15 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 109 197 ] concat
-%I
-176 544 213 544 Line
-End
-
-Begin %I Line
-%I b 13107
-1 0 0 [2 2 2 2 2 2 2 2] 15 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 109 222 ] concat
-%I
-176 544 213 544 Line
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 284 680 ] concat
-%I
-[
-(Closure Type)
-] Text
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 134 248 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 305 653 ] concat
-%I
-[
-(Size)
-] Text
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 1 0 0 1 134 222 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 289 627 ] concat
-%I
-[
-(No of Ptrs)
-] Text
-End
-
-Begin %I Line
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-0 SetP
-%I t
-[ 1 0 0 1.13333 148 148.333 ] concat
-%I
-205 365 205 336 Line
-End
-
-Begin %I Line
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-0 SetP
-%I t
-[ 1 0 0 1.17241 148 134.069 ] concat
-%I
-131 365 131 337 Line
-End
-
-Begin %I Line
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-0 SetP
-%I t
-[ 1 0 0 0.925926 148 239.148 ] concat
-%I
-114 569 114 543 Line
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 275 757 ] concat
-%I
-[
-(Var Hdr)
-] Text
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 211 727 ] concat
-%I
-[
-( Info)
-(Pointer)
-] Text
-End
-
-End %I eop
-
-showpage
-
-%%Trailer
-
-end
+++ /dev/null
-/* config.h.in. Generated automatically from configure.in by autoheader. */
-
-/* Define to empty if the keyword does not work. */
-#undef const
-
-/* Define as the return type of signal handlers (int or void). */
-#undef RETSIGTYPE
-
-/* Define if you have the ANSI C header files. */
-#undef STDC_HEADERS
-
-/* Define if you can safely include both <sys/time.h> and <time.h>. */
-#undef TIME_WITH_SYS_TIME
-
-/* Define if you have access. */
-#undef HAVE_ACCESS
-
-/* Define if you have ftime. */
-#undef HAVE_FTIME
-
-/* Define if you have getclock. */
-#undef HAVE_GETCLOCK
-
-/* Define if you have getpagesize. */
-#undef HAVE_GETPAGESIZE
-
-/* Define if you have getrusage. */
-#undef HAVE_GETRUSAGE
-
-/* Define if you have gettimeofday. */
-#undef HAVE_GETTIMEOFDAY
-
-/* Define if you have mktime. */
-#undef HAVE_MKTIME
-
-/* Define if you have mprotect. */
-#undef HAVE_MPROTECT
-
-/* Define if you have setitimer. */
-#undef HAVE_SETITIMER
-
-/* Define if you have stat. */
-#undef HAVE_STAT
-
-/* Define if you have sysconf. */
-#undef HAVE_SYSCONF
-
-/* Define if you have timelocal. */
-#undef HAVE_TIMELOCAL
-
-/* Define if you have times. */
-#undef HAVE_TIMES
-
-/* Define if you have vadvise. */
-#undef HAVE_VADVISE
-
-/* Define if you have vfork. */
-#undef HAVE_VFORK
-
-/* Define if you have alloca. */
-#undef HAVE_ALLOCA
-
-/* Define if you have the <alloca.h> header file. */
-#undef HAVE_ALLOCA_H
-
-/* Define if you have the <dirent.h> header file. */
-#undef HAVE_DIRENT_H
-
-/* Define if you have the <fcntl.h> header file. */
-#undef HAVE_FCNTL_H
-
-/* Define if you have the <grp.h> header file. */
-#undef HAVE_GRP_H
-
-/* Define if you have the <malloc.h> header file. */
-#undef HAVE_MALLOC_H
-
-/* Define if you have the <memory.h> header file. */
-#undef HAVE_MEMORY_H
-
-/* Define if you have the <nlist.h> header file. */
-#undef HAVE_NLIST_H
-
-/* Define if you have the <pwd.h> header file. */
-#undef HAVE_PWD_H
-
-/* Define if you have the <siginfo.h> header file. */
-#undef HAVE_SIGINFO_H
-
-/* Define if you have the <signal.h> header file. */
-#undef HAVE_SIGNAL_H
-
-/* Define if you have the <sys/socket.h> header file. */
-#undef HAVE_SYS_SOCKET_H
-
-/* Define if you have the <stdlib.h> header file. */
-#undef HAVE_STDLIB_H
-
-/* Define if you have the <string.h> header file. */
-#undef HAVE_STRING_H
-
-/* Define if you have the <sys/fault.h> header file. */
-#undef HAVE_SYS_FAULT_H
-
-/* Define if you have the <sys/file.h> header file. */
-#undef HAVE_SYS_FILE_H
-
-/* Define if you have the <sys/file.h> header file. */
-#undef HAVE_SYS_MMAN_H
-
-/* Define if you have the <sys/param.h> header file. */
-#undef HAVE_SYS_PARAM_H
-
-/* Define if you have the <sys/procfs.h> header file. */
-#undef HAVE_SYS_PROCFS_H
-
-/* Define if you have the <sys/resource.h> header file. */
-#undef HAVE_SYS_RESOURCE_H
-
-/* Define if you have the <sys/signal.h> header file. */
-#undef HAVE_SYS_SIGNAL_H
-
-/* Define if you have the <sys/stat.h> header file. */
-#undef HAVE_SYS_STAT_H
-
-/* Define if you have the <sys/syscall.h> header file. */
-#undef HAVE_SYS_SYSCALL_H
-
-/* Define if you have the <sys/time.h> header file. */
-#undef HAVE_SYS_TIME_H
-
-/* Define if you have the <sys/timeb.h> header file. */
-#undef HAVE_SYS_TIMEB_H
-
-/* Define if you have the <sys/timers.h> header file. */
-#undef HAVE_SYS_TIMERS_H
-
-/* Define if you have the <sys/times.h> header file. */
-#undef HAVE_SYS_TIMES_H
-
-/* Define if you have the <sys/types.h> header file. */
-#undef HAVE_SYS_TYPES_H
-
-/* Define if you have the <sys/utsname.h> header file. */
-#undef HAVE_SYS_UTSNAME_H
-
-/* Define if you have the <sys/vadvise.h> header file. */
-#undef HAVE_SYS_VADVISE_H
-
-/* Define if you have the <sys/wait.h> header file. */
-#undef HAVE_SYS_WAIT_H
-
-/* Define if you have the <termios.h> header file. */
-#undef HAVE_TERMIOS_H
-
-/* Define if you have the <time.h> header file. */
-#undef HAVE_TIME_H
-
-/* Define if you have the <types.h> header file. */
-#undef HAVE_TYPES_H
-
-/* Define if you have the <unistd.h> header file. */
-#undef HAVE_UNISTD_H
-
-/* Define if you have the <utime.h> header file. */
-#undef HAVE_UTIME_H
-
-/* Define if you have the <vfork.h> header file. */
-#undef HAVE_VFORK_H
-
-/* Define if you have the fl library (-lfl). */
-#undef HAVE_LIBFL
-
-/* Define if you have the l library (-ll). */
-#undef HAVE_LIBL
-
-/* Define if you have tm_zone in struct tm. */
-#undef HAVE_TM_ZONE
-
-/* Define if you have extern char *tzname[2]. */
-#undef HAVE_TZNAME
-
+++ /dev/null
-#define ERR_ALREADYEXISTS 1
-#define ERR_HARDWAREFAULT 2
-#define ERR_ILLEGALOPERATION 3
-#define ERR_INAPPROPRIATETYPE 4
-#define ERR_INTERRUPTED 5
-#define ERR_INVALIDARGUMENT 6
-#define ERR_NOSUCHTHING 7
-#define ERR_OTHERERROR 8
-#define ERR_PERMISSIONDENIED 9
-#define ERR_PROTOCOLERROR 10
-#define ERR_RESOURCEBUSY 11
-#define ERR_RESOURCEEXHAUSTED 12
-#define ERR_RESOURCEVANISHED 13
-#define ERR_SYSTEMERROR 14
-#define ERR_TIMEEXPIRED 15
-#define ERR_UNSATISFIEDCONSTRAINTS 16
-#define ERR_UNSUPPORTEDOPERATION 17
-#define ERR_USERERROR 18
-#define ERR_EOF 19
-
-#define GHC_E2BIG -1
-#define GHC_EACCES -2
-#define GHC_EADDRINUSE -3
-#define GHC_EADDRNOTAVAIL -4
-#define GHC_EADV -5
-#define GHC_EAFNOSUPPORT -6
-#define GHC_EAGAIN -7
-#define GHC_EAIO -8
-#define GHC_EALREADY -9
-#define GHC_EBADF -10
-#define GHC_EBADMSG -11
-#define GHC_EBADRPC -12
-#define GHC_EBUSY -13
-#define GHC_ECANCELED -14
-#define GHC_ECHILD -15
-#define GHC_ECLONEME -16
-#define GHC_ECOMM -17
-#define GHC_ECONNABORTED -18
-#define GHC_ECONNREFUSED -19
-#define GHC_ECONNRESET -20
-#define GHC_EDEADLK -21
-#define GHC_EDESTADDRREQ -22
-#define GHC_EDIRTY -23
-#define GHC_EDOM -24
-#define GHC_EDOTDOT -25
-#define GHC_EDQUOT -26
-#define GHC_EDUPPKG -27
-#define GHC_EEXIST -28
-#define GHC_EFAIL -29
-#define GHC_EFAULT -30
-#define GHC_EFBIG -31
-#define GHC_EFTYPE -32
-#define GHC_EHOSTDOWN -33
-#define GHC_EHOSTUNREACH -34
-#define GHC_EIDRM -35
-#define GHC_EILSEQ -36
-#define GHC_EINPROG -37
-#define GHC_EINPROGRESS -38
-#define GHC_EINTR -39
-#define GHC_EINVAL -40
-#define GHC_EIO -41
-#define GHC_EISCONN -42
-#define GHC_EISDIR -43
-#define GHC_ELOOP -44
-#define GHC_EMEDIA -45
-#define GHC_EMFILE -46
-#define GHC_EMLINK -47
-#define GHC_EMSGSIZE -48
-#define GHC_EMTIMERS -49
-#define GHC_EMULTIHOP -50
-#define GHC_ENAMETOOLONG -51
-#define GHC_ENETDOWN -52
-#define GHC_ENETRESET -53
-#define GHC_ENETUNREACH -54
-#define GHC_ENFILE -55
-#define GHC_ENOBUFS -56
-#define GHC_ENODATA -57
-#define GHC_ENODEV -58
-#define GHC_ENOENT -59
-#define GHC_ENOEXEC -60
-#define GHC_ENOLCK -61
-#define GHC_ENOLINK -62
-#define GHC_ENOMEM -63
-#define GHC_ENOMSG -64
-#define GHC_ENONET -65
-#define GHC_ENOPKG -66
-#define GHC_ENOPROTOOPT -67
-#define GHC_ENOSPC -68
-#define GHC_ENOSR -69
-#define GHC_ENOSTR -70
-#define GHC_ENOSYM -71
-#define GHC_ENOSYS -72
-#define GHC_ENOTBLK -73
-#define GHC_ENOTCONN -74
-#define GHC_ENOTDIR -75
-#define GHC_ENOTEMPTY -76
-#define GHC_ENOTSOCK -77
-#define GHC_ENOTSUP -78
-#define GHC_ENOTTY -79
-#define GHC_ENXIO -80
-#define GHC_EOPNOTSUPP -81
-#define GHC_EPERM -82
-#define GHC_EPFNOSUPPORT -83
-#define GHC_EPIPE -84
-#define GHC_EPROCLIM -85
-#define GHC_EPROCUNAVAIL -86
-#define GHC_EPROGMISMATCH -87
-#define GHC_EPROGUNAVAIL -88
-#define GHC_EPROTO -89
-#define GHC_EPROTONOSUPPORT -90
-#define GHC_EPROTOTYPE -91
-#define GHC_ERANGE -92
-#define GHC_ERELOCATED -93
-#define GHC_EREMCHG -94
-#define GHC_EREMOTE -95
-#define GHC_EROFS -96
-#define GHC_ERPCMISMATCH -97
-#define GHC_ERREMOTE -98
-#define GHC_ESHUTDOWN -99
-#define GHC_ESOCKTNOSUPPORT -100
-#define GHC_ESOFT -101
-#define GHC_ESPIPE -102
-#define GHC_ESRCH -103
-#define GHC_ESRMNT -104
-#define GHC_ESTALE -105
-#define GHC_ETIME -106
-#define GHC_ETIMEDOUT -107
-#define GHC_ETOOMANYREFS -108
-#define GHC_ETXTBSY -109
-#define GHC_EUSERS -110
-#define GHC_EVERSION -111
-#define GHC_EWOULDBLOCK -112
-#define GHC_EXDEV -113
-
-
--- /dev/null
+/* --------------------------------------------------------------------------
+ * $Id: mkNativeHdr.c,v 1.2 1998/12/02 13:21:50 simonm Exp $
+ *
+ * (c) The GHC Team, 1992-1998
+ *
+ * Generate a header for the native code generator
+ *
+ * ------------------------------------------------------------------------*/
+
+#include "Stg.h"
+
+#define OFFSET(table, x) ((StgUnion *) &(x) - (StgUnion *) (&table))
+
+#define OFFSET_R1 OFFSET(RegTable, RegTable.rR1)
+#define OFFSET_R2 OFFSET(RegTable, RegTable.rR2)
+#define OFFSET_R3 OFFSET(RegTable, RegTable.rR3)
+#define OFFSET_R4 OFFSET(RegTable, RegTable.rR4)
+#define OFFSET_R5 OFFSET(RegTable, RegTable.rR5)
+#define OFFSET_R6 OFFSET(RegTable, RegTable.rR6)
+#define OFFSET_R7 OFFSET(RegTable, RegTable.rR7)
+#define OFFSET_R8 OFFSET(RegTable, RegTable.rR8)
+#define OFFSET_F1 OFFSET(RegTable, RegTable.rF1)
+#define OFFSET_F2 OFFSET(RegTable, RegTable.rF2)
+#define OFFSET_F3 OFFSET(RegTable, RegTable.rF3)
+#define OFFSET_F4 OFFSET(RegTable, RegTable.rF4)
+#define OFFSET_D1 OFFSET(RegTable, RegTable.rD1)
+#define OFFSET_D2 OFFSET(RegTable, RegTable.rD2)
+#define OFFSET_L1 OFFSET(RegTable, RegTable.rL1)
+#define OFFSET_Sp OFFSET(RegTable, RegTable.rSp)
+#define OFFSET_Su OFFSET(RegTable, RegTable.rSu)
+#define OFFSET_SpLim OFFSET(RegTable, RegTable.rSpLim)
+#define OFFSET_Hp OFFSET(RegTable, RegTable.rHp)
+#define OFFSET_HpLim OFFSET(RegTable, RegTable.rHpLim)
+
+#define TSO_SP OFFSET(tso, tso.sp)
+#define TSO_SPLIM OFFSET(tso, tso.splim)
+#define TSO_SU OFFSET(tso, tso.su)
+
+StgRegTable RegTable;
+StgTSO tso;
+
+int
+main()
+{
+ printf("-- This file is created automatically. Do not edit by hand.\n\n");
+
+ printf("\n-- Base table offsets for the Native Code Generator\n");
+
+ printf("#define OFFSET_R1 %d\n", OFFSET_R1);
+ printf("#define OFFSET_R2 %d\n", OFFSET_R2);
+ printf("#define OFFSET_R3 %d\n", OFFSET_R3);
+ printf("#define OFFSET_R4 %d\n", OFFSET_R4);
+ printf("#define OFFSET_R5 %d\n", OFFSET_R5);
+ printf("#define OFFSET_R6 %d\n", OFFSET_R6);
+ printf("#define OFFSET_R7 %d\n", OFFSET_R7);
+ printf("#define OFFSET_R8 %d\n", OFFSET_R8);
+ printf("#define OFFSET_F1 %d\n", OFFSET_F1);
+ printf("#define OFFSET_F2 %d\n", OFFSET_F2);
+ printf("#define OFFSET_F3 %d\n", OFFSET_F3);
+ printf("#define OFFSET_F4 %d\n", OFFSET_F4);
+ printf("#define OFFSET_D1 %d\n", OFFSET_D1);
+ printf("#define OFFSET_D2 %d\n", OFFSET_D2);
+#ifdef SUPPORT_LONG_LONGS
+ printf("#define OFFSET_L1 %d\n", OFFSET_L1);
+#endif
+ printf("#define OFFSET_Sp %d\n", OFFSET_Sp);
+ printf("#define OFFSET_Su %d\n", OFFSET_Su);
+ printf("#define OFFSET_SpLim %d\n", OFFSET_SpLim);
+ printf("#define OFFSET_Hp %d\n", OFFSET_Hp);
+ printf("#define OFFSET_HpLim %d\n", OFFSET_HpLim);
+
+ printf("\n-- Storage Manager offsets for the Native Code Generator\n");
+
+ printf("\n-- TSO offsets for the Native Code Generator\n");
+
+ printf("#define TSO_SP %d\n", TSO_SP);
+ printf("#define TSO_SU %d\n", TSO_SU);
+ printf("#define TSO_SPLIM %d\n", TSO_SPLIM);
+
+ printf("\n-- FILE size for the Native Code Generator\n");
+
+ printf("#define FILE_SIZE %d\n", sizeof(*stdin));
+
+ exit(0);
+}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994
-%
-\section[mkNativeGen-header]{Generate a header for the native code generator}
-
-\begin{code}
-
-#define MAIN_REG_MAP
-#include "stgdefs.h"
-
-#define OFFSET(table, x) ((StgUnion *) &(x) - (StgUnion *) (&table))
-
-
-#define OFFSET_Dbl1 OFFSET(MainRegTable, MAIN_Dbl1)
-#define OFFSET_Dbl2 OFFSET(MainRegTable, MAIN_Dbl2)
-#define OFFSET_Lng1 OFFSET(MainRegTable, MAIN_Lng1)
-#define OFFSET_Lng2 OFFSET(MainRegTable, MAIN_Lng2)
-#define OFFSET_Flt1 OFFSET(MainRegTable, MAIN_Flt1)
-#define OFFSET_Flt2 OFFSET(MainRegTable, MAIN_Flt2)
-#define OFFSET_Flt3 OFFSET(MainRegTable, MAIN_Flt3)
-#define OFFSET_Flt4 OFFSET(MainRegTable, MAIN_Flt4)
-#define OFFSET_R1 OFFSET(MainRegTable, MAIN_R1)
-#define OFFSET_R2 OFFSET(MainRegTable, MAIN_R2)
-#define OFFSET_R3 OFFSET(MainRegTable, MAIN_R3)
-#define OFFSET_R4 OFFSET(MainRegTable, MAIN_R4)
-#define OFFSET_R5 OFFSET(MainRegTable, MAIN_R5)
-#define OFFSET_R6 OFFSET(MainRegTable, MAIN_R6)
-#define OFFSET_R7 OFFSET(MainRegTable, MAIN_R7)
-#define OFFSET_R8 OFFSET(MainRegTable, MAIN_R8)
-#define OFFSET_SpA OFFSET(MainRegTable, MAIN_SpA)
-#define OFFSET_SuA OFFSET(MainRegTable, MAIN_SuA)
-#define OFFSET_SpB OFFSET(MainRegTable, MAIN_SpB)
-#define OFFSET_SuB OFFSET(MainRegTable, MAIN_SuB)
-#define OFFSET_Hp OFFSET(MainRegTable, MAIN_Hp)
-#define OFFSET_HpLim OFFSET(MainRegTable, MAIN_HpLim)
-#define OFFSET_Tag OFFSET(MainRegTable, MAIN_Tag)
-#define OFFSET_Ret OFFSET(MainRegTable, MAIN_Ret)
-#define OFFSET_StkO OFFSET(MainRegTable, MAIN_StkO)
-#define OFFSET_Liveness OFFSET(MainRegTable, MAIN_Liveness)
-
-#define SM_HP OFFSET(StorageMgrInfo, StorageMgrInfo.hp)
-#define SM_HPLIM OFFSET(StorageMgrInfo, StorageMgrInfo.hplim)
-#define SM_ROOTNO OFFSET(StorageMgrInfo, StorageMgrInfo.rootno)
-#define SM_ROOTS OFFSET(StorageMgrInfo, StorageMgrInfo.roots)
-#define SM_CAFLIST OFFSET(StorageMgrInfo, StorageMgrInfo.CAFlist)
-#define SM_OLDMUTABLES OFFSET(StorageMgrInfo, StorageMgrInfo.OldMutables)
-#define SM_OLDLIM OFFSET(StorageMgrInfo, StorageMgrInfo.OldLim)
-#define SM_FOREIGNOBJLIST OFFSET(StorageMgrInfo, StorageMgrInfo.ForeignObjList)
-#define SM_OLDFOREIGNOBJLIST OFFSET(StorageMgrInfo, StorageMgrInfo.OldForeignObjList)
-#define SM_STABLEPOINTERTABLE OFFSET(StorageMgrInfo, StorageMgrInfo.StablePointerTable)
-
-STGRegisterTable MainRegTable;
-smInfo StorageMgrInfo;
-
-int
-main()
-{
- printf("-- This file is created automatically. Do not edit by hand.\n\n");
-
- printf("\n-- Base table offsets for the Native Code Generator\n");
-
- printf("#define OFFSET_Dbl1 %d\n", OFFSET_Dbl1);
- printf("#define OFFSET_Dbl2 %d\n", OFFSET_Dbl2);
-#if HAVE_LONG_LONG && SIZEOF_LONG < 8
- printf("#define OFFSET_Lng1 %d\n", OFFSET_Lng1);
- printf("#define OFFSET_Lng2 %d\n", OFFSET_Lng2);
-#endif
- printf("#define OFFSET_Flt1 %d\n", OFFSET_Flt1);
- printf("#define OFFSET_Flt2 %d\n", OFFSET_Flt2);
- printf("#define OFFSET_Flt3 %d\n", OFFSET_Flt3);
- printf("#define OFFSET_Flt4 %d\n", OFFSET_Flt4);
- printf("#define OFFSET_R1 %d\n", OFFSET_R1);
- printf("#define OFFSET_R2 %d\n", OFFSET_R2);
- printf("#define OFFSET_R3 %d\n", OFFSET_R3);
- printf("#define OFFSET_R4 %d\n", OFFSET_R4);
- printf("#define OFFSET_R5 %d\n", OFFSET_R5);
- printf("#define OFFSET_R6 %d\n", OFFSET_R6);
- printf("#define OFFSET_R7 %d\n", OFFSET_R7);
- printf("#define OFFSET_R8 %d\n", OFFSET_R8);
- printf("#define OFFSET_SpA %d\n", OFFSET_SpA);
- printf("#define OFFSET_SuA %d\n", OFFSET_SuA);
- printf("#define OFFSET_SpB %d\n", OFFSET_SpB);
- printf("#define OFFSET_SuB %d\n", OFFSET_SuB);
- printf("#define OFFSET_Hp %d\n", OFFSET_Hp);
- printf("#define OFFSET_HpLim %d\n", OFFSET_HpLim);
- printf("#define OFFSET_Tag %d\n", OFFSET_Tag);
- printf("#define OFFSET_Ret %d\n", OFFSET_Ret);
-#ifdef CONCURRENT
- printf("#define OFFSET_StkO %d\n", OFFSET_StkO);
- printf("#define OFFSET_Liveness %d\n", OFFSET_Liveness);
-#else
- printf("#define OFFSET_StkO panic \"OFFSET_StkO\"\n");
- printf("#define OFFSET_Liveness panic \"OFFSET_Liveness\"\n");
-#endif
-
- printf("\n-- Storage Manager offsets for the Native Code Generator\n");
-
- printf("#define SM_HP %d\n", SM_HP);
- printf("#define SM_HPLIM %d\n", SM_HPLIM);
- printf("#define SM_ROOTNO %d\n", SM_ROOTNO);
- printf("#define SM_ROOTS %d\n", SM_ROOTS);
- printf("#define SM_CAFLIST %d\n", SM_CAFLIST);
-#if defined(GCap) || defined(GCgn)
- printf("#define SM_OLDMUTABLES %d\n", SM_OLDMUTABLES);
- printf("#define SM_OLDLIM %d\n", SM_OLDLIM);
-#endif
-#ifndef PAR
- printf("#define SM_FOREIGNOBJLIST %d\n", SM_FOREIGNOBJLIST);
-#if defined(GCap) || defined(GCgn)
- printf("#define SM_OLDFOREIGNOBJLIST %d\n", SM_OLDFOREIGNOBJLIST);
-#endif
- printf("#define SM_STABLEPOINTERTABLE %d\n", SM_STABLEPOINTERTABLE);
-#endif
-
- printf("\n-- FILE size for the Native Code Generator\n");
-
- printf("#define FILE_SIZE %d\n", sizeof(*stdin));
-
- exit(0);
-}
-
-\end{code}
--- /dev/null
+/* ../options.h. Generated automatically by configure. */
+/* --------------------------------------------------------------------------
+ * Configuration options
+ *
+ * Most configuration options are arguments to the configure script
+ * (try running "configure --help"). The following options are either
+ * experimental or require changes to "Prelude.hs", the standard libraries
+ * and demos and therefore cannot be modified using the configure script.
+ * Most users should leave them alone!
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: options.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:21:51 $
+ * ------------------------------------------------------------------------*/
+
+
+/* --------------------------------------------------------------------------
+ * Hugs paths and directories
+ * ------------------------------------------------------------------------*/
+
+/* Define this as the default setting of HUGSPATH.
+ * Value may contain string "{Hugs}" (for which we will substitute the
+ * value of HUGSDIR) and should be either colon-separated (Unix)
+ * or semicolon-separated (Macintosh, Windows, DOS). Escape
+ * characters in the path string are interpreted according to normal
+ * Haskell conventions.
+ *
+ * This value can be overridden from the command line by setting the
+ * HUGSFLAGS environment variable or by storing an appropriate value
+ * for HUGSFLAGS in the registry (Win32 only). In all cases, use a
+ * string of the form -P"...".
+ */
+#define HUGSPATH ""
+
+/* The directory name which is substituted for the string "{Hugs}"
+ * in a path variable. This normally points to where the Hugs libraries
+ * are installed - ie so that the file HUGSDIR/lib/Prelude.hs exists
+ * Typical values are:
+ * "/usr/local/lib/hugs"
+ * "/usr/homes/JFHaskell/hugs"
+ * ".."
+ *
+ * This value is ignored on Windows and Macintosh versions since
+ * it is assumed that the binary is installed in HUGSDIR.
+ *
+ * This value cannot be overridden from the command line or by using
+ * environment variables. This isn't quite as limiting as you'd think
+ * since you can always choose _not_ to use the {Hugs} variable - however,
+ * it's obviously _nicer_ to have it set correctly.
+ */
+#ifndef HUGSDIR
+#define HUGSDIR "."
+#endif
+
+
+/* --------------------------------------------------------------------------
+ * User interface options
+ * ------------------------------------------------------------------------*/
+
+/* Define if you want to use the "Hugs for Windows" GUI.
+ * (Windows 3.1 and compatibles only)
+ */
+#define HUGS_FOR_WINDOWS 0
+
+/* Define if you want filenames to be converted to normal form by:
+ * o replacing relative pathnames with absolute pathnames and
+ * eliminating .. and . where possible.
+ * o converting to lower case (only in case-insensitive filesystems)
+ */
+#define PATH_CANONICALIZATION 0
+
+/* Define if a command line editor is available and should be used.
+ * There are two choices of command line editor that can be used with Hugs:
+ * GNU readline and editline (from comp.sources.misc, vol 31, issue 71)
+ */
+#define USE_READLINE 0
+
+/* Define if you want the small startup banner.
+ */
+#define SMALL_BANNER 0
+
+/* Define if you want to be able to redirect stdout/stderr to a buffer.
+ * Only necessary for the Hugs server interface (which is used in the
+ * Netscape plugin and the standalone evaluator "runhugs").
+ */
+#define REDIRECT_OUTPUT (!HUGS_FOR_WINDOWS)
+
+
+/* --------------------------------------------------------------------------
+ * Making Hugs smaller
+ * ------------------------------------------------------------------------*/
+
+/* Define one of these to select overall size of Hugs
+ * SMALL_HUGS for 16 bit operation on a limited memory PC.
+ * REGULAR_HUGS for 32 bit operation using largish default table sizes.
+ * LARGE_HUGS for 32 bit operation using larger default table sizes.
+ */
+#define SMALL_HUGS 0
+#define REGULAR_HUGS 0
+#define LARGE_HUGS 1
+
+#define NUM_SYNTAX 100
+#define NUM_TUPLES 100
+#define NUM_OFFSETS 1024
+#define NUM_CHARS 256
+#if TREX
+#define NUM_EXT 100
+#endif
+#define CHAR_MASK 0xff
+
+#if SMALL_HUGS /* the McDonalds mentality :-) */
+#define Pick(s,r,l) s
+#endif
+#if REGULAR_HUGS
+#define Pick(s,r,l) r
+#endif
+#if LARGE_HUGS
+#define Pick(s,r,l) l
+#endif
+
+#define MINIMUMHEAP Pick(7500, 19000, 19000)
+#define MAXIMUMHEAP Pick(32765, 0, 0)
+#define DEFAULTHEAP Pick(28000, 50000, 300000)
+
+#define NUM_SCRIPTS Pick(64, 100, 100)
+#define NUM_MODULE NUM_SCRIPTS
+#define NUM_TYCON Pick(60, 160, 400)
+#define NUM_NAME Pick(1000, 2000, 16000)
+#define NUM_CLASSES Pick(30, 40, 80)
+#define NUM_INSTS Pick(200, 300, 600)
+#define NUM_TEXT Pick(12000, 20000, 80000)
+#define NUM_TEXTH Pick(1, 10, 10)
+#define NUM_TYVARS Pick(800, 2000, 4000)
+#define NUM_STACK Pick(1800, 12000, 16000)
+#define NUM_DTUPLES Pick(3, 5, 5)
+
+#define MAXPOSINT 0x7fffffff
+#define MINNEGINT (-MAXPOSINT-1)
+#define MAXHUGSWORD 0xffffffffU
+
+#define BIGBASE Pick(100, 10000, 10000)
+#define BIGEXP Pick(2, 4, 4)
+
+#define minRecovery Pick(1000, 1000, 1000)
+#define bitsPerWord Pick(16, 32, 32)
+#define wordShift Pick(4, 5, 5)
+#define wordMask Pick(15, 31, 31)
+
+/* Define to force a fixed size (NUM_TYVARS) for the current substitution.
+ * Setting this flag places a limit on the maximum complexity of
+ * expressions handled by the typechecker. It is normally turned off
+ * but may be required for small machines/configurations.
+ */
+#define FIXED_SUBST 0
+
+/* Define this to allocate tables dynamically.
+ * This is currently just a memory saving trick, but this may be
+ * extended at a later stage to allow at least some of the tables
+ * to be extended dynamically at run-time to avoid exhausted space errors.
+ */
+#define DYN_TABLES SMALL_HUGS
+
+/* Define this to include support for storing pointers in the heap.
+ * This is required by the code generator (which has to store
+ * pointers to AsmObjects).
+ */
+#define PTR_ON_HEAP 1
+
+/* Should quantifiers be displayed in error messages.
+ * Warning: not consistently used.
+ */
+#define DISPLAY_QUANTIFIERS 1
+
+/* Flags to determine which raw representations and operations are available
+ * Notes:
+ * o the INTEGER implementation is quite different from GHC's
+ * implementation so you usually don't PROVIDE_INTEGER if
+ * using GHC compiled code.
+ * o if you turn everything on, you might end up with more then 256
+ * bytecodes: check the value of i_ccall (the lst bytecode) to check
+ * o Addrs are used to represent literal Strings in Hugs - so you can't
+ * really turn them off.
+ * o Either Int64 or Integer has to be provided so that we can
+ * define BIGNUMTYPE (below)
+ */
+
+#define PROVIDE_INTEGER
+#define PROVIDE_INT64
+#define PROVIDE_WORD
+#define PROVIDE_ADDR
+#define PROVIDE_STABLE
+#define PROVIDE_FOREIGN
+#define PROVIDE_WEAK
+#define PROVIDE_ARRAY
+#define PROVIDE_CONCURRENT
+#define PROVIDE_PTREQUALITY
+#define PROVIDE_COERCE
+
+/* The following aren't options at the moment - but could be
+ * #define PROVIDE_FLOAT
+ * #define PROVIDE_DOUBLE
+ */
+
+/* Flags to determine how Haskell types are mapped onto internal types.
+ * Note that this has to be an injection: you can't have two names
+ * for the same internal type.
+ * Also, the settings have to be consistent with GHC if GHC is being used.
+ */
+
+#define BIGNUM_IS_INTEGER 1
+#define BIGNUM_IS_INT64 0
+
+#if BIGNUM_IS_INT64
+#define BIGNUMTYPE Int64
+#elif BIGNUM_IS_INTEGER
+#define BIGNUMTYPE Integer
+#else
+#warning BIGNUMTYPE undefined
+#endif
+
+/* Is the default default (Int,Double) or (Integer,Double)?
+ */
+#define DEFAULT_BIGNUM 0
+
+/* Should lambda lifter lift constant expressions out to top level?
+ * Experimental optimisation.
+ */
+#define LIFT_CONSTANTS 1
+
+/* Should we run optimizer on Hugs code?
+ * Experimental optimisation.
+ */
+#define USE_HUGS_OPTIMIZER 1
+
+/* Are things being used in an interactive setting or a batch setting?
+ * In an interactive setting, System.exitWith should not call _exit
+ * getProgName and getProgArgs need to be handled differently, etc.
+ *
+ * Warning: this flag is ignored by an awful lot of code.
+ */
+#define INTERACTIVE
+
+/* Turn bytecode interpreter support on/off.
+ */
+#define INTERPRETER 1
+
+/* Turn on debugging output and some sanity checks
+ */
+/*#define DEBUG */
+/*#define NDEBUG */
+
+/* Make stack tags more informative than just their size.
+ * Helps when printing the stack and when running sanity checks.
+ */
+/*#define DEBUG_EXTRA */
+
+/* Turn lazy blackholing on/off.
+ * Warning: Lazy blackholing can't be disabled in GHC generated code.
+ *
+ * Using eager blackholing makes things easier to debug because
+ * the blackholes are more predicatable - but it's slower and less sexy.
+ */
+#define LAZY_BLACKHOLING
+
+/* Turn miniinterpreter on/off.
+ *
+ * The mininterpreter is portable but slow - if you turn it off,
+ * you'll probably need to provide some assembly language support
+ * for your architecture.
+ */
+#define USE_MINIINTERPRETER 1
+
+/* Turn registerisation on/off.
+ *
+ * If you turn this off, you'll probably need to provide some
+ * assembly language support for your architecture.
+ */
+#define NO_REGS
+
+
+/* --------------------------------------------------------------------------
+ * Fancy features
+ * ------------------------------------------------------------------------*/
+
+/* Define if T-REX; Typed Rows and EXtension should be enabled */
+/* Doesn't work in current system - I don't know what the primops do */
+#define TREX 0
+
+/* Define if you want to run Haskell code through a preprocessor
+ *
+ * Note that the :reload command doesn't know about any dependencies
+ * introduced by using #include so you must :load (not :reload) if
+ * you change any #included files (such as configuration files).
+ */
+#define USE_PREPROCESSOR 1
+
+/* Define if you want to time every evaluation.
+ *
+ * Timing is included in the Hugs distribution for the purpose of benchmarking
+ * the Hugs interpreter, comparing its performance across a variety of
+ * different machines, and with other systems for similar languages.
+ *
+ * It would be somewhat foolish to try to use the timings produced in this
+ * way for any other purpose. In particular, using timings to compare the
+ * performance of different versions of an algorithm is likely to give very
+ * misleading results. The current implementation of Hugs as an interpreter,
+ * without any significant optimizations, means that there are much more
+ * significant overheads than can be accounted for by small variations in
+ * Hugs code.
+ */
+/* #undef WANT_TIMER */
+
+
+/* --------------------------------------------------------------------------
+ * Desugaring options
+ *
+ * These options are mostly used for developing/debugging the system.
+ * Since they turn off required parts of the Haskell language, you'll
+ * probably need to modify Prelude.hs and the libraries if you change
+ * these flags.
+ * ------------------------------------------------------------------------*/
+
+/* Define if you want to be able to derive instances of each class. */
+#define DERIVE_EQ 1
+#define DERIVE_ORD 1
+#define DERIVE_ENUM 1
+#define DERIVE_IX 1
+#define DERIVE_SHOW 1
+#define DERIVE_READ 1
+#define DERIVE_BOUNDED 1
+
+/* Define if single-element dictionaries are implemented by newtype.
+ * Should be turned on. Mostly used to make it easier to find which
+ * bits of code implement this optimisation and as a way of documenting
+ * them.
+ */
+#define USE_NEWTYPE_FOR_DICTS 1
+
+/* Define if strings should be represented as normal C strings.
+ * Note that this doesn't work if the string contains '\0'
+ * and makes persistence problematic.
+ * Intended as a stop-gap measure until mutable byte arrays are available.
+ */
+#define USE_ADDR_FOR_STRINGS 1
+
+/* turn this off to avoid wrapping int and float literals in "fromInt"
+ * or "fromFloat" */
+#define OVERLOADED_CONSTANTS 1
+
+/* turn this off to remove the ultramagical treatment of the Eval class */
+#define EVAL_INSTANCES 0
+
+/* Define to include support for (n+k) patterns.
+ * Warning: many people in the Haskell committee want to remove n+k patterns.
+ */
+#define NPLUSK 1
+
+
+/* --------------------------------------------------------------------------
+ * Debugging options (intended for use by maintainers)
+ * ------------------------------------------------------------------------*/
+
+/* Define if debugging generated bytecodes or the bytecode interpreter */
+#define DEBUG_CODE 1
+
+/* Define if you want to use a low-level printer from within a debugger */
+#define DEBUG_PRINTER 1
+
+
+/* --------------------------------------------------------------------------
+ * Experimental features
+ * These are likely to disappear/change in future versions and should not
+ * be used by most people..
+ * ------------------------------------------------------------------------*/
+
+/* In a plain Hugs system, most signals (SIGBUS, SIGTERM, etc) indicate
+ * some kind of error in Hugs - or maybe a stack overflow. Rather than
+ * just crash, Hugs catches these errors and returns to the main loop.
+ * It does this by calling a function "panic" which longjmp's back to the
+ * main loop.
+ * If you're developing a GreenCard library, this may not be the right
+ * behaviour - it's better if Hugs leaves them for your debugger to
+ * catch rather than trapping them and "panicking".
+ */
+#define DONT_PANIC 1
+
+
+/* ----------------------------------------------------------------------- */
+++ /dev/null
-#ifndef PLATFORM_H
-#define PLATFORM_H
-
-#define alpha_dec_osf1 10
-#define alpha_unknown_linux 11
-#define alpha_dec_osf3 12
-#define hppa1_1_hp_hpux 20
-#define i386_next_nextstep3 30
-#define i386_unknown_bsdi 31
-#define i386_unknown_freebsd 32
-#define i386_unknown_linux 33
-#define i386_unknown_linuxaout 34
-#define i386_unknown_netbsd 35
-#define i386_unknown_solaris2 36
-#define m68k_next_nextstep 50
-#define m68k_simonpj_grip 51
-#define m68k_sun_sunos4 52
-#define mips_dec_ultrix 60
-#define mips_sgi_irix 61
-#define powerpc_ibm_aix 70
-#define sparc_sun_solaris2 80
-#define sparc_sun_sunos4 81
-#define sparc_unknown_linux 82
-
-#define HostPlatform_TYPE @HostPlatform_CPP@
-#define TargetPlatform_TYPE @HostPlatform_CPP@
-#define BuildPlatform_TYPE @HostPlatform_CPP@
-
-#define @HostPlatform_CPP@_HOST 1
-#define @HostPlatform_CPP@_TARGET 1
-#define @HostPlatform_CPP@_BUILD 1
-
-#define @HostArch_CPP@_HOST_ARCH 1
-#define @HostArch_CPP@_TARGET_ARCH 1
-#define @HostArch_CPP@_BUILD_ARCH 1
-
-#define @HostOS_CPP@_HOST_OS 1
-#define @HostOS_CPP@_TARGET_OS 1
-#define @HostOS_CPP@_BUILD_OS 1
-
-#define @HostVendor_CPP@_HOST_VENDOR 1
-#define @HostVendor_CPP@_TARGET_VENDOR 1
-#define @HostVendor_CPP@_BUILD_VENDOR 1
-
-#define HC_UNSPECIFIED 1
-#define HC_GLASGOW_GHC 2
-#define HC_USE_HC_FILES 3
-#define HC_CHALMERS_HBC 4
-#define HC_ROJEMO_NHC 5
-#define HC_YALE_YHC 6
-#define HC_HUGS 7
-
-#endif
+++ /dev/null
-
-/*
- * PVM version 3.3: Parallel Virtual Machine System
- * University of Tennessee, Knoxville TN.
- * Oak Ridge National Laboratory, Oak Ridge TN.
- * Emory University, Atlanta GA.
- * Authors: A. L. Beguelin, J. J. Dongarra, G. A. Geist,
- * W. C. Jiang, R. J. Manchek, B. K. Moore, and V. S. Sunderam
- * (C) 1992 All Rights Reserved
- *
- * NOTICE
- *
- * Permission to use, copy, modify, and distribute this software and
- * its documentation for any purpose and without fee is hereby granted
- * provided that the above copyright notice appear in all copies and
- * that both the copyright notice and this permission notice appear in
- * supporting documentation.
- *
- * Neither the Institutions (Emory University, Oak Ridge National
- * Laboratory, and University of Tennessee) nor the Authors make any
- * representations about the suitability of this software for any
- * purpose. This software is provided ``as is'' without express or
- * implied warranty.
- *
- * PVM version 3 was funded in part by the U.S. Department of Energy,
- * the National Science Foundation and the State of Tennessee.
- */
-
-/*
- * pvm3.h
- *
- * Libpvm3 includes.
- *
-$Log: pvm3.h,v $
-Revision 1.1 1996/01/08 20:26:27 partain
-Initial revision
-
- */
-
-#ifndef _PVM3_H_
-
-#define _PVM3_H_
-
-#include <sys/time.h>
-
-/*
-* Data packing styles for pvm_initsend()
-*/
-
-#define PvmDataDefault 0
-#define PvmDataRaw 1
-#define PvmDataInPlace 2
-#define PvmDataFoo 3
-
-/*
-* pvm_spawn options
-*/
-
-#define PvmTaskDefault 0
-#define PvmTaskHost 1 /* specify host */
-#define PvmTaskArch 2 /* specify architecture */
-#define PvmTaskDebug 4 /* start task in debugger */
-#define PvmTaskTrace 8 /* process generates trace data */
-/* for MPP ports */
-#define PvmMppFront 16 /* spawn task on service node */
-#define PvmHostCompl 32 /* complement host set */
-
-/*
-* pvm_notify types
-*/
-
-#define PvmTaskExit 1 /* on task exit */
-#define PvmHostDelete 2 /* on host fail/delete */
-#define PvmHostAdd 3 /* on host startup */
-
-/*
-* for pvm_setopt and pvm_getopt
-*/
-
-#define PvmRoute 1 /* routing policy */
-#define PvmDontRoute 1 /* don't allow direct task-task links */
-#define PvmAllowDirect 2 /* allow direct links, but don't request */
-#define PvmRouteDirect 3 /* request direct links */
-#define PvmDebugMask 2 /* debugmask */
-#define PvmAutoErr 3 /* auto error reporting */
-#define PvmOutputTid 4 /* stdout destination for children */
-#define PvmOutputCode 5 /* stdout message tag */
-#define PvmTraceTid 6 /* trace destination for children */
-#define PvmTraceCode 7 /* trace message tag */
-#define PvmFragSize 8 /* message fragment size */
-#define PvmResvTids 9 /* allow reserved message tids and codes */
-#define PvmSelfOutputTid 10 /* stdout destination for task */
-#define PvmSelfOutputCode 11 /* stdout message tag */
-#define PvmSelfTraceTid 12 /* trace destination for task */
-#define PvmSelfTraceCode 13 /* trace message tag */
-#define PvmShowTids 14 /* pvm_catchout prints task ids with output */
-
-/*
-* for pvm_[sg]ettmask
-*/
-
-#define PvmTaskSelf 0 /* this task */
-#define PvmTaskChild 1 /* (future) child tasks */
-
-/*
-* Libpvm error codes
-*/
-
-#define PvmOk 0 /* Error 0 */
-#define PvmBadParam -2 /* Bad parameter */
-#define PvmMismatch -3 /* Count mismatch */
-#define PvmOverflow -4 /* Value too large */
-#define PvmNoData -5 /* End of buffer */
-#define PvmNoHost -6 /* No such host */
-#define PvmNoFile -7 /* No such file */
-#define PvmNoMem -10 /* Malloc failed */
-#define PvmBadMsg -12 /* Can't decode message */
-#define PvmSysErr -14 /* Can't contact local daemon */
-#define PvmNoBuf -15 /* No current buffer */
-#define PvmNoSuchBuf -16 /* No such buffer */
-#define PvmNullGroup -17 /* Null group name */
-#define PvmDupGroup -18 /* Already in group */
-#define PvmNoGroup -19 /* No such group */
-#define PvmNotInGroup -20 /* Not in group */
-#define PvmNoInst -21 /* No such instance */
-#define PvmHostFail -22 /* Host failed */
-#define PvmNoParent -23 /* No parent task */
-#define PvmNotImpl -24 /* Not implemented */
-#define PvmDSysErr -25 /* Pvmd system error */
-#define PvmBadVersion -26 /* Version mismatch */
-#define PvmOutOfRes -27 /* Out of resources */
-#define PvmDupHost -28 /* Duplicate host */
-#define PvmCantStart -29 /* Can't start pvmd */
-#define PvmAlready -30 /* Already in progress */
-#define PvmNoTask -31 /* No such task */
-#define PvmNoEntry -32 /* No such entry */
-#define PvmDupEntry -33 /* Duplicate entry */
-
-/*
-* Data types for pvm_reduce(), pvm_psend(), pvm_precv()
-*/
-
-#define PVM_STR 0 /* string */
-#define PVM_BYTE 1 /* byte */
-#define PVM_SHORT 2 /* short */
-#define PVM_INT 3 /* int */
-#define PVM_FLOAT 4 /* real */
-#define PVM_CPLX 5 /* complex */
-#define PVM_DOUBLE 6 /* double */
-#define PVM_DCPLX 7 /* double complex */
-#define PVM_LONG 8 /* long integer */
-#define PVM_USHORT 9 /* unsigned short int */
-#define PVM_UINT 10 /* unsigned int */
-#define PVM_ULONG 11 /* unsigned long int */
-
-/*
-* returned by pvm_config()
-*/
-
-struct pvmhostinfo {
- int hi_tid; /* pvmd tid */
- char *hi_name; /* host name */
- char *hi_arch; /* host arch */
- int hi_speed; /* cpu relative speed */
-};
-
-/*
-* returned by pvm_tasks()
-*/
-
-struct pvmtaskinfo {
- int ti_tid; /* task id */
- int ti_ptid; /* parent tid */
- int ti_host; /* pvmd tid */
- int ti_flag; /* status flags */
- char *ti_a_out; /* a.out name */
- int ti_pid; /* task (O/S dependent) process id */
-};
-
-
-#ifdef __ProtoGlarp__
-#undef __ProtoGlarp__
-#endif
-#if defined(__STDC__) || defined(__cplusplus)
-#define __ProtoGlarp__(x) x
-#else
-#define __ProtoGlarp__(x) ()
-#endif
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-int pvm_addhosts __ProtoGlarp__(( char **, int, int * ));
-int pvm_archcode __ProtoGlarp__(( char * ));
-int pvm_barrier __ProtoGlarp__(( char *, int ));
-int pvm_bcast __ProtoGlarp__(( char *, int ));
-int pvm_bufinfo __ProtoGlarp__(( int, int *, int *, int * ));
-/*
-int pvm_catchout __ProtoGlarp__(( FILE * ));
-*/
-int pvm_config __ProtoGlarp__(( int *, int *,
- struct pvmhostinfo ** ));
-int pvm_delete __ProtoGlarp__(( char *, int ));
-int pvm_delhosts __ProtoGlarp__(( char **, int, int * ));
-int pvm_exit __ProtoGlarp__(( void ));
-int pvm_freebuf __ProtoGlarp__(( int ));
-int pvm_gather __ProtoGlarp__(( void*, void*,
- int, int, int, char*, int));
-int pvm_getfds __ProtoGlarp__(( int ** ));
-int pvm_getinst __ProtoGlarp__(( char *, int ));
-int pvm_getmwid __ProtoGlarp__(( int ));
-int pvm_getopt __ProtoGlarp__(( int ));
-int pvm_getrbuf __ProtoGlarp__(( void ));
-int pvm_getsbuf __ProtoGlarp__(( void ));
-int pvm_gettid __ProtoGlarp__(( char *, int ));
-int pvm_gsize __ProtoGlarp__(( char * ));
-int pvm_halt __ProtoGlarp__(( void ));
-int pvm_hostsync __ProtoGlarp__(( int, struct timeval *,
- struct timeval * ));
-int pvm_initsend __ProtoGlarp__(( int ));
-int pvm_insert __ProtoGlarp__(( char *, int, int ));
-int pvm_joingroup __ProtoGlarp__(( char * ));
-int pvm_kill __ProtoGlarp__(( int ));
-int pvm_lookup __ProtoGlarp__(( char *, int, int * ));
-int pvm_lvgroup __ProtoGlarp__(( char * ));
-int pvm_mcast __ProtoGlarp__(( int *, int, int ));
-int pvm_mkbuf __ProtoGlarp__(( int ));
-int pvm_mstat __ProtoGlarp__(( char * ));
-int pvm_mytid __ProtoGlarp__(( void ));
-int pvm_notify __ProtoGlarp__(( int, int,
- int, int * ));
-int pvm_nrecv __ProtoGlarp__(( int, int ));
-int pvm_packf __ProtoGlarp__(( const char *, ... ));
-int pvm_parent __ProtoGlarp__(( void ));
-int pvm_perror __ProtoGlarp__(( char * ));
-int pvm_pkbyte __ProtoGlarp__(( char *, int, int ));
-int pvm_pkcplx __ProtoGlarp__(( float *, int, int ));
-int pvm_pkdcplx __ProtoGlarp__(( double *, int, int ));
-int pvm_pkdouble __ProtoGlarp__(( double *, int, int ));
-int pvm_pkfloat __ProtoGlarp__(( float *, int, int ));
-int pvm_pkint __ProtoGlarp__(( int *, int, int ));
-int pvm_pklong __ProtoGlarp__(( long *, int, int ));
-int pvm_pkshort __ProtoGlarp__(( short *, int, int ));
-int pvm_pkstr __ProtoGlarp__(( char * ));
-int pvm_pkuint __ProtoGlarp__(( unsigned int *, int, int ));
-int pvm_pkulong __ProtoGlarp__(( unsigned long *, int, int ));
-int pvm_pkushort __ProtoGlarp__(( unsigned short *, int, int ));
-int pvm_precv __ProtoGlarp__(( int, int,
- void *, int, int,
- int *, int *, int * ));
-int pvm_probe __ProtoGlarp__(( int, int ));
-int pvm_psend __ProtoGlarp__(( int, int,
- void *, int, int ));
-int pvm_pstat __ProtoGlarp__(( int ));
-int pvm_recv __ProtoGlarp__(( int, int ));
-int (*pvm_recvf __ProtoGlarp__(( int (*)(int, int, int) )) )();
-int pvm_reduce __ProtoGlarp__(( void (*)(int*, void*, void*, int*, int*),
- void *, int,
- int, int, char *,
- int ));
-
-/*
-* Predefined pvm_reduce functions
-*/
-void PvmMax __ProtoGlarp__(( int *, void *, void *,
- int *, int * ));
-void PvmMin __ProtoGlarp__(( int *, void *, void *,
- int *, int * ));
-void PvmSum __ProtoGlarp__(( int *, void *, void *,
- int *, int * ));
-void PvmProduct __ProtoGlarp__(( int *, void *, void *,
- int *, int * ));
-
-int pvm_reg_hoster __ProtoGlarp__(( void ));
-int pvm_reg_rm __ProtoGlarp__(( struct pvmhostinfo ** ));
-int pvm_reg_tasker __ProtoGlarp__(( void ));
-int pvm_scatter __ProtoGlarp__(( void*, void*,
- int, int, int, char*, int));
-int pvm_send __ProtoGlarp__(( int, int ));
-int pvm_sendsig __ProtoGlarp__(( int, int ));
-int pvm_setmwid __ProtoGlarp__(( int, int ));
-int pvm_setopt __ProtoGlarp__(( int, int ));
-int pvm_setrbuf __ProtoGlarp__(( int ));
-int pvm_setsbuf __ProtoGlarp__(( int ));
-int pvm_spawn __ProtoGlarp__(( char *, char **, int,
- char *, int, int * ));
-int pvm_start_pvmd __ProtoGlarp__(( int, char **, int ));
-int pvm_tasks __ProtoGlarp__(( int, int *,
- struct pvmtaskinfo ** ));
-int pvm_tickle __ProtoGlarp__(( int, int *,
- int *, int * ));
-int pvm_tidtohost __ProtoGlarp__(( int ));
-int pvm_trecv __ProtoGlarp__(( int, int, struct timeval * ));
-int pvm_unpackf __ProtoGlarp__(( const char *, ... ));
-int pvm_upkbyte __ProtoGlarp__(( char *, int, int ));
-int pvm_upkcplx __ProtoGlarp__(( float *, int, int ));
-int pvm_upkdcplx __ProtoGlarp__(( double *, int, int ));
-int pvm_upkdouble __ProtoGlarp__(( double *, int, int ));
-int pvm_upkfloat __ProtoGlarp__(( float *, int, int ));
-int pvm_upkint __ProtoGlarp__(( int *, int, int ));
-int pvm_upklong __ProtoGlarp__(( long *, int, int ));
-int pvm_upkshort __ProtoGlarp__(( short *, int, int ));
-int pvm_upkstr __ProtoGlarp__(( char * ));
-int pvm_upkuint __ProtoGlarp__(( unsigned int *, int, int ));
-int pvm_upkulong __ProtoGlarp__(( unsigned long *, int, int ));
-int pvm_upkushort __ProtoGlarp__(( unsigned short *, int, int ));
-char *pvm_version __ProtoGlarp__(( void ));
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /*_PVM3_H_*/
-
+++ /dev/null
-#ifndef RTSDEFS_H
-#define RTSDEFS_H
-
-#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 NULL_REG_MAP
-# endif
-#endif
-
-#define IN_GHC_RTS 1
-
-#include "stgdefs.h"
-
-#endif /* RTSDEFS_H */
+++ /dev/null
-/* these are the definitions included at the beginning
- * of every compiled-to-C module
- */
-#ifndef STGDEFS_H
-#define STGDEFS_H
-
-/* machine/compiler/system dependencies :-( Must be first! */
-#include "config.h" /* generated by configure */
-#include "error.h"
-#include "StgMachDeps.h"
-
-#include "COptRegs.h"
-
-/* our own ASSERT macro (for C) */
-#ifndef DEBUG
-#define NDEBUG 1 /* for assert.h */
-#define ASSERT(predicate) /*nothing*/
-
-#else
-#undef NDEBUG /* for assert.h */
-
-void _stgAssert PROTO((char *, unsigned int));
-
-#define ASSERT(predicate) \
- if (predicate) \
- /*null*/; \
- else \
- _stgAssert(__FILE__, __LINE__)
-#endif
-
-#if macos7_TARGET_OS
-#define NON_POSIX_SOURCE
-#endif
-
-/* If _NEXT_SOURCE is defined, certain header files make more
- * constants visible to us.
- * Perhaps it would have been wise, also to define NON_POSIX_SOURCE.
- * Things seemed to work better without it however, so I have not
- * done it. Nevertheless we do the signal stuff in a NON_POSIX way,
- * see StgMacros.lh.
- * CaS
- */
-#ifdef nextstep3_TARGET_OS
-#define _NEXT_SOURCE
-#endif
-
-#ifdef aix_TARGET_OS
-/* for fd_set */
-#include <sys/select.h>
-#endif
-
-#ifdef NON_POSIX_SOURCE
-#undef _POSIX_SOURCE
-#undef _POSIX_C_SOURCE
-#else
-# ifndef aix_TARGET_OS
-/* already defined on aix */
-#define _POSIX_SOURCE 1
-# endif
-#ifndef irix_TARGET_OS
-#define _POSIX_C_SOURCE 199301L
-#else
-/* defines contributed by Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu>
- ( this is with gcc-2.7.2 for irix-6.{2.3} ) .. hopefully they will not
- upset anything under irix5 ..
- */
-#define _POSIX_C_SOURCE 199309L
-#define __EXTENSIONS__
-#endif
-/* Bogus use of non-existent variable POSIX_C_SOURCE in the supplied header files
- for gcc-2.7.1 on Solaris forces us to define it: (this strikes when using st_atime
- and friends in <sys/stat.h> )
-*/
-
-#if (__GNUC__ == 2) && (__GNUC_MINOR__ == 7)
-/* sigh, not possible to get at bugfix release number (fixed in 2.7.2) */
-#define POSIX_C_SOURCE _POSIX_C_SOURCE
-#endif
-
-#include <unistd.h>
-#include <signal.h>
-#endif
-
-/* these are all ANSI C headers */
-#include <stdlib.h>
-#include <string.h>
-#include <math.h>
-#include <assert.h>
-#include <errno.h>
-#include <stdio.h>
-
-#ifndef STDC_HEADERS
-/* hack: though the following are defined in the ANSI C library,
- they may not be defined in a systems stdio.h (Suns, for example).
- GCC is schizophrenic about whether it adds these into its
- own headers for you; so we have no choice but to throw them in.
-*/
-int fclose PROTO((FILE *));
-int fflush PROTO((FILE *));
-int fgetc PROTO((FILE *));
-int fprintf PROTO((FILE *, const char *, ...));
-int fputc PROTO((int, FILE *));
-int fputs PROTO((const char *, FILE *));
-size_t fread PROTO((void *, size_t, size_t, FILE *));
-int fscanf PROTO((FILE *, const char *, ...));
-int fseek PROTO((FILE *, long int, int));
-size_t fwrite PROTO((const void *, size_t, size_t, FILE *));
-void perror PROTO((const char *));
-int printf PROTO((const char *, ...));
-int puts PROTO((const char *));
-int remove PROTO((const char *));
-int rename PROTO((const char *, const char *));
-void rewind PROTO((FILE *));
-int scanf PROTO((const char *, ...));
-void setbuf PROTO((FILE *, char *));
-int setvbuf PROTO((FILE *, char *, int, size_t));
-int sscanf PROTO((const char *, const char *, ...));
-/* end of hack */
-#endif /* STDC_HEADERS */
-
-#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.
-*/
-#define EXIT_SUCCESS 0
-#define EXIT_FAILURE 1
-#endif
-
-/* Make sure that *some* register map is defined */
-#ifdef __STG_GCC_REGS__
-# if !(defined(NULL_REG_MAP) || defined(FLUSH_REG_MAP) || defined(MAIN_REG_MAP) \
- || defined(MARK_REG_MAP) || defined(SCAN_REG_MAP) || defined(SCAV_REG_MAP))
-yikes! no register map defined!
-# endif
-#endif
-
-/* Make sure that *some* garbage-collector is expected; GCap is the default */
-#if !(defined(GCap) || defined(GC2s) || defined(GC1s) || defined(GCdu) || defined(GCgn))
-#define GCap 1
-#endif
-
-#ifdef IN_GHC_RTS
-#define IF_RTS(x) x
-#else
-#define IF_RTS(x) /*nothing*/
-#endif
-
-/* GNU multi-precision arith */
-#include "gmp.h"
-
-/* typedefs for the basic entities */
-#include "StgTypes.h"
-
-/* constants about the system known to *everybody* (compiler & RTS) */
-#include "GhcConstants.h"
-
-/* macros to deal with stacks (no longer heap) growing in either dirn */
-#include "StgDirections.h"
-
-/* declarations for all the runtime flags for the RTS */
-#ifdef IN_GHC_RTS
-#include "RtsFlags.h"
-#endif
-/* and those that are visible *everywhere* (RTS + Haskell code) */
-struct ALL_FLAGS {
-#ifdef TICKY_TICKY
- W_ doUpdEntryCounts; /* if true, we cannot short-circuit Inds,
- common-up {Int,Char}Likes or Consts
- */
-#endif
- W_ dummy_entry; /* so there is *something* in it... */
-};
-extern struct ALL_FLAGS AllFlags;
-
-/* declarations for garbage collection routines */
-#include "SMinterface.h"
-
-/* Macros for declaring "registers" and other Optimising stuff */
-#include "COptJumps.h"
-#include "COptRegs.h"
-#include "COptWraps.h"
-
-/* these will come into play if you use -DTICKY_TICKY (default: off) */
-#include "Ticky.h"
-
-hash_t hash_str PROTO((char *str));
-hash_t hash_fixed PROTO((char *data, I_ len));
-
-/* ullong (64bit) formatting */
-char *ullong_format_string PROTO((ullong x, char *s, rtsBool with_commas));
-
-/* declarations of macros for "high-level instructions" */
-#include "StgMacros.h"
-
-/* You always need these */
-#include "Info.h"
-
-/* You need these if you are using the threads package or a parallel machine... */
-#include "Threads.h"
-#include "Parallel.h"
-
-/* Things will happen in here if the driver does -DPROFILING */
-#include "CostCentre.h"
-
-/* GRAN and PAR stuff */
-#include "GranSim.h"
-
-#if defined(PROFILING) || defined(CONCURRENT)
-char * time_str(STG_NO_ARGS);
-#endif
-
-/* declarations for runtime-system entry points */
-void miniInterpret PROTO((StgFunPtr));
-void miniInterpret_debug PROTO(( StgFunPtr, void(*)(STG_NO_ARGS) ));
-void miniInterpretEnd(STG_NO_ARGS);
-
-/* UNUSED -- SOF 9/97
-StgFunPtr evaluateMain(STG_NO_ARGS);
-StgFunPtr returnMain(STG_NO_ARGS);
-StgFunPtr impossible_jump_after_switch(STG_NO_ARGS);
-*/
-
-/* error handling for IO implementation*/
-extern int ghc_errno;
-extern int ghc_errtype;
-extern char *ghc_errstr;
-
-void cvtErrno (void);
-void stdErrno (void);
-
-/* hooks: user might write some of their own */
-void ErrorHdrHook PROTO((StgInt));
-void OutOfHeapHook PROTO((W_, W_));
-void OnExitHook (STG_NO_ARGS);
-void StackOverflowHook PROTO((I_));
-#ifdef CONCURRENT
-int NoRunnableThreadsHook (STG_NO_ARGS);
-#endif
-void MallocFailHook PROTO((I_, char *));
-void PatErrorHdrHook PROTO((StgInt));
-void PreTraceHook PROTO((StgInt));
-void PostTraceHook PROTO((StgInt));
-void defaultsHook (STG_NO_ARGS);
-void initEachPEHook (STG_NO_ARGS);
-void IOErrorHdrHook PROTO((StgInt));
-
-EXTFUN(startStgWorld);
-#ifdef CONCURRENT
-EXTFUN(CheckHeapCode);
-EXTFUN(Continue);
-EXTFUN(resumeThread);
-#endif
-
-extern char **prog_argv; /* from runtime/main/main.lc */
-extern int prog_argc;
-extern char **environ; /* we can get this one straight */
-
-EXTDATA(STK_STUB_closure);
-
-/* now these really *DO* need to be somewhere else... */
-char *time_str(STG_NO_ARGS);
-I_ stg_exit PROTO((I_));
-I_ _stg_rem PROTO((I_, I_));
-char *stgMallocBytes PROTO((I_, char *));
-char *stgMallocWords PROTO((I_, char *));
-
-/* definitions for closures */
-#include "SMClosures.h"
-
-/* definitions for info tables */
-#include "SMInfoTables.h"
-
-/* declarations for Update & Indirection stuff */
-#include "SMupdate.h"
-
-/* declarations for runtime flags/values */
-#define MAX_RTS_ARGS 32
-
-/* Saving and restoring registers */
-#include "StgRegs.h"
-
-
-/*
- * 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
-# ifdef __FD_SETSIZE
-# define FD_SETSIZE __FD_SETSIZE
-# else /* cop out */
-# define FD_SETSIZE 1024
-# endif
-#endif
-
-#endif /* ! STGDEFS_H */
+++ /dev/null
-%!PS-Adobe-2.0 EPSF-1.2
-%%DocumentFonts: Times-Roman
-%%Pages: 1
-%%BoundingBox: 233 491 369 578
-%%EndComments
-
-50 dict begin
-
-/arrowHeight 8 def
-/arrowWidth 4 def
-/none null def
-/numGraphicParameters 17 def
-/stringLimit 65535 def
-
-/Begin {
-save
-numGraphicParameters dict begin
-} def
-
-/End {
-end
-restore
-} def
-
-/SetB {
-dup type /nulltype eq {
-pop
-false /brushRightArrow idef
-false /brushLeftArrow idef
-true /brushNone idef
-} {
-/brushDashOffset idef
-/brushDashArray idef
-0 ne /brushRightArrow idef
-0 ne /brushLeftArrow idef
-/brushWidth idef
-false /brushNone idef
-} ifelse
-} def
-
-/SetCFg {
-/fgblue idef
-/fggreen idef
-/fgred idef
-} def
-
-/SetCBg {
-/bgblue idef
-/bggreen idef
-/bgred idef
-} def
-
-/SetF {
-/printSize idef
-/printFont idef
-} def
-
-/SetP {
-dup type /nulltype eq {
-pop true /patternNone idef
-} {
-dup -1 eq {
-/patternGrayLevel idef
-/patternString idef
-} {
-/patternGrayLevel idef
-} ifelse
-false /patternNone idef
-} ifelse
-} def
-
-/BSpl {
-0 begin
-storexyn
-newpath
-n 1 gt {
-0 0 0 0 0 0 1 1 true subspline
-n 2 gt {
-0 0 0 0 1 1 2 2 false subspline
-1 1 n 3 sub {
-/i exch def
-i 1 sub dup i dup i 1 add dup i 2 add dup false subspline
-} for
-n 3 sub dup n 2 sub dup n 1 sub dup 2 copy false subspline
-} if
-n 2 sub dup n 1 sub dup 2 copy 2 copy false subspline
-patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if
-brushNone not { istroke } if
-0 0 1 1 leftarrow
-n 2 sub dup n 1 sub dup rightarrow
-} if
-end
-} dup 0 4 dict put def
-
-/Circ {
-newpath
-0 360 arc
-patternNone not { ifill } if
-brushNone not { istroke } if
-} def
-
-/CBSpl {
-0 begin
-dup 2 gt {
-storexyn
-newpath
-n 1 sub dup 0 0 1 1 2 2 true subspline
-1 1 n 3 sub {
-/i exch def
-i 1 sub dup i dup i 1 add dup i 2 add dup false subspline
-} for
-n 3 sub dup n 2 sub dup n 1 sub dup 0 0 false subspline
-n 2 sub dup n 1 sub dup 0 0 1 1 false subspline
-patternNone not { ifill } if
-brushNone not { istroke } if
-} {
-Poly
-} ifelse
-end
-} dup 0 4 dict put def
-
-/Elli {
-0 begin
-newpath
-4 2 roll
-translate
-scale
-0 0 1 0 360 arc
-patternNone not { ifill } if
-brushNone not { istroke } if
-end
-} dup 0 1 dict put def
-
-/Line {
-0 begin
-2 storexyn
-newpath
-x 0 get y 0 get moveto
-x 1 get y 1 get lineto
-brushNone not { istroke } if
-0 0 1 1 leftarrow
-0 0 1 1 rightarrow
-end
-} dup 0 4 dict put def
-
-/MLine {
-0 begin
-storexyn
-newpath
-n 1 gt {
-x 0 get y 0 get moveto
-1 1 n 1 sub {
-/i exch def
-x i get y i get lineto
-} for
-patternNone not brushLeftArrow not brushRightArrow not and and { ifill } if
-brushNone not { istroke } if
-0 0 1 1 leftarrow
-n 2 sub dup n 1 sub dup rightarrow
-} if
-end
-} dup 0 4 dict put def
-
-/Poly {
-3 1 roll
-newpath
-moveto
--1 add
-{ lineto } repeat
-closepath
-patternNone not { ifill } if
-brushNone not { istroke } if
-} def
-
-/Rect {
-0 begin
-/t exch def
-/r exch def
-/b exch def
-/l exch def
-newpath
-l b moveto
-l t lineto
-r t lineto
-r b lineto
-closepath
-patternNone not { ifill } if
-brushNone not { istroke } if
-end
-} dup 0 4 dict put def
-
-/Text {
-ishow
-} def
-
-/idef {
-dup where { pop pop pop } { exch def } ifelse
-} def
-
-/ifill {
-0 begin
-gsave
-patternGrayLevel -1 ne {
-fgred bgred fgred sub patternGrayLevel mul add
-fggreen bggreen fggreen sub patternGrayLevel mul add
-fgblue bgblue fgblue sub patternGrayLevel mul add setrgbcolor
-eofill
-} {
-eoclip
-originalCTM setmatrix
-pathbbox /t exch def /r exch def /b exch def /l exch def
-/w r l sub ceiling cvi def
-/h t b sub ceiling cvi def
-/imageByteWidth w 8 div ceiling cvi def
-/imageHeight h def
-bgred bggreen bgblue setrgbcolor
-eofill
-fgred fggreen fgblue setrgbcolor
-w 0 gt h 0 gt and {
-l b translate w h scale
-w h true [w 0 0 h neg 0 h] { patternproc } imagemask
-} if
-} ifelse
-grestore
-end
-} dup 0 8 dict put def
-
-/istroke {
-gsave
-brushDashOffset -1 eq {
-[] 0 setdash
-1 setgray
-} {
-brushDashArray brushDashOffset setdash
-fgred fggreen fgblue setrgbcolor
-} ifelse
-brushWidth setlinewidth
-originalCTM setmatrix
-stroke
-grestore
-} def
-
-/ishow {
-0 begin
-gsave
-fgred fggreen fgblue setrgbcolor
-/fontDict printFont findfont printSize scalefont dup setfont def
-/descender fontDict begin 0 [FontBBox] 1 get FontMatrix end
-transform exch pop def
-/vertoffset 0 descender sub printSize sub printFont /Courier ne
-printFont /Courier-Bold ne and { 1 add } if def {
-0 vertoffset moveto show
-/vertoffset vertoffset printSize sub def
-} forall
-grestore
-end
-} dup 0 3 dict put def
-
-/patternproc {
-0 begin
-/patternByteLength patternString length def
-/patternHeight patternByteLength 8 mul sqrt cvi def
-/patternWidth patternHeight def
-/patternByteWidth patternWidth 8 idiv def
-/imageByteMaxLength imageByteWidth imageHeight mul
-stringLimit patternByteWidth sub min def
-/imageMaxHeight imageByteMaxLength imageByteWidth idiv patternHeight idiv
-patternHeight mul patternHeight max def
-/imageHeight imageHeight imageMaxHeight sub store
-/imageString imageByteWidth imageMaxHeight mul patternByteWidth add string def
-0 1 imageMaxHeight 1 sub {
-/y exch def
-/patternRow y patternByteWidth mul patternByteLength mod def
-/patternRowString patternString patternRow patternByteWidth getinterval def
-/imageRow y imageByteWidth mul def
-0 patternByteWidth imageByteWidth 1 sub {
-/x exch def
-imageString imageRow x add patternRowString putinterval
-} for
-} for
-imageString
-end
-} dup 0 12 dict put def
-
-/min {
-dup 3 2 roll dup 4 3 roll lt { exch } if pop
-} def
-
-/max {
-dup 3 2 roll dup 4 3 roll gt { exch } if pop
-} def
-
-/arrowhead {
-0 begin
-transform originalCTM itransform
-/taily exch def
-/tailx exch def
-transform originalCTM itransform
-/tipy exch def
-/tipx exch def
-/dy tipy taily sub def
-/dx tipx tailx sub def
-/angle dx 0 ne dy 0 ne or { dy dx atan } { 90 } ifelse def
-gsave
-originalCTM setmatrix
-tipx tipy translate
-angle rotate
-newpath
-0 0 moveto
-arrowHeight neg arrowWidth 2 div lineto
-arrowHeight neg arrowWidth 2 div neg lineto
-closepath
-patternNone not {
-originalCTM setmatrix
-/padtip arrowHeight 2 exp 0.25 arrowWidth 2 exp mul add sqrt brushWidth mul
-arrowWidth div def
-/padtail brushWidth 2 div def
-tipx tipy translate
-angle rotate
-padtip 0 translate
-arrowHeight padtip add padtail add arrowHeight div dup scale
-arrowheadpath
-ifill
-} if
-brushNone not {
-originalCTM setmatrix
-tipx tipy translate
-angle rotate
-arrowheadpath
-istroke
-} if
-grestore
-end
-} dup 0 9 dict put def
-
-/arrowheadpath {
-newpath
-0 0 moveto
-arrowHeight neg arrowWidth 2 div lineto
-arrowHeight neg arrowWidth 2 div neg lineto
-closepath
-} def
-
-/leftarrow {
-0 begin
-y exch get /taily exch def
-x exch get /tailx exch def
-y exch get /tipy exch def
-x exch get /tipx exch def
-brushLeftArrow { tipx tipy tailx taily arrowhead } if
-end
-} dup 0 4 dict put def
-
-/rightarrow {
-0 begin
-y exch get /tipy exch def
-x exch get /tipx exch def
-y exch get /taily exch def
-x exch get /tailx exch def
-brushRightArrow { tipx tipy tailx taily arrowhead } if
-end
-} dup 0 4 dict put def
-
-/midpoint {
-0 begin
-/y1 exch def
-/x1 exch def
-/y0 exch def
-/x0 exch def
-x0 x1 add 2 div
-y0 y1 add 2 div
-end
-} dup 0 4 dict put def
-
-/thirdpoint {
-0 begin
-/y1 exch def
-/x1 exch def
-/y0 exch def
-/x0 exch def
-x0 2 mul x1 add 3 div
-y0 2 mul y1 add 3 div
-end
-} dup 0 4 dict put def
-
-/subspline {
-0 begin
-/movetoNeeded exch def
-y exch get /y3 exch def
-x exch get /x3 exch def
-y exch get /y2 exch def
-x exch get /x2 exch def
-y exch get /y1 exch def
-x exch get /x1 exch def
-y exch get /y0 exch def
-x exch get /x0 exch def
-x1 y1 x2 y2 thirdpoint
-/p1y exch def
-/p1x exch def
-x2 y2 x1 y1 thirdpoint
-/p2y exch def
-/p2x exch def
-x1 y1 x0 y0 thirdpoint
-p1x p1y midpoint
-/p0y exch def
-/p0x exch def
-x2 y2 x3 y3 thirdpoint
-p2x p2y midpoint
-/p3y exch def
-/p3x exch def
-movetoNeeded { p0x p0y moveto } if
-p1x p1y p2x p2y p3x p3y curveto
-end
-} dup 0 17 dict put def
-
-/storexyn {
-/n exch def
-/y n array def
-/x n array def
-n 1 sub -1 0 {
-/i exch def
-y i 3 2 roll put
-x i 3 2 roll put
-} for
-} def
-
-%%EndProlog
-
-%I Idraw 7 Grid 5
-
-%%Page: 1 1
-
-Begin
-%I b u
-%I cfg u
-%I cbg u
-%I f u
-%I p u
-%I t
-[ 0.8 0 0 0.8 0 0 ] concat
-/originalCTM matrix currentmatrix def
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 2.27341 0 0 1 -36.6448 228 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 298.5 633 ] concat
-%I
-[
-(Pointer to Update return vector)
-] Text
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 2.27325 0 0 1 -36.6219 252 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1.00625 0 0 1 298.006 656 ] concat
-%I
-[
-(Pointer to closure to be updated)
-] Text
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 2.2731 0 0 1 -36.5992 276 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I MLine
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 2.2731 0 0 1.35294 -36.5975 163.059 ] concat
-%I 4
-145 413
-145 388
-219 388
-219 413
-4 MLine
-End
-
-Begin %I Line
-%I b 65535
-1 0 0 [] 0 SetB
-%I cfg Black
-0 0 0 SetCFg
-%I cbg White
-1 1 1 SetCBg
-%I p
-1 SetP
-%I t
-[ 2.25503 0 0 17 -33.4799 -8109 ] concat
-%I
-145 519 219 519 Line
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 300 682 ] concat
-%I
-[
-(Saved SuB)
-] Text
-End
-
-Begin %I Text
-%I cfg Black
-0 0 0 SetCFg
-%I f *-times-medium-r-*-120-*
-/Times-Roman 12 SetF
-%I t
-[ 1 0 0 1 301 705 ] concat
-%I
-[
-(Saved SuA)
-] Text
-End
-
-End %I eop
-
-showpage
-
-%%Trailer
-
-end
--- /dev/null
+################################################################
+# Start of Makefile
+#
+# To use this, try the following:
+# cd ../..
+# rm -f config.cache && autoheader && autoconf && ./configure --enable-hc-boot && make -C ghc/includes boot
+# cd ghc/interpreter
+# make hugs Prelude.hs
+# ./hugs -h300k
+################################################################
+
+# This rule goes first to make it the default choice
+default :: hugs
+
+RTS_DIR = ..
+
+CPPFLAGS += -I$(RTS_DIR)/includes
+CPPFLAGS += -D__HUGS__
+
+CC = gcc
+
+CFLAGS += -Wall
+CFLAGS += -Wno-unused
+CFLAGS += -W
+CFLAGS += -Wstrict-prototypes
+CFLAGS += -Wmissing-prototypes
+CFLAGS += -Wmissing-declarations
+#CFLAGS += -Wredundant-decls
+#CFLAGS += -Wnested-externs
+#CFLAGS += -Wshadow
+CFLAGS += -Winline
+CFLAGS += -Waggregate-return
+
+#CFLAGS += -ggdb3 -O0 # debug with gdb, minimal confusion
+#CFLAGS += -pg -O2 # Profile with gprof
+#CFLAGS += -pg -g # Profile more with gprof
+#CFLAGS += -pg -g -a # Profile basic blocks with gprof (disnae work)
+CFLAGS += -O2 # we just want to run it!
+#CFLAGS += -O2 -g # we just want to run it!
+
+LIBS += -lm # math - may not need it
+#LIBS += -lreadline # cool library
+#LIBS += -lmcheck # GNU extension - consistency check malloc usage
+#LIBS += -ldl # dynamic loading
+
+YACC = bison -y
+RM = /bin/rm -f
+
+# grep include *.c | grep .c\"
+#INCFILES = parser.c preds.c kind.c timer.c scc.c
+
+C_FILES = $(wildcard *.c)
+Y_FILES = $(wildcard *.y)
+
+OBJECTS = hugs.o connect.o \
+ storage.o machdep.o charset.o input.o output.o \
+ static.o modules.o interface.o type.o subst.o link.o \
+ compiler.o desugar.o pmc.o pat.o derive.o \
+ stg.o translate.o pp.o \
+ codegen.o free.o lift.o stgSubst.o optimise.o \
+ dynamic.o
+
+source:
+ echo $(addsuffix .h,$(basename $(OBJECTS)))
+
+################################################################
+# Building the rts library
+#
+# Two ways to link Hugs:
+# o Static link to libHSrts.a using -rdynamic so that GHC generated .so files
+# can access libHSrts.a
+# o Dynamic link to libHSrts.so
+# There's not that much to choose between these two methods: static linking
+# makes debugging easier, dynamic linking will make delivered systems
+# smaller (if you use multiple clients).
+################################################################
+
+.PHONY: libgmp.a libHSrts.a libHSrts.so
+libgmp.a:
+ @$(MAKE) -C $(RTS_DIR)/rts/gmp libgmp.a
+libHSrts.a:
+ @$(MAKE) -C $(RTS_DIR)/rts -fadr libHSrts.a
+libHSrts.so:
+ @$(MAKE) -C $(RTS_DIR)/rts -fadr libHSrts.so
+
+# libHS_cbits.so: $(wildcard ../lib/std/cbits/*.c)
+# @$(MAKE) -C ../lib/std/cbits libHS_cbits.a
+# rm -f $@
+# $(CC) -shared $(patsubst %.c,%.o,$^) -L$(HOME)/lib -lc -o $@
+
+libHS_cbits.so: $(wildcard ../lib/std/cbits/*.c)
+ rm -f $@
+# $(CC) -shared $(CPPFLAGS) -D__CONCURRENT_HASKELL__ $^ -lc -o $@
+# dlltool --def libHS_cbits.def --output-exp libHS_cbits.exp --output-lib libHS_cbits.a --dllname libHS_cbits.dll
+ $(CC) -c $(CPPFLAGS) -D__CONCURRENT_HASKELL__ $^ -lc
+# $(LD) -o libHS_cbits.dll libHS_cbits.exp
+
+CBITS_C = $(wildcard ../lib/std/cbits/*.c)
+CBITS_O = allocMem.o closeFile.o createDirectory.o directoryAux.o echoAux.o errno.o fileEOF.o fileGetc.o fileLookAhead.o fileObject.o filePosn.o filePutc.o fileSize.o flushFile.o freeFile.o getBufferMode.o getCPUTime.o getClockTime.o getCurrentDirectory.o getDirectoryContents.o getLock.o inputReady.o openFile.o readFile.o removeDirectory.o removeFile.o renameDirectory.o renameFile.o seekFile.o setBuffering.o setCurrentDirectory.o showTime.o system.o timezone.o toClockSec.o toLocalTime.o toUTCTime.o writeError.o writeFile.o
+
+libHS_cbits.dll: $(CBITS_O)
+ $(LD) --image-base=0x3000000 -o libHS_cbits.dll libHS_cbits.exp $(CBITS_O) -lcygwin -lkernel32
+
+clean::
+ rm -f libHS_cbits.so
+
+LIBS += $(RTS_DIR)/rts/libHSrts.a $(RTS_DIR)/rts/gmp/libgmp.a
+#LIBS += $(RTS_DIR)/rts/libHSrts.so
+#LIBS += -L$(HOME)/lib -lgmp
+#LIBS += -lbfd -liberty
+LIBS += -ladvapi32
+
+SHARED_LINK = gcc -shared
+
+
+hugs : $(OBJECTS) libHSrts.a libgmp.a
+ $(CC) $(LDFLAGS) $(CPPFLAGS) $(CFLAGS) $(OBJECTS) $(LIBS) -o hugs
+# $(CC) $(LDFLAGS) -rdynamic $(CPPFLAGS) $(CFLAGS) $(OBJECTS) $(LIBS) -o hugs
+
+clean ::
+ $(RM) *.o *.so
+ $(RM) depends.mk
+ $(RM) TAGS
+ $(RM) hugs
+#default :: TAGS
+TAGS ::
+ etags *.[ych] ../{interpreter,rts,includes}/*.{y,hc,c,S,h}
+
+# copied from the standard rules so that I can use @ to make it quieter
+# you'll want to comment this out if you have to debug this Makefile
+%.o : %.c
+ @echo Compiling $<
+ @$(CC) $(CPPFLAGS) $(CFLAGS) -c $<
+
+%.c : %.y
+ -$(YACC) $<
+ mv y.tab.c $@
+clean ::
+ $(RM) parser.c
+
+################################################################
+# Various test libraries:
+################################################################
+
+AB.so: A.o B.o
+ $(SHARED_LINK) $^ -o $@
+
+AB.myhi: A.myhi B.myhi
+ cat $^ > $@
+
+
+################################################################
+# Building .so files I can load into Hugs
+################################################################
+
+.PRECIOUS: A.hc B.hc C.hc D.hc
+
+%.hc: %.hs
+ $(RTS_DIR)/driver/ghc -recomp -i$(RTS_DIR)/lib/std -C $<
+
+# The substitutions rename constructor wrappers to match our expectations
+# And replace Z-encoded $ signs with underscores
+%.c: %.hc
+ echo "#include \"Rts.h\"" > $@
+ cat $< >> $@
+ perl -p -i -e "s/a_closure/A_closure/g" $@
+ perl -p -i -e "s/b_closure/B_closure/g" $@
+ perl -p -i -e "s/mkT_closure/MkT_closure/g" $@
+ perl -p -i -e "s/Z36/_/g" $@
+
+HCFLAGS += -DDEBUG=1
+HCFLAGS += -DDEBUG_EXTRA=1
+HCFLAGS += -ULAZY_BLACKHOLING
+HCFLAGS += -DUSE_MINIINTERPRETER=1
+HCFLAGS += -DINTERPRETER_ONLY=1
+HCFLAGS += -DNO_REGS
+
+# The substitutions rename constructor wrappers to match our expectations
+%.o: %.hc
+ echo "#include \"Rts.h\"" >> $<.c
+ cat $< >> $<.c
+ perl -p -i -e "s/Comb_a_closure/Comb_A_closure/g" $<.c
+ perl -p -i -e "s/Comb_b_closure/Comb_B_closure/g" $<.c
+ $(CC) $(CPPFLAGS) $(CFLAGS) $(HCFLAGS) -xc -c $<.c -o $@
+
+%.so: %.c
+ gcc -shared $(CPPFLAGS) $(CFLAGS) $(HCFLAGS) $< -lm -lbfd -liberty -o $@
+
+################################################################
+# Floppy disk for me to take home at night
+################################################################
+
+# We avoid using zip because we're fed up being bitten by the
+# default=non-recursive bug
+floppy: clean
+ mount /mnt/floppy
+ tar zcvf /mnt/floppy/stghugs.tgz . --exclude=CVS
+ umount /mnt/floppy
+
+################################################################
+# Prelude
+################################################################
+
+# HPPFLAGS += "-DBEGIN_FOR_HUGS={-"
+# HPPFLAGS += "-DEND_FOR_HUGS=-}"
+
+HPP = gcc -E -P -traditional -xc -DSTD_PRELUDE=0 $(HPPFLAGS) $(CPPFLAGS) -Iprelude -Ilibrary -I.
+UNLIT = ../utils/unlit/unlit
+
+# we cleanup by deleting adjacent blank lines - which just happen to be the
+# only duplicate adjacent lines in all the files we process
+CLEANUP = uniq
+
+# Fiendishly cunning this:
+# o PreludeBuiltin.hs contains the BODY of the libraries it requires.
+# o All the other libraries just contain the HEAD of the file.
+Prelude.hs : $(wildcard prelude/*.hs) $(wildcard library/*.hs) $(wildcard ../lib/*/*.lhs) libHS_cbits.dll $(RTS_DIR)/includes/options.h
+ @ echo Building PreludeBuiltin
+ @ $(HPP) ../lib/std/PrelHandle.lhs | $(UNLIT) - PrelHandle.unlit
+ @ $(HPP) ../lib/std/PrelIOBase.lhs | $(UNLIT) - PrelIOBase.unlit
+ @ $(HPP) ../lib/std/PrelException.lhs | $(UNLIT) - PrelException.unlit
+ @ $(HPP) ../lib/std/PrelDynamic.lhs | $(UNLIT) - PrelDynamic.unlit
+ @ $(HPP) -DBODY ../lib/std/IO.lhs | $(UNLIT) - IO.unlit
+ @ $(HPP) -DHEAD ../lib/std/IO.lhs | $(UNLIT) - IO.hs
+ @ $(HPP) -DBODY prelude/Prelude.hs | $(CLEANUP) > PreludeBuiltin.hs
+ @ $(HPP) -DHEAD prelude/Prelude.hs | $(CLEANUP) > Prelude.hs
+ @ $(HPP) -DHEAD library/Array.hs | $(CLEANUP) > Array.hs
+ @ $(HPP) -DHEAD library/Char.hs | $(CLEANUP) > Char.hs
+ @ $(HPP) -DHEAD library/Ix.hs | $(CLEANUP) > Ix.hs
+ @ $(HPP) -DHEAD library/List.hs | $(CLEANUP) > List.hs
+ @ $(HPP) -DHEAD library/Maybe.hs | $(CLEANUP) > Maybe.hs
+ @ $(HPP) -DHEAD library/Numeric.hs | $(CLEANUP) > Numeric.hs
+ @ $(HPP) -DHEAD library/Ratio.hs | $(CLEANUP) > Ratio.hs
+ @ $(HPP) -DHEAD library/UnicodePrims.hs| $(CLEANUP) > UnicodePrims.hs
+ @ $(HPP) -DHEAD prelude/PreludeIO.hs | $(CLEANUP) > PreludeIO.hs
+ @ $(HPP) -DHEAD prelude/PreludeList.hs | $(CLEANUP) > PreludeList.hs
+ @ $(HPP) -DHEAD prelude/PreludeText.hs | $(CLEANUP) > PreludeText.hs
+ @ $(HPP) -DHEAD prelude/PrelConc.hs | $(CLEANUP) > PrelConc.hs
+ @ echo "Building standard libraries"
+ @ $(HPP) library/Complex.hs > Complex.hs
+ @ $(HPP) library/Monad.hs > Monad.hs
+ @ $(HPP) ../lib/std/System.lhs > System.lhs
+ @ $(HPP) ../lib/std/Directory.lhs > Directory.lhs
+ @ $(HPP) ../lib/std/Locale.lhs > Locale.lhs
+ @ $(HPP) ../lib/std/Random.lhs > Random.lhs
+ @ $(HPP) ../lib/std/CPUTime.lhs > CPUTime.lhs
+ @ $(HPP) ../lib/std/Time.lhs > Time.lhs
+ @ echo "And some standard libraries which ain't done yet"
+ @ # $(HPP) library/IO.hs > IO.hs
+ @ #
+ @ echo "Building Hugs-GHC libraries"
+ @ $(HPP) ../lib/exts/ST.lhs > ST.lhs
+ @ $(HPP) ../lib/misc/Pretty.lhs > Pretty.lhs
+ @ $(HPP) ../lib/exts/IOExts.lhs > IOExts.lhs
+ @ $(HPP) ../lib/exts/NumExts.lhs > NumExts.lhs
+ @ $(HPP) ../lib/exts/Dynamic.lhs > Dynamic.lhs
+ @ $(HPP) ../lib/exts/Bits.lhs > Bits.lhs
+ @ $(HPP) ../lib/exts/Exception.lhs > Exception.lhs
+ @ $(HPP) library/Int.hs > Int.hs
+ @ $(HPP) library/Word.hs > Word.hs
+ @ $(HPP) ../lib/exts/Addr.lhs > Addr.lhs
+ @ $(HPP) ../lib/concurrent/Channel.lhs > Channel.lhs
+ @ $(HPP) ../lib/concurrent/ChannelVar.lhs > ChannelVar.lhs
+ @ $(HPP) ../lib/concurrent/Concurrent.lhs > Concurrent.lhs
+ @ $(HPP) ../lib/concurrent/Merge.lhs > Merge.lhs
+ @ $(HPP) ../lib/concurrent/SampleVar.lhs > SampleVar.lhs
+ @ $(HPP) ../lib/concurrent/Semaphore.lhs > Semaphore.lhs
+ @ echo "And some libraries which ain't converted yet"
+ @ # $(HPP) ../lib/exts/Foreign.lhs > Foreign.lhs
+ @ #
+ @ # $(HPP) ../lib/concurrent/Parallel.lhs > Parallel.lhs
+
+clean ::
+ $(RM) Array.hs Dynamic.lhs NumExts.lhs Pretty.lhs
+ $(RM) Bits.lhs Exception.lhs Numeric.hs Ratio.hs
+ $(RM) Channel.lhs IOExts.lhs PrelConc.hs ST.lhs
+ $(RM) ChannelVar.lhs Ix.hs Prelude.hs SampleVar.lhs
+ $(RM) Char.hs List.hs PreludeBuiltin.hs Semaphore.lhs
+ $(RM) Complex.hs Maybe.hs PreludeIO.hs System.lhs
+ $(RM) Concurrent.lhs Merge.lhs PreludeList.hs UnicodePrims.hs
+ $(RM) Directory.lhs Monad.hs PreludeText.hs
+ $(RM) Locale.lhs Int.hs IO.hs Addr.lhs Time.lhs Word.hs
+ $(RM) *.unlit
+
+################################################################
+# Greencard:
+#
+# This works - at least, it seems to:
+#
+# echo "runGreenCard \"--target ffi StdDIS.gc\"" | ./hugs -w -h500k ../../green-card/src/GreenCard.lhs
+# make StdDIS_stub.so
+# env LD_LIBRARY_PATH=. ./hugs -h300k StdDIS.hs
+################################################################
+
+
+################################################################
+# Regression tests (Unix only). Run "make install" first
+#
+# Uses runstdtest (from ghc-0.26/ghc/glafp-utils/scripts), perl 5
+# and /bin/sh (Bourne shell).
+#
+# "make check" generates a lot of output to explain what is going on
+# and reassure you that progress is being made. This is great if you've
+# never run these tests before - but if you just want to reassure yourself
+# that nothing has broken since the last release, you might prefer to
+# run this command which removes all the explanations and success
+# stories - leaving just the useful output.
+#
+# make check | grep -v "^--" -
+#
+################################################################
+
+check : hugs Prelude.hs
+ ./test/runtests test/static/*.hs
+ ./test/runtests test/typechecker/*.hs
+ ./test/runtests test/runtime/*.hs
+ ./test/runtests test/std/*.hs
+ ./test/runtests test/exts/*.hs
+clean ::
+ $(RM) testFile
+
+################################################################
+# Dependencies
+################################################################
+
+DEP_FILES = $(addsuffix .d,$(basename $(C_FILES)) $(basename $(Y_FILES)))
+
+include $(DEP_FILES)
+
+#Copied from the gmake manual - builds a dependency file for every C file
+%.d : %.c
+ @echo "Making dependency file $@"
+ @$(SHELL) -ec '$(CC) -MM $(CPPFLAGS) $< \
+ | sed '\''s/\($*\)\.o[ :]*/\1.o $@ : /g'\'' > $@ \
+ ; [ -s $@ ] || rm -f $@'
+
+clean::
+ $(RM) $(DEP_FILES)
+
+################################################################
+# End of Makefile
+################################################################
--- /dev/null
+/* --------------------------------------------------------------------------
+ * Character set handling:
+ *
+ * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1
+ * character set. The following code provides methods for classifying
+ * input characters according to the lexical structure specified by the
+ * report. Hugs should still accept older programs because ASCII is
+ * essentially just a subset of the ISO character set.
+ *
+ * Notes: If you want to port Hugs to a machine that uses something
+ * substantially different from the ISO character set, then you will need
+ * to insert additional code to map between character sets.
+ *
+ * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "charset.h"
+
+unsigned char ctable[NUM_CHARS];
+
+Void initCharTab() { /* Initialize char decode table */
+#define setRange(x,f,t) {Int i=f; while (i<=t) ctable[i++] |=x;}
+#define setChars(x,s) {char *p=s; while (*p) ctable[(Int)*p++]|=x;}
+#define setCopy(x,c) {Int i; \
+ for (i=0; i<NUM_CHARS; ++i) \
+ if (isIn(i,c)) \
+ ctable[i]|=x; \
+ }
+
+ setRange(DIGIT, '0','9'); /* ASCII decimal digits */
+
+ setRange(SMALL, 'a','z'); /* ASCII lower case letters */
+ setRange(SMALL, 223,246); /* ISO lower case letters */
+ setRange(SMALL, 248,255); /* (omits division symbol, 247) */
+
+ setRange(LARGE, 'A','Z'); /* ASCII upper case letters */
+ setRange(LARGE, 192,214); /* ISO upper case letters */
+ setRange(LARGE, 216,222); /* (omits multiplication, 215) */
+
+ setRange(SYMBOL, 161,191); /* Symbol characters + ':' */
+ setRange(SYMBOL, 215,215);
+ setRange(SYMBOL, 247,247);
+ setChars(SYMBOL, ":!#$%&*+./<=>?@\\^|-~");
+
+ setChars(IDAFTER, "'_"); /* Characters in identifier */
+ setCopy (IDAFTER, (DIGIT|SMALL|LARGE));
+
+ setRange(SPACE, ' ',' '); /* ASCII space character */
+ setRange(SPACE, 160,160); /* ISO non breaking space */
+ setRange(SPACE, 9,13); /* special whitespace: \t\n\v\f\r */
+
+ setChars(PRINT, "(),;[]_`{}"); /* Special characters */
+ setChars(PRINT, " '\""); /* Space and quotes */
+ setCopy (PRINT, (DIGIT|SMALL|LARGE|SYMBOL));
+
+#undef setRange
+#undef setChars
+#undef setCopy
+}
+
--- /dev/null
+/* --------------------------------------------------------------------------
+ * Character set handling:
+ *
+ * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1
+ * character set. The following code provides methods for classifying
+ * input characters according to the lexical structure specified by the
+ * report. Hugs should still accept older programs because ASCII is
+ * essentially just a subset of the ISO character set.
+ *
+ * Notes: If you want to port Hugs to a machine that uses something
+ * substantially different from the ISO character set, then you will need
+ * to insert additional code to map between character sets.
+ *
+ * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
+ * ------------------------------------------------------------------------*/
+
+extern unsigned char ctable[NUM_CHARS];
+
+#define isIn(c,x) (ctable[(Int)(c)]&(x))
+#define isISO(c) (0<=(c) && (c)<NUM_CHARS)
+
+#define DIGIT 0x01
+#define SMALL 0x02
+#define LARGE 0x04
+#define SYMBOL 0x08
+#define IDAFTER 0x10
+#define SPACE 0x20
+#define PRINT 0x40
+
+extern Void local initCharTab Args(( Void ));
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Code generator
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: codegen.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:21:59 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+#include "Assembler.h"
+#include "lift.h"
+#include "link.h"
+#include "pp.h"
+#include "codegen.h"
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+#define getPos(v) intOf(stgVarInfo(v))
+#define setPos(v,sp) stgVarInfo(v) = mkInt(sp)
+#define getObj(v) ptrOf(stgVarInfo(v))
+#define setObj(v,obj) stgVarInfo(v) = mkPtr(obj)
+
+#define repOf(x) charOf(stgVarRep(x))
+
+static void cgBind ( AsmBCO bco, StgVar v );
+static Void pushVar ( AsmBCO bco, StgVar v );
+static Void pushAtom ( AsmBCO bco, StgAtom atom );
+static Void alloc ( AsmBCO bco, StgRhs rhs );
+static Void build ( AsmBCO bco, StgRhs rhs );
+static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e );
+
+static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
+static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
+static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
+static AsmBCO cgLambda ( StgExpr e );
+static AsmBCO cgRhs ( StgRhs rhs );
+static void beginTop ( StgVar v );
+static void endTop ( StgVar v );
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+static Bool varHasClosure( StgVar v )
+{
+ return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
+}
+
+/* should be AsmClosure* */
+void* closureOfVar( StgVar v )
+{
+ return asmClosureOfObject((AsmClosure*)ptrOf(stgVarInfo(v)));
+}
+
+char* lookupHugsName( void* closure )
+{
+ extern Name nameHw;
+ Name nm;
+ for( nm=NAMEMIN; nm<nameHw; ++nm ) {
+ StgVar v = name(nm).stgVar;
+ if (isStgVar(v)
+ && isPtr(stgVarInfo(v))
+ && varHasClosure(v)
+ && closureOfVar(v) == closure) {
+ return textToStr(name(nm).text);
+ }
+ }
+ return 0;
+}
+
+/* called at the start of GC */
+void markHugsObjects( void )
+{
+ extern Name nameHw;
+ Name nm;
+ for( nm=NAMEMIN; nm<nameHw; ++nm ) {
+ StgVar v = name(nm).stgVar;
+ if (isStgVar(v) && isPtr(stgVarInfo(v))) {
+ asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
+ }
+ }
+}
+
+static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
+{
+ setPos(v,asmBind(bco,rep));
+}
+
+static void cgBind( AsmBCO bco, StgVar v )
+{
+ cgBindRep(bco,v,repOf(v));
+}
+
+static Void pushVar( AsmBCO bco, StgVar v )
+{
+ Cell info = stgVarInfo(v);
+ assert(isStgVar(v));
+ if (isPtr(info)) {
+ asmClosure(bco,ptrOf(info));
+ } else if (isInt(info)) {
+ asmVar(bco,intOf(info),repOf(v));
+ } else {
+ internal("pushVar");
+ }
+}
+
+static Void pushAtom( AsmBCO bco, StgAtom e )
+{
+ switch (whatIs(e)) {
+ case STGVAR:
+ pushVar(bco,e);
+ break;
+ case NAME:
+ pushVar(bco,name(e).stgVar);
+ break;
+ case CHARCELL:
+ asmConstChar(bco,charOf(e));
+ break;
+ case INTCELL:
+ asmConstInt(bco,intOf(e));
+ break;
+#if BIGNUM_IS_INTEGER
+ case BIGCELL:
+ asmConstInteger(bco,bignumToString(e));
+ break;
+#elif BIGNUM_IS_INT64
+ case BIGCELL:
+ asmConstInt64(bco,bignumOf(e));
+ break;
+#else
+#warning What is BIGNUM?
+#endif
+ case FLOATCELL:
+#if 0
+ asmConstFloat(bco,e); /* ToDo: support both float and double! */
+#else
+ asmConstDouble(bco,floatOf(e));
+#endif
+ break;
+#if DOUBLES
+ case DOUBLECELL:
+ asmConstDouble(bco,doubleOf(e));
+ break;
+#endif
+ case STRCELL:
+#if USE_ADDR_FOR_STRINGS
+ asmConstAddr(bco,textToStr(textOf(e)));
+#else
+ asmClosure(bco,asmStringObj(textToStr(textOf(e))));
+#endif
+ break;
+ case PTRCELL:
+ asmConstAddr(bco,ptrOf(e));
+ break;
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ internal("pushAtom");
+ }
+}
+
+static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
+{
+ AsmBCO bco = asmBeginContinuation(sp);
+ /* ppStgAlts(alts); */
+ for(; nonNull(alts); alts=tl(alts)) {
+ StgCaseAlt alt = hd(alts);
+ StgPat pat = stgCaseAltPat(alt);
+ StgExpr body = stgCaseAltBody(alt);
+ if (isDefaultPat(pat)) {
+ AsmSp begin = asmBeginAlt(bco);
+ cgBind(bco,pat);
+ cgExpr(bco,root,body);
+ asmEndContinuation(bco);
+ return bco; /* ignore any further alternatives */
+ } else {
+ StgDiscr con = stgPatDiscr(pat);
+ List vs = stgPatVars(pat);
+ AsmSp begin = asmBeginAlt(bco);
+ AsmPc fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */
+ cgBind(bco,pat);
+ if (isBoxingCon(con)) {
+ setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
+ } else {
+ asmBeginUnpack(bco);
+ map1Proc(cgBind,bco,reverse(vs));
+ asmEndUnpack(bco);
+ }
+ cgExpr(bco,root,body);
+ asmEndAlt(bco,begin);
+ asmFixBranch(bco,fix);
+ }
+ }
+ /* if we got this far and didn't match, panic! */
+ asmPanic(bco);
+ asmEndContinuation(bco);
+ return bco;
+}
+
+static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
+{
+ if (isNull(pats)) {
+ cgExpr(bco,root,e);
+ } else {
+ StgPrimPat pat = hd(pats);
+ if (isInt(stgVarBody(pat))) {
+ /* asmTestInt leaves stack unchanged - so no need to adjust it */
+ AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
+ assert(repOf(pat) == INT_REP);
+ testPrimPats(bco,root,tl(pats),e);
+ asmFixBranch(bco,tst);
+ } else {
+ testPrimPats(bco,root,tl(pats),e);
+ }
+ }
+}
+
+static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
+{
+ assert(0); /* ToDo: test for patterns */
+ map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
+ cgExpr(bco,root,e);
+}
+
+static AsmBCO cgLambda( StgExpr e )
+{
+ AsmBCO bco = asmBeginBCO();
+
+ AsmSp root = asmBeginArgCheck(bco);
+ map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
+ asmEndArgCheck(bco,root);
+
+ /* ppStgExpr(e); */
+ cgExpr(bco,root,stgLambdaBody(e));
+
+ asmEndBCO(bco);
+ return bco;
+}
+
+static AsmBCO cgRhs( StgRhs rhs )
+{
+ AsmBCO bco = asmBeginBCO( );
+
+ AsmSp root = asmBeginArgCheck(bco);
+ asmEndArgCheck(bco,root);
+
+ /* ppStgExpr(rhs); */
+ cgExpr(bco,root,rhs);
+
+ asmEndBCO(bco);
+ return bco;
+}
+
+static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
+{
+ switch (whatIs(e)) {
+ case LETREC:
+ {
+ List binds = stgLetBinds(e);
+ map1Proc(alloc,bco,binds);
+ map1Proc(build,bco,binds);
+ cgExpr(bco,root,stgLetBody(e));
+ break;
+ }
+ case LAMBDA:
+ {
+ AsmSp begin = asmBeginEnter(bco);
+ asmClosure(bco,cgLambda(e));
+ asmEndEnter(bco,begin,root);
+ break;
+ }
+ case CASE:
+ {
+ List alts = stgCaseAlts(e);
+ AsmSp sp = asmBeginCase(bco);
+ AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
+ cgExpr(bco,caseroot,stgCaseScrut(e));
+ asmEndCase(bco);
+ break;
+ }
+ case PRIMCASE:
+ {
+ StgExpr scrut = stgPrimCaseScrut(e);
+ List alts = stgPrimCaseAlts(e);
+ if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
+
+ /* No need to use return address or to Slide */
+ AsmSp beginPrim = asmBeginPrim(bco);
+ map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
+ asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
+
+ for(; nonNull(alts); alts=tl(alts)) {
+ StgPrimAlt alt = hd(alts);
+ List pats = stgPrimAltPats(alt);
+ StgExpr body = stgPrimAltBody(alt);
+ AsmSp altBegin = asmBeginAlt(bco);
+ map1Proc(cgBind,bco,reverse(pats));
+ testPrimPats(bco,root,pats,body);
+ asmEndAlt(bco,altBegin);
+ }
+ /* if we got this far and didn't match, panic! */
+ asmPanic(bco);
+
+ } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
+
+ /* No need to use return address or to Slide */
+
+ /* only part different from primop code... todo */
+ AsmSp beginCase = asmBeginCase(bco);
+ pushVar(bco,scrut);
+ asmEndAlt(bco,beginCase); /* hack, hack - */
+
+ for(; nonNull(alts); alts=tl(alts)) {
+ StgPrimAlt alt = hd(alts);
+ List pats = stgPrimAltPats(alt);
+ StgExpr body = stgPrimAltBody(alt);
+ AsmSp altBegin = asmBeginAlt(bco);
+ map1Proc(cgBind,bco,pats);
+ testPrimPats(bco,root,pats,body);
+ asmEndAlt(bco,altBegin);
+ }
+ /* if we got this far and didn't match, panic! */
+ asmPanic(bco);
+
+ } else {
+ /* ToDo: implement this code... */
+ assert(0);
+ /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */
+ /* cgExpr( bco,root,scrut ); */
+ }
+ break;
+ }
+ case STGAPP: /* Tail call */
+ {
+ AsmSp env = asmBeginEnter(bco);
+ map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
+ pushAtom(bco,stgAppFun(e));
+ asmEndEnter(bco,env,root);
+ break;
+ }
+ case NAME: /* Tail call (with no args) */
+ {
+ AsmSp env = asmBeginEnter(bco);
+ pushVar(bco,name(e).stgVar);
+ asmEndEnter(bco,env,root);
+ break;
+ }
+ case STGVAR: /* Tail call (with no args), plus unboxed return */
+ switch (repOf(e)) {
+ case PTR_REP:
+ case ALPHA_REP:
+ case BETA_REP:
+ {
+ AsmSp env = asmBeginEnter(bco);
+ pushVar(bco,e);
+ asmEndEnter(bco,env,root);
+ break;
+ }
+ case INT_REP:
+ assert(0);
+ /* cgTailCall(bco,singleton(e)); */
+ /* asmReturnInt(bco); */
+ break;
+ default:
+ internal("cgExpr StgVar");
+ }
+ break;
+ case STGPRIM: /* Tail call again */
+ {
+ AsmSp beginPrim = asmBeginPrim(bco);
+ map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
+ asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
+ /* map1Proc(cgBind,bco,rs_vars); */
+ assert(0); /* asmReturn_retty(); */
+ break;
+ }
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ internal("cgExpr");
+ }
+}
+
+/* allocate space for top level variable
+ * any change requires a corresponding change in 'build'.
+ */
+static Void alloc( AsmBCO bco, StgVar v )
+{
+ StgRhs rhs = stgVarBody(v);
+ assert(isStgVar(v));
+ switch (whatIs(rhs)) {
+ case STGCON:
+ {
+ StgDiscr con = stgConCon(rhs);
+ List args = stgConArgs(rhs);
+ if (isBoxingCon(con)) {
+ pushAtom(bco,hd(args));
+ setPos(v,asmBox(bco,boxingConRep(con)));
+ } else {
+ setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
+ }
+ break;
+ }
+ case STGAPP:
+ setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
+ break;
+ case LAMBDA: /* optimisation */
+ setObj(v,cgLambda(rhs));
+ break;
+ default:
+ setPos(v,asmAllocAP(bco,0));
+ break;
+ }
+}
+
+static Void build( AsmBCO bco, StgVar v )
+{
+ StgRhs rhs = stgVarBody(v);
+ assert(isStgVar(v));
+ switch (whatIs(rhs)) {
+ case STGCON:
+ {
+ StgDiscr con = stgConCon(rhs);
+ List args = stgConArgs(rhs);
+ if (isBoxingCon(con)) {
+ doNothing(); /* already done in alloc */
+ } else {
+ AsmSp start = asmBeginPack(bco);
+ map1Proc(pushAtom,bco,reverse(args));
+ asmEndPack(bco,getPos(v),start,stgConInfo(con));
+ }
+ return;
+ }
+ case STGAPP:
+ {
+ StgVar fun = stgAppFun(rhs);
+ List args = stgAppArgs(rhs);
+ if (isName(fun)) {
+ fun = name(fun).stgVar;
+ }
+ if (nonNull(stgVarBody(fun))
+ && whatIs(stgVarBody(fun)) == LAMBDA
+ && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
+ AsmSp start = asmBeginMkPAP(bco);
+ map1Proc(pushAtom,bco,reverse(args));
+ pushAtom(bco,fun);
+ asmEndMkPAP(bco,getPos(v),start); /* optimisation */
+ } else {
+ AsmSp start = asmBeginMkAP(bco);
+ map1Proc(pushAtom,bco,reverse(args));
+ pushAtom(bco,fun);
+ asmEndMkAP(bco,getPos(v),start);
+ }
+ return;
+ }
+ case LAMBDA: /* optimisation */
+ doNothing(); /* already pushed in alloc */
+ break;
+
+ /* These two cases look almost identical to the default but they're really
+ * special cases of STGAPP. The essential thing here is that we can't call
+ * cgRhs(rhs) because that expects the rhs to have no free variables when,
+ * in fact, the rhs is _always_ a free variable.
+ *
+ * ToDo: a simple optimiser would eliminate all examples
+ * of this except "let x = x in ..."
+ */
+ case NAME:
+ rhs = name(rhs).stgVar;
+ case STGVAR:
+ {
+ AsmSp start = asmBeginMkAP(bco);
+ pushAtom(bco,rhs);
+ asmEndMkAP(bco,getPos(v),start);
+ }
+ return;
+ default:
+ {
+ AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
+ asmClosure(bco,cgRhs(rhs));
+ asmEndMkAP(bco,getPos(v),start);
+ return;
+ }
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Top level variables
+ *
+ * ToDo: these should be handled by allocating a dynamic unentered CAF
+ * for each top level variable - this should be simpler!
+ * ------------------------------------------------------------------------*/
+
+static void cgAddVar( AsmObject obj, StgAtom v )
+{
+ if (isName(v)) {
+ v = name(v).stgVar;
+ }
+ assert(isStgVar(v));
+ asmAddPtr(obj,getObj(v));
+}
+
+/* allocate AsmObject for top level variables
+ * any change requires a corresponding change in endTop
+ */
+static void beginTop( StgVar v )
+{
+ StgRhs rhs;
+ assert(isStgVar(v));
+ rhs = stgVarBody(v);
+ switch (whatIs(rhs)) {
+ case STGCON:
+ {
+ List as = stgConArgs(rhs);
+ setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
+ break;
+ }
+ case LAMBDA:
+ setObj(v,asmBeginBCO());
+ break;
+ default:
+ setObj(v,asmBeginCAF());
+ break;
+ }
+}
+
+static void endTop( StgVar v )
+{
+ StgRhs rhs = stgVarBody(v);
+ ppStgRhs(rhs);
+ switch (whatIs(rhs)) {
+ case STGCON:
+ {
+ List as = stgConArgs(rhs);
+ AsmCon con = (AsmCon)getObj(v);
+ for( ; nonNull(as); as=tl(as)) {
+ StgAtom a = hd(as);
+ switch (whatIs(a)) {
+ case STGVAR:
+ /* should be a delayed combinator! */
+ asmAddPtr(con,(AsmObject)getObj(a));
+ break;
+ case NAME:
+ {
+ StgVar var = name(a).stgVar;
+ assert(var);
+ asmAddPtr(con,(AsmObject)getObj(a));
+ break;
+ }
+#if !USE_ADDR_FOR_STRINGS
+ case STRCELL:
+ asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
+ break;
+#endif
+ default:
+ /* asmAddPtr(con,??); */
+ assert(0);
+ break;
+ }
+ }
+ asmEndCon(con);
+ break;
+ }
+ case LAMBDA: /* optimisation */
+ {
+ /* ToDo: merge this code with cgLambda */
+ AsmBCO bco = (AsmBCO)getObj(v);
+ AsmSp root = asmBeginArgCheck(bco);
+ map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
+ asmEndArgCheck(bco,root);
+
+ cgExpr(bco,root,stgLambdaBody(rhs));
+
+ asmEndBCO(bco);
+ break;
+ }
+ default: /* updateable caf */
+ {
+ AsmCAF caf = (AsmCAF)getObj(v);
+ asmEndCAF(caf,cgRhs(rhs));
+ break;
+ }
+ }
+}
+
+static void zap( StgVar v )
+{
+ stgVarBody(v) = NIL;
+}
+
+/* external entry point */
+Void cgBinds( List binds )
+{
+ binds = liftBinds(binds);
+ mapProc(beginTop,binds);
+ mapProc(endTop,binds);
+ mapProc(zap,binds);
+}
+
+/* --------------------------------------------------------------------------
+ * Code Generator control:
+ * ------------------------------------------------------------------------*/
+
+Void codegen(what)
+Int what; {
+ switch (what) {
+ case INSTALL:
+ /* deliberate fall though */
+ case RESET:
+ break;
+ case MARK:
+ break;
+ }
+ liftControl(what);
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+extern Void cgBinds Args(( StgRhs rhs ));
+extern void* closureOfVar Args(( StgVar v ));
+extern char* lookupHugsName Args(( void* closure ));
--- /dev/null
+/* --------------------------------------------------------------------------
+ * Interpreter command structure
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: command.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:01 $
+ * ------------------------------------------------------------------------*/
+
+typedef Int Command;
+
+struct cmd {
+ String cmdString;
+ Command cmdCode;
+};
+
+extern Command readCommand Args((struct cmd *, Char, Char));
+
+#define EDIT 0
+#define FIND 1
+#define LOAD 2
+#define ALSO 3
+#define PROJECT 4
+#define RELOAD 5
+#define EVAL 6
+#define TYPEOF 7
+#define HELP 8
+#define NAMES 9
+#define BADCMD 10
+#define SET 11
+#define QUIT 12
+#define SYSTEM 13
+#define CHGDIR 14
+#define INFO 15
+#define COLLECT 16
+#define SETMODULE 17
+#define SHOWVERSION 18
+#define NOCMD 19
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * This is the Hugs compiler, handling translation of typechecked code to
+ * `kernel' language, elimination of pattern matching and translation to
+ * super combinators (lambda lifting).
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: compiler.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:01 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "input.h"
+#include "compiler.h"
+#include "hugs.h" /* for target */
+#include "errors.h"
+
+#include "desugar.h"
+#include "pmc.h"
+
+#include "optimise.h"
+
+#include "Rts.h" /* for rts_eval and related stuff */
+#include "RtsAPI.h" /* for rts_eval and related stuff */
+
+Name currentName; /* Top level name being processed */
+#if DEBUG_CODE
+Bool debugCode = FALSE; /* TRUE => print G-code to screen */
+#endif
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static List local addGlobals( List binds );
+static Void local compileGlobalFunction Args((Pair));
+static Void local compileGenFunction Args((Name));
+static Name local compileSelFunction Args((Pair));
+
+/* --------------------------------------------------------------------------
+ * STG stuff
+ * ------------------------------------------------------------------------*/
+
+#include "stg.h"
+#include "translate.h"
+#include "codegen.h"
+
+static Void local stgCGBinds( List );
+
+static Void local stgCGBinds(binds)
+List binds; {
+ cgBinds(binds);
+}
+
+/* --------------------------------------------------------------------------
+ * Main entry points to compiler:
+ * ------------------------------------------------------------------------*/
+
+static List addGlobals( List binds )
+{
+ /* stgGlobals = pieces of code generated for selectors, tuples, etc */
+ for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
+ StgVar bind = snd(hd(stgGlobals));
+ if (nonNull(stgVarBody(bind))) {
+ binds = cons(bind,binds);
+ }
+ }
+ return binds;
+}
+
+#if 0
+/* This is a hack to see if "show [1..1000]" will go any faster if I
+ * code primShowInt in C
+ */
+char* prim_showInt(int x)
+{
+ char buffer[50];
+ sprintf(buffer,"%d",x);
+ return buffer;
+}
+
+void prim_flush_stdout(void)
+{
+ fflush(stdout);
+}
+#endif
+
+Void evalExp() { /* compile and run input expression */
+ /* ToDo: this name (and other names generated during pattern match?)
+ * get inserted in the symbol table but never get removed.
+ */
+ Name n = newName(inventText());
+ StgVar v = mkStgVar(NIL,NIL);
+ name(n).stgVar = v;
+ compiler(RESET);
+ stgDefn(n,0,pmcTerm(0,NIL,translate(inputExpr)));
+ inputExpr = NIL;
+ stgCGBinds(addGlobals(singleton(v)));
+
+
+ /* Run thread (and any other runnable threads) */
+
+ /* Re-initialise the scheduler - ToDo: do I need this? */
+ initScheduler();
+ {
+ HaskellObj result; /* ignored */
+ SchedulerStatus status = rts_eval_(closureOfVar(v),10000,&result);
+ switch (status) {
+ case Deadlock:
+ case AllBlocked: /* I don't understand the distinction - ADR */
+ printf("{Deadlock}");
+ RevertCAFs();
+ break;
+ case Interrupted:
+ printf("{Interrupted}");
+ RevertCAFs();
+ break;
+ case Killed:
+ printf("{Killed}");
+ RevertCAFs();
+ break;
+ case Success:
+ /* Nothing to do */
+ break;
+ default:
+ internal("evalExp: Unrecognised SchedulerStatus");
+ }
+ fflush(stdout);
+ fflush(stderr);
+ }
+}
+
+static List local addStgVar( List binds, Pair bind ); /* todo */
+
+static List local addStgVar( List binds, Pair bind )
+{
+ StgVar nv = mkStgVar(NIL,NIL);
+ Text t = textOf(fst(bind));
+ Name n = findName(t);
+
+ if (isNull(n)) { /* Lookup global name - the only way*/
+ n = newName(t); /* this (should be able to happen) */
+ } /* is with new global var introduced*/
+ /* after type check; e.g. remPat1 */
+ name(n).stgVar = nv;
+ return cons(nv,binds);
+}
+
+
+Void compileDefns() { /* compile script definitions */
+ Target t = length(valDefns) + length(genDefns) + length(selDefns);
+ Target i = 0;
+
+ List binds = NIL;
+ {
+ List vss;
+ List vs;
+ for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
+ Name n = hd(vs);
+ StgVar nv = mkStgVar(NIL,NIL);
+ assert(isName(n));
+ name(n).stgVar = nv;
+ binds = cons(nv,binds);
+ }
+ for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
+ for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
+ Pair p = hd(vs);
+ Name n = fst(p);
+ StgVar nv = mkStgVar(NIL,NIL);
+ assert(isName(n));
+ name(n).stgVar = nv;
+ binds = cons(nv,binds);
+ }
+ }
+ }
+
+ setGoal("Compiling",t);
+ /* do valDefns before everything else so that all stgVar's get added. */
+ for (; nonNull(valDefns); valDefns=tl(valDefns)) {
+ hd(valDefns) = transBinds(hd(valDefns));
+ mapAccum(addStgVar,binds,hd(valDefns));
+ mapProc(compileGlobalFunction,hd(valDefns));
+ soFar(i++);
+ }
+ for (; nonNull(genDefns); genDefns=tl(genDefns)) {
+ compileGenFunction(hd(genDefns));
+ soFar(i++);
+ }
+ for (; nonNull(selDefns); selDefns=tl(selDefns)) {
+ mapOver(compileSelFunction,hd(selDefns));
+ soFar(i++);
+ }
+
+ /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */
+ binds = addGlobals(binds);
+#if USE_HUGS_OPTIMIZER
+ mapProc(optimiseBind,binds);
+#endif
+ stgCGBinds(binds);
+
+ done();
+}
+
+static Void local compileGlobalFunction(bind)
+Pair bind; {
+ Name n = findName(textOf(fst(bind)));
+ List defs = snd(bind);
+ Int arity = length(fst(hd(defs)));
+ assert(isName(n));
+ compiler(RESET);
+ stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
+}
+
+static Void local compileGenFunction(n) /* Produce code for internally */
+Name n; { /* generated function */
+ List defs = name(n).defn;
+ Int arity = length(fst(hd(defs)));
+
+ compiler(RESET);
+ mapProc(transAlt,defs);
+ stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
+ name(n).defn = NIL;
+}
+
+static Name local compileSelFunction(p) /* Produce code for selector func */
+Pair p; { /* Should be merged with genDefns, */
+ Name s = fst(p); /* but the name(_).defn field is */
+ List defs = snd(p); /* already used for other purposes */
+ Int arity = length(fst(hd(defs))); /* in selector functions. */
+
+ compiler(RESET);
+ mapProc(transAlt,defs);
+ stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
+ return s;
+}
+
+/* --------------------------------------------------------------------------
+ * Compiler control:
+ * ------------------------------------------------------------------------*/
+
+Void compiler(what)
+Int what; {
+ switch (what) {
+ case INSTALL :
+ case RESET : break;
+ case MARK : break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+extern Void compileDefns Args((Void));
+extern Void evalExp Args((Void));
+extern Void newGlobalFunction Args((Name,Int,List,Int,Cell));
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Send message to each component of system:
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: connect.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:02 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+
+Void everybody(what) /* send command `what' to each component of*/
+Int what; { /* system to respond as appropriate ... */
+ machdep(what); /* The order of calling each component is */
+ storage(what); /* important for the INSTALL command */
+ substitution(what);
+ input(what);
+ linkControl(what);
+ staticAnalysis(what);
+ deriveControl(what);
+ typeChecker(what);
+ desugarControl(what);
+ translateControl(what);
+ compiler(what);
+ codegen(what);
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Connections between components of the Hugs system
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: connect.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:03 $
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Standard data:
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Function prototypes etc...
+ * ------------------------------------------------------------------------*/
+
+#define RESET 1 /* reset subsystem */
+#define MARK 2 /* mark parts of graph in use by subsystem */
+#define INSTALL 3 /* install subsystem (executed once only) */
+#define EXIT 4 /* Take action immediately before exit() */
+#define BREAK 5 /* Take action after program break */
+
+extern Void everybody Args((Int));
+extern Void machdep Args((Int));
+extern Void storage Args((Int));
+extern Void linkControl Args((Int));
+extern Void translateControl Args((Int));
+extern Void staticAnalysis Args((Int));
+extern Void interface Args((Int));
+extern Void deriveControl Args((Int));
+extern Void input Args((Int));
+extern Void typeChecker Args((Int));
+extern Void desugarControl Args((Int));
+extern Void codegen Args((Int));
+extern Void compiler Args((Int));
+extern Void substitution Args((Int));
+extern Void stgTranslate Args((Int));
+extern Void codegen Args((Int));
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Deriving
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: derive.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:03 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "translate.h" /* for implementConTag */
+#include "derive.h"
+
+static Cell varTrue;
+static Cell varFalse;
+#if DERIVE_ORD
+static Cell varCompAux; /* auxiliary function for compares */
+static Cell varCompare;
+static Cell varEQ;
+#endif
+#if DERIVE_IX
+static Cell varRangeSize; /* calculate size of index range */
+static Cell varInRange;
+static Cell varRange;
+static Cell varIndex;
+static Cell varMult;
+static Cell varPlus;
+static Cell varMap;
+static Cell varMinus;
+static Cell varError;
+#endif
+#if DERIVE_ENUM
+static Cell varToEnum;
+static Cell varFromEnum;
+static Cell varEnumFromTo;
+static Cell varEnumFromThenTo;
+#endif
+#if DERIVE_BOUNDED
+static Cell varMinBound;
+static Cell varMaxBound;
+#endif
+#if DERIVE_SHOW
+static Cell conCons;
+static Cell varShowField; /* display single field */
+static Cell varShowParen; /* wrap with parens */
+static Cell varCompose; /* function composition */
+static Cell varShowsPrec;
+static Cell varLe;
+#endif
+#if DERIVE_READ
+static Cell varReadField; /* read single field */
+static Cell varReadParen; /* unwrap from parens */
+static Cell varLex; /* lexer */
+static Cell varReadsPrec;
+static Cell varGt;
+#endif
+#if DERIVE_SHOW || DERIVE_READ
+static Cell varAppend; /* list append */
+List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
+#endif
+#if DERIVE_EQ || DERIVE_IX
+static Cell varAnd; /* built-in logical connectives */
+#endif
+#if DERIVE_EQ || DERIVE_ORD
+static Cell varEq;
+#endif
+
+
+/* --------------------------------------------------------------------------
+ * local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static List local getDiVars Args((Int));
+static Cell local mkBind Args((String,List));
+static Cell local mkVarAlts Args((Int,Cell));
+
+#if DERIVE_EQ || DERIVE_ORD
+static List local makeDPats2 Args((Cell,Int));
+#endif
+#if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
+static Bool local isEnumType Args((Tycon));
+#endif
+
+/* --------------------------------------------------------------------------
+ * Deriving Utilities
+ * ------------------------------------------------------------------------*/
+
+static List diVars = NIL; /* Acts as a cache of invented vars*/
+static Int diNum = 0;
+
+static List local getDiVars(n) /* get list of at least n vars for */
+Int n; { /* derived instance generation */
+ for (; diNum<n; diNum++) {
+ diVars = cons(inventVar(),diVars);
+ }
+ return diVars;
+}
+
+static Cell local mkBind(s,alts) /* make a binding for a variable */
+String s;
+List alts; {
+ return pair(mkVar(findText(s)),pair(NIL,alts));
+}
+
+static Cell local mkVarAlts(line,r) /* make alts for binding a var to */
+Int line; /* a simple expression */
+Cell r; {
+ return singleton(pair(NIL,pair(mkInt(line),r)));
+}
+
+#if DERIVE_EQ || DERIVE_ORD
+static List local makeDPats2(h,n) /* generate pattern list */
+Cell h; /* by putting two new patterns with*/
+Int n; { /* head h and new var components */
+ List us = getDiVars(2*n);
+ List vs = NIL;
+ Cell p;
+ Int i;
+
+ for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
+ p = ap(p,hd(us));
+ us = tl(us);
+ }
+ vs = cons(p,vs);
+
+ for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
+ p = ap(p,hd(us));
+ us = tl(us);
+ }
+ return cons(p,vs);
+}
+#endif
+
+#if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
+static Bool local isEnumType(t) /* Determine whether t is an enumeration */
+Tycon t; { /* type (i.e. all constructors arity == 0) */
+ if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
+ List cs = tycon(t).defn;
+ for (; hasCfun(cs); cs=tl(cs)) {
+ if (name(hd(cs)).arity!=0) {
+ return FALSE;
+ }
+ }
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
+ * The derived definitions of equality and ordering are given by:
+ *
+ * A a b == A x y = a==x && b==y
+ * B a == B x = a==x
+ * C == C = True
+ * _ == _ = False
+ *
+ * compare (A a b) (A x y) = primCompAux a x (compare b y)
+ * compare (B a) (B x) = compare a x
+ * compare C C = EQ
+ * compare a x = cmpConstr a x
+ *
+ * In each case, the last line is only needed if there are multiple
+ * constructors in the datatype definition.
+ * ------------------------------------------------------------------------*/
+
+#if DERIVE_EQ
+
+static Pair local mkAltEq Args((Int,List));
+
+List deriveEq(t) /* generate binding for derived == */
+Type t; { /* for some TUPLE or DATATYPE t */
+ List alts = NIL;
+ if (isTycon(t)) { /* deal with type constrs */
+ List cs = tycon(t).defn;
+ for (; hasCfun(cs); cs=tl(cs)) {
+ alts = cons(mkAltEq(tycon(t).line,
+ makeDPats2(hd(cs),name(hd(cs)).arity)),
+ alts);
+ }
+ if (cfunOf(hd(tycon(t).defn))!=0) {
+ alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
+ pair(mkInt(tycon(t).line),varFalse)),alts);
+ }
+ alts = rev(alts);
+ } else { /* special case for tuples */
+ alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
+ }
+ return singleton(mkBind("==",alts));
+}
+
+static Pair local mkAltEq(line,pats) /* make alt for an equation for == */
+Int line; /* using patterns in pats for lhs */
+List pats; { /* arguments */
+ Cell p = hd(pats);
+ Cell q = hd(tl(pats));
+ Cell e = varTrue;
+
+ if (isAp(p)) {
+ e = ap2(varEq,arg(p),arg(q));
+ for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
+ e = ap2(varAnd,ap2(varEq,arg(p),arg(q)),e);
+ }
+ }
+ return pair(pats,pair(mkInt(line),e));
+}
+#endif /* DERIVE_EQ */
+
+#if DERIVE_ORD
+
+static Pair local mkAltOrd Args((Int,List));
+
+List deriveOrd(t) /* make binding for derived compare*/
+Type t; { /* for some TUPLE or DATATYPE t */
+ List alts = NIL;
+ if (isEnumType(t)) { /* special case for enumerations */
+ Cell u = inventVar();
+ Cell w = inventVar();
+ Cell rhs = NIL;
+ if (cfunOf(hd(tycon(t).defn))!=0) {
+ implementConToTag(t);
+ rhs = ap2(varCompare,
+ ap(tycon(t).conToTag,u),
+ ap(tycon(t).conToTag,w));
+ } else {
+ rhs = varEQ;
+ }
+ alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
+ } else if (isTycon(t)) { /* deal with type constrs */
+ List cs = tycon(t).defn;
+ for (; hasCfun(cs); cs=tl(cs)) {
+ alts = cons(mkAltOrd(tycon(t).line,
+ makeDPats2(hd(cs),name(hd(cs)).arity)),
+ alts);
+ }
+ if (cfunOf(hd(tycon(t).defn))!=0) {
+ Cell u = inventVar();
+ Cell w = inventVar();
+ implementConToTag(t);
+ alts = cons(pair(doubleton(u,w),
+ pair(mkInt(tycon(t).line),
+ ap2(varCompare,
+ ap(tycon(t).conToTag,u),
+ ap(tycon(t).conToTag,w)))),
+ alts);
+ }
+ alts = rev(alts);
+ } else { /* special case for tuples */
+ alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
+ }
+ return singleton(mkBind("compare",alts));
+}
+
+static Pair local mkAltOrd(line,pats) /* make alt for eqn for compare */
+Int line; /* using patterns in pats for lhs */
+List pats; { /* arguments */
+ Cell p = hd(pats);
+ Cell q = hd(tl(pats));
+ Cell e = varEQ;
+
+ if (isAp(p)) {
+ e = ap2(varCompare,arg(p),arg(q));
+ for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
+ e = ap3(varCompAux,arg(p),arg(q),e);
+ }
+ }
+
+ return pair(pats,pair(mkInt(line),e));
+}
+#endif /* DERIVE_ORD */
+
+/* --------------------------------------------------------------------------
+ * Deriving Ix and Enum:
+ * ------------------------------------------------------------------------*/
+
+#if DERIVE_ENUM
+List deriveEnum(t) /* Construct definition of enumeration */
+Tycon t; {
+ Int l = tycon(t).line;
+ Cell x = inventVar();
+ Cell y = inventVar();
+ Cell first = hd(tycon(t).defn);
+ Cell last = tycon(t).defn;
+
+ if (!isEnumType(t)) {
+ ERRMSG(l) "Can only derive instances of Enum for enumeration types"
+ EEND;
+ }
+ while (hasCfun(tl(last))) {
+ last = tl(last);
+ }
+ last = hd(last);
+ implementConToTag(t);
+ implementTagToCon(t);
+ return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
+ cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
+ cons(mkBind("enumFrom", singleton(pair(singleton(x), pair(mkInt(l),ap2(varEnumFromTo,x,last))))),
+ /* default instance of enumFromTo is good */
+ cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),pair(mkInt(l),ap3(varEnumFromThenTo,x,y,ap(COND,triple(ap2(varLe,x,y),last,first))))))),
+ /* default instance of enumFromThenTo is good */
+ NIL))));
+}
+#endif /* DERIVE_ENUM */
+
+#if DERIVE_IX
+static List local mkIxBindsEnum Args((Tycon));
+static List local mkIxBinds Args((Int,Cell,Int));
+static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
+static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
+static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
+
+List deriveIx(t) /* Construct definition of indexing */
+Tycon t; {
+ Int l = tycon(t).line;
+ if (isEnumType(t)) { /* Definitions for enumerations */
+ implementConToTag(t);
+ implementTagToCon(t);
+ return mkIxBindsEnum(t);
+ } else if (isTuple(t)) { /* Definitions for product types */
+ return mkIxBinds(0,t,tupleOf(t));
+ } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
+ return mkIxBinds(tycon(t).line,
+ hd(tycon(t).defn),
+ name(hd(tycon(t).defn)).arity);
+ }
+ ERRMSG(tycon(t).line)
+ "Can only derive instances of Ix for enumeration or product types"
+ EEND;
+ return NIL;/* NOTREACHED*/
+}
+
+/* instance Ix T where
+ * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
+ * index b@(c1,c2) ci
+ * | inRange b ci = conToTag ci - conToTag c1
+ * | otherwise = error "Ix.index.T: Index out of range."
+ * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
+ * where i = conToTag ci
+ */
+static List local mkIxBindsEnum(t)
+Tycon t; {
+ Int l = tycon(t).line;
+ Name tagToCon = tycon(t).tagToCon;
+ Name conToTag = tycon(t).conToTag;
+ Cell b = inventVar();
+ Cell c1 = inventVar();
+ Cell c2 = inventVar();
+ Cell ci = inventVar();
+ return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),c1,c2)), pair(mkInt(l),ap2(varMap,tagToCon,ap2(varEnumFromTo,ap(conToTag,c1),ap(conToTag,c2))))))),
+ cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,ap2(mkTuple(2),c1,c2))),ci),
+ pair(mkInt(l),ap(COND,triple(ap2(varInRange,b,ci),
+ ap2(varMinus,ap(conToTag,ci),ap(conToTag,c1)),
+ ap(varError,mkStr(findText("Ix.index: Index out of range"))))))))),
+ cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),c1,c2),ci), pair(mkInt(l),ap2(varAnd,ap2(varLe,ap(conToTag,c1),ap(conToTag,ci)),ap2(varLe,ap(conToTag,ci),ap(conToTag,c2))))))), /* ToDo: share conToTag ci */
+ NIL)));
+}
+
+static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
+Int line; /* a product type */
+Cell h;
+Int n; {
+ List vs = getDiVars(3*n);
+ Cell ls = h;
+ Cell us = h;
+ Cell is = h;
+ Cell pr = NIL;
+ Cell pats = NIL;
+ Int i;
+
+ for (i=0; i<n; ++i, vs=tl(vs)) { /* build three patterns for values */
+ ls = ap(ls,hd(vs)); /* of the datatype concerned */
+ us = ap(us,hd(vs=tl(vs)));
+ is = ap(is,hd(vs=tl(vs)));
+ }
+ pr = ap2(mkTuple(2),ls,us); /* Build (ls,us) */
+ pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
+
+ return cons(prodRange(line,singleton(pr),ls,us,is),
+ cons(prodIndex(line,pats,ls,us,is),
+ cons(prodInRange(line,pats,ls,us,is),
+ NIL)));
+}
+
+static Cell local prodRange(line,pats,ls,us,is)
+Int line; /* Make definition of range for a */
+List pats; /* product type */
+Cell ls, us, is; {
+ /* range :: (a,a) -> [a]
+ * range (X a b c, X p q r)
+ * = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
+ */
+ Cell is1 = is;
+ List e = NIL;
+ for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
+ e = cons(ap(FROMQUAL,pair(arg(is),
+ ap(varRange,ap2(mkTuple(2),
+ arg(ls),
+ arg(us))))),e);
+ }
+ e = ap(COMP,pair(is1,e));
+ e = singleton(pair(pats,pair(mkInt(line),e)));
+ return mkBind("range",e);
+}
+
+static Cell local prodIndex(line,pats,ls,us,is)
+Int line; /* Make definition of index for a */
+List pats; /* product type */
+Cell ls, us, is; {
+ /* index :: (a,a) -> a -> Bool
+ * index (X a b c, X p q r) (X x y z)
+ * = index (c,r) z + rangeSize (c,r) * (
+ * index (b,q) y + rangeSize (b,q) * (
+ * index (a,x) x))
+ */
+ List xs = NIL;
+ Cell e = NIL;
+ for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
+ xs = cons(ap2(varIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
+ }
+ for (e=hd(xs); nonNull(xs=tl(xs));) {
+ Cell x = hd(xs);
+ e = ap2(varPlus,x,ap2(varMult,ap(varRangeSize,arg(fun(x))),e));
+ }
+ e = singleton(pair(pats,pair(mkInt(line),e)));
+ return mkBind("index",e);
+}
+
+static Cell local prodInRange(line,pats,ls,us,is)
+Int line; /* Make definition of inRange for a*/
+List pats; /* product type */
+Cell ls, us, is; {
+ /* inRange :: (a,a) -> a -> Bool
+ * inRange (X a b c, X p q r) (X x y z)
+ * = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
+ */
+ Cell e = ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
+ while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
+ e = ap2(varAnd,
+ ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
+ e);
+ }
+ e = singleton(pair(pats,pair(mkInt(line),e)));
+ return mkBind("inRange",e);
+}
+#endif /* DERIVE_IX */
+
+/* --------------------------------------------------------------------------
+ * Deriving Show:
+ * ------------------------------------------------------------------------*/
+
+#if DERIVE_SHOW
+
+static Cell local mkAltShow Args((Int,Cell,Int));
+static Cell local showsPrecRhs Args((Cell,Cell));
+
+List deriveShow(t) /* Construct definition of text conversion */
+Tycon t; {
+ List alts = NIL;
+ if (isTycon(t)) { /* deal with type constrs */
+ List cs = tycon(t).defn;
+ for (; hasCfun(cs); cs=tl(cs)) {
+ alts = cons(mkAltShow(tycon(t).line,hd(cs),name(hd(cs)).arity),
+ alts);
+ }
+ alts = rev(alts);
+ } else { /* special case for tuples */
+ alts = singleton(mkAltShow(0,t,tupleOf(t)));
+ }
+ return singleton(mkBind("showsPrec",alts));
+}
+
+static Cell local mkAltShow(line,h,a) /* make alt for showsPrec eqn */
+Int line;
+Cell h;
+Int a; {
+ List vs = getDiVars(a+1);
+ Cell d = hd(vs);
+ Cell pat = h;
+ while (vs=tl(vs), 0<a--) {
+ pat = ap(pat,hd(vs));
+ }
+ return pair(doubleton(d,pat),
+ pair(mkInt(line),showsPrecRhs(d,pat)));
+}
+
+#define consChar(c) ap(conCons,mkChar(c))
+#define shows0 ap(varShowsPrec,mkInt(0))
+#define shows10 ap(varShowsPrec,mkInt(10))
+#define showsOP ap(varCompose,consChar('('))
+#define showsOB ap(varCompose,consChar('{'))
+#define showsCM ap(varCompose,consChar(','))
+#define showsSP ap(varCompose,consChar(' '))
+#define showsBQ ap(varCompose,consChar('`'))
+#define showsCP consChar(')')
+#define showsCB consChar('}')
+
+static Cell local showsPrecRhs(d,pat) /* build a rhs for showsPrec for a */
+Cell d, pat; { /* given pattern, pat */
+ Cell h = getHead(pat);
+ List cfs = cfunSfuns;
+
+ if (isTuple(h)) {
+ /* To display a tuple:
+ * showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
+ * showChar ',' . showsPrec 0 b .
+ * showChar ',' . showsPrec 0 c .
+ * showChar ',' . showsPrec 0 d .
+ * showChar ')'
+ */
+ Int i = tupleOf(h);
+ Cell rhs = showsCP;
+ for (; i>1; --i) {
+ rhs = ap(showsCM,ap2(varCompose,ap(shows0,arg(pat)),rhs));
+ pat = fun(pat);
+ }
+ return ap(showsOP,ap2(varCompose,ap(shows0,arg(pat)),rhs));
+ }
+
+ for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
+ }
+ if (nonNull(cfs)) {
+ /* To display a value using record syntax:
+ * showsPrec d C{x=e, y=f, z=g} = showString "C" . showChar '{' .
+ * showField "x" e . showChar ',' .
+ * showField "y" f . showChar ',' .
+ * showField "z" g . showChar '}'
+ * showField lab val
+ * = showString lab . showChar '=' . shows val
+ */
+ Cell rhs = showsCB;
+ List vs = revDupOnto(snd(hd(cfs)),NIL);
+ if (isAp(pat)) {
+ for (;;) {
+ rhs = ap2(varCompose,
+ ap2(varShowField,
+ mkStr(textOf(hd(vs))),
+ arg(pat)),
+ rhs);
+ pat = fun(pat);
+ vs = tl(vs);
+ if (isAp(pat)) {
+ rhs = ap(showsCM,rhs);
+ } else {
+ break;
+ }
+ }
+ }
+ rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),ap(showsOB,rhs));
+ return rhs;
+ } else if (name(h).arity==0) {
+ /* To display a nullary constructor:
+ * showsPrec d Foo = showString "Foo"
+ */
+ return ap(varAppend,mkStr(name(h).text));
+ } else {
+ Syntax s = syntaxOf(name(h).text);
+ if (name(h).arity==2 && assocOf(s)!=APPLIC) {
+ /* For a binary constructor with prec p:
+ * showsPrec d (a :* b) = showParen (d > p)
+ * (showsPrec lp a . showChar ' ' .
+ * showsString s . showChar ' ' .
+ * showsPrec rp b)
+ */
+ Int p = precOf(s);
+ Int lp = (assocOf(s)==LEFT_ASS) ? p : (p+1);
+ Int rp = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
+ Cell rhs = ap(showsSP,ap2(varShowsPrec,mkInt(rp),arg(pat)));
+ if (defaultSyntax(name(h).text)==APPLIC) {
+ rhs = ap(showsBQ,
+ ap2(varCompose,
+ ap(varAppend,mkStr(name(h).text)),
+ ap(showsBQ,rhs)));
+ } else {
+ rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),rhs);
+ }
+ rhs = ap2(varCompose,
+ ap2(varShowsPrec,mkInt(lp),arg(fun(pat))),
+ ap(showsSP,rhs));
+ rhs = ap2(varShowParen,ap2(varLe,mkInt(p+1),d),rhs);
+ return rhs;
+ } else {
+ /* To display a non-nullary constructor with applicative syntax:
+ * showsPrec d (Foo x y) = showParen (d>=10)
+ * (showString "Foo" .
+ * showChar ' ' . showsPrec 10 x .
+ * showChar ' ' . showsPrec 10 y)
+ */
+ Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
+ for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
+ rhs = ap(showsSP,ap2(varCompose,ap(shows10,arg(pat)),rhs));
+ }
+ rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),rhs);
+ rhs = ap2(varShowParen,ap2(varLe,mkInt(10),d),rhs);
+ return rhs;
+ }
+ }
+}
+#undef shows10
+#undef shows0
+#undef showsOP
+#undef showsOB
+#undef showsCM
+#undef showsSP
+#undef showsBQ
+#undef showsCP
+#undef showsCB
+#undef consChar
+
+#endif /* DERIVE_SHOW */
+
+/* --------------------------------------------------------------------------
+ * Deriving Read:
+ * ------------------------------------------------------------------------*/
+
+#if DERIVE_READ
+
+static Cell local mkReadCon Args((Name,Cell,Cell));
+static Cell local mkReadPrefix Args((Cell));
+static Cell local mkReadInfix Args((Cell));
+static Cell local mkReadTuple Args((Cell));
+static Cell local mkReadRecord Args((Cell,List));
+
+#define Tuple2(f,s) ap2(mkTuple(2),f,s)
+#define Lex(r) ap(varLex,r)
+#define ZFexp(h,q) ap(FROMQUAL, pair(h,q))
+#define ReadsPrec(n,e) ap2(varReadsPrec,n,e)
+#define Lambda(v,e) ap(LAMBDA,pair(v, pair(mkInt(0),e)))
+#define ReadParen(a,b,c) ap3(varReadParen,a,b,c)
+#define ReadField(f,s) ap2(varReadField,f,s)
+#define GT(l,r) ap2(varGt,l,r)
+#define Append(a,b) ap2(varAppend,a,b)
+
+/* Construct the readsPrec function of the form:
+ *
+ * readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
+ * (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
+ * ...
+ * (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
+ */
+List deriveRead(t) /* construct definition of text reader */
+Cell t; {
+ Cell alt = NIL;
+ Cell exp = NIL;
+ Cell d = inventVar();
+ Cell r = inventVar();
+ List pat = cons(d,cons(r,NIL));
+ Int line = 0;
+
+ if (isTycon(t)) {
+ List cs = tycon(t).defn;
+ List exps = NIL;
+ for(; hasCfun(cs); cs=tl(cs)) {
+ exps = cons(mkReadCon(hd(cs),d,r),exps);
+ }
+ /* reverse concatenate list of subexpressions */
+ exp = hd(exps);
+ for(exps=tl(exps); nonNull(exps); exps=tl(exps)) {
+ exp = ap2(varAppend,hd(exps),exp);
+ }
+ line = tycon(t).line;
+ } else { /* Tuples */
+ exp = ap(mkReadTuple(t),r);
+ }
+ /* printExp(stdout,exp); putc('\n',stdout); */
+ alt = pair(pat,pair(mkInt(line),exp));
+ return singleton(mkBind("readsPrec",singleton(alt)));
+}
+
+/* Generate an expression of the form:
+ *
+ * readParen (d > p) <derived expression> r
+ *
+ * for a (non-tuple) constructor "con" of precedence "p".
+ */
+static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
+Name con;
+Cell d;
+Cell r; {
+ Cell exp = NIL;
+ Int p = 0;
+ Syntax s = syntaxOf(name(con).text);
+ List cfs = cfunSfuns;
+ for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
+ }
+ if (nonNull(cfs)) {
+ exp = mkReadRecord(con,snd(hd(cfs)));
+ p = 9;
+ } else if (name(con).arity==2 && assocOf(s)!=APPLIC) {
+ exp = mkReadInfix(con);
+ p = precOf(s);
+ } else {
+ exp = mkReadPrefix(con);
+ p = 9;
+ }
+ return ReadParen(name(con).arity==0 ? varFalse : GT(d,mkInt(p)),
+ exp,
+ r);
+}
+
+/* Given an n-ary prefix constructor, generate a single lambda
+ * expression, such that
+ *
+ * data T ... = Constr a1 a2 .. an | ....
+ *
+ * derives
+ *
+ * \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
+ * (t1,s1) <- readsPrec 10 s0,
+ * (t2,s2) <- readsPrec 10 s1,
+ * ...,
+ * (tn,sn) <- readsPrec 10 sn-1 ]
+ *
+ */
+static Cell local mkReadPrefix(con) /* readsPrec for prefix constructor */
+Cell con; {
+ Int arity = name(con).arity;
+ Cell cn = mkStr(name(con).text);
+ Cell r = inventVar();
+ Cell prev_s = inventVar();
+ Cell exp = con;
+ List quals = NIL;
+ Int i;
+
+ /* build (reversed) list of qualifiers and constructor */
+ quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
+ for(i=0; i<arity; i++) {
+ Cell t = inventVar();
+ Cell s = inventVar();
+ quals = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
+ exp = ap(exp,t);
+ prev_s = s;
+ }
+
+ /* \r -> [ (exp, prev_s) | quals ] */
+ return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
+}
+
+/* Given a binary infix constructor of precedence p
+ *
+ * ... | T1 `con` T2 | ...
+ *
+ * generate the lambda expression
+ *
+ * \ r -> [ (u `con` v, s2) | (u,s0) <- readsPrec lp r,
+ * ("con",s1) <- lex s0,
+ * (v,s2) <- readsPrec rp s1 ]
+ *
+ * where lp and rp are either p or p+1 depending on associativity
+ */
+static Cell local mkReadInfix( con )
+Cell con;
+{
+ Syntax s = syntaxOf(name(con).text);
+ Int p = precOf(s);
+ Int lp = assocOf(s)==LEFT_ASS ? p : (p+1);
+ Int rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
+ Cell cn = mkStr(name(con).text);
+ Cell r = inventVar();
+ Cell s0 = inventVar();
+ Cell s1 = inventVar();
+ Cell s2 = inventVar();
+ Cell u = inventVar();
+ Cell v = inventVar();
+ List quals = NIL;
+
+ quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)), quals);
+ quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)), quals);
+ quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
+
+ return Lambda(singleton(r),
+ ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
+}
+
+/* Given the n-ary tuple constructor return a lambda expression:
+ *
+ * \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0) <- lex r,
+ * (t1, s1) <- readsPrec 0 s0,
+ * ...
+ * (",",s(2n-1)) <- lex s(2n-2),
+ * (tn, s(2n)) <- readsPrec 0 s(2n-1),
+ * (")",s(2n+1)) <- lex s(2n) ]
+ */
+static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
+Cell tup; {
+ Int arity = tupleOf(tup);
+ Cell lp = mkStr(findText("("));
+ Cell rp = mkStr(findText(")"));
+ Cell co = mkStr(findText(","));
+ Cell sep = lp;
+ Cell r = inventVar();
+ Cell prev_s = r;
+ Cell s = inventVar();
+ Cell exp = tup;
+ List quals = NIL;
+ Int i;
+
+ /* build (reversed) list of qualifiers and constructor */
+ for(i=0; i<arity; i++) {
+ Cell t = inventVar();
+ Cell si = inventVar();
+ Cell sj = inventVar();
+ quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
+ quals = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
+ exp = ap(exp,t);
+ prev_s = sj;
+ sep = co;
+ }
+ quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
+
+ /* \ r -> [ (exp,s) | quals ] */
+ return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
+}
+
+/* Given a record constructor
+ *
+ * ... | C { f1 :: T1, ... fn :: Tn } | ...
+ *
+ * generate the expression:
+ *
+ * \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0) <- lex r,
+ * ("{", s1) <- lex s0,
+ * (t1, s2) <- readField "f1" s1,
+ * ...
+ * (",", s(2n-1)) <- lex s(2n),
+ * (tn, s(2n)) <- readField "fn" s(2n+1),
+ * ("}", s(2n+1)) <- lex s(2n+2) ]
+ *
+ * where
+ *
+ * readField :: Read a => String -> ReadS a
+ * readField m s0 = [ r | (t, s1) <- lex s0, t == m,
+ * ("=",s2) <- lex s1,
+ * r <- readsPrec 10 s2 ]
+ */
+static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
+Cell con;
+List fs; {
+ Cell cn = mkStr(name(con).text);
+ Cell lb = mkStr(findText("{"));
+ Cell rb = mkStr(findText("}"));
+ Cell co = mkStr(findText(","));
+ Cell sep = lb;
+ Cell r = inventVar();
+ Cell s0 = inventVar();
+ Cell prev_s = s0;
+ Cell s = inventVar();
+ Cell exp = con;
+ List quals = NIL;
+
+ /* build (reversed) list of qualifiers and constructor */
+ quals = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
+ for(; nonNull(fs); fs=tl(fs)) {
+ Cell f = mkStr(textOf(hd(fs)));
+ Cell t = inventVar();
+ Cell si = inventVar();
+ Cell sj = inventVar();
+ quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)), quals);
+ quals = cons(ZFexp(Tuple2(t, sj),ReadField(f,si)), quals);
+ exp = ap(exp,t);
+ prev_s = sj;
+ sep = co;
+ }
+ quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
+
+ /* \ r -> [ (exp,s) | quals ] */
+ return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
+}
+
+#undef Tuple2
+#undef Lex
+#undef ZFexp
+#undef ReadsPrec
+#undef Lambda
+#undef ReadParen
+#undef ReadField
+#undef GT
+#undef Append
+
+#endif /* DERIVE_READ */
+
+/* --------------------------------------------------------------------------
+ * Deriving Bounded:
+ * ------------------------------------------------------------------------*/
+
+#if DERIVE_BOUNDED
+
+static List local mkBndBinds Args((Int,Cell,Int));
+
+List deriveBounded(t) /* construct definition of bounds */
+Tycon t; {
+ if (isEnumType(t)) {
+ Cell last = tycon(t).defn;
+ Cell first = hd(last);
+ while (hasCfun(tl(last))) {
+ last = tl(last);
+ }
+ return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
+ cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
+ NIL));
+ } else if (isTuple(t)) { /* Definitions for product types */
+ return mkBndBinds(0,t,tupleOf(t));
+ } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
+ return mkBndBinds(tycon(t).line,
+ hd(tycon(t).defn),
+ name(hd(tycon(t).defn)).arity);
+ }
+ ERRMSG(tycon(t).line)
+ "Can only derive instances of Bounded for enumeration and product types"
+ EEND;
+ return NIL;
+}
+
+static List local mkBndBinds(line,h,n) /* build bindings for derived */
+Int line; /* Bounded on a product type */
+Cell h;
+Int n; {
+ Cell minB = h;
+ Cell maxB = h;
+ while (n-- > 0) {
+ minB = ap(minB,varMinBound);
+ maxB = ap(maxB,varMaxBound);
+ }
+ return cons(mkBind("minBound",mkVarAlts(line,minB)),
+ cons(mkBind("maxBound",mkVarAlts(line,maxB)),
+ NIL));
+}
+
+#endif /* DERIVE_BOUNDED */
+
+/* --------------------------------------------------------------------------
+ * Static Analysis control:
+ * ------------------------------------------------------------------------*/
+
+Void deriveControl(what)
+Int what; {
+ Text textPrelude = findText("PreludeBuiltin");
+ switch (what) {
+ case INSTALL :
+ varTrue = mkQVar(textPrelude,findText("True"));
+ varFalse = mkQVar(textPrelude,findText("False"));
+#if DERIVE_ORD
+ varCompAux = mkQVar(textPrelude,findText("primCompAux"));
+ varCompare = mkQVar(textPrelude,findText("compare"));
+ varEQ = mkQVar(textPrelude,findText("EQ"));
+#endif
+#if DERIVE_IX
+ varRangeSize = mkQVar(textPrelude,findText("rangeSize"));
+ varInRange = mkQVar(textPrelude,findText("inRange"));
+ varRange = mkQVar(textPrelude,findText("range"));
+ varIndex = mkQVar(textPrelude,findText("index"));
+ varMult = mkQVar(textPrelude,findText("*"));
+ varPlus = mkQVar(textPrelude,findText("+"));
+ varMap = mkQVar(textPrelude,findText("map"));
+ varMinus = mkQVar(textPrelude,findText("-"));
+ varError = mkQVar(textPrelude,findText("error"));
+#endif
+#if DERIVE_ENUM
+ varToEnum = mkQVar(textPrelude,findText("toEnum"));
+ varFromEnum = mkQVar(textPrelude,findText("fromEnum"));
+ varEnumFromTo = mkQVar(textPrelude,findText("enumFromTo"));
+ varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
+#endif
+#if DERIVE_BOUNDED
+ varMinBound = mkQVar(textPrelude,findText("minBound"));
+ varMaxBound = mkQVar(textPrelude,findText("maxBound"));
+#endif
+#if DERIVE_SHOW
+ conCons = mkQCon(textPrelude,findText(":"));
+ varShowField = mkQVar(textPrelude,findText("primShowField"));
+ varShowParen = mkQVar(textPrelude,findText("showParen"));
+ varCompose = mkQVar(textPrelude,findText("."));
+ varShowsPrec = mkQVar(textPrelude,findText("showsPrec"));
+ varLe = mkQVar(textPrelude,findText("<="));
+#endif
+#if DERIVE_READ
+ varReadField = mkQVar(textPrelude,findText("primReadField"));
+ varReadParen = mkQVar(textPrelude,findText("readParen"));
+ varLex = mkQVar(textPrelude,findText("lex"));
+ varReadsPrec = mkQVar(textPrelude,findText("readsPrec"));
+ varGt = mkQVar(textPrelude,findText(">"));
+#endif
+#if DERIVE_SHOW || DERIVE_READ
+ varAppend = mkQVar(textPrelude,findText("++"));
+#endif
+#if DERIVE_EQ || DERIVE_IX
+ varAnd = mkQVar(textPrelude,findText("&&"));
+#endif
+#if DERIVE_EQ || DERIVE_ORD
+ varEq = mkQVar(textPrelude,findText("=="));
+#endif
+ /* deliberate fall through */
+ case RESET :
+ diVars = NIL;
+ diNum = 0;
+#if DERIVE_SHOW | DERIVE_READ
+ cfunSfuns = NIL;
+#endif
+ break;
+
+ case MARK :
+ mark(diVars);
+#if DERIVE_SHOW | DERIVE_READ
+ mark(cfunSfuns);
+#endif
+ mark(varTrue);
+ mark(varFalse);
+#if DERIVE_ORD
+ mark(varCompAux);
+ mark(varCompare);
+ mark(varEQ);
+#endif
+#if DERIVE_IX
+ mark(varRangeSize);
+ mark(varInRange);
+ mark(varRange);
+ mark(varIndex);
+ mark(varMult);
+ mark(varPlus);
+ mark(varMap);
+ mark(varMinus);
+ mark(varError);
+#endif
+#if DERIVE_ENUM
+ mark(varToEnum);
+ mark(varFromEnum);
+ mark(varEnumFromTo);
+ mark(varEnumFromThenTo);
+#endif
+#if DERIVE_BOUNDED
+ mark(varMinBound);
+ mark(varMaxBound);
+#endif
+#if DERIVE_SHOW
+ mark(conCons);
+ mark(varShowField);
+ mark(varShowParen);
+ mark(varCompose);
+ mark(varShowsPrec);
+ mark(varLe);
+#endif
+#if DERIVE_READ
+ mark(varReadField);
+ mark(varReadParen);
+ mark(varLex);
+ mark(varReadsPrec);
+ mark(varGt);
+#endif
+#if DERIVE_SHOW || DERIVE_READ
+ mark(varAppend);
+#endif
+#if DERIVE_EQ || DERIVE_IX
+ mark(varAnd);
+#endif
+#if DERIVE_EQ || DERIVE_ORD
+ mark(varEq);
+#endif
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+
+#if DERIVE_SHOW | DERIVE_READ
+extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
+#endif
+
+extern List deriveEq Args((Tycon));
+extern List deriveOrd Args((Tycon));
+extern List deriveIx Args((Tycon));
+extern List deriveEnum Args((Tycon));
+extern List deriveShow Args((Tycon));
+extern List deriveRead Args((Cell));
+extern List deriveBounded Args((Tycon));
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Desugarer
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: desugar.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:05 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "link.h"
+
+#include "desugar.h"
+#include "pat.h"
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Void local transPair Args((Pair));
+static Void local transTriple Args((Triple));
+static Void local transCase Args((Cell));
+static Cell local transRhs Args((Cell));
+static Cell local expandLetrec Args((Cell));
+static Cell local transComp Args((Cell,List,Cell));
+static Cell local transDo Args((Cell,Cell,Cell,List));
+static Cell local transConFlds Args((Cell,List));
+static Cell local transUpdFlds Args((Cell,List,List));
+
+/* --------------------------------------------------------------------------
+ * Translation: Convert input expressions into a less complex language
+ * of terms using only LETREC, AP, constants and vars.
+ * Also remove pattern definitions on lhs of eqns.
+ * ------------------------------------------------------------------------*/
+
+Cell translate(e) /* Translate expression: */
+Cell e; {
+ switch (whatIs(e)) {
+ case LETREC : snd(snd(e)) = translate(snd(snd(e)));
+ return expandLetrec(e);
+
+ case COND : transTriple(snd(e));
+ return e;
+
+ case AP : fst(e) = translate(fst(e));
+
+ if (fst(e)==nameId || fst(e)==nameInd)
+ return translate(snd(e));
+#if USE_NEWTYPE_FOR_DICTS
+ if (isName(fst(e)) &&
+ isMfun(fst(e)) &&
+ mfunOf(fst(e))==0)
+ return translate(snd(e));
+#endif
+ snd(e) = translate(snd(e));
+ return e;
+
+ case NAME : if (e==nameOtherwise)
+ return nameTrue;
+ if (isCfun(e)) {
+ if (isName(name(e).defn))
+ return name(e).defn;
+ if (isPair(name(e).defn))
+ return snd(name(e).defn);
+ }
+ return e;
+
+#if TREX
+ case RECSEL : return nameRecSel;
+
+ case EXT :
+#endif
+ case TUPLE :
+ case VAROPCELL :
+ case VARIDCELL :
+ case DICTVAR :
+ case INTCELL :
+ case BIGCELL :
+ case FLOATCELL :
+ case STRCELL :
+ case CHARCELL : return e;
+
+ case FINLIST : mapOver(translate,snd(e));
+ return mkConsList(snd(e));
+
+ case DOCOMP : { Cell m = translate(fst(fst(snd(e))));
+ Cell m0 = snd(fst(snd(e)));
+ Cell r = translate(fst(snd(snd(e))));
+ if (nonNull(m0))
+ m0 = translate(m0);
+ return transDo(m,m0,r,snd(snd(snd(e))));
+ }
+
+ case COMP : return transComp(translate(fst(snd(e))),
+ snd(snd(e)),
+ nameNil);
+
+ case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e)));
+
+ case UPDFLDS : return transUpdFlds(fst3(snd(e)),
+ snd3(snd(e)),
+ thd3(snd(e)));
+
+ case CASE : { Cell nv = inventVar();
+ mapProc(transCase,snd(snd(e)));
+ return ap(LETREC,
+ pair(singleton(pair(nv,snd(snd(e)))),
+ ap(nv,translate(fst(snd(e))))));
+ }
+
+ case LAMBDA : { Cell nv = inventVar();
+ transAlt(snd(e));
+ return ap(LETREC,
+ pair(singleton(pair(
+ nv,
+ singleton(snd(e)))),
+ nv));
+ }
+
+ default : internal("translate");
+ }
+ return e;
+}
+
+static Void local transPair(pr) /* Translate each component in a */
+Pair pr; { /* pair of expressions. */
+ fst(pr) = translate(fst(pr));
+ snd(pr) = translate(snd(pr));
+}
+
+static Void local transTriple(tr) /* Translate each component in a */
+Triple tr; { /* triple of expressions. */
+ fst3(tr) = translate(fst3(tr));
+ snd3(tr) = translate(snd3(tr));
+ thd3(tr) = translate(thd3(tr));
+}
+
+Void transAlt(e) /* Translate alt: */
+Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
+ snd(e) = transRhs(snd(e));
+}
+
+static Void local transCase(c) /* Translate case: */
+Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
+ fst(c) = singleton(fst(c));
+ snd(c) = transRhs(snd(c));
+}
+
+List transBinds(bs) /* Translate list of bindings: */
+List bs; { /* eliminating pattern matching on */
+ List newBinds=NIL; /* lhs of bindings. */
+ for (; nonNull(bs); bs=tl(bs)) {
+ if (isVar(fst(hd(bs)))) {
+ mapProc(transAlt,snd(hd(bs)));
+ newBinds = cons(hd(bs),newBinds);
+ }
+ else
+ newBinds = remPat(fst(snd(hd(bs))),
+ snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
+ newBinds);
+ }
+ return newBinds;
+}
+
+static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
+Cell rhs; {
+ switch (whatIs(rhs)) {
+ case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
+ return expandLetrec(rhs);
+
+ case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
+ mapProc(transPair,snd(rhs));
+ return rhs;
+
+ default : return translate(snd(rhs)); /* discard line number */
+ }
+}
+
+Cell mkConsList(es) /* Construct expression for list es */
+List es; { /* using nameNil and nameCons */
+ if (isNull(es))
+ return nameNil;
+ else
+ return ap2(nameCons,hd(es),mkConsList(tl(es)));
+}
+
+static Cell local expandLetrec(root) /* translate LETREC with list of */
+Cell root; { /* groups of bindings (from depend. */
+ Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
+ List bss = fst(snd(root));
+ Cell temp;
+
+ if (isNull(bss)) /* should never happen, but just in */
+ return e; /* case: LETREC [] IN e ==> e */
+
+ mapOver(transBinds,bss); /* translate each group of bindings */
+
+ for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
+ fst(snd(temp)) = hd(bss);
+ snd(snd(temp)) = ap(LETREC,pair(NIL,e));
+ temp = snd(snd(temp));
+ }
+ fst(snd(temp)) = hd(bss);
+
+ return root;
+}
+
+/* --------------------------------------------------------------------------
+ * Translation of list comprehensions is based on the description in
+ * `The Implementation of Functional Programming Languages':
+ *
+ * [ e | qs ] ++ l => transComp e qs l
+ * transComp e [] l => e : l
+ * transComp e ((p<-xs):qs) l => LETREC _h [] = l
+ * _h (p:_xs) = transComp e qs (_h _xs)
+ * _h (_:_xs) = _h _xs --if p !failFree
+ * IN _h xs
+ * transComp e (b:qs) l => if b then transComp e qs l else l
+ * transComp e (decls:qs) l => LETREC decls IN transComp e qs l
+ * ------------------------------------------------------------------------*/
+
+static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
+Cell e;
+List qs;
+Cell l; {
+ if (nonNull(qs)) {
+ Cell q = hd(qs);
+ Cell qs1 = tl(qs);
+
+ switch (fst(q)) {
+ case FROMQUAL : { Cell ld = NIL;
+ Cell hVar = inventVar();
+ Cell xsVar = inventVar();
+
+ if (!failFree(fst(snd(q))))
+ ld = cons(pair(singleton(
+ ap2(nameCons,
+ WILDCARD,
+ xsVar)),
+ ap(hVar,xsVar)),
+ ld);
+
+ ld = cons(pair(singleton(
+ ap2(nameCons,
+ fst(snd(q)),
+ xsVar)),
+ transComp(e,
+ qs1,
+ ap(hVar,xsVar))),
+ ld);
+ ld = cons(pair(singleton(nameNil),
+ l),
+ ld);
+
+ return ap(LETREC,
+ pair(singleton(pair(hVar,
+ ld)),
+ ap(hVar,
+ translate(snd(snd(q))))));
+ }
+
+ case QWHERE : return
+ expandLetrec(ap(LETREC,
+ pair(snd(q),
+ transComp(e,qs1,l))));
+
+ case BOOLQUAL : return ap(COND,
+ triple(translate(snd(q)),
+ transComp(e,qs1,l),
+ l));
+ }
+ }
+
+ return ap2(nameCons,e,l);
+}
+
+/* --------------------------------------------------------------------------
+ * Translation of monad comprehensions written using do-notation:
+ *
+ * do { e } => e
+ * do { p <- exp; qs } => LETREC _h p = do { qs }
+ * _h _ = zero{m0} -- if monad with 0
+ * IN exp >>={m} _h
+ * do { LET decls; qs } => LETREC decls IN do { qs }
+ * do { IF guard; qs } => if guard then do { qs } else zero{m0}
+ * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
+ *
+ * where m :: Monad f, m0 :: Monad0 f
+ * ------------------------------------------------------------------------*/
+
+static Cell local transDo(m,m0,e,qs) /* Translate do { qs ; e } */
+Cell m;
+Cell m0;
+Cell e;
+List qs; {
+ if (nonNull(qs)) {
+ Cell q = hd(qs);
+ Cell qs1 = tl(qs);
+
+ switch (fst(q)) {
+ case FROMQUAL : { Cell ld = NIL;
+ Cell hVar = inventVar();
+
+ if (!failFree(fst(snd(q))) && nonNull(m0))
+ ld = cons(pair(singleton(WILDCARD),
+ ap(nameZero,m0)),ld);
+
+ ld = cons(pair(singleton(fst(snd(q))),
+ transDo(m,m0,e,qs1)),
+ ld);
+
+ return ap(LETREC,
+ pair(singleton(pair(hVar,ld)),
+ ap3(nameBind,
+ m,
+ translate(snd(snd(q))),
+ hVar)));
+ }
+
+ case DOQUAL : { Cell hVar = inventVar();
+ Cell ld = cons(pair(singleton(WILDCARD),
+ transDo(m,m0,e,qs1)),
+ NIL);
+ return ap(LETREC,
+ pair(singleton(pair(hVar,ld)),
+ ap3(nameBind,
+ m,
+ translate(snd(q)),
+ hVar)));
+ }
+
+ case QWHERE : return
+ expandLetrec(ap(LETREC,
+ pair(snd(q),
+ transDo(m,m0,e,qs1))));
+
+ case BOOLQUAL : return ap(COND,
+ triple(translate(snd(q)),
+ transDo(m,m0,e,qs1),
+ ap(nameZero,m0)));
+ }
+ }
+ return e;
+}
+
+/* --------------------------------------------------------------------------
+ * Translation of named field construction and update:
+ *
+ * Construction is implemented using the following transformation:
+ *
+ * C{x1=e1, ..., xn=en} = C v1 ... vm
+ * where:
+ * vi = e1, if the ith component of C is labelled with x1
+ * ...
+ * = en, if the ith component of C is labelled with xn
+ * = undefined, otherwise
+ *
+ * Update is implemented using the following transformation:
+ *
+ * e{x1=e1, ..., xn=en}
+ * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
+ * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
+ * ...
+ * nv _ v1 ... vn = error "failed update"
+ * in nv e e1 ... en
+ * where:
+ * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
+ * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
+ * and:
+ * ai' = v1, if the ith component of C is labelled with x1
+ * ...
+ * = vn, if the ith component of C is labelled with xn
+ * = ai, otherwise
+ * etc...
+ *
+ * The error case may be omitted if C,D,... is an enumeration of all of the
+ * constructors for the datatype concerned. Strictly speaking, error case
+ * isn't needed at all -- the only benefit of including it is that the user
+ * will get a "failed update" message rather than a cryptic {v354 ...}.
+ * So, for now, we'll go with the second option!
+ *
+ * For the time being, code for each update operation is generated
+ * independently of any other updates. However, if updates are used
+ * frequently, then we might want to consider changing the implementation
+ * at a later stage to cache definitions of functions like nv above. This
+ * would create a shared library of update functions, indexed by a set of
+ * constructors {C,D,...}.
+ * ------------------------------------------------------------------------*/
+
+static Cell local transConFlds(c,flds) /* Translate C{flds} */
+Name c;
+List flds; {
+ Cell e = c;
+ Int m = name(c).arity;
+ Int i;
+ for (i=m; i>0; i--)
+ e = ap(e,nameUndefined);
+ for (; nonNull(flds); flds=tl(flds)) {
+ Cell a = e;
+ for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
+ a = fun(a);
+ arg(a) = translate(snd(hd(flds)));
+ }
+ return e;
+}
+
+static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
+Cell e; /* (cs is corresp list of constrs) */
+List cs;
+List flds; {
+ Cell nv = inventVar();
+ Cell body = ap(nv,translate(e));
+ List fs = flds;
+ List args = NIL;
+ List alts = NIL;
+
+ for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
+ Cell b = hd(fs); /* args = [v1, ..., vn] */
+ body = ap(body,translate(snd(b)));
+ args = cons(inventVar(),args);
+ }
+
+ for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
+ Cell c = hd(cs); /* build up list of alts. */
+ Cell pat = c;
+ Cell rhs = c;
+ List as = args;
+ Int m = name(c).arity;
+ Int i;
+
+ for (i=m; i>0; i--) { /* pat = C a1 ... am */
+ Cell a = inventVar(); /* rhs = C a1 ... am */
+ pat = ap(pat,a);
+ rhs = ap(rhs,a);
+ }
+
+ for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
+ Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
+ Cell r = rhs; /* vars from [v1,...,vn] */
+ for (i=m-sfunPos(s,c); i>0; i--)
+ r = fun(r);
+ arg(r) = hd(as);
+ }
+
+ alts = cons(pair(cons(pat,args),rhs),alts);
+ }
+ return ap(LETREC,pair(singleton(pair(nv,alts)),body));
+}
+
+/* --------------------------------------------------------------------------
+ * Desugar control:
+ * ------------------------------------------------------------------------*/
+
+Void desugarControl(what)
+Int what; {
+ patControl(what);
+ switch (what) {
+ case INSTALL :
+ /* Fall through */
+ case RESET : break;
+ case MARK : break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern Cell translate Args((Cell));
+extern Void transAlt Args((Cell));
+extern List transBinds Args((List));
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Dynamic loading (of .dll or .so files) for Hugs
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: dynamic.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:06 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "errors.h"
+#include "dynamic.h"
+
+#if HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
+
+#include <stdio.h>
+#include <dlfcn.h>
+
+ObjectFile loadLibrary(fn)
+String fn; {
+ return dlopen(fn,RTLD_NOW | RTLD_GLOBAL);
+}
+
+void* lookupSymbol(file,symbol)
+ObjectFile file;
+String symbol; {
+ return dlsym(file,symbol)
+}
+
+void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */
+String dll;
+String symbol; {
+#ifdef RTLD_NOW
+ ObjectFile instance = dlopen(dll,RTLD_NOW);
+#elif defined RTLD_LAZY /* eg SunOS4 doesn't have RTLD_NOW */
+ ObjectFile instance = dlopen(dll,RTLD_LAZY);
+#else /* eg FreeBSD doesn't have RTLD_LAZY */
+ ObjectFile instance = dlopen(dll,1);
+#endif
+ if (NULL == instance) {
+ ERRMSG(0) "Error %s while importing DLL \"%s\"", dlerror(), dll
+ EEND;
+ }
+ return dlsym(instance,symbol);
+}
+
+#elif HAVE_DL_H /* eg HPUX */
+
+#include <dl.h>
+
+void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */
+String dll;
+String symbol; {
+ ObjectFile instance = shl_load(dll,BIND_IMMEDIATE,0L);
+ void* r;
+ if (NULL == instance) {
+ ERRMSG(0) "Error while importing DLL \"%s\"", dll
+ EEND;
+ }
+ return (0 == shl_findsym(&instance,symbol,TYPE_PROCEDURE,&r)) ? r : 0;
+}
+
+#elif HAVE_WINDOWS_H && !defined(__MSDOS__)
+
+#include <windows.h>
+
+ObjectFile loadLibrary(fn)
+String fn; {
+ return LoadLibrary(fn);
+}
+
+void* lookupSymbol(file,symbol)
+ObjectFile file;
+String symbol; {
+ return GetProcAddress(file,symbol);
+}
+
+const char *dlerror(void)
+{
+ return "<unknown>";
+}
+
+void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */
+String dll;
+String symbol; {
+ ObjectFile instance = LoadLibrary(dll);
+ if (NULL == instance) {
+ /* GetLastError allegedly provides more detail - in practice,
+ * it tells you nothing more.
+ */
+ ERRMSG(0) "Error while importing DLL \"%s\"", dll
+ EEND;
+ }
+ return GetProcAddress(instance,symbol);
+}
+
+#else /* Dynamic loading not available */
+
+void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */
+String dll;
+String symbol; {
+#if 1 /* very little to choose between these options */
+ return 0;
+#else
+ ERRMSG(0) "This Hugs build does not support dynamic loading\n"
+ EEND;
+#endif
+}
+
+#endif /* Dynamic loading not available */
+
--- /dev/null
+void* getDLLSymbol Args((String,String));
+void* lookupSymbol Args((ObjectFile file, String symbol));
+ObjectFile loadLibrary Args((String fn));
+
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Error handling support functions
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: errors.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:07 $
+ * ------------------------------------------------------------------------*/
+
+extern Void internal Args((String)) HUGS_noreturn;
+extern Void fatal Args((String)) HUGS_noreturn;
+
+#if HUGS_FOR_WINDOWS
+#define Hilite() WinTextcolor(hWndText,RED);
+#define Lolite() WinTextcolor(hWndText,BLACK);
+#define errorStream stderr
+#else
+#define Hilite() doNothing()
+#define Lolite() doNothing()
+#define errorStream stdout
+#endif
+
+#define ERRMSG(l) Hilite(); errHead(l); FPrintf(errorStream,
+#define EEND ); Lolite(); errFail()
+#define ETHEN );
+#define ERRTEXT Hilite(); FPrintf(errorStream,
+#define ERREXPR(e) Hilite(); printExp(errorStream,e); Lolite()
+#define ERRTYPE(e) Hilite(); printType(errorStream,e); Lolite()
+#define ERRCONTEXT(qs) Hilite(); printContext(errorStream,qs); Lolite()
+#define ERRPRED(pi) Hilite(); printPred(errorStream,pi); Lolite()
+#define ERRKIND(k) Hilite(); printKind(errorStream,k); Lolite()
+#define ERRKINDS(ks) Hilite(); printKinds(errorStream,ks); Lolite()
+
+extern Void errHead Args((Int)); /* in main.c */
+extern Void errFail Args((Void)) HUGS_noreturn;
+extern Void errAbort Args((Void));
+
+extern sigProto(breakHandler);
+
+#include "output.h"
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Free variable analysis
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: free.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:08 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+#include "free.h"
+
+/* --------------------------------------------------------------------------
+ * Local functions
+ * ------------------------------------------------------------------------*/
+
+static List freeVarsAlt Args((List, StgCaseAlt));
+static List freeVarsPrimAlt Args((List, StgPrimAlt));
+static List freeVarsExpr Args((List, StgExpr));
+static List freeVarsAtom Args((List, StgAtom));
+static List freeVarsVar Args((List, StgVar));
+
+/* --------------------------------------------------------------------------
+ * Free variable analysis
+ * ------------------------------------------------------------------------*/
+
+static List freeVarsAtom( List acc, StgAtom a)
+{
+ switch (whatIs(a)) {
+ case STGVAR:
+ return freeVarsVar(acc,a);
+ /* Note that NAMEs have no free vars. */
+ default:
+ return acc;
+ }
+}
+
+static List freeVarsVar( List acc, StgVar v)
+{
+ if (cellIsMember(v,acc)) {
+ return acc;
+ } else {
+ return cons(v,acc);
+ }
+}
+
+List freeVarsBind( List acc, StgVar v )
+{
+ StgRhs rhs = stgVarBody(v);
+ List fvs = NIL;
+ switch (whatIs(rhs)) {
+ case STGCON:
+ mapAccum(freeVarsAtom,fvs,stgConArgs(rhs));
+ break;
+ default:
+ fvs = freeVarsExpr(fvs,rhs);
+ break;
+ }
+ /* fvs = rev(fvs); */ /* todo might cause less stack rearrangement? */
+ stgVarInfo(v) = fvs;
+ mapAccum(freeVarsVar,acc,fvs); /* copy onto acc */
+ return acc;
+}
+
+static List freeVarsAlt( List acc, StgCaseAlt alt )
+{
+ StgPat pat = stgCaseAltPat(alt);
+ acc = freeVarsExpr(acc,stgCaseAltBody(alt));
+ if (!isDefaultPat(pat)) {
+ acc = diffList(acc,stgPatVars(pat));
+ }
+ return deleteCell(acc,pat);
+}
+
+static List freeVarsPrimAlt( List acc, StgPrimAlt alt )
+{
+ List vs = stgPrimAltPats(alt);
+ acc = freeVarsExpr(acc,stgPrimAltBody(alt));
+ return diffList(acc,vs);
+}
+
+static List freeVarsExpr( List acc, StgExpr e )
+{
+ switch (whatIs(e)) {
+ case LETREC:
+ mapAccum(freeVarsBind,acc,stgLetBinds(e));
+ return diffList(freeVarsExpr(acc,stgLetBody(e)),stgLetBinds(e));
+ case LAMBDA:
+ return diffList(freeVarsExpr(acc,stgLambdaBody(e)),stgLambdaArgs(e));
+ case CASE:
+ mapAccum(freeVarsAlt,acc,stgCaseAlts(e));
+ return freeVarsExpr(acc,stgCaseScrut(e));
+ case PRIMCASE:
+ mapAccum(freeVarsPrimAlt,acc,stgPrimCaseAlts(e));
+ return freeVarsExpr(acc,stgPrimCaseScrut(e));
+ case STGPRIM:
+ mapAccum(freeVarsAtom,acc,stgPrimArgs(e));
+ /* primop is not a var */
+ return acc;
+ case STGAPP:
+ /* Doing fun first causes slightly less stack rearrangement. */
+ acc = freeVarsExpr(acc,stgAppFun(e));
+ mapAccum(freeVarsAtom,acc,stgAppArgs(e));
+ return acc;
+ case STGVAR:
+ return freeVarsVar(acc, e);
+ case NAME:
+ return acc; /* Names are never free vars */
+ default:
+ internal("freeVarsExpr");
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern List freeVarsBind Args((List, StgVar));
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Command interpreter
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: hugs.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:09 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "version.h"
+#include "storage.h"
+#include "command.h"
+#include "connect.h"
+#include "charset.h"
+#include "input.h"
+#include "type.h"
+#include "subst.h" /* for typeMatches */
+#include "link.h" /* for classShow, nameRunIO and namePrint */
+#include "static.h"
+#include "compiler.h"
+#include "interface.h"
+#include "hugs.h"
+#include "errors.h"
+#include <setjmp.h>
+#include <ctype.h>
+
+#include <stdio.h>
+
+#include "machdep.h"
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Void local initialize Args((Int,String []));
+static Void local promptForInput Args((String));
+static Void local interpreter Args((Int,String []));
+static Void local menu Args((Void));
+static Void local guidance Args((Void));
+static Void local forHelp Args((Void));
+static Void local set Args((Void));
+static Void local changeDir Args((Void));
+static Void local load Args((Void));
+static Void local project Args((Void));
+static Void local readScripts Args((Int));
+static Void local whatScripts Args((Void));
+static Void local editor Args((Void));
+static Void local find Args((Void));
+static Void local runEditor Args((Void));
+static Void local setModule Args((Void));
+static Module local findEvalModule Args((Void));
+static Void local evaluator Args((Void));
+static Void local showtype Args((Void));
+static Void local info Args((Void));
+static Void local showInst Args((Inst));
+static Void local describe Args((Text));
+static Void local listNames Args((Void));
+
+static Void local toggleSet Args((Char,Bool));
+static Void local togglesIn Args((Bool));
+static Void local optionInfo Args((Void));
+#if USE_REGISTRY || HUGS_FOR_WINDOWS
+static String local optionsToStr Args((Void));
+#endif
+static Void local readOptions Args((String));
+static Bool local processOption Args((String));
+static Void local setHeapSize Args((String));
+static Int local argToInt Args((String));
+
+static Void local loadProject Args((String));
+static Void local clearProject Args((Void));
+static Void local addScriptName Args((String,Bool));
+static Bool local addScript Args((String,Long));
+static Void local forgetScriptsFrom Args((Script));
+static Void local setLastEdit Args((String,Int));
+static Void local failed Args((Void));
+static String local strCopy Args((String));
+
+/* --------------------------------------------------------------------------
+ * Machine dependent code for Hugs interpreter:
+ * ------------------------------------------------------------------------*/
+
+#ifdef WANT_TIMER
+#include "timer.c"
+#endif
+
+/* --------------------------------------------------------------------------
+ * Local data areas:
+ * ------------------------------------------------------------------------*/
+
+static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
+static Bool addType = FALSE; /* TRUE => print type with value */
+static Bool chaseImports = TRUE; /* TRUE => chase imports on load */
+static Bool useDots = RISCOS; /* TRUE => use dots in progress */
+static Bool quiet = FALSE; /* TRUE => don't show progress */
+
+static String scriptName[NUM_SCRIPTS]; /* Script file names */
+static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */
+static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */
+static Int scriptBase; /* Number of scripts in Prelude */
+static Int numScripts; /* Number of scripts loaded */
+static Int namesUpto; /* Number of script names set */
+static Bool needsImports; /* set to TRUE if imports required */
+ String scriptFile; /* Name of current script (if any) */
+
+static Text evalModule = 0; /* Name of module we eval exprs in */
+static String currProject = 0; /* Name of current project file */
+static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
+
+static String lastEdit = 0; /* Name of script to edit (if any) */
+static Int lastLine = 0; /* Editor line number (if possible)*/
+static String prompt = 0; /* Prompt string */
+static Int hpSize = DEFAULTHEAP; /* Desired heap size */
+String hugsEdit = 0; /* String for editor command */
+String hugsPath = 0; /* String for file search path */
+
+#if REDIRECT_OUTPUT
+static Bool disableOutput = FALSE; /* redirect output to buffer? */
+#endif
+
+/* --------------------------------------------------------------------------
+ * Hugs entry point:
+ * ------------------------------------------------------------------------*/
+
+#ifndef NO_MAIN /* we omit main when building the "Hugs server" */
+
+Main main Args((Int, String [])); /* now every func has a prototype */
+
+Main main(argc,argv)
+int argc;
+char *argv[]; {
+
+#ifdef HAVE_CONSOLE_H /* Macintosh port */
+ _ftype = 'TEXT';
+ _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
+
+ console_options.top = 50;
+ console_options.left = 20;
+
+ console_options.nrows = 32;
+ console_options.ncols = 80;
+
+ console_options.pause_atexit = 1;
+ console_options.title = "\pHugs";
+
+ console_options.procID = 5;
+ argc = ccommand(&argv);
+#endif
+
+ CStackBase = &argc; /* Save stack base for use in gc */
+
+ /* The startup banner now includes my name. Hugs is provided free of */
+ /* charge. I ask however that you show your appreciation for the many */
+ /* hours of work involved by retaining my name in the banner. Thanks! */
+
+#if SMALL_BANNER
+ Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
+ Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
+ Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
+#else
+#ifdef OLD_LOGO
+ Printf(" ___ ___ ___ ___ __________ __________ \n");
+ Printf(" / / / / / / / / / _______/ / _______/ Hugs 1.4 \n");
+ Printf(" / /___/ / / / / / / / _____ / /______ \n");
+ Printf(" / ____ / / / / / / / /_ / /______ / The Nottingham and Yale\n");
+ Printf(" / / / / / /___/ / / /___/ / _______/ / Haskell User's System \n");
+ Printf(" /__/ /__/ /_________/ /_________/ /_________/ %s\n\n", HUGS_VERSION);
+ Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
+ Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
+#else
+ /* There is now a new banner, designed to draw attention to the fact */
+ /* that the version of Hugs being used is substantially different from */
+ /* previous releases (and to correct the mistaken view that Hugs is */
+ /* written in capitals). If you really prefer the old style banner, */
+ /* you can still get it by compiling with -DOLD_LOGO. */
+
+ printf(" __ __ __ __ ____ ___ __________________________________________\n");
+ printf(" || || || || || || ||__ Hugs 1.4: The Haskell User's Gofer System\n");
+ printf(" ||___|| ||__|| ||__|| __|| (c) The University of Nottingham\n");
+ printf(" ||---|| ___|| and Yale University, 1994-1998.\n");
+ printf(" || || Report bugs to hugs-bugs@haskell.org\n");
+ printf(" || || "HUGS_VERSION" __________________________________________\n\n");
+#endif
+#endif
+#if SYMANTEC_C
+ Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
+#endif
+ FlushStdout();
+ interpreter(argc,argv);
+ Printf("[Leaving Hugs]\n");
+ everybody(EXIT);
+ FlushStdout();
+ fflush(stderr);
+ exit(0);
+ MainDone();
+}
+
+#endif
+
+/* --------------------------------------------------------------------------
+ * Initialization, interpret command line args and read prelude:
+ * ------------------------------------------------------------------------*/
+
+static Void local initialize(argc,argv)/* Interpreter initialization */
+Int argc;
+String argv[]; {
+ Script i;
+ String proj = 0;
+
+ setLastEdit((String)0,0);
+ lastEdit = 0;
+ scriptFile = 0;
+ numScripts = 0;
+ namesUpto = 1;
+ initCharTab();
+
+#if HUGS_FOR_WINDOWS
+ hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe"));
+#elif SYMANTEC_C
+ hugsEdit = "";
+#else
+ hugsEdit = strCopy(fromEnv("EDITOR",NULL));
+#endif
+ hugsPath = strCopy(HUGSPATH);
+ readOptions("-p\"%s> \" -r$$");
+#if USE_REGISTRY
+ readOptions(readRegString("Options",""));
+#endif
+ readOptions(fromEnv("HUGSFLAGS",""));
+
+ for (i=1; i<argc; ++i) { /* process command line arguments */
+ if (strcmp(argv[i],"+")==0 && i+1<argc) {
+ if (proj) {
+ ERRMSG(0) "Multiple project filenames on command line"
+ EEND;
+ } else {
+ proj = argv[++i];
+ }
+ } else if (!processOption(argv[i])) {
+ addScriptName(argv[i],TRUE);
+ }
+ }
+ /* ToDo: clean up this hack */
+ {
+ static char* my_argv[] = {"Hugs"};
+ startupHaskell(sizeof(my_argv)/sizeof(char*),my_argv);
+ }
+#ifdef DEBUG
+ DEBUG_LoadSymbols(argv[0]);
+#endif
+
+ scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE));
+ if (!scriptName[0]) {
+ Printf("Prelude not found on current path: \"%s\"\n",
+ hugsPath ? hugsPath : "");
+ fatal("Unable to load prelude");
+ }
+
+ everybody(INSTALL);
+ evalModule = findText(""); /* evaluate wrt last module by default */
+ if (proj) {
+ if (namesUpto>1) {
+ fprintf(stderr,
+ "\nUsing project file, ignoring additional filenames\n");
+ }
+ loadProject(strCopy(proj));
+ }
+ readScripts(0);
+ scriptBase = numScripts;
+}
+
+/* --------------------------------------------------------------------------
+ * Command line options:
+ * ------------------------------------------------------------------------*/
+
+struct options { /* command line option toggles */
+ char c; /* table defined in main app. */
+ String description;
+ Bool *flag;
+};
+extern struct options toggle[];
+
+static Void local toggleSet(c,state) /* Set command line toggle */
+Char c;
+Bool state; {
+ Int i;
+ for (i=0; toggle[i].c; ++i)
+ if (toggle[i].c == c) {
+ *toggle[i].flag = state;
+ return;
+ }
+ ERRMSG(0) "Unknown toggle `%c'", c
+ EEND;
+}
+
+static Void local togglesIn(state) /* Print current list of toggles in*/
+Bool state; { /* given state */
+ Int count = 0;
+ Int i;
+ for (i=0; toggle[i].c; ++i)
+ if (*toggle[i].flag == state) {
+ if (count==0)
+ Putchar((char)(state ? '+' : '-'));
+ Putchar(toggle[i].c);
+ count++;
+ }
+ if (count>0)
+ Putchar(' ');
+}
+
+static Void local optionInfo() { /* Print information about command */
+ static String fmts = "%-5s%s\n"; /* line settings */
+ static String fmtc = "%-5c%s\n";
+ Int i;
+
+ Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
+ for (i=0; toggle[i].c; ++i)
+ Printf(fmtc,toggle[i].c,toggle[i].description);
+
+ Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
+ Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
+ Printf(fmts,"pstr","Set prompt string to str");
+ Printf(fmts,"rstr","Set repeat last expression string to str");
+ Printf(fmts,"Pstr","Set search path for modules to str");
+ Printf(fmts,"Estr","Use editor setting given by str");
+#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
+ Printf(fmts,"Fstr","Set preprocessor filter to str");
+#endif
+
+ Printf("\nCurrent settings: ");
+ togglesIn(TRUE);
+ togglesIn(FALSE);
+ Printf("-h%d",heapSize);
+ Printf(" -p");
+ printString(prompt);
+ Printf(" -r");
+ printString(repeatStr);
+ Printf("\nSearch path : -P");
+ printString(hugsPath);
+ Printf("\nEditor setting : -E");
+ printString(hugsEdit);
+#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
+ Printf("\nPreprocessor : -F");
+ printString(preprocessor);
+#endif
+ Putchar('\n');
+}
+
+#if USE_REGISTRY || HUGS_FOR_WINDOWS
+#define PUTC(c) \
+ *next++=(c)
+
+#define PUTS(s) \
+ strcpy(next,s); \
+ next+=strlen(next)
+
+#define PUTInt(optc,i) \
+ sprintf(next,"-%c%d",optc,i); \
+ next+=strlen(next)
+
+#define PUTStr(c,s) \
+ next=PUTStr_aux(next,c,s)
+
+static String local PUTStr_aux Args((String,Char, String));
+
+static String local PUTStr_aux(next,c,s)
+String next;
+Char c;
+String s; {
+ if (s) {
+ String t = 0;
+ sprintf(next,"-%c\"",c);
+ next+=strlen(next);
+ for(t=s; *t; ++t) {
+ PUTS(unlexChar(*t,'"'));
+ }
+ next+=strlen(next);
+ PUTS("\" ");
+ }
+ return next;
+}
+
+static String local optionsToStr() { /* convert options to string */
+ static char buffer[2000];
+ String next = buffer;
+
+ Int i;
+ for (i=0; toggle[i].c; ++i) {
+ PUTC(*toggle[i].flag ? '+' : '-');
+ PUTC(toggle[i].c);
+ PUTC(' ');
+ }
+ PUTInt('h',hpSize); PUTC(' ');
+ PUTStr('p',prompt);
+ PUTStr('r',repeatStr);
+ PUTStr('P',hugsPath);
+ PUTStr('E',hugsEdit);
+#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
+ PUTStr('F',preprocessor);
+#endif
+ PUTC('\0');
+ return buffer;
+}
+#endif /* USE_REGISTRY */
+
+#undef PUTC
+#undef PUTS
+#undef PUTInt
+#undef PUTStr
+
+static Void local readOptions(options) /* read options from string */
+String options; {
+ String s;
+ if (options) {
+ stringInput(options);
+ while ((s=readFilename())!=0) {
+ if (*s && !processOption(s)) {
+ ERRMSG(0) "Option string must begin with `+' or `-'"
+ EEND;
+ }
+ }
+ }
+}
+
+static Bool local processOption(s) /* process string s for options, */
+String s; { /* return FALSE if none found. */
+ Bool state;
+
+ if (s[0]=='-')
+ state = FALSE;
+ else if (s[0]=='+')
+ state = TRUE;
+ else
+ return FALSE;
+
+ while (*++s)
+ switch (*s) {
+ case 'p' : if (s[1]) {
+ if (prompt) free(prompt);
+ prompt = strCopy(s+1);
+ }
+ return TRUE;
+
+ case 'r' : if (s[1]) {
+ if (repeatStr) free(repeatStr);
+ repeatStr = strCopy(s+1);
+ }
+ return TRUE;
+
+ case 'P' : {
+ String p = substPath(s+1,hugsPath ? hugsPath : "");
+ if (hugsPath) free(hugsPath);
+ hugsPath = p;
+ return TRUE;
+ }
+
+ case 'E' : if (hugsEdit) free(hugsEdit);
+ hugsEdit = strCopy(s+1);
+ return TRUE;
+
+#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
+ case 'F' : if (preprocessor) free(preprocessor);
+ preprocessor = strCopy(s+1);
+ return TRUE;
+#endif
+
+ case 'h' : setHeapSize(s+1);
+ return TRUE;
+
+ case 'd' : /* hack */
+ {
+ extern void setRtsFlags( int x );
+ setRtsFlags(argToInt(s+1));
+ return TRUE;
+ }
+
+ default : toggleSet(*s,state);
+ break;
+ }
+ return TRUE;
+}
+
+static Void local setHeapSize(s)
+String s; {
+ if (s) {
+ hpSize = argToInt(s);
+ if (hpSize < MINIMUMHEAP)
+ hpSize = MINIMUMHEAP;
+ else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
+ hpSize = MAXIMUMHEAP;
+ if (heapBuilt() && hpSize != heapSize) {
+ /* ToDo: should this use a message box in winhugs? */
+#if USE_REGISTRY
+ FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
+#else
+ FPrintf(stderr,"Cannot change heap size\n");
+#endif
+ } else {
+ heapSize = hpSize;
+ }
+ }
+}
+
+static Int local argToInt(s) /* read integer from argument str */
+String s; {
+ Int n = 0;
+ String t = s;
+
+ if (*s=='\0' || !isascii(*s) || !isdigit(*s)) {
+ ERRMSG(0) "Missing integer in option setting \"%s\"", t
+ EEND;
+ }
+
+ do {
+ Int d = (*s++) - '0';
+ if (n > ((MAXPOSINT - d)/10)) {
+ ERRMSG(0) "Option setting \"%s\" is too large", t
+ EEND;
+ }
+ n = 10*n + d;
+ } while (isascii(*s) && isdigit(*s));
+
+ if (*s=='K' || *s=='k') {
+ if (n > (MAXPOSINT/1000)) {
+ ERRMSG(0) "Option setting \"%s\" is too large", t
+ EEND;
+ }
+ n *= 1000;
+ s++;
+ }
+
+#if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
+ if (*s=='M' || *s=='m') {
+ if (n > (MAXPOSINT/1000000)) {
+ ERRMSG(0) "Option setting \"%s\" is too large", t
+ EEND;
+ }
+ n *= 1000000;
+ s++;
+ }
+#endif
+
+#if MAXPOSINT > 1000000000
+ if (*s=='G' || *s=='g') {
+ if (n > (MAXPOSINT/1000000000)) {
+ ERRMSG(0) "Option setting \"%s\" is too large", t
+ EEND;
+ }
+ n *= 1000000000;
+ s++;
+ }
+#endif
+
+ if (*s!='\0') {
+ ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
+ EEND;
+ }
+
+ return n;
+}
+
+/* --------------------------------------------------------------------------
+ * Print Menu of list of commands:
+ * ------------------------------------------------------------------------*/
+
+static struct cmd cmds[] = {
+ {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
+ {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
+ {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
+ {":quit", QUIT}, {":set", SET}, {":find", FIND},
+ {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
+ {":module", SETMODULE},
+ {":version", SHOWVERSION},
+ {"", EVAL},
+ {0,0}
+};
+
+static Void local menu() {
+ Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
+ Printf("c is the first character in the full name.\n\n");
+ Printf(":load <filenames> load modules from specified files\n");
+ Printf(":load clear all files except prelude\n");
+ Printf(":also <filenames> read additional modules\n");
+ Printf(":reload repeat last load command\n");
+ Printf(":project <filename> use project file\n");
+ Printf(":edit <filename> edit file\n");
+ Printf(":edit edit last module\n");
+ Printf(":module <module> set module for evaluating expressions\n");
+ Printf("<expr> evaluate expression\n");
+ Printf(":type <expr> print type of expression\n");
+ Printf(":version show Hugs version\n");
+ Printf(":? display this list of commands\n");
+ Printf(":set <options> set command line options\n");
+ Printf(":set help on command line options\n");
+ Printf(":names [pat] list names currently in scope\n");
+ Printf(":info <names> describe named objects\n");
+ Printf(":find <name> edit module containing definition of name\n");
+ Printf(":!command shell escape\n");
+ Printf(":cd dir change directory\n");
+ Printf(":gc force garbage collection\n");
+ Printf(":quit exit Hugs interpreter\n");
+}
+
+static Void local guidance() {
+ Printf("Command not recognised. ");
+ forHelp();
+}
+
+static Void local forHelp() {
+ Printf("Type :? for help\n");
+}
+
+/* --------------------------------------------------------------------------
+ * Setting of command line options:
+ * ------------------------------------------------------------------------*/
+
+struct options toggle[] = { /* List of command line toggles */
+ {'t', "Print type after evaluation", &addType},
+ {'g', "Print no. cells recovered after gc", &gcMessages},
+ {'l', "Literate modules as default", &literateScripts},
+ {'e', "Warn about errors in literate modules", &literateErrors},
+ {'.', "Print dots to show progress", &useDots},
+ {'q', "Print nothing to show progress", &quiet},
+ {'w', "Always show which modules are loaded", &listScripts},
+ {'k', "Show kind errors in full", &kindExpert},
+ {'o', "Allow overlapping instances", &allowOverlap},
+ {'i', "Chase imports while loading modules", &chaseImports},
+#if DEBUG_CODE
+ {'D', "Debug: show generated code", &debugCode},
+#endif
+ {0, 0, 0}
+};
+
+static Void local set() { /* change command line options from*/
+ String s; /* Hugs command line */
+
+ if ((s=readFilename())!=0) {
+ do {
+ if (!processOption(s)) {
+ ERRMSG(0) "Option string must begin with `+' or `-'"
+ EEND;
+ }
+ } while ((s=readFilename())!=0);
+#if USE_REGISTRY
+ writeRegString("Options", optionsToStr());
+#endif
+ }
+ else
+ optionInfo();
+}
+
+/* --------------------------------------------------------------------------
+ * Change directory command:
+ * ------------------------------------------------------------------------*/
+
+static Void local changeDir() { /* change directory */
+ String s = readFilename();
+ if (s && chdir(s)) {
+ ERRMSG(0) "Unable to change to directory \"%s\"", s
+ EEND;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Loading project and script files:
+ * ------------------------------------------------------------------------*/
+
+static Void local loadProject(s) /* Load project file */
+String s; {
+ clearProject();
+ currProject = s;
+ projInput(currProject);
+ scriptFile = currProject;
+ forgetScriptsFrom(scriptBase);
+ while ((s=readFilename())!=0)
+ addScriptName(s,TRUE);
+ if (namesUpto<=1) {
+ ERRMSG(0) "Empty project file"
+ EEND;
+ }
+ scriptFile = 0;
+ projectLoaded = TRUE;
+}
+
+static Void local clearProject() { /* clear name for current project */
+ if (currProject)
+ free(currProject);
+ currProject = 0;
+ projectLoaded = FALSE;
+#if HUGS_FOR_WINDOWS
+ setLastEdit((String)0,0);
+#endif
+}
+
+static Void local addScriptName(s,sch) /* Add script to list of scripts */
+String s; /* to be read in ... */
+Bool sch; { /* TRUE => requires pathname search*/
+ if (namesUpto>=NUM_SCRIPTS) {
+ ERRMSG(0) "Too many module files (maximum of %d allowed)",
+ NUM_SCRIPTS
+ EEND;
+ }
+ else
+ scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s);
+}
+
+static Bool local addScript(fname,len) /* read single script file */
+String fname; /* name of script file */
+Long len; { /* length of script file */
+ scriptFile = fname;
+
+#if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
+ allowBreak();
+ SetCursor(LoadCursor(NULL, IDC_WAIT));
+#endif
+
+ Printf("Reading file \"%s\":\n",fname);
+ setLastEdit(fname,0);
+
+ if (isInterfaceFile(fname)) {
+ loadInterface(fname);
+ } else {
+ needsImports = FALSE;
+ parseScript(fname,len); /* process script file */
+ if (needsImports)
+ return FALSE;
+ checkDefns();
+ typeCheckDefns();
+ compileDefns();
+ }
+ scriptFile = 0;
+ return TRUE;
+}
+
+Bool chase(imps) /* Process list of import requests */
+List imps; {
+ if (chaseImports) {
+ Int origPos = numScripts; /* keep track of original position */
+ String origName = scriptName[origPos];
+ for (; nonNull(imps); imps=tl(imps)) {
+ String iname = findPathname(origName,textToStr(textOf(hd(imps))));
+ Int i = 0;
+ for (; i<namesUpto; i++)
+ if (pathCmp(scriptName[i],iname)==0)
+ break;
+ if (i>=origPos) { /* Neither loaded or queued */
+ String theName;
+ Time theTime;
+ Bool thePost;
+
+ postponed[origPos] = TRUE;
+ needsImports = TRUE;
+
+ if (i>=namesUpto) /* Name not found (i==namesUpto) */
+ addScriptName(iname,FALSE);
+ else if (postponed[i]) {/* Check for recursive dependency */
+ ERRMSG(0)
+ "Recursive import dependency between \"%s\" and \"%s\"",
+ scriptName[origPos], iname
+ EEND;
+ }
+ /* Right rotate section of tables between numScripts and i so
+ * that i ends up with other imports in front of orig. script
+ */
+ theName = scriptName[i];
+ thePost = postponed[i];
+ timeSet(theTime,lastChange[i]);
+ for (; i>numScripts; i--) {
+ scriptName[i] = scriptName[i-1];
+ postponed[i] = postponed[i-1];
+ timeSet(lastChange[i],lastChange[i-1]);
+ }
+ scriptName[numScripts] = theName;
+ postponed[numScripts] = thePost;
+ timeSet(lastChange[numScripts],theTime);
+ origPos++;
+ }
+ }
+ return needsImports;
+ }
+ return FALSE;
+}
+
+static Void local forgetScriptsFrom(scno)/* remove scripts from system */
+Script scno; {
+ Script i;
+ for (i=scno; i<namesUpto; ++i)
+ if (scriptName[i])
+ free(scriptName[i]);
+ dropScriptsFrom(scno);
+ namesUpto = scno;
+ if (numScripts>namesUpto)
+ numScripts = scno;
+}
+
+/* --------------------------------------------------------------------------
+ * Commands for loading and removing script files:
+ * ------------------------------------------------------------------------*/
+
+static Void local load() { /* read filenames from command line */
+ String s; /* and add to list of scripts waiting */
+ /* to be read */
+ while ((s=readFilename())!=0)
+ addScriptName(s,TRUE);
+ readScripts(scriptBase);
+}
+
+static Void local project() { /* read list of script names from */
+ String s; /* project file */
+
+ if ((s=readFilename()) || currProject) {
+ if (!s)
+ s = strCopy(currProject);
+ else if (readFilename()) {
+ ERRMSG(0) "Too many project files"
+ EEND;
+ }
+ else
+ s = strCopy(s);
+ }
+ else {
+ ERRMSG(0) "No project filename specified"
+ EEND;
+ }
+ loadProject(s);
+ readScripts(scriptBase);
+}
+
+static Void local readScripts(n) /* Reread current list of scripts, */
+Int n; { /* loading everything after and */
+ Time timeStamp; /* including the first script which*/
+ Long fileSize; /* has been either changed or added*/
+
+#if HUGS_FOR_WINDOWS
+ SetCursor(LoadCursor(NULL, IDC_WAIT));
+#endif
+
+ for (; n<numScripts; n++) { /* Scan previously loaded scripts */
+ getFileInfo(scriptName[n], &timeStamp, &fileSize);
+ if (timeChanged(timeStamp,lastChange[n])) {
+ dropScriptsFrom(n);
+ numScripts = n;
+ break;
+ }
+ }
+ for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
+ postponed[n] = FALSE; /* at this stage */
+
+ while (numScripts<namesUpto) { /* Process any remaining scripts */
+ getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
+ timeSet(lastChange[numScripts],timeStamp);
+ startNewScript(scriptName[numScripts]);
+ if (addScript(scriptName[numScripts],fileSize))
+ numScripts++;
+ else
+ dropScriptsFrom(numScripts);
+ }
+
+ if (listScripts)
+ whatScripts();
+ if (numScripts<=scriptBase)
+ setLastEdit((String)0, 0);
+}
+
+static Void local whatScripts() { /* list scripts in current session */
+ int i;
+ Printf("\nHugs session for:");
+ if (projectLoaded)
+ Printf(" (project: %s)",currProject);
+ for (i=0; i<numScripts; ++i)
+ Printf("\n%s",scriptName[i]);
+ Putchar('\n');
+}
+
+/* --------------------------------------------------------------------------
+ * Access to external editor:
+ * ------------------------------------------------------------------------*/
+
+static Void local editor() { /* interpreter-editor interface */
+ String newFile = readFilename();
+ if (newFile) {
+ setLastEdit(newFile,0);
+ if (readFilename()) {
+ ERRMSG(0) "Multiple filenames not permitted"
+ EEND;
+ }
+ }
+ runEditor();
+}
+
+static Void local find() { /* edit file containing definition */
+ String nm = readFilename(); /* of specified name */
+ if (!nm) {
+ ERRMSG(0) "No name specified"
+ EEND;
+ }
+ else if (readFilename()) {
+ ERRMSG(0) "Multiple names not permitted"
+ EEND;
+ }
+ else {
+ Text t;
+ Cell c;
+ setCurrModule(findEvalModule());
+ startNewScript(0);
+ if (nonNull(c=findTycon(t=findText(nm)))) {
+ if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
+ readScripts(scriptBase);
+ }
+ } else if (nonNull(c=findName(t))) {
+ if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
+ readScripts(scriptBase);
+ }
+ } else {
+ ERRMSG(0) "No current definition for name \"%s\"", nm
+ EEND;
+ }
+ }
+}
+
+static Void local runEditor() { /* run editor on script lastEdit */
+ if (startEdit(lastLine,lastEdit)) /* at line lastLine */
+ readScripts(scriptBase);
+}
+
+static Void local setLastEdit(fname,line)/* keep name of last file to edit */
+String fname;
+Int line; {
+ if (lastEdit)
+ free(lastEdit);
+ lastEdit = strCopy(fname);
+ lastLine = line;
+#if HUGS_FOR_WINDOWS
+ DrawStatusLine(hWndMain); /* Redo status line */
+#endif
+}
+
+/* --------------------------------------------------------------------------
+ * Read and evaluate an expression:
+ * ------------------------------------------------------------------------*/
+
+static Void local setModule(){/*set module in which to evaluate expressions*/
+ String s = readFilename();
+ if (!s) s = ""; /* :m clears the current module selection */
+ evalModule = findText(s);
+ setLastEdit(fileOfModule(findEvalModule()),0);
+}
+
+static Module local findEvalModule() { /*Module in which to eval expressions*/
+ Module m = findModule(evalModule);
+ if (isNull(m)) {
+ m = lastModule();
+ }
+ return m;
+}
+
+static Void local evaluator() { /* evaluate expr and print value */
+ Type type, bd;
+ Kinds ks = NIL;
+
+ setCurrModule(findEvalModule());
+ scriptFile = 0;
+ startNewScript(0); /* Enables recovery of storage */
+ /* allocated during evaluation */
+ parseExp();
+ checkExp();
+ defaultDefns = evalDefaults;
+ type = typeCheckExp(TRUE);
+ if (isPolyType(type)) {
+ ks = polySigOf(type);
+ bd = monotypeOf(type);
+ }
+ else
+ bd = type;
+
+ if (whatIs(bd)==QUAL) {
+ ERRMSG(0) "Unresolved overloading" ETHEN
+ ERRTEXT "\n*** type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n"
+ EEND;
+ }
+
+ /* ToDo: restore the code to print types, use show, etc */
+
+#ifdef WANT_TIMER
+ updateTimers();
+#endif
+ if (typeMatches(type,ap(typeIO,typeUnit))) {
+ inputExpr = ap(nameRunIO,inputExpr);
+ evalExp();
+ Putchar('\n');
+ } else {
+ Cell d = provePred(ks,NIL,ap(classShow,bd));
+ if (isNull(d)) {
+ ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
+ ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n"
+ EEND;
+ }
+ inputExpr = ap2(namePrint,d,inputExpr);
+ inputExpr = ap(nameRunIO,inputExpr);
+ evalExp();
+ if (addType) {
+ printf(" :: ");
+ printType(stdout,type);
+ Putchar('\n');
+ }
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Print type of input expression:
+ * ------------------------------------------------------------------------*/
+
+static Void local showtype() { /* print type of expression (if any)*/
+ Cell type;
+
+ setCurrModule(findEvalModule());
+ startNewScript(0); /* Enables recovery of storage */
+ /* allocated during evaluation */
+ parseExp();
+ checkExp();
+ defaultDefns = evalDefaults;
+ type = typeCheckExp(FALSE);
+ printExp(stdout,inputExpr);
+ Printf(" :: ");
+ printType(stdout,type);
+ Putchar('\n');
+}
+
+/* --------------------------------------------------------------------------
+ * Enhanced help system: print current list of scripts or give information
+ * about an object.
+ * ------------------------------------------------------------------------*/
+
+static String local objToStr Args((Module, Cell));
+
+static String local objToStr(m,c)
+Module m;
+Cell c; {
+#if DISPLAY_QUANTIFIERS
+ static char newVar[60];
+ switch (whatIs(c)) {
+ case NAME : if (m == name(c).mod) {
+ sprintf(newVar,"%s", textToStr(name(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",textToStr(module(name(c).mod).text),
+ textToStr(name(c).text));
+ }
+ break;
+ case TYCON : if (m == tycon(c).mod) {
+ sprintf(newVar,"%s", textToStr(tycon(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",textToStr(module(tycon(c).mod).text),
+ textToStr(tycon(c).text));
+ }
+ break;
+ case CLASS : if (m == cclass(c).mod) {
+ sprintf(newVar,"%s", textToStr(cclass(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",textToStr(module(cclass(c).mod).text),
+ textToStr(cclass(c).text));
+ }
+ break;
+ default : internal("objToStr");
+ }
+ return newVar;
+#else
+ static char newVar[33];
+ switch (whatIs(c)) {
+ case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
+ break;
+ case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
+ break;
+ case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
+ default : internal("objToStr");
+ }
+ return newVar;
+#endif
+}
+
+static Void local info() { /* describe objects */
+ Int count = 0; /* or give menu of commands */
+ String s;
+
+ setCurrModule(findEvalModule());
+ startNewScript(0); /* for recovery of storage */
+ for (; (s=readFilename())!=0; count++) {
+ describe(findText(s));
+ }
+ if (count == 0) {
+ whatScripts();
+ }
+}
+
+static Void local describe(t) /* describe an object */
+Text t; {
+ Tycon tc = findTycon(t);
+ Class cl = findClass(t);
+ Name nm = findName(t);
+ Module mod = findEvalModule();
+
+ if (nonNull(tc)) { /* as a type constructor */
+ Type ty = tc;
+ Int i;
+ Inst in;
+ for (i=0; i<tycon(tc).arity; ++i) {
+ ty = ap(ty,mkOffset(i));
+ }
+ Printf("-- type constructor");
+ if (kindExpert) {
+ Printf(" with kind ");
+ printKind(stdout,tycon(tc).kind);
+ }
+ Putchar('\n');
+ switch (tycon(tc).what) {
+ case SYNONYM : Printf("type ");
+ printType(stdout,ty);
+ Printf(" = ");
+ printType(stdout,tycon(tc).defn);
+ break;
+
+ case NEWTYPE :
+ case DATATYPE : { List cs = tycon(tc).defn;
+ if (tycon(tc).what==DATATYPE) {
+ Printf("data ");
+ } else {
+ Printf("newtype ");
+ }
+ printType(stdout,ty);
+ if (hasCfun(cs)) {
+ Printf("\n\n-- constructors:");
+ }
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Putchar('\n');
+ printExp(stdout,hd(cs));
+ Printf(" :: ");
+ printType(stdout,name(hd(cs)).type);
+ }
+ if (nonNull(cs)) {
+ Printf("\n\n-- selectors:");
+ }
+ for (; nonNull(cs); cs=tl(cs)) {
+ Putchar('\n');
+ printExp(stdout,hd(cs));
+ Printf(" :: ");
+ printType(stdout,name(hd(cs)).type);
+ }
+ }
+ break;
+
+ case RESTRICTSYN : Printf("type ");
+ printType(stdout,ty);
+ Printf(" = <restricted>");
+ break;
+ }
+ Putchar('\n');
+ if (nonNull(in=findFirstInst(tc))) {
+ Printf("\n-- instances:\n");
+ do {
+ showInst(in);
+ in = findNextInst(tc,in);
+ } while (nonNull(in));
+ }
+ Putchar('\n');
+ }
+
+ if (nonNull(cl)) { /* as a class */
+ List ins = cclass(cl).instances;
+ Kinds ks = cclass(cl).kinds;
+ if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
+ printf("-- type class");
+ } else {
+ printf("-- constructor class");
+ if (kindExpert) {
+ printf(" with arity ");
+ printKinds(stdout,ks);
+ }
+ }
+ printf("\nclass ");
+ if (nonNull(cclass(cl).supers)) {
+ printContext(stdout,cclass(cl).supers);
+ printf(" => ");
+ }
+ printPred(stdout,cclass(cl).head);
+ if (nonNull(cclass(cl).members)) {
+ List ms = cclass(cl).members;
+ printf(" where");
+ do {
+ Type t = monotypeOf(name(hd(ms)).type);
+ printf("\n ");
+ printExp(stdout,hd(ms));
+ printf(" :: ");
+ if (isNull(tl(fst(snd(t))))) {
+ t = snd(snd(t));
+ } else {
+ t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
+ }
+ printType(stdout,t);
+ ms = tl(ms);
+ } while (nonNull(ms));
+ }
+ putchar('\n');
+ if (nonNull(ins)) {
+ printf("\n-- instances:\n");
+ do {
+ showInst(hd(ins));
+ ins = tl(ins);
+ } while (nonNull(ins));
+ }
+ putchar('\n');
+ }
+
+ if (nonNull(nm)) { /* as a function/name */
+ printExp(stdout,nm);
+ printf(" :: ");
+ if (nonNull(name(nm).type)) {
+ printType(stdout,name(nm).type);
+ } else {
+ printf("<unknown type>");
+ }
+
+ if (isCfun(nm)) {
+ printf(" -- data constructor");
+ } else if (isMfun(nm)) {
+ printf(" -- class member");
+ } else if (isSfun(nm)) {
+ printf(" -- selector function");
+ }
+ if (name(nm).primop) {
+ printf(" -- primitive");
+ }
+ printf("\n\n");
+ }
+
+ if (isNull(tc) && isNull(cl) && isNull(nm)) {
+ Printf("Unknown reference `%s'\n",textToStr(t));
+ }
+}
+
+static Void local showInst(in) /* Display instance decl header */
+Inst in; {
+ printf("instance ");
+ if (nonNull(inst(in).specifics)) {
+ printContext(stdout,inst(in).specifics);
+ printf(" => ");
+ }
+ printPred(stdout,inst(in).head);
+ putchar('\n');
+}
+
+/* --------------------------------------------------------------------------
+ * List all names currently in scope:
+ * ------------------------------------------------------------------------*/
+
+static Void local listNames() { /* list names matching optional pat*/
+ String pat = readFilename();
+ List names = NIL;
+ Int width = getTerminalWidth() - 1;
+ Int count = 0;
+ Int termPos;
+ Module mod = findEvalModule();
+
+ if (pat) { /* First gather names to list */
+ do {
+ names = addNamesMatching(pat,names);
+ } while ((pat=readFilename())!=0);
+ } else {
+ names = addNamesMatching((String)0,names);
+ }
+ if (isNull(names)) { /* Then print them out */
+ ERRMSG(0) "No names selected"
+ EEND;
+ }
+ for (termPos=0; nonNull(names); names=tl(names)) {
+ String s = objToStr(mod,hd(names));
+ Int l = strlen(s);
+ if (termPos+1+l>width) {
+ Putchar('\n');
+ termPos = 0;
+ } else if (termPos>0) {
+ Putchar(' ');
+ termPos++;
+ }
+ Printf("%s",s);
+ termPos += l;
+ count++;
+ }
+ Printf("\n(%d names listed)\n", count);
+}
+
+/* --------------------------------------------------------------------------
+ * print a prompt and read a line of input:
+ * ------------------------------------------------------------------------*/
+
+static Void local promptForInput(moduleName)
+String moduleName; {
+ char promptBuffer[1000];
+#if 1
+ /* This is portable but could overflow buffer */
+ sprintf(promptBuffer,prompt,moduleName);
+#else
+ /* Works on ANSI C - but pre-ANSI compilers return a pointer to
+ * promptBuffer instead.
+ */
+ if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
+ /* Reset prompt to a safe default to avoid an infinite loop */
+ free(prompt);
+ prompt = strCopy("? ");
+ internal("Combined prompt and evaluation module name too long");
+ }
+#endif
+ consoleInput(promptBuffer);
+}
+
+/* --------------------------------------------------------------------------
+ * main read-eval-print loop, with error trapping:
+ * ------------------------------------------------------------------------*/
+
+static jmp_buf catch_error; /* jump buffer for error trapping */
+
+static Void local interpreter(argc,argv)/* main interpreter loop */
+Int argc;
+String argv[]; {
+ Int errorNumber = setjmp(catch_error);
+
+ breakOn(TRUE); /* enable break trapping */
+ if (numScripts==0) { /* only succeeds on first time, */
+ if (errorNumber) /* before prelude has been loaded */
+ fatal("Unable to load prelude");
+ initialize(argc,argv);
+ forHelp();
+ }
+
+ for (;;) {
+ Command cmd;
+ everybody(RESET); /* reset to sensible initial state */
+ dropScriptsFrom(numScripts); /* remove partially loaded scripts */
+
+ promptForInput(textToStr(module(findEvalModule()).text));
+
+ cmd = readCommand(cmds, (Char)':', (Char)'!');
+#ifdef WANT_TIMER
+ updateTimers();
+#endif
+ switch (cmd) {
+ case EDIT : editor();
+ break;
+ case FIND : find();
+ break;
+ case LOAD : clearProject();
+ forgetScriptsFrom(scriptBase);
+ load();
+ break;
+ case ALSO : clearProject();
+ forgetScriptsFrom(numScripts);
+ load();
+ break;
+ case RELOAD : readScripts(scriptBase);
+ break;
+ case PROJECT: project();
+ break;
+ case SETMODULE :
+ setModule();
+ break;
+ case SHOWVERSION :
+ Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
+ break;
+ case EVAL : evaluator();
+ break;
+ case TYPEOF : showtype();
+ break;
+ case NAMES : listNames();
+ break;
+ case HELP : menu();
+ break;
+ case BADCMD : guidance();
+ break;
+ case SET : set();
+ break;
+ case SYSTEM : if (shellEsc(readLine()))
+ Printf("Warning: Shell escape terminated abnormally\n");
+ break;
+ case CHGDIR : changeDir();
+ break;
+ case INFO : info();
+ break;
+ case QUIT : return;
+ case COLLECT: consGC = FALSE;
+ garbageCollect();
+ consGC = TRUE;
+ Printf("Garbage collection recovered %d cells\n",
+ cellsRecovered);
+ break;
+ case NOCMD : break;
+ }
+#ifdef WANT_TIMER
+ updateTimers();
+ Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
+ millisecs(userElapsed), millisecs(systElapsed));
+#endif
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Display progress towards goal:
+ * ------------------------------------------------------------------------*/
+
+static Target currTarget;
+static Bool aiming = FALSE;
+static Int currPos;
+static Int maxPos;
+static Int charCount;
+
+Void setGoal(what, t) /* Set goal for what to be t */
+String what;
+Target t; {
+ if (quiet) return;
+ currTarget = (t?t:1);
+ aiming = TRUE;
+ if (useDots) {
+ currPos = strlen(what);
+ maxPos = getTerminalWidth() - 1;
+ Printf("%s",what);
+ }
+ else
+ for (charCount=0; *what; charCount++)
+ Putchar(*what++);
+ FlushStdout();
+}
+
+Void soFar(t) /* Indicate progress towards goal */
+Target t; { /* has now reached t */
+ if (quiet) return;
+ if (useDots) {
+ Int newPos = (Int)((maxPos * ((long)t))/currTarget);
+
+ if (newPos>maxPos)
+ newPos = maxPos;
+
+ if (newPos>currPos) {
+ do
+ Putchar('.');
+ while (newPos>++currPos);
+ FlushStdout();
+ }
+ FlushStdout();
+ }
+}
+
+Void done() { /* Goal has now been achieved */
+ if (quiet) return;
+ if (useDots) {
+ while (maxPos>currPos++)
+ Putchar('.');
+ Putchar('\n');
+ }
+ else
+ for (; charCount>0; charCount--) {
+ Putchar('\b');
+ Putchar(' ');
+ Putchar('\b');
+ }
+ aiming = FALSE;
+ FlushStdout();
+}
+
+static Void local failed() { /* Goal cannot be reached due to */
+ if (aiming) { /* errors */
+ aiming = FALSE;
+ Putchar('\n');
+ FlushStdout();
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Error handling:
+ * ------------------------------------------------------------------------*/
+
+Void errHead(l) /* print start of error message */
+Int l; {
+ failed(); /* failed to reach target ... */
+ FPrintf(errorStream,"ERROR");
+
+ if (scriptFile) {
+ FPrintf(errorStream," \"%s\"", scriptFile);
+ setLastEdit(scriptFile,l);
+ if (l) FPrintf(errorStream," (line %d)",l);
+ scriptFile = 0;
+ }
+ FPrintf(errorStream,": ");
+ FFlush(errorStream);
+}
+
+Void errFail() { /* terminate error message and */
+ Putc('\n',errorStream); /* produce exception to return to */
+ FFlush(errorStream); /* main command loop */
+ longjmp(catch_error,1);
+}
+
+Void errAbort() { /* altern. form of error handling */
+ failed(); /* used when suitable error message*/
+ errFail(); /* has already been printed */
+}
+
+Void internal(msg) /* handle internal error */
+String msg; {
+#if HUGS_FOR_WINDOWS
+ char buf[300];
+ wsprintf(buf,"INTERNAL ERROR: %s",msg);
+ MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
+#endif
+ failed();
+ Printf("INTERNAL ERROR: %s\n",msg);
+ FlushStdout();
+ longjmp(catch_error,1);
+}
+
+Void fatal(msg) /* handle fatal error */
+String msg; {
+#if HUGS_FOR_WINDOWS
+ char buf[300];
+ wsprintf(buf,"FATAL ERROR: %s",msg);
+ MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
+#endif
+ FlushStdout();
+ Printf("\nFATAL ERROR: %s\n",msg);
+ everybody(EXIT);
+ exit(1);
+}
+
+sigHandler(breakHandler) { /* respond to break interrupt */
+#if HUGS_FOR_WINDOWS
+ MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
+#endif
+ Hilite();
+ Printf("{Interrupted!}\n");
+ Lolite();
+ breakOn(TRUE);
+ everybody(BREAK);
+ failed();
+ FlushStdout();
+ clearerr(stdin);
+ longjmp(catch_error,1);
+ sigResume;/*NOTREACHED*/
+}
+
+/* --------------------------------------------------------------------------
+ * Read value from environment variable or registry:
+ * ------------------------------------------------------------------------*/
+
+String fromEnv(var,def) /* return value of: */
+String var; /* environment variable named by var */
+String def; { /* or: default value given by def */
+ String s = getenv(var);
+ return (s ? s : def);
+}
+
+/* --------------------------------------------------------------------------
+ * String manipulation routines:
+ * ------------------------------------------------------------------------*/
+
+static String local strCopy(s) /* make malloced copy of a string */
+String s; {
+ if (s && *s) {
+ char *t, *r;
+ if ((t=(char *)malloc(strlen(s)+1))==0) {
+ ERRMSG(0) "String storage space exhausted"
+ EEND;
+ }
+ for (r=t; (*r++ = *s++)!=0; ) {
+ }
+ return t;
+ }
+ return NULL;
+}
+
+/* --------------------------------------------------------------------------
+ * Compiler output
+ * We can redirect compiler output (prompts, error messages, etc) by
+ * tweaking these functions.
+ * ------------------------------------------------------------------------*/
+
+#if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
+
+#ifdef HAVE_STDARG_H
+#include <stdarg.h>
+#else
+#include <varargs.h>
+#endif
+
+/* ----------------------------------------------------------------------- */
+
+#define BufferSize 5000 /* size of redirected output buffer */
+
+typedef struct _HugsStream {
+ char buffer[BufferSize]; /* buffer for redirected output */
+ Int next; /* next space in buffer */
+} HugsStream;
+
+static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
+static Void local bufferedPutchar Args((HugsStream*, Char));
+static String local bufferClear Args((HugsStream *stream));
+
+static Void local vBufferedPrintf(stream, fmt, ap)
+HugsStream* stream;
+const char* fmt;
+va_list ap; {
+ Int spaceLeft = BufferSize - stream->next;
+ char* p = &stream->buffer[stream->next];
+ Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
+ if (0 <= charsAdded && charsAdded < spaceLeft)
+ stream->next += charsAdded;
+#if 1 /* we can either buffer the first n chars or buffer the last n chars */
+ else
+ stream->next = 0;
+#endif
+}
+
+static Void local bufferedPutchar(stream, c)
+HugsStream *stream;
+Char c; {
+ if (BufferSize - stream->next >= 2) {
+ stream->buffer[stream->next++] = c;
+ stream->buffer[stream->next] = '\0';
+ }
+}
+
+static String local bufferClear(stream)
+HugsStream *stream; {
+ if (stream->next == 0) {
+ return "";
+ } else {
+ stream->next = 0;
+ return stream->buffer;
+ }
+}
+
+/* ----------------------------------------------------------------------- */
+
+static HugsStream outputStream;
+/* ADR note:
+ * We rely on standard C semantics to initialise outputStream.next to 0.
+ */
+
+Void hugsEnableOutput(f)
+Bool f; {
+ disableOutput = !f;
+}
+
+String hugsClearOutputBuffer() {
+ return bufferClear(&outputStream);
+}
+
+#ifdef HAVE_STDARG_H
+Void hugsPrintf(const char *fmt, ...) {
+ va_list ap; /* pointer into argument list */
+ va_start(ap, fmt); /* make ap point to first arg after fmt */
+ if (!disableOutput) {
+ vprintf(fmt, ap);
+ } else {
+ vBufferedPrintf(&outputStream, fmt, ap);
+ }
+ va_end(ap); /* clean up */
+}
+#else
+Void hugsPrintf(fmt, va_alist)
+const char *fmt;
+va_dcl {
+ va_list ap; /* pointer into argument list */
+ va_start(ap); /* make ap point to first arg after fmt */
+ if (!disableOutput) {
+ vprintf(fmt, ap);
+ } else {
+ vBufferedPrintf(&outputStream, fmt, ap);
+ }
+ va_end(ap); /* clean up */
+}
+#endif
+
+Void hugsPutchar(c)
+int c; {
+ if (!disableOutput) {
+ putchar(c);
+ } else {
+ bufferedPutchar(&outputStream, c);
+ }
+}
+
+Void hugsFlushStdout() {
+ if (!disableOutput) {
+ fflush(stdout);
+ }
+}
+
+Void hugsFFlush(fp)
+FILE* fp; {
+ if (!disableOutput) {
+ fflush(fp);
+ }
+}
+
+#ifdef HAVE_STDARG_H
+Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
+ va_list ap;
+ va_start(ap, fmt);
+ if (!disableOutput) {
+ vfprintf(fp, fmt, ap);
+ } else {
+ vBufferedPrintf(&outputStream, fmt, ap);
+ }
+ va_end(ap);
+}
+#else
+Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
+FILE* fp;
+const char* fmt;
+va_dcl {
+ va_list ap;
+ va_start(ap);
+ if (!disableOutput) {
+ vfprintf(fp, fmt, ap);
+ } else {
+ vBufferedPrintf(&outputStream, fmt, ap);
+ }
+ va_end(ap);
+}
+#endif
+
+Void hugsPutc(c, fp)
+int c;
+FILE* fp; {
+ if (!disableOutput) {
+ putc(c,fp);
+ } else {
+ bufferedPutchar(&outputStream, c);
+ }
+}
+
+#endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
+
+/* --------------------------------------------------------------------------
+ * Hugs for Windows code (WinMain and related functions)
+ * ------------------------------------------------------------------------*/
+
+#if HUGS_FOR_WINDOWS
+#include "winhugs.c"
+#endif
+
+/*-------------------------------------------------------------------------*/
+
--- /dev/null
+typedef long Target;
+extern Void setGoal Args((String, Target));
+extern Void soFar Args((Target));
+extern Void done Args((Void));
+
+extern String fromEnv Args((String,String));
+extern Bool chase Args((List));
+
+
+extern String hugsEdit; /* String for editor command */
+extern String hugsPath; /* String for file search path */
+
+extern Cell *CStackBase; /* pointer to base of C stack */
+
+
+
+extern Bool gcMessages; /* TRUE => print GC messages */
+#if DEBUG_CODE
+extern Bool debugCode; /* TRUE => print G-code to screen */
+#endif
+extern Bool kindExpert; /* TRUE => display kind errors in */
+ /* full detail */
+extern Bool allowOverlap; /* TRUE => allow overlapping insts */
+
--- /dev/null
+/****************************************************************
+ * Grammar for interface files
+ ****************************************************************/
+
+This document purports to describe the syntax (and semantics?) of
+interface files generated by GHC for use by Hugs.
+
+
+/****************************************************************
+ * ToDo:
+ ****************************************************************/
+
+o GHC currently generates "Functor( :Functor :Functor map )" in export lists.
+ This is no longer legal and is very confusing besides - but what
+ will GHC generate instead?
+
+
+/****************************************************************
+ * Closures generated by GHC
+ ****************************************************************/
+
+GHC generates a closure for the following objects (if exported):
+
+o variables
+o instance decls
+o methods selectors and superclass selectors
+o selector functions (from record syntax)
+o data constructors
+
+If an object foo (respectively Foo) is declared in a module Bar, then
+the closure is called Bar_foo_closure (respectively Bar_Foo_closure).
+
+Whether the object is static or not is not reflected in the name. The
+type or arity of the object is not reflected in the name. The name is
+just Bar_foo_closure.
+
+Modifications to the above:
+
+1) Depending on the architecture, it might be necessary to add a
+ leading underscore to the name.
+
+2) We also have to apply the infamous Z-encoding:
+
+ Code from somewhere inside GHC (circa 1994)
+ * Z-escapes:
+ "std"++xs -> "Zstd"++xs
+ char_to_c 'Z' = "ZZ"
+ char_to_c '&' = "Za"
+ char_to_c '|' = "Zb"
+ char_to_c ':' = "Zc"
+ char_to_c '/' = "Zd"
+ char_to_c '=' = "Ze"
+ char_to_c '>' = "Zg"
+ char_to_c '#' = "Zh"
+ char_to_c '<' = "Zl"
+ char_to_c '-' = "Zm"
+ char_to_c '!' = "Zn"
+ char_to_c '.' = "Zo"
+ char_to_c '+' = "Zp"
+ char_to_c '\'' = "Zq"
+ char_to_c '*' = "Zt"
+ char_to_c '_' = "Zu"
+ char_to_c c = "Z" ++ show (ord c)
+
+ (There's a commented out piece of code in rts/Printer.c which
+ implements this.)
+
+
+/****************************************************************
+ * Lexical syntax
+ ****************************************************************/
+
+The lexical syntax is exactly the same as for Haskell with the
+following additions:
+
+Keywords
+~~~~~~~~
+
+We add: __export __interface __requires
+
+
+Pragmas
+~~~~~~~
+
+GHC will use pragmas of the form: {-## ##-}.
+
+These are always ignored by Hugs and may be ignored by GHC.
+
+GHC will be able to use lazy parsing for these - just as it
+ currently does for unfoldings and the like.
+
+
+Compiler generated names
+~~~~~~~~~~~~~~~~~~~~~~~~
+
+Are of the form _letter(letter|digit|symbol)*.
+
+It's important that they can always be generated by putting "_l"
+in front of a valid Haskell varid, varop, conid or conop.
+
+It's also important that valid Haskell patterns such as _:_
+should not be valid compiler generated names.
+
+The letter indicates something about the kind of object it is
+but all that Hugs needs to do is separate conid/ops from varid/ops
+- which it does depending on whether the letter is uppercase.
+
+
+/****************************************************************
+ * Header
+ ****************************************************************/
+
+iface : '__interface' ifaceName NUMLIT version 'where' Body
+
+Body : '__requires' STRINGLIT ';'
+ { importDecl ';' }
+ { instanceImportDecl ';' }
+ { exportDecl ';' }
+ { fixityDecl ';' }
+ { classDecl ';' }
+ { instanceDecl ';' }
+ { typeDecl ';' }
+ { valueDecl ';' }
+
+version : NUMLIT
+
+/****************************************************************
+ * Import-export stuff
+ *
+ * I believe the meaning of 'import' is "qualified import" - but
+ * I'm not sure. - ADR
+ ****************************************************************/
+
+importDecl : 'import' CONID NUMLIT
+instanceImportDecl : 'instance' 'import' CONID NUMLIT
+exportDecl : '__export' CONID { Entity }
+
+Entity : EntityOcc
+ | EntityOcc StuffInside
+ | EntityOcc '|' StuffInside
+
+EntityOcc : Var
+ | Data
+ | '->'
+ | '(' '->' ')'
+
+StuffInside : '{' ValOcc { ValOcc } '}'
+
+ValOcc : Var
+ | Data
+
+/****************************************************************
+ * Fixities
+ ****************************************************************/
+
+fixityDecl : 'infixl' optdigit op
+ | 'infixr' optdigit op
+ | 'infix' optdigit op
+
+/****************************************************************
+ * Type declarations
+ *
+ * o data decls use "Data" on lhs and rhs to allow this decl:
+ *
+ * data () = ()
+ *
+ * o data declarations don't have the usual Haskell syntax:
+ * o they don't have strictness annotations
+ * o they are given an explicit signature instead of a list of
+ * argument types
+ * o field selectors are given an explicit signature
+ *
+ * [Simon PJ asked me to look again at how much work it would take to
+ * handle the standard syntax. The answer is:
+ * o It takes an awful lot of code to process the standard syntax.
+ * o I can hardly reuse any of the existing code because it is too
+ * tightly interwoven with other parts of static analysis.
+ * o The rules for processing data decls are very intricate
+ * (and are worse since existentials and local polymorphism were
+ * added). Implementing a complicated thing twice (once in
+ * GHC and once in Hugs) is bad; implementing it a third time
+ * is Just Plain Wrong.
+ * ]
+ *
+ * Data decls look like this:
+ *
+ * data List a = Nil :: forall [a] => List a
+ * | Cons{hd,tl} :: forall [a] => a -> List a -> List a
+ * where
+ * hd :: forall [a] => List a -> a
+ * tl :: forall [a] => List a -> List a
+ *
+ * o The tyvars on the lhs serve only to help infer the kind of List
+ * o The type of each data constructor and selector is written
+ * explicitly.
+ * o A small amount of work is required to figure out which
+ * variables are existentially quantified.
+ * o GHC will require an inlining pragma to recover strictness
+ * annotations.
+ ****************************************************************/
+
+typeDecl : NUMLIT 'type' TCName {TVBndr} '=' Type
+ | NUMLIT 'data' Data {TVBndr} ['=' Constrs ['where' Sels]]
+ | NUMLIT 'newtype' TCName {TVBndr} [ '=' Data AType ]
+
+Constrs : Constr {'|' Constr}
+Constr : Data [Fields] '::' Type
+Fields : '{' VarName {',' VarName} '}'
+
+Sels : Sel {';' Sel}
+Sel : VarName '::' ['!'] Type
+
+/****************************************************************
+ * Classes and instances
+ *
+ * Question: should the method signature include the class
+ * constraint? That is, should we write the Eq decl like this:
+ *
+ * class Eq a where { (==) :: a -> a -> Bool } -- like Haskell
+ *
+ * or like this
+ *
+ * class Eq a where { (==) :: Eq a => a -> a -> Bool }
+ *
+ * There's not much to choose between them but the second version
+ * is more consistent with what we're doing with data constructors.
+ ****************************************************************/
+
+classDecl : NUMLIT 'class' [ Context '=>' ] TCName {TVBndr} 'where' CSigs
+instanceDecl : 'instance' [Quant] Class '=' Var
+
+CSigs : '{' CSig { ';' CSigs } '}'
+CSig : VarName ['='] '::' Type
+
+/****************************************************************
+ * Types
+ ****************************************************************/
+
+Type : Quant Type
+ | BType '->' Type
+ | BType
+
+Context : '(' Class { ',' Class } ')'
+
+Class : QTCName { AType }
+
+BType : AType { AType }
+
+AType : QTCName
+ | TVName
+ | '(' ')' // unit
+ | '(' Type ')' // parens
+ | '(' Type ',' Type { ',' Type } ')' // tuple
+ | '[' Type ']' // list
+ | '{' QTCName { AType } '}' // dictionary
+
+
+Quant : 'forall' {TVBndr} [Context] '=>'
+
+TVBndr : TVName [ '::' AKind ]
+
+Kind : { AKind -> } AKind
+AKind : VAROP // really '*'
+ | '(' Kind ')'
+
+/****************************************************************
+ * Values
+ ****************************************************************/
+
+valueDecl : NUMLIT Var '::' Type
+
+/****************************************************************
+ * Atoms
+ ****************************************************************/
+
+VarName : Var
+TVName : VARID
+
+Var : VARID
+ | VAROP
+ | '!'
+ | '.'
+ | '-'
+
+Data : CONID
+ | CONOP
+ | '(' ')'
+ | '[' ']'
+
+TCName : CONID
+ | CONOP
+ | '(' '->' ')'
+ | '[' ']'
+
+QTCName : TCName
+ | QCONID
+ | QCONOP
+
+ifaceName : CONID
+
+/****************************************************************
+ * End
+ ****************************************************************/
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Input functions, lexical analysis parsing etc...
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: input.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:12 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "charset.h"
+#include "input.h"
+#include "static.h"
+#include "interface.h"
+#include "command.h"
+#include "errors.h"
+#include "link.h"
+#include "hugs.h" /* for target */
+#include <ctype.h>
+#if HAVE_GETDELIM_H
+#include "getdelim.h"
+#endif
+
+#include "machdep.h" /* for findPathname */
+
+#if HUGS_FOR_WINDOWS
+#undef IN
+#endif
+
+/* --------------------------------------------------------------------------
+ * Global data:
+ * ------------------------------------------------------------------------*/
+
+List tyconDefns = NIL; /* type constructor definitions */
+List typeInDefns = NIL; /* type synonym restrictions */
+List valDefns = NIL; /* value definitions in script */
+List opDefns = NIL; /* operator defns in script */
+List classDefns = NIL; /* class defns in script */
+List instDefns = NIL; /* instance defns in script */
+List selDefns = NIL; /* list of selector lists */
+List genDefns = NIL; /* list of generated names */
+List unqualImports = NIL; /* unqualified import list */
+List foreignImports = NIL; /* foreign imports */
+List foreignExports = NIL; /* foreign exportsd */
+List defaultDefns = NIL; /* default definitions (if any) */
+Int defaultLine = 0; /* line in which default defs occur*/
+List evalDefaults = NIL; /* defaults for evaluator */
+
+Cell inputExpr = NIL; /* input expression */
+Bool literateScripts = FALSE; /* TRUE => default to lit scripts */
+Bool literateErrors = TRUE; /* TRUE => report errs in lit scrs */
+
+String repeatStr = 0; /* Repeat last expr */
+
+#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
+String preprocessor = 0;
+#endif
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Void local fileInput Args((String,Long));
+static Bool local literateMode Args((String));
+static Bool local linecmp Args((String,String));
+static Int local nextLine Args((Void));
+static Void local skip Args((Void));
+static Void local thisLineIs Args((Int));
+static Void local newlineSkip Args((Void));
+static Void local closeAnyInput Args((Void));
+
+ Int yyparse Args((Void)); /* can't stop yacc making this */
+ /* public, but don't advertise */
+ /* it in a header file. */
+
+static Void local endToken Args((Void));
+static Text local readOperator Args((Void));
+static Text local readIdent Args((Void));
+static Cell local readRadixNumber Args((Int));
+static Cell local readNumber Args((Void));
+static Cell local readChar Args((Void));
+static Cell local readString Args((Void));
+static Void local saveStrChr Args((Char));
+static Cell local readAChar Args((Bool));
+
+static Bool local lazyReadMatches Args((String));
+static Cell local readEscapeChar Args((Bool));
+static Void local skipGap Args((Void));
+static Cell local readCtrlChar Args((Void));
+static Cell local readOctChar Args((Void));
+static Cell local readHexChar Args((Void));
+static Int local readHexDigit Args((Char));
+static Cell local readDecChar Args((Void));
+
+static Void local goOffside Args((Int));
+static Void local unOffside Args((Void));
+static Bool local canUnOffside Args((Void));
+
+static Void local skipWhitespace Args((Void));
+static Int local yylex Args((Void));
+static Int local repeatLast Args((Void));
+
+static Void local parseInput Args((Int));
+
+/* --------------------------------------------------------------------------
+ * Text values for reserved words and special symbols:
+ * ------------------------------------------------------------------------*/
+
+static Text textCase, textOfK, textData, textType, textIf;
+static Text textThen, textElse, textWhere, textLet, textIn;
+static Text textInfix, textInfixl, textInfixr, textForeign, textNewtype;
+static Text textDefault, textDeriving, textDo, textClass, textInstance;
+
+static Text textCoco, textEq, textUpto, textAs, textLambda;
+static Text textBar, textMinus, textFrom, textArrow, textLazy;
+static Text textBang, textDot, textAll, textImplies;
+static Text textWildcard;
+
+static Text textModule, textImport, textPrelude, textPreludeHugs;
+static Text textHiding, textQualified, textAsMod;
+static Text textExport, textInterface, textRequires, textUnsafe;
+
+#if NPLUSK
+Text textPlus; /* (+) */
+#endif
+Cell conPrelude; /* Prelude */
+
+static Cell conMain; /* Main */
+static Cell varMain; /* main */
+
+static Cell conUnit; /* () */
+static Cell conList; /* [] */
+static Cell conNil; /* [] */
+static Cell conPreludeUnit; /* Prelude.() */
+static Cell conPreludeList; /* Prelude.[] */
+static Cell conPreludeNil; /* Prelude.[] */
+
+static Cell varMinus; /* (-) */
+static Cell varBang; /* (!) */
+static Cell varDot; /* (.) */
+static Cell varHiding; /* hiding */
+static Cell varQualified; /* qualified */
+static Cell varAsMod; /* as */
+
+static Cell varNegate;
+static Cell varFlip;
+static Cell varEnumFrom;
+static Cell varEnumFromThen;
+static Cell varEnumFromTo;
+static Cell varEnumFromThenTo;
+
+static List imps; /* List of imports to be chased */
+
+/* --------------------------------------------------------------------------
+ * Single character input routines:
+ *
+ * At the lowest level of input, characters are read one at a time, with the
+ * current character held in c0 and the following (lookahead) character in
+ * c1. The corrdinates of c0 within the file are held in (column,row).
+ * The input stream is advanced by one character using the skip() function.
+ * ------------------------------------------------------------------------*/
+
+#define TABSIZE 8 /* spacing between tabstops */
+
+#define NOTHING 0 /* what kind of input is being read?*/
+#define KEYBOARD 1 /* - keyboard/console? */
+#define SCRIPTFILE 2 /* - script file */
+#define PROJFILE 3 /* - project file */
+#define STRING 4 /* - string buffer? */
+
+static Int reading = NOTHING;
+
+static Target readSoFar;
+static Int row, column, startColumn;
+static int c0, c1;
+static FILE *inputStream = 0;
+static Bool thisLiterate;
+static String nextStringChar; /* next char in string buffer */
+
+#if USE_READLINE /* for command line editors */
+static String currentLine; /* editline or GNU readline */
+static String nextChar;
+#define nextConsoleChar() (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
+extern Void add_history Args((String));
+extern String readline Args((String));
+#else
+#define nextConsoleChar() getc(stdin)
+#endif
+
+static Int litLines; /* count defn lines in lit script */
+#define DEFNCHAR '>' /* definition lines begin with this */
+static Int lastLine; /* records type of last line read: */
+#define STARTLINE 0 /* - at start of file, none read */
+#define BLANKLINE 1 /* - blank (may preceed definition) */
+#define TEXTLINE 2 /* - text comment */
+#define DEFNLINE 3 /* - line containing definition */
+#define CODELINE 4 /* - line inside code block */
+
+#define BEGINCODE "\\begin{code}"
+#define ENDCODE "\\end{code}"
+
+#if HAVE_GETDELIM_H
+static char *lineBuffer = NULL; /* getline() does the initial allocation */
+#else
+#define LINEBUFFER_SIZE 1000
+static char lineBuffer[LINEBUFFER_SIZE];
+#endif
+static int lineLength = 0;
+static int inCodeBlock = FALSE; /* Inside \begin{code}..\end{code} */
+static int linePtr = 0;
+
+Void consoleInput(prompt) /* prepare to input characters from */
+String prompt; { /* standard in (i.e. console/kbd) */
+ reading = KEYBOARD; /* keyboard input is Line oriented, */
+ c0 = /* i.e. input terminated by '\n' */
+ c1 = ' ';
+ column = (-1);
+ row = 0;
+
+#if USE_READLINE
+ /* Paranoid freeing code supplied by Sverker Nilsson (sverker@opq.se)
+ * avoids accidentally freeing currentLine twice.
+ */
+ if (currentLine) {
+ String oldCurrentLine = currentLine;
+ currentLine = 0; /* We may lose the space of currentLine */
+ free(oldCurrentLine); /* if interrupted here - unlikely */
+ }
+ currentLine = readline(prompt);
+ nextChar = currentLine;
+ if (currentLine) {
+ if (*currentLine)
+ add_history(currentLine);
+ }
+ else
+ c0 = c1 = EOF;
+#else
+ Printf("%s",prompt);
+ FlushStdout();
+#endif
+}
+
+Void projInput(nm) /* prepare to input characters from */
+String nm; { /* from named project file */
+ if ((inputStream = fopen(nm,"r"))!=0) {
+ reading = PROJFILE;
+ c0 = ' ';
+ c1 = '\n';
+ column = 1;
+ row = 0;
+ }
+ else {
+ ERRMSG(0) "Unable to open project file \"%s\"", nm
+ EEND;
+ }
+}
+
+static Void local fileInput(nm,len) /* prepare to input characters from*/
+String nm; /* named file (specified length is */
+Long len; { /* used to set target for reading) */
+#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
+ if (preprocessor) {
+ char cmd[100];
+ strncpy(cmd,preprocessor,100);
+ strncat(cmd," ",100);
+ strncat(cmd,nm,100);
+ cmd[99] = '\0'; /* paranoia */
+ inputStream = popen(cmd,"r");
+ } else {
+ inputStream = fopen(nm,"r");
+ }
+#else
+ inputStream = fopen(nm,"r");
+#endif
+ if (inputStream) {
+ reading = SCRIPTFILE;
+ c0 = ' ';
+ c1 = '\n';
+ column = 1;
+ row = 0;
+
+ lastLine = STARTLINE; /* literate file processing */
+ litLines = 0;
+ linePtr = 0;
+ lineLength = 0;
+ thisLiterate = literateMode(nm);
+ inCodeBlock = FALSE;
+
+ readSoFar = 0;
+ setGoal("Parsing", (Target)len);
+ }
+ else {
+ ERRMSG(0) "Unable to open file \"%s\"", nm
+ EEND;
+ }
+}
+
+Void stringInput(s) /* prepare to input characters from string */
+String s; {
+ reading = STRING;
+ c0 = EOF;
+ c1 = EOF;
+ if (*s) c0 = *s++;
+ if (*s) c1 = *s++;
+ column = 1;
+ row = 1;
+
+ nextStringChar = s;
+}
+
+static Bool local literateMode(nm) /* select literate mode for file */
+String nm; {
+ char *dot = strrchr(nm,'.'); /* look for last dot in file name */
+ if (dot) {
+ if (filenamecmp(dot+1,"hs")==0) /* .hs files are never literate */
+ return FALSE;
+ if (filenamecmp(dot+1,"lhs") ==0 || /* .lhs, .verb files are always*/
+ filenamecmp(dot+1,"verb")==0) /* literate scripts */
+ return TRUE;
+ }
+ return literateScripts; /* otherwise, use the default */
+}
+
+Bool isInterfaceFile(nm) /* is nm an interface file? */
+String nm; {
+ char *dot = strrchr(nm,'.'); /* look for last dot in file name */
+ return (dot && filenamecmp(dot+1,"myhi")==0);
+}
+
+
+/* This code originally came from Sigbjorn Finne (sof@dcs.gla.ac.uk).
+ * I've removed the loop (since newLineSkip contains a loop too) and
+ * replaced the warnings with errors. ADR
+ */
+/*
+ * To deal with literate \begin{code}...\end{code} blocks,
+ * add a line buffer that rooms the current line. The old c0 and c1
+ * stream pointers are used as before within that buffer -- sof
+ *
+ * Upon reading a new line into the line buffer, we check to see if
+ * we're reading in a line containing \begin{code} or \end{code} and
+ * take appropriate action.
+ */
+
+static Bool local linecmp(s,line) /* compare string with line */
+String s; /* line may end in whitespace */
+String line; {
+ Int i=0;
+ while (s[i] != '\0' && s[i] == line[i]) {
+ ++i;
+ }
+ /* s[0..i-1] == line[0..i-1] */
+ if (s[i] != '\0') { /* check s `isPrefixOf` line */
+ return FALSE;
+ }
+ while (isIn(line[i], SPACE)) { /* allow whitespace at end of line */
+ ++i;
+ }
+ return (line[i] == '\0');
+}
+
+/* Returns line length (including \n) or 0 upon EOF. */
+static Int local nextLine()
+{
+#if HAVE_GETDELIM_H
+ /*
+ Forget about fgets(), it is utterly braindead.
+ (Assumes \NUL free streams and does not gracefully deal
+ with overflow.) Instead, use GNU libc's getline().
+ */
+ lineLength = getline(&lineBuffer, &lineLength, inputStream);
+#else
+ if (NULL != fgets(lineBuffer, LINEBUFFER_SIZE, inputStream))
+ lineLength = strlen(lineBuffer);
+ else
+ lineLength = 0;
+#endif
+ /* printf("Read: \"%s\"", lineBuffer); */
+ if (lineLength <= 0) { /* EOF / IO error, who knows.. */
+ return lineLength;
+ }
+ else if (lineLength >= 2 && lineBuffer[0] == '#' && lineBuffer[1] == '!') {
+ lineBuffer[0]='\n'; /* pretend it's a blank line */
+ lineBuffer[1]='\0';
+ lineLength=1;
+ } else if (thisLiterate) {
+ if (linecmp(BEGINCODE, lineBuffer)) {
+ if (!inCodeBlock) { /* Entered a code block */
+ inCodeBlock = TRUE;
+ lineBuffer[0]='\n'; /* pretend it's a blank line */
+ lineBuffer[1]='\0';
+ lineLength=1;
+ }
+ else {
+ ERRMSG(row) "\\begin{code} encountered inside code block"
+ EEND;
+ }
+ }
+ else if (linecmp(ENDCODE, lineBuffer)) {
+ if (inCodeBlock) { /* Finished code block */
+ inCodeBlock = FALSE;
+ lineBuffer[0]='\n'; /* pretend it's a blank line */
+ lineBuffer[1]='\0';
+ lineLength=1;
+ }
+ else {
+ ERRMSG(row) "\\end{code} encountered outside code block"
+ EEND;
+ }
+ }
+ }
+ /* printf("Read: \"%s\"", lineBuffer); */
+ return lineLength;
+}
+
+static Void local skip() { /* move forward one char in input */
+ if (c0!=EOF) { /* stream, updating c0, c1, ... */
+ if (c0=='\n') { /* Adjusting cursor coords as nec. */
+ row++;
+ column=1;
+ if (reading==SCRIPTFILE)
+ soFar(readSoFar);
+ }
+ else if (c0=='\t')
+ column += TABSIZE - ((column-1)%TABSIZE);
+ else
+ column++;
+
+ c0 = c1;
+ readSoFar++;
+
+ if (c0==EOF) {
+ column = 0;
+ if (reading==SCRIPTFILE)
+ done();
+ closeAnyInput();
+ }
+ else if (reading==KEYBOARD) {
+ allowBreak();
+ if (c0=='\n')
+ c1 = EOF;
+ else {
+ c1 = nextConsoleChar();
+ /* On Win32, hitting ctrl-C causes the next getchar to
+ * fail - returning "-1" to indicate an error.
+ * This is one of the rare cases where "-1" does not mean EOF.
+ */
+ if (EOF == c1 && !feof(stdin)) {
+ c1 = ' ';
+ }
+ }
+ }
+ else if (reading==STRING) {
+ c1 = (unsigned char) *nextStringChar++;
+ if (c1 == '\0')
+ c1 = EOF;
+ }
+ else {
+ if (lineLength <=0 || linePtr == lineLength) {
+ /* Current line, exhausted - get new one */
+ if (nextLine() <= 0) { /* EOF */
+ c1 = EOF;
+ }
+ else {
+ linePtr = 0;
+ c1 = (unsigned char)lineBuffer[linePtr++];
+ }
+ }
+ else {
+ c1 = (unsigned char)lineBuffer[linePtr++];
+ }
+ }
+
+ }
+}
+
+static Void local thisLineIs(kind) /* register kind of current line */
+Int kind; { /* & check for literate script errs */
+ if (literateErrors) {
+ if ((kind==DEFNLINE && lastLine==TEXTLINE) ||
+ (kind==TEXTLINE && lastLine==DEFNLINE)) {
+ ERRMSG(row) "Program line next to comment"
+ EEND;
+ }
+ lastLine = kind;
+ }
+}
+
+static Void local newlineSkip() { /* skip `\n' (supports lit scripts) */
+ /* assert(c0=='\n'); */
+ if (reading==SCRIPTFILE && thisLiterate) {
+ do {
+ skip();
+ if (inCodeBlock) { /* pass chars on definition lines */
+ thisLineIs(CODELINE); /* to lexer (w/o leading DEFNCHAR) */
+ litLines++;
+ return;
+ }
+ if (c0==DEFNCHAR) { /* pass chars on definition lines */
+ thisLineIs(DEFNLINE); /* to lexer (w/o leading DEFNCHAR) */
+ skip();
+ litLines++;
+ return;
+ }
+ while (c0==' ' || c0=='\t')/* maybe line is blank? */
+ skip();
+ if (c0=='\n' || c0==EOF)
+ thisLineIs(BLANKLINE);
+ else {
+ thisLineIs(TEXTLINE); /* otherwise it must be a comment */
+ while (c0!='\n' && c0!=EOF)
+ skip();
+ } /* by now, c0=='\n' or c0==EOF */
+ } while (c0!=EOF); /* if new line, start again */
+
+ if (litLines==0 && literateErrors) {
+ ERRMSG(row) "Empty script - perhaps you forgot the `%c's?",
+ DEFNCHAR
+ EEND;
+ }
+ return;
+ }
+ skip();
+}
+
+static Void local closeAnyInput() { /* Close input stream, if open, */
+ switch (reading) { /* or skip to end of console line */
+ case PROJFILE :
+ case SCRIPTFILE : if (inputStream) {
+#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
+ if (preprocessor) {
+ pclose(inputStream);
+ } else {
+ fclose(inputStream);
+ }
+#else
+ fclose(inputStream);
+#endif
+ inputStream = 0;
+ }
+ break;
+ case KEYBOARD : while (c0!=EOF)
+ skip();
+ break;
+ }
+ reading=NOTHING;
+}
+
+/* --------------------------------------------------------------------------
+ * Parser: Uses table driven parser generated from parser.y using yacc
+ * ------------------------------------------------------------------------*/
+
+#include "parser.c"
+
+/* --------------------------------------------------------------------------
+ * Single token input routines:
+ *
+ * The following routines read the values of particular kinds of token given
+ * that the first character of the token has already been located in c0 on
+ * entry to the routine.
+ * ------------------------------------------------------------------------*/
+
+#define MAX_TOKEN 500
+#define startToken() tokPos = 0
+#define saveTokenChar(c) if (tokPos<=MAX_TOKEN) saveChar(c); else ++tokPos
+#define saveChar(c) tokenStr[tokPos++]=(char)(c)
+#define overflows(n,b,d,m) (n > ((m)-(d))/(b))
+
+static char tokenStr[MAX_TOKEN+1]; /* token buffer */
+static Int tokPos; /* input position in buffer */
+static Int identType; /* identifier type: CONID / VARID */
+static Int opType; /* operator type : CONOP / VAROP */
+
+static Void local endToken() { /* check for token overflow */
+ if (tokPos>MAX_TOKEN) {
+ ERRMSG(row) "Maximum token length (%d) exceeded", MAX_TOKEN
+ EEND;
+ }
+ tokenStr[tokPos] = '\0';
+}
+
+static Text local readOperator() { /* read operator symbol */
+ startToken();
+ do {
+ saveTokenChar(c0);
+ skip();
+ } while (isISO(c0) && isIn(c0,SYMBOL));
+ opType = (tokenStr[0]==':' ? CONOP : VAROP);
+ endToken();
+ return findText(tokenStr);
+}
+
+static Text local readIdent() { /* read identifier */
+ startToken();
+ do {
+ saveTokenChar(c0);
+ skip();
+ } while (isISO(c0) && isIn(c0,IDAFTER));
+ endToken();
+ identType = isIn(tokenStr[0],LARGE) ? CONID : VARID;
+ return findText(tokenStr);
+}
+
+static Cell local readRadixNumber(r) /* Read literal in specified radix */
+Int r; { /* from input of the form 0c{digs} */
+ Int d;
+ startToken();
+ saveTokenChar(c0);
+ skip(); /* skip leading zero */
+ if ((d=readHexDigit(c1))<0 || d>=r) {
+ /* Special case; no digits, lex as */
+ /* if it had been written "0 c..." */
+ saveTokenChar('0');
+ } else {
+ Int n = 0;
+ saveTokenChar(c0);
+ skip();
+ do {
+ saveTokenChar(c0);
+ skip();
+ d = readHexDigit(c0);
+ } while (d>=0 && d<r);
+ }
+ endToken();
+ /* ToDo: return an INTCELL if small enough */
+ return stringToBignum(tokenStr);
+}
+
+static Cell local readNumber() { /* read numeric constant */
+ Bool intTooLarge = FALSE;
+
+ if (c0=='0') {
+ if (c1=='x' || c1=='X') /* Maybe a hexadecimal literal? */
+ return readRadixNumber(16);
+ if (c1=='o' || c1=='O') /* Maybe an octal literal? */
+ return readRadixNumber(8);
+ }
+
+ startToken();
+ do {
+ saveTokenChar(c0);
+ skip();
+ } while (isISO(c0) && isIn(c0,DIGIT));
+
+ if (c0!='.' || !isISO(c1) || !isIn(c1,DIGIT)) {
+ endToken();
+ /* ToDo: return an INTCELL if small enough */
+ return stringToBignum(tokenStr);
+ }
+
+ saveTokenChar(c0); /* save decimal point */
+ skip();
+ do { /* process fractional part ... */
+ saveTokenChar(c0);
+ skip();
+ } while (isISO(c0) && isIn(c0,DIGIT));
+
+ if (c0=='e' || c0=='E') { /* look for exponent part... */
+ saveTokenChar('e');
+ skip();
+ if (c0=='-') {
+ saveTokenChar('-');
+ skip();
+ }
+ else if (c0=='+')
+ skip();
+
+ if (!isISO(c0) || !isIn(c0,DIGIT)) {
+ ERRMSG(row) "Missing digits in exponent"
+ EEND;
+ }
+ else {
+ do {
+ saveTokenChar(c0);
+ skip();
+ } while (isISO(c0) && isIn(c0,DIGIT));
+ }
+ }
+
+ endToken();
+ return stringToFloat(tokenStr);
+}
+
+static Cell local readChar() { /* read character constant */
+ Cell charRead;
+
+ skip(/* '\'' */);
+ if (c0=='\'' || c0=='\n' || c0==EOF) {
+ ERRMSG(row) "Illegal character constant"
+ EEND;
+ }
+
+ charRead = readAChar(FALSE);
+
+ if (c0=='\'')
+ skip(/* '\'' */);
+ else {
+ ERRMSG(row) "Improperly terminated character constant"
+ EEND;
+ }
+ return charRead;
+}
+
+static Cell local readString() { /* read string literal */
+ Cell c;
+
+ startToken();
+ skip(/* '\"' */);
+ while (c0!='\"' && c0!='\n' && c0!=EOF) {
+ c = readAChar(TRUE);
+ if (nonNull(c))
+ saveStrChr(charOf(c));
+ }
+
+ if (c0=='\"')
+ skip(/* '\"' */);
+ else {
+ ERRMSG(row) "Improperly terminated string"
+ EEND;
+ }
+ endToken();
+ return mkStr(findText(tokenStr));
+}
+
+static Void local saveStrChr(c) /* save character in string */
+Char c; {
+ if (c!='\0' && c!='\\') { /* save non null char as single char*/
+ saveTokenChar(c);
+ }
+ else { /* save null char as TWO null chars */
+ if (tokPos+1<MAX_TOKEN) {
+ saveChar('\\');
+ if (c=='\\')
+ saveChar('\\');
+ else
+ saveChar('0');
+ }
+ }
+}
+
+static Cell local readAChar(isStrLit) /* read single char constant */
+Bool isStrLit; { /* TRUE => enable \& and gaps */
+ Cell c = mkChar(c0);
+
+ if (c0=='\\') /* escape character? */
+ return readEscapeChar(isStrLit);
+ if (!isISO(c0)) {
+ ERRMSG(row) "Non ISO character `\\%d' in constant", ((int)c0)
+ EEND;
+ }
+ skip(); /* normal character? */
+ return c;
+}
+
+/* --------------------------------------------------------------------------
+ * Character escape code sequences:
+ * ------------------------------------------------------------------------*/
+
+static struct { /* table of special escape codes */
+ char *codename;
+ int codenumber;
+} escapes[] = {
+ {"a", 7}, {"b", 8}, {"f", 12}, {"n", 10}, /* common escapes */
+ {"r", 13}, {"t", 9}, {"\\",'\\'}, {"\"",'\"'},
+ {"\'",'\''}, {"v", 11},
+ {"NUL", 0}, {"SOH", 1}, {"STX", 2}, {"ETX", 3}, /* ascii codenames */
+ {"EOT", 4}, {"ENQ", 5}, {"ACK", 6}, {"BEL", 7},
+ {"BS", 8}, {"HT", 9}, {"LF", 10}, {"VT", 11},
+ {"FF", 12}, {"CR", 13}, {"SO", 14}, {"SI", 15},
+ {"DLE", 16}, {"DC1", 17}, {"DC2", 18}, {"DC3", 19},
+ {"DC4", 20}, {"NAK", 21}, {"SYN", 22}, {"ETB", 23},
+ {"CAN", 24}, {"EM", 25}, {"SUB", 26}, {"ESC", 27},
+ {"FS", 28}, {"GS", 29}, {"RS", 30}, {"US", 31},
+ {"SP", 32}, {"DEL", 127},
+ {0,0}
+};
+
+static Int alreadyMatched; /* Record portion of input stream */
+static char alreadyRead[10]; /* that has been read w/o a match */
+
+static Bool local lazyReadMatches(s) /* compare input stream with string */
+String s; { /* possibly using characters that */
+ int i; /* have already been read */
+
+ for (i=0; i<alreadyMatched; ++i)
+ if (alreadyRead[i]!=s[i])
+ return FALSE;
+
+ while (s[i] && s[i]==c0) {
+ alreadyRead[alreadyMatched++]=(char)c0;
+ skip();
+ i++;
+ }
+
+ return s[i]=='\0';
+}
+
+static Cell local readEscapeChar(isStrLit)/* read escape character */
+Bool isStrLit; {
+ int i=0;
+
+ skip(/* '\\' */);
+ switch (c0) {
+ case '&' : if (isStrLit) {
+ skip();
+ return NIL;
+ }
+ ERRMSG(row) "Illegal use of `\\&' in character constant"
+ EEND;
+ break;/*NOTREACHED*/
+
+ case '^' : return readCtrlChar();
+
+ case 'o' : return readOctChar();
+ case 'x' : return readHexChar();
+
+ default : if (!isISO(c0)) {
+ ERRMSG(row) "Illegal escape sequence"
+ EEND;
+ }
+ else if (isIn(c0,SPACE)) {
+ if (isStrLit) {
+ skipGap();
+ return NIL;
+ }
+ ERRMSG(row) "Illegal use of gap in character constant"
+ EEND;
+ break;
+ }
+ else if (isIn(c0,DIGIT))
+ return readDecChar();
+ }
+
+ for (alreadyMatched=0; escapes[i].codename; i++)
+ if (lazyReadMatches(escapes[i].codename))
+ return mkChar(escapes[i].codenumber);
+
+ alreadyRead[alreadyMatched++] = (char)c0;
+ alreadyRead[alreadyMatched++] = '\0';
+ ERRMSG(row) "Illegal character escape sequence \"\\%s\"",
+ alreadyRead
+ EEND;
+ return NIL;/*NOTREACHED*/
+}
+
+static Void local skipGap() { /* skip over gap in string literal */
+ do /* (simplified in Haskell 1.1) */
+ if (c0=='\n')
+ newlineSkip();
+ else
+ skip();
+ while (isISO(c0) && isIn(c0,SPACE));
+ if (c0!='\\') {
+ ERRMSG(row) "Missing `\\' terminating string literal gap"
+ EEND;
+ }
+ skip(/* '\\' */);
+}
+
+static Cell local readCtrlChar() { /* read escape sequence \^x */
+ static String controls = "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+ String which;
+
+ skip(/* '^' */);
+ if ((which = strchr(controls,c0))==NULL) {
+ ERRMSG(row) "Unrecognised escape sequence `\\^%c'", c0
+ EEND;
+ }
+ skip();
+ return mkChar(which-controls);
+}
+
+static Cell local readOctChar() { /* read octal character constant */
+ Int n = 0;
+ Int d;
+
+ skip(/* 'o' */);
+ if ((d = readHexDigit(c0))<0 || d>=8) {
+ ERRMSG(row) "Empty octal character escape"
+ EEND;
+ }
+ do {
+ if (overflows(n,8,d,MAXCHARVAL)) {
+ ERRMSG(row) "Octal character escape out of range"
+ EEND;
+ }
+ n = 8*n + d;
+ skip();
+ } while ((d = readHexDigit(c0))>=0 && d<8);
+
+ return mkChar(n);
+}
+
+static Cell local readHexChar() { /* read hex character constant */
+ Int n = 0;
+ Int d;
+
+ skip(/* 'x' */);
+ if ((d = readHexDigit(c0))<0) {
+ ERRMSG(row) "Empty hexadecimal character escape"
+ EEND;
+ }
+ do {
+ if (overflows(n,16,d,MAXCHARVAL)) {
+ ERRMSG(row) "Hexadecimal character escape out of range"
+ EEND;
+ }
+ n = 16*n + d;
+ skip();
+ } while ((d = readHexDigit(c0))>=0);
+
+ return mkChar(n);
+}
+
+static Int local readHexDigit(c) /* read single hex digit */
+Char c; {
+ if ('0'<=c && c<='9')
+ return c-'0';
+ if ('A'<=c && c<='F')
+ return 10 + (c-'A');
+ if ('a'<=c && c<='f')
+ return 10 + (c-'a');
+ return -1;
+}
+
+static Cell local readDecChar() { /* read decimal character constant */
+ Int n = 0;
+
+ do {
+ if (overflows(n,10,(c0-'0'),MAXCHARVAL)) {
+ ERRMSG(row) "Decimal character escape out of range"
+ EEND;
+ }
+ n = 10*n + (c0-'0');
+ skip();
+ } while (c0!=EOF && isIn(c0,DIGIT));
+
+ return mkChar(n);
+}
+
+/* --------------------------------------------------------------------------
+ * Produce printable representation of character:
+ * ------------------------------------------------------------------------*/
+
+String unlexChar(c,quote) /* return string representation of */
+Char c; /* character... */
+Char quote; { /* protect quote character */
+ static char buffer[12];
+
+ if (c<0) /* deal with sign extended chars.. */
+ c += NUM_CHARS;
+
+ if (isISO(c) && isIn(c,PRINT)) { /* normal printable character */
+ if (c==quote || c=='\\') { /* look for quote of approp. kind */
+ buffer[0] = '\\';
+ buffer[1] = (char)c;
+ buffer[2] = '\0';
+ }
+ else {
+ buffer[0] = (char)c;
+ buffer[1] = '\0';
+ }
+ }
+ else { /* look for escape code */
+ Int escs;
+ for (escs=0; escapes[escs].codename; escs++)
+ if (escapes[escs].codenumber==c) {
+ sprintf(buffer,"\\%s",escapes[escs].codename);
+ return buffer;
+ }
+ sprintf(buffer,"\\%d",c); /* otherwise use numeric escape */
+ }
+ return buffer;
+}
+
+Void printString(s) /* print string s, using quotes and */
+String s; { /* escapes if any parts need them */
+ if (s) {
+ String t = s;
+ Char c;
+ while ((c = *t)!=0 && isISO(c) && isIn(c,PRINT) && c!='"' && !isIn(c,SPACE)) {
+ t++;
+ }
+ if (*t) {
+ Putchar('"');
+ for (t=s; *t; t++)
+ Printf("%s",unlexChar(*t,'"'));
+ Putchar('"');
+ }
+ else
+ Printf("%s",s);
+ }
+}
+
+/* -------------------------------------------------------------------------
+ * Handle special types of input for us in interpreter:
+ * -----------------------------------------------------------------------*/
+
+Command readCommand(cmds,start,sys) /* read command at start of input */
+struct cmd *cmds; /* line in interpreter */
+Char start; /* characters introducing a cmd */
+Char sys; { /* character for shell escape */
+ while (c0==' ' || c0 =='\t')
+ skip();
+
+ if (c0=='\n') /* look for blank command lines */
+ return NOCMD;
+ if (c0==EOF) /* look for end of input stream */
+ return QUIT;
+ if (c0==sys) { /* single character system escape */
+ skip();
+ return SYSTEM;
+ }
+ if (c0==start && c1==sys) { /* two character system escape */
+ skip();
+ skip();
+ return SYSTEM;
+ }
+
+ startToken(); /* All cmds start with start */
+ if (c0==start) /* except default (usually EVAL) */
+ do { /* which is empty */
+ saveTokenChar(c0);
+ skip();
+ } while (c0!=EOF && !isIn(c0,SPACE));
+ endToken();
+
+ for (; cmds->cmdString; ++cmds)
+ if (strcmp((cmds->cmdString),tokenStr)==0 ||
+ (tokenStr[0]==start &&
+ tokenStr[1]==(cmds->cmdString)[1] &&
+ tokenStr[2]=='\0'))
+ return (cmds->cmdCode);
+ return BADCMD;
+}
+
+String readFilename() { /* Read filename from input (if any)*/
+ if (reading==PROJFILE)
+ skipWhitespace();
+ else
+ while (c0==' ' || c0=='\t')
+ skip();
+
+ if (c0=='\n' || c0==EOF) /* return null string at end of line*/
+ return 0;
+
+ startToken();
+ while (c0!=EOF && !isIn(c0,SPACE)) {
+ if (c0=='"') {
+ skip();
+ while (c0!=EOF && c0!='\"') {
+ Cell c = readAChar(TRUE);
+ if (nonNull(c))
+ saveTokenChar(charOf(c));
+ }
+ if (c0=='"')
+ skip();
+ else {
+ ERRMSG(row) "a closing quote, '\"', was expected"
+ EEND;
+ }
+ }
+ else {
+ saveTokenChar(c0);
+ skip();
+ }
+ }
+ endToken();
+ return tokenStr;
+}
+
+String readLine() { /* Read command line from input */
+ while (c0==' ' || c0=='\t') /* skip leading whitespace */
+ skip();
+
+ startToken();
+ while (c0!='\n' && c0!=EOF) {
+ saveTokenChar(c0);
+ skip();
+ }
+ endToken();
+
+ return tokenStr;
+}
+
+/* --------------------------------------------------------------------------
+ * This lexer supports the Haskell layout rule:
+ *
+ * - Layout area bounded by { ... }, with `;'s in between.
+ * - A `{' is a HARD indentation and can only be matched by a corresponding
+ * HARD '}'
+ * - Otherwise, if no `{' follows the keywords WHERE/LET or OF, a SOFT `{'
+ * is inserted with the column number of the first token after the
+ * WHERE/LET/OF keyword.
+ * - When a soft indentation is uppermost on the indetation stack with
+ * column col' we insert:
+ * `}' in front of token with column<col' and pop indentation off stack,
+ * `;' in front of token with column==col'.
+ * ------------------------------------------------------------------------*/
+
+#define MAXINDENT 100 /* maximum nesting of layout rule */
+static Int layout[MAXINDENT+1];/* indentation stack */
+#define HARD (-1) /* indicates hard indentation */
+static Int indentDepth = (-1); /* current indentation nesting */
+
+static Void local goOffside(col) /* insert offside marker */
+Int col; { /* for specified column */
+ if (indentDepth>=MAXINDENT) {
+ ERRMSG(row) "Too many levels of program nesting"
+ EEND;
+ }
+ layout[++indentDepth] = col;
+}
+
+static Void local unOffside() { /* leave layout rule area */
+ indentDepth--;
+}
+
+static Bool local canUnOffside() { /* Decide if unoffside permitted */
+ return indentDepth>=0 && layout[indentDepth]!=HARD;
+}
+
+/* --------------------------------------------------------------------------
+ * Main tokeniser:
+ * ------------------------------------------------------------------------*/
+
+static Void local skipWhitespace() { /* Skip over whitespace/comments */
+ for (;;) /* Strictly speaking, this code is */
+ if (c0==EOF) /* a little more liberal than the */
+ return; /* report allows ... */
+ else if (c0=='\n')
+ newlineSkip();
+ else if (isIn(c0,SPACE))
+ skip();
+ else if (c0=='{' && c1=='-') { /* (potentially) nested comment */
+ Int nesting = 1;
+ Int origRow = row; /* Save original row number */
+ skip();
+ skip();
+ while (nesting>0 && c0!=EOF)
+ if (c0=='{' && c1=='-') {
+ skip();
+ skip();
+ nesting++;
+ }
+ else if (c0=='-' && c1=='}') {
+ skip();
+ skip();
+ nesting--;
+ }
+ else if (c0=='\n')
+ newlineSkip();
+ else
+ skip();
+ if (nesting>0) {
+ ERRMSG(origRow) "Unterminated nested comment {- ..."
+ EEND;
+ }
+ }
+ else if (c0=='-' && c1=='-') { /* One line comment */
+ do
+ skip();
+ while (c0!='\n' && c0!=EOF);
+ if (c0=='\n')
+ newlineSkip();
+ }
+ else
+ return;
+}
+
+static Bool firstToken; /* Set to TRUE for first token */
+static Int firstTokenIs; /* ... with token value stored here */
+
+static Int local yylex() { /* Read next input token ... */
+ static Bool insertOpen = FALSE;
+ static Bool insertedToken = FALSE;
+ static Text textRepeat;
+
+#define lookAhead(t) {skipWhitespace(); insertOpen = (c0!='{'); return t;}
+
+ if (firstToken) { /* Special case for first token */
+ indentDepth = (-1);
+ firstToken = FALSE;
+ insertOpen = FALSE;
+ insertedToken = FALSE;
+ if (reading==KEYBOARD)
+ textRepeat = findText(repeatStr);
+ return firstTokenIs;
+ }
+
+ if (insertOpen) { /* insert `soft' opening brace */
+ insertOpen = FALSE;
+ insertedToken = TRUE;
+ goOffside(column);
+ push(yylval = mkInt(row));
+ return '{';
+ }
+
+ /* ----------------------------------------------------------------------
+ * Skip white space, and insert tokens to support layout rules as reqd.
+ * --------------------------------------------------------------------*/
+
+ skipWhitespace();
+ startColumn = column;
+ push(yylval = mkInt(row)); /* default token value is line no. */
+ /* subsequent changes to yylval must also set top() to the same value */
+
+ if (indentDepth>=0) /* layout rule(s) active ? */
+ if (insertedToken) /* avoid inserting multiple `;'s */
+ insertedToken = FALSE; /* or putting `;' after `{' */
+ else if (layout[indentDepth]!=HARD)
+ if (column<layout[indentDepth]) {
+ unOffside();
+ return '}';
+ }
+ else if (column==layout[indentDepth] && c0!=EOF) {
+ insertedToken = TRUE;
+ return ';';
+ }
+
+ /* ----------------------------------------------------------------------
+ * Now try to identify token type:
+ * --------------------------------------------------------------------*/
+
+ switch (c0) {
+ case EOF : return 0; /* End of file/input */
+
+ /* The next 10 characters make up the `special' category in 1.3 */
+ case '(' : skip(); return '(';
+ case ')' : skip(); return ')';
+ case ',' : skip(); return ',';
+ case ';' : skip(); return ';';
+ case '[' : skip(); return '[';
+ case ']' : skip(); return ']';
+ case '`' : skip(); return '`';
+ case '{' : goOffside(HARD);
+ skip();
+ return '{';
+ case '}' : if (indentDepth<0) {
+ ERRMSG(row) "Misplaced `}'"
+ EEND;
+ }
+ if (layout[indentDepth]==HARD) /* skip over hard }*/
+ skip();
+ unOffside(); /* otherwise, we have to insert a }*/
+ return '}'; /* to (try to) avoid an error... */
+
+ /* Character and string literals */
+ case '\'' : top() = yylval = readChar();
+ return CHARLIT;
+
+ case '\"' : top() = yylval = readString();
+ return STRINGLIT;
+ }
+
+#if TREX
+ if (c0=='#' && isIn(c1,SMALL)) { /* Look for record selector name */
+ Text it;
+ skip();
+ it = readIdent();
+ top() = yylval = ap(RECSEL,mkExt(it));
+ return identType=RECSELID;
+ }
+#endif
+ if (isIn(c0,LARGE)) { /* Look for qualified name */
+ Text it = readIdent(); /* No keyword begins with LARGE ...*/
+ if (c0=='.' && isIn(c1,(SMALL|LARGE|SYMBOL))) {
+ Text it2 = NIL;
+ skip(); /* Skip qualifying dot */
+ if (isIn(c0,SYMBOL)) { /* Qualified operator */
+ it2 = readOperator();
+ if (opType==CONOP) {
+ top() = yylval = mkQConOp(it,it2);
+ return QCONOP;
+ } else {
+ top() = yylval = mkQVarOp(it,it2);
+ return QVAROP;
+ }
+ } else { /* Qualified identifier */
+ it2 = readIdent();
+ if (identType==CONID) {
+ top() = yylval = mkQCon(it,it2);
+ return QCONID;
+ } else {
+ top() = yylval = mkQVar(it,it2);
+ return QVARID;
+ }
+ }
+ } else {
+ top() = yylval = mkCon(it);
+ return identType;
+ } /* We could easily keep a record of*/
+ } /* the qualifying name here ... */
+ if (isIn(c0,(SMALL|LARGE)) || c0 == '_') {
+ Text it = readIdent();
+
+ if (it==textCase) return CASEXP;
+ if (it==textOfK) lookAhead(OF);
+ if (it==textData) return DATA;
+ if (it==textType) return TYPE;
+ if (it==textIf) return IF;
+ if (it==textThen) return THEN;
+ if (it==textElse) return ELSE;
+ if (it==textWhere) lookAhead(WHERE);
+ if (it==textLet) lookAhead(LET);
+ if (it==textIn) return IN;
+ if (it==textInfix) return INFIX;
+ if (it==textInfixl) return INFIXL;
+ if (it==textInfixr) return INFIXR;
+ if (it==textForeign) return FOREIGN;
+ if (it==textUnsafe) return UNSAFE;
+ if (it==textNewtype) return TNEWTYPE;
+ if (it==textDefault) return DEFAULT;
+ if (it==textDeriving) return DERIVING;
+ if (it==textDo) lookAhead(DO);
+ if (it==textClass) return TCLASS;
+ if (it==textInstance) return TINSTANCE;
+ if (it==textModule) return MODULETOK;
+ if (it==textInterface) return INTERFACE;
+ if (it==textRequires) return REQUIRES;
+ if (it==textImport) return IMPORT;
+ if (it==textExport) return EXPORT;
+ if (it==textHiding) return HIDING;
+ if (it==textQualified) return QUALIFIED;
+ if (it==textAsMod) return ASMOD;
+ if (it==textWildcard) return '_';
+ if (it==textAll) return ALL;
+ if (it==textRepeat && reading==KEYBOARD)
+ return repeatLast();
+
+ top() = yylval = ap((identType==CONID ? CONIDCELL : VARIDCELL),it);
+ return identType;
+ }
+
+ if (isIn(c0,SYMBOL)) {
+ Text it = readOperator();
+
+ if (it==textCoco) return COCO;
+ if (it==textEq) return '=';
+ if (it==textUpto) return UPTO;
+ if (it==textAs) return '@';
+ if (it==textLambda) return '\\';
+ if (it==textBar) return '|';
+ if (it==textFrom) return FROM;
+ if (it==textMinus) return '-';
+ if (it==textBang) return '!';
+ if (it==textDot) return '.';
+ if (it==textArrow) return ARROW;
+ if (it==textLazy) return '~';
+ if (it==textImplies) return IMPLIES;
+ if (it==textRepeat && reading==KEYBOARD)
+ return repeatLast();
+
+ top() = yylval = ap((opType==CONOP ? CONOPCELL : VAROPCELL),it);
+ return opType;
+ }
+
+ if (isIn(c0,DIGIT)) {
+ top() = yylval = readNumber();
+ return NUMLIT;
+ }
+
+ ERRMSG(row) "Unrecognised character `\\%d' in column %d", ((int)c0), column
+ EEND;
+ return 0; /*NOTREACHED*/
+}
+
+static Int local repeatLast() { /* Obtain last expression entered */
+ if (isNull(yylval=getLastExpr())) {
+ ERRMSG(row) "Cannot use %s without any previous input", repeatStr
+ EEND;
+ }
+ return REPEAT;
+}
+
+/* --------------------------------------------------------------------------
+ * main entry points to parser/lexer:
+ * ------------------------------------------------------------------------*/
+
+static Void local parseInput(startWith)/* Parse input with given first tok,*/
+Int startWith; { /* determining whether to read a */
+ firstToken = TRUE; /* script or an expression */
+ firstTokenIs = startWith;
+
+ clearStack();
+ if (yyparse()) { /* This can only be parser overflow */
+ ERRMSG(row) "Parser overflow" /* as all syntax errors are caught */
+ EEND; /* in the parser... */
+ }
+ drop();
+ assert(stackEmpty()); /* stack should now be empty */
+}
+
+Void parseScript(nm,len) /* Read a script */
+String nm;
+Long len; { /* Used to set a target for reading */
+ input(RESET);
+ fileInput(nm,len);
+ parseInput(SCRIPT);
+}
+
+Void parseInterface(nm,len) /* Read a GHC interface file */
+String nm;
+Long len; { /* Used to set a target for reading */
+ input(RESET);
+ fileInput(nm,len);
+ parseInput(INTERFACE);
+}
+
+Void parseExp() { /* Read an expression to evaluate */
+ parseInput(EXPR);
+ setLastExpr(inputExpr);
+}
+
+/* --------------------------------------------------------------------------
+ * Input control:
+ * ------------------------------------------------------------------------*/
+
+Void input(what)
+Int what; {
+ switch (what) {
+ case INSTALL : initCharTab();
+ textCase = findText("case");
+ textOfK = findText("of");
+ textData = findText("data");
+ textType = findText("type");
+ textIf = findText("if");
+ textThen = findText("then");
+ textElse = findText("else");
+ textWhere = findText("where");
+ textLet = findText("let");
+ textIn = findText("in");
+ textInfix = findText("infix");
+ textInfixl = findText("infixl");
+ textInfixr = findText("infixr");
+ textForeign = findText("foreign");
+ textUnsafe = findText("unsafe");
+ textNewtype = findText("newtype");
+ textDefault = findText("default");
+ textDeriving = findText("deriving");
+ textDo = findText("do");
+ textClass = findText("class");
+ textInstance = findText("instance");
+ textCoco = findText("::");
+ textEq = findText("=");
+ textUpto = findText("..");
+ textAs = findText("@");
+ textLambda = findText("\\");
+ textBar = findText("|");
+ textMinus = findText("-");
+ textFrom = findText("<-");
+ textArrow = findText("->");
+ textLazy = findText("~");
+ textBang = findText("!");
+ textDot = findText(".");
+ textImplies = findText("=>");
+#if NPLUSK
+ textPlus = findText("+");
+#endif
+ textModule = findText("module");
+ textInterface = findText("__interface");
+ textRequires = findText("__requires");
+ textImport = findText("import");
+ textExport = findText("__export");
+ textHiding = findText("hiding");
+ textQualified = findText("qualified");
+ textAsMod = findText("as");
+ textWildcard = findText("_");
+ textAll = findText("forall");
+ varMinus = mkVar(textMinus);
+ varBang = mkVar(textBang);
+ varDot = mkVar(textDot);
+ varHiding = mkVar(textHiding);
+ varQualified = mkVar(textQualified);
+ varAsMod = mkVar(textAsMod);
+ conMain = mkCon(findText("Main"));
+ varMain = mkVar(findText("main"));
+ textPrelude = findText("Prelude");
+ textPreludeHugs= findText("PreludeBuiltin");
+ conPrelude = mkCon(textPrelude);
+ conNil = mkCon(findText("[]"));
+ conList = mkCon(findText("[]"));
+ conUnit = mkCon(findText("()"));
+ conPreludeNil = mkQCon(textPreludeHugs,findText("[]"));
+ conPreludeList = mkQCon(textPreludeHugs,findText("[]"));
+ conPreludeUnit = mkQCon(textPreludeHugs,findText("()"));
+ varNegate = mkQVar(textPreludeHugs,findText("negate"));
+ varFlip = mkQVar(textPreludeHugs,findText("flip"));
+ varEnumFrom = mkQVar(textPreludeHugs,findText("enumFrom"));
+ varEnumFromThen = mkQVar(textPreludeHugs,findText("enumFromThen"));
+ varEnumFromTo = mkQVar(textPreludeHugs,findText("enumFromTo"));
+ varEnumFromThenTo = mkQVar(textPreludeHugs,findText("enumFromThenTo"));
+
+ evalDefaults = NIL;
+
+ input(RESET);
+ break;
+
+ case RESET : tyconDefns = NIL;
+ typeInDefns = NIL;
+ valDefns = NIL;
+ opDefns = NIL;
+ classDefns = NIL;
+ instDefns = NIL;
+ selDefns = NIL;
+ genDefns = NIL;
+ unqualImports= NIL;
+ foreignImports= NIL;
+ foreignExports= NIL;
+ defaultDefns = NIL;
+ defaultLine = 0;
+ inputExpr = NIL;
+ imps = NIL;
+ closeAnyInput();
+ break;
+
+ case BREAK : if (reading==KEYBOARD)
+ c0 = EOF;
+ break;
+
+ case MARK : mark(tyconDefns);
+ mark(typeInDefns);
+ mark(valDefns);
+ mark(opDefns);
+ mark(classDefns);
+ mark(instDefns);
+ mark(selDefns);
+ mark(genDefns);
+ mark(unqualImports);
+ mark(foreignImports);
+ mark(foreignExports);
+ mark(defaultDefns);
+ mark(evalDefaults);
+ mark(inputExpr);
+ mark(varMinus);
+ mark(varNegate);
+ mark(varFlip);
+ mark(varEnumFrom);
+ mark(varEnumFromThen);
+ mark(varEnumFromTo);
+ mark(varEnumFromThenTo);
+ mark(varBang);
+ mark(varDot);
+ mark(varHiding);
+ mark(varQualified);
+ mark(varAsMod);
+ mark(varMain);
+ mark(conPrelude);
+ mark(conMain);
+ mark(conNil);
+ mark(conList);
+ mark(conUnit);
+ mark(conPreludeNil);
+ mark(conPreludeList);
+ mark(conPreludeUnit);
+ mark(imps);
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+extern String repeatStr; /* Repeat last command string */
+
+extern List tyconDefns; /* list of type constructor defns */
+extern List typeInDefns; /* list of synonym restrictions */
+extern List valDefns; /* list of value definitions */
+extern List opDefns; /* list of operator definitions */
+extern List classDefns; /* list of class definitions */
+extern List instDefns; /* list of instance definitions */
+extern List selDefns; /* list of selector lists */
+extern List genDefns; /* list of generated defns */
+extern List foreignImports; /* foreign import declarations */
+extern List foreignExports; /* foreign export declarations */
+extern List defaultDefns; /* default definitions (if any) */
+extern Int defaultLine; /* line in which default defs occur*/
+extern List evalDefaults; /* defaults for evaluator */
+extern Cell inputExpr; /* evaluator input expression */
+
+extern Bool literateScripts; /* TRUE => default lit scripts */
+extern Bool literateErrors; /* TRUE => report errs in lit scrs */
+ /* termination */
+#if USE_PREPROCESSOR
+extern String preprocessor; /* preprocessor command */
+#endif
+
+extern Cell conPrelude; /* Prelude */
+#if NPLUSK
+extern Text textPlus; /* Used to recognise n+k patterns */
+#endif
+
+extern String unlexChar Args((Char,Char));
+extern Void printString Args((String));
+
+extern Void consoleInput Args((String));
+extern Void projInput Args((String));
+extern Void stringInput Args((String));
+extern Void parseScript Args((String,Long));
+extern Void parseInterface Args((String,Long));
+extern Void parseExp Args((Void));
+extern String readFilename Args((Void));
+extern String readLine Args((Void));
+
+extern Bool isInterfaceFile Args((String));
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * GHC interface file processing for Hugs
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: interface.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:15 $
+ * ------------------------------------------------------------------------*/
+
+/* ToDo:
+ * o use Z encoding
+ * o use vectored CONSTR_entry when appropriate
+ * o generate export list
+ *
+ * Needs GHC changes to generate member selectors,
+ * superclass selectors, etc
+ * o instance decls
+ * o dictionary constructors ?
+ *
+ * o Get Hugs/GHC to agree on what interface files look like.
+ * o figure out how to replace the Hugs Prelude with the GHC Prelude
+ */
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "static.h"
+#include "errors.h"
+#include "link.h"
+#include "modules.h"
+#include "machdep.h" /* for Time */
+#include "input.h" /* for parseInterface */
+#include "type.h" /* for offsetTyVarsIn */
+#include "stg.h" /* for wrapping GHC objects */
+#include "Assembler.h" /* for wrapping GHC objects */
+#include "interface.h"
+#include "dynamic.h"
+
+/* --------------------------------------------------------------------------
+ * The "addGHC*" functions act as "impedence matchers" between GHC
+ * interface files and Hugs. Their main job is to convert abstract
+ * syntax trees into Hugs' internal representations.
+ *
+ * The main trick here is how we deal with mutually recursive interface
+ * files:
+ *
+ * o As we read an import decl, we add it to a list of required imports
+ * (unless it's already loaded, of course).
+ *
+ * o Processing of declarations is split into two phases:
+ *
+ * 1) While reading the interface files, we construct all the Names,
+ * Tycons, etc declared in the interface file but we don't try to
+ * resolve references to any entities the declaration mentions.
+ *
+ * This is done by the "addGHC*" functions.
+ *
+ * 2) After reading all the interface files, we finish processing the
+ * declarations by resolving any references in the declarations
+ * and doing any other processing that may be required.
+ *
+ * This is done by the "finishGHC*" functions which use the
+ * "fixup*" functions to assist them.
+ *
+ * The interface between these two phases are the "ghc*Decls" which
+ * contain lists of decls that haven't been completed yet.
+ *
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * local variables:
+ * ------------------------------------------------------------------------*/
+
+static List ghcVarDecls;
+static List ghcConDecls;
+static List ghcSynonymDecls;
+static List ghcClassDecls;
+static List ghcInstanceDecls;
+
+/* --------------------------------------------------------------------------
+ * local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static List local addGHCConstrs Args((Int,List,List));
+static Name local addGHCSel Args((Int,Pair,List));
+static Name local addGHCConstr Args((Int,Int,Triple));
+
+
+static Void local finishGHCVar Args((Name));
+static Void local finishGHCCon Args((Name));
+static Void local finishGHCSynonym Args((Tycon));
+static Void local finishGHCClass Args((Class));
+static Void local finishGHCInstance Args((Inst));
+
+static Name local fixupSel Args((Int,Pair,List));
+static Name local fixupConstr Args((Int,Int,Triple));
+static Name local fixupMember Args((Int,Int,Pair));
+static List local fixupMembers Args((Int,List));
+static Type local fixupTypeVar Args((Int,List,Text));
+static Class local fixupClass Args((Int,Text));
+static Cell local fixupPred Args((Int,List,Pair));
+static List local fixupContext Args((Int,List,List));
+static Type local fixupType Args((Int,List,Type));
+static Type local fixupConType Args((Int,Type));
+
+static Void local bindNameToClosure Args((Name,AsmClosure));
+static Kinds local tvsToKind Args((List));
+static Int local arityFromType Args((Type));
+
+static AsmClosure local lookupGHCClosure Args((Module,Text));
+
+/* --------------------------------------------------------------------------
+ * code:
+ * ------------------------------------------------------------------------*/
+
+static List interfaces; /* Interface files that haven't been loaded yet */
+
+Void loadInterface(String fname)
+{
+ ghcVarDecls = NIL;
+ ghcConDecls = NIL;
+ ghcSynonymDecls = NIL;
+ ghcClassDecls = NIL;
+ ghcInstanceDecls = NIL;
+
+ /* Note: interfaces is added to by addGHCImport which is called by
+ * parseInterface so each time round the loop we remove the
+ * current interface from the list before calling parseInterface again.
+ */
+ interfaces=singleton(mkCon(findText(fname)));
+ while (nonNull(interfaces)) {
+ String fname = textToStr(textOf(hd(interfaces)));
+ Time timeStamp; /* not used */
+ Long fileSize;
+ getFileInfo(fname, &timeStamp, &fileSize);
+ interfaces=tl(interfaces);
+ parseInterface(fname,fileSize);
+ }
+
+ /* the order of these doesn't matter
+ * (ToDo: unless synonyms have to be eliminated??)
+ */
+ mapProc(finishGHCVar, ghcVarDecls);
+ mapProc(finishGHCCon, ghcConDecls);
+ mapProc(finishGHCSynonym, ghcSynonymDecls);
+ mapProc(finishGHCClass, ghcClassDecls);
+ mapProc(finishGHCInstance, ghcInstanceDecls);
+ ghcVarDecls = NIL;
+ ghcConDecls = NIL;
+ ghcSynonymDecls = NIL;
+ ghcClassDecls = NIL;
+ ghcInstanceDecls = NIL;
+}
+
+Void openGHCIface(t)
+Text t; {
+ Module m = findModule(t);
+ if (isNull(m)) {
+ m = newModule(t);
+ } else if (m != modulePreludeHugs) {
+ ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
+ EEND;
+ }
+ setCurrModule(m);
+}
+
+Void addGHCImport(line,mn,fn)
+Int line;
+Text mn;
+String fn; {
+#if 1 /* new */
+ Text t = findText(fn);
+ Module m = findModule(mn);
+ if (isNull(m)) {
+ if (isNull(varIsMember(t,interfaces))) {
+ interfaces = cons(mkCon(t),interfaces);
+ }
+ }
+#else /* old - and probably wrong */
+ Module m = findModule(t);
+ if (isNull(m)) {
+ ERRMSG(0) "Unknown module \"%s\"", textToStr(t)
+ EEND;
+ }
+ /* ToDo: what to do if there's a name conflict? */
+ { /* copied from resolveImportList */
+ List es = module(m).exports;
+ List imports = NIL;
+ for(; nonNull(es); es=tl(es)) {
+ Cell e = hd(es);
+ if (isName(e)) {
+ imports = cons(e,imports);
+ } else {
+ Cell c = fst(e);
+ List subentities = NIL;
+ imports = cons(c,imports);
+ if (isTycon(c)
+ && (tycon(c).what == DATATYPE
+ || tycon(c).what == NEWTYPE)) {
+ subentities = tycon(c).defn;
+ } else if (isClass(c)) {
+ subentities = cclass(c).members;
+ }
+ if (DOTDOT == snd(e)) {
+ imports = revDupOnto(subentities,imports);
+ }
+ }
+ }
+ map1Proc(importEntity,m,imports);
+ }
+#endif
+}
+
+void addGHCVar(line,v,ty)
+Int line;
+Text v;
+Type ty;
+{
+ Name n = findName(v);
+ if (nonNull(n)) {
+ ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
+ EEND;
+ }
+ n = newName(v);
+ bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text));
+
+ /* prepare for finishGHCVar */
+ name(n).type = ty;
+ ghcVarDecls = cons(n,ghcVarDecls);
+}
+
+static Void local finishGHCVar(Name n)
+{
+ Int line = name(n).line;
+ Type ty = name(n).type;
+ setCurrModule(name(n).mod);
+ name(n).type = fixupType(line,NIL,ty);
+}
+
+Void addGHCSynonym(line,tycon,tvs,ty)
+Int line;
+Cell tycon; /* ConId */
+List tvs; /* [(VarId,Kind)] */
+Type ty; {
+ /* ToDo: worry about being given a decl for (->) ?
+ * and worry about qualidents for ()
+ */
+ Text t = textOf(tycon);
+ if (nonNull(findTycon(t))) {
+ ERRMSG(line) "Repeated definition of type constructor \"%s\"",
+ textToStr(t)
+ EEND;
+ } else {
+ Tycon tc = newTycon(t);
+ tycon(tc).line = line;
+ tycon(tc).arity = length(tvs);
+ tycon(tc).what = SYNONYM;
+ tycon(tc).kind = tvsToKind(tvs);
+
+ /* prepare for finishGHCSynonym */
+ tycon(tc).defn = pair(tvs,ty);
+ ghcSynonymDecls = cons(tc,ghcSynonymDecls);
+ }
+}
+
+static Void local finishGHCSynonym(Tycon tc)
+{
+ Int line = tycon(tc).line;
+ List tvs = fst(tycon(tc).defn);
+ Type ty = snd(tycon(tc).defn);
+
+ setCurrModule(tycon(tc).mod);
+ tycon(tc).defn = fixupType(line,singleton(tvs),ty);
+
+ /* ToDo: can't really do this until I've done all synonyms
+ * and then I have to do them in order
+ * tycon(tc).defn = fullExpand(ty);
+ */
+}
+
+Void addGHCDataDecl(line,tycon,tvs,constrs,sels)
+Int line;
+Cell tycon; /* ConId | QualConId */
+List tvs; /* [(VarId,Kind)] */
+List constrs; /* [(ConId,[VarId],Type)] */
+List sels; { /* [(VarId,Type)] */
+ /* ToDo: worry about being given a decl for (->) ?
+ * and worry about qualidents for ()
+ */
+ Text t = textOf(tycon);
+ if (nonNull(findTycon(t))) {
+ ERRMSG(line) "Repeated definition of type constructor \"%s\"",
+ textToStr(t)
+ EEND;
+ } else {
+ Tycon tc = newTycon(t);
+ tycon(tc).line = line;
+ tycon(tc).arity = length(tvs);
+ tycon(tc).what = DATATYPE;
+ tycon(tc).kind = tvsToKind(tvs);
+ tycon(tc).defn = addGHCConstrs(line,constrs,sels);
+ }
+}
+
+static List local addGHCConstrs(line,cons,sels)
+Int line;
+List cons; /* [(ConId,[VarId],Type)] */
+List sels; { /* [(VarId,Type)] */
+ List uses = NIL; /* [(ConName,[VarId])] */
+ if (nonNull(cons) && isNull(tl(cons))) { /* Single constructor datatype? */
+ List fs = snd3(hd(cons));
+ Name c = addGHCConstr(line,0,hd(cons));
+ uses = cons(pair(c,fs),uses);
+ hd(cons) = c;
+ } else {
+ Int conNo = 0; /* or maybe 1? */
+ List cs = cons;
+ for(; nonNull(cs); cs=tl(cs), conNo++) {
+ List fs = snd3(hd(cs));
+ Name c = addGHCConstr(line,conNo,hd(cs));
+ uses = cons(pair(c,fs),uses);
+ hd(cs) = c;
+ }
+ }
+ {
+ List ss = sels;
+ for(; nonNull(ss); ss=tl(ss)) {
+ hd(ss) = addGHCSel(line,hd(ss),uses);
+ }
+ }
+ return appendOnto(cons,sels);
+}
+
+static Name local addGHCSel(line,sel,uses)
+Int line;
+Pair sel; /* (VarId,Type) */
+List uses; { /* [(ConName,[VarId])] */
+ Text t = textOf(fst(sel));
+ Type type = snd(sel);
+ List fields = NIL;
+
+ Name n = findName(t);
+ if (nonNull(n)) {
+ ERRMSG(line) "Repeated definition for selector \"%s\"",
+ textToStr(t)
+ EEND;
+ }
+
+ n = newName(t);
+ name(n).line = line;
+ name(n).number = SELNAME;
+ name(n).arity = 1;
+
+ for(; nonNull(uses); uses=tl(uses)) {
+ Int fNo = 1;
+ Name c = fst(hd(uses));
+ List fs = snd(hd(uses));
+ for(; nonNull(fs); fs=tl(fs), fNo++) {
+ if (textOf(hd(fs)) == t) {
+ fields = cons(pair(c,mkInt(fNo)),fields);
+ }
+ }
+ }
+ name(n).defn = fields;
+
+ /* prepare for finishGHCVar */
+ name(n).type = type;
+ ghcVarDecls = cons(n,ghcVarDecls);
+
+ return n;
+}
+
+static Name local addGHCConstr(line,conNo,constr)
+Int line;
+Int conNo;
+Triple constr; { /* (ConId,[VarId],Type) */
+ /* ToDo: add rank2 annotation and existential annotation
+ * these affect how constr can be used.
+ */
+ Text con = textOf(fst3(constr));
+ Type type = thd3(constr);
+ Int arity = arityFromType(type);
+ Name n = findName(con); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(con);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for constructor \"%s\"",
+ textToStr(con)
+ EEND;
+ }
+ name(n).arity = arity; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(conNo);
+ bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text));
+
+ /* prepare for finishGHCCon */
+ name(n).type = type;
+ ghcConDecls = cons(n,ghcConDecls);
+
+ return n;
+}
+
+static Void local finishGHCCon(Name n)
+{
+ Int line = name(n).line;
+ Type ty = name(n).type;
+ setCurrModule(name(n).mod);
+ name(n).type = fixupConType(line,ty);
+}
+
+Void addGHCNewType(line,tycon,tvs,constr)
+Int line;
+Cell tycon; /* ConId | QualConId */
+List tvs; /* [(VarId,Kind)] */
+Cell constr; {
+ /* ToDo: worry about being given a decl for (->) ?
+ * and worry about qualidents for ()
+ */
+ Text t = textOf(tycon);
+ if (nonNull(findTycon(t))) {
+ ERRMSG(line) "Repeated definition of type constructor \"%s\"",
+ textToStr(t)
+ EEND;
+ } else {
+ Tycon tc = newTycon(t);
+ tycon(tc).line = line;
+ tycon(tc).arity = length(tvs);
+ tycon(tc).what = NEWTYPE;
+ tycon(tc).kind = tvsToKind(tvs);
+ /* can't really do this until I've read in all synonyms */
+
+ if (isNull(constr)) {
+ tycon(tc).defn = NIL;
+ } else {
+ /* constr :: (ConId,Type) */
+ Text con = textOf(fst(constr));
+ Type type = snd(constr);
+ Name n = findName(con); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(con);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for constructor \"%s\"",
+ textToStr(con)
+ EEND;
+ }
+ name(n).arity = 1; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(0);
+ name(n).defn = nameId;
+ tycon(tc).defn = singleton(n);
+
+ /* prepare for finishGHCCon */
+ /* ToDo: we use finishGHCCon instead of finishGHCVar in case
+ * there's any existential quantification in the newtype -
+ * but I don't think that's allowed in newtype constrs.
+ * Still, no harm done by doing it this way...
+ */
+ name(n).type = type;
+ ghcConDecls = cons(n,ghcConDecls);
+ }
+ }
+}
+
+Void addGHCClass(line,ctxt,tc_name,tvs,mems)
+Int line;
+List ctxt; /* [(ConId, [Type])] */
+Cell tc_name; /* ConId | QualConId */
+List tvs; /* [(VarId,Kind)] */
+List mems; {
+ Text ct = textOf(tc_name);
+ if (nonNull(findClass(ct))) {
+ ERRMSG(line) "Repeated definition of class \"%s\"",
+ textToStr(ct)
+ EEND;
+ } else if (nonNull(findTycon(ct))) {
+ ERRMSG(line) "\"%s\" used as both class and type constructor",
+ textToStr(ct)
+ EEND;
+ } else {
+ Class nw = newClass(ct);
+ Int arity = length(tvs);
+ Cell head = nw;
+ Int i;
+ for(i=0; i < arity; ++i) {
+ head = ap(head,mkOffset(i));
+ }
+ cclass(nw).line = line;
+ cclass(nw).arity = arity;
+ cclass(nw).head = head;
+ cclass(nw).kinds = tvsToKind(tvs); /* ToDo: I don't think this is right */
+ cclass(nw).instances = NIL;
+
+ /* prepare for finishGHCClass */
+ cclass(nw).supers = pair(tvs,ctxt);
+ cclass(nw).members = mems;
+ ghcClassDecls = cons(nw,ghcClassDecls);
+
+ /* ToDo:
+ * cclass(nw).dsels = ?;
+ * cclass(nw).dbuild = ?;
+ * cclass(nm).dcon = ?;
+ * cclass(nm).defaults = ?;
+ */
+ }
+}
+
+static Void local finishGHCClass(Class nw)
+{
+ Int line = cclass(nw).line;
+ List tvs = fst(cclass(nw).supers);
+ List ctxt = snd(cclass(nw).supers);
+ List mems = cclass(nw).members;
+
+ setCurrModule(cclass(nw).mod);
+
+ cclass(nw).supers = fixupContext(line,singleton(tvs),ctxt);
+ cclass(nw).numSupers = length(cclass(nw).supers);
+ cclass(nw).members = fixupMembers(line,mems);
+ cclass(nw).numMembers = length(cclass(nw).members);
+ cclass(nw).level = 0; /* ToDo: level = 1 + max (map level supers) */
+}
+
+Void addGHCInstance (line,quant,cls,var)
+Int line;
+Cell quant;
+Pair cls; /* :: (ConId, [Type]) */
+Text var; {
+ Inst in = newInst();
+
+ List ctxt = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */
+
+ inst(in).line = line;
+ inst(in).implements = NIL;
+
+ {
+ Name b = newName(inventText());
+ name(b).line = line;
+ name(b).arity = length(ctxt); /* unused? */
+ name(b).number = DFUNNAME;
+ inst(in).builder = b;
+ bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
+ }
+
+ /* prepare for finishGHCInstance */
+ inst(in).head = cls;
+ inst(in).specifics = quant;
+ ghcInstanceDecls = cons(in,ghcInstanceDecls);
+}
+
+static Void local finishGHCInstance(Inst in)
+{
+ Int line = inst(in).line;
+ Cell cl = fst(inst(in).head);
+ List tys = snd(inst(in).head);
+ Cell quant = inst(in).specifics;
+ List tvs = nonNull(quant) ? fst(quant) : NIL; /* [(VarId,Kind)] */
+ List ctxt = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */
+ List tyvars = singleton(tvs);
+ Class c;
+
+ setCurrModule(inst(in).mod);
+ c = findClass(textOf(cl));
+ if (isNull(c)) {
+ ERRMSG(line) "Unknown class \"%s\" in instance",
+ textToStr(textOf(cl))
+ EEND;
+ }
+ map2Over(fixupType,line,tyvars,tys);
+ inst(in).head = applyToArgs(c,tys);
+ inst(in).specifics = fixupContext(line,tyvars,ctxt);
+ inst(in).numSpecifics = length(inst(in).specifics);
+ cclass(c).instances = cons(in,cclass(c).instances);
+}
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+static Name local fixupMember(line,memNo,mem)
+Int line;
+Int memNo;
+Pair mem; { /* :: (Text,Type) */
+ Text t = textOf(fst(mem));
+ Type type = snd(mem);
+ Name m = findName(t);
+
+ if (isNull(m)) {
+ m = newName(t);
+ } else if (name(m).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for member function \"%s\"",
+ textToStr(t)
+ EEND;
+ }
+
+ name(m).line = line;
+ name(m).arity = 1;
+ name(m).number = mfunNo(memNo);
+ name(m).type = fixupType(line,NIL,type);
+
+ /* ToDo: name(m).stgVar = ?; */
+
+ return m;
+}
+
+
+static List local fixupMembers(line,ms)
+Int line;
+List ms; {
+ Int memNo = 1;
+ List mems = ms;
+ for(; nonNull(mems); mems=tl(mems), memNo++) {
+ hd(mems) = fixupMember(line,memNo,hd(mems));
+ }
+ return ms;
+}
+
+static Type local fixupTypeVar(line,tyvars,tv)
+Int line;
+List tyvars; /* [[(VarId,Kind)]] */
+Text tv; {
+ Int offset = 0;
+ for (; nonNull(tyvars); tyvars=tl(tyvars)) {
+ List tvs = hd(tyvars);
+ for (; nonNull(tvs); offset++, tvs=tl(tvs)) {
+ if (tv == textOf(fst(hd(tvs)))) {
+ return mkOffset(offset);
+ }
+ }
+ }
+ ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
+ EEND;
+}
+
+static Class local fixupClass(line,cls)
+Int line;
+Text cls; {
+ Class c = findClass(cls);
+ if (isNull(c)) {
+ ERRMSG(line)
+ "Undefined class \"%s\"", textToStr(cls)
+ EEND;
+ }
+ return c;
+}
+
+static Cell local fixupPred(line,tyvars,pred)
+Int line;
+List tyvars; /* [[(VarId,Kind)]] */
+Pair pred; { /* (ConId,[Type]) */
+ Class c = fixupClass(line,textOf(fst(pred)));
+ List tys = snd(pred);
+
+ map2Over(fixupType,line,tyvars,tys);
+ return applyToArgs(c,tys);
+}
+
+static List local fixupContext(line,tyvars,ctxt)
+Int line;
+List tyvars; /* [[(VarId,Kind)]] */
+List ctxt; { /* [(ConId,[Type])] */
+ map2Over(fixupPred,line,tyvars,ctxt);
+ return ctxt;
+}
+
+static Type local fixupType(line,tyvars,type)
+Int line;
+List tyvars; /* [[(VarId,Kind)]] */
+Type type; {
+ switch (whatIs(type)) {
+ case AP:
+ {
+ fst(type) = fixupType(line,tyvars,fst(type));
+ snd(type) = fixupType(line,tyvars,snd(type));
+ break;
+ }
+ case DICTAP:
+ {
+ /* Alternatively: raise an error. These can only
+ * occur in the types of instance variables which
+ * we could easily separate from "real variables".
+ */
+ snd(type) = fixupPred(line,tyvars,snd(type));
+ break;
+ }
+ case VARIDCELL:
+ return fixupTypeVar(line,tyvars,textOf(type));
+ case CONIDCELL:
+ {
+ Tycon tc = findQualTycon(type);
+ if (isNull(tc)) {
+ ERRMSG(line)
+ "Undefined type constructor \"%s\"",
+ identToStr(type)
+ EEND;
+ }
+ return tc;
+ }
+#if TREX
+ case EXT:
+#endif
+ case TYCON:
+ case TUPLE:
+ break;
+ case POLYTYPE:
+ {
+ List tvs = fst3(snd(type)); /* [(VarId, Kind)] */
+ List ctxt = snd3(snd(type)); /* [(ConId, [Type])] */
+ Type ty = thd3(snd(type));
+
+ if (nonNull(tvs)) {
+ tyvars = cons(tvs,tyvars);
+ }
+ type = fixupType(line,tyvars,ty);
+
+ if (nonNull(ctxt)) {
+ type = ap(QUAL,pair(fixupContext(line,tyvars,ctxt),type));
+ }
+ if (nonNull(tvs)) {
+ type = mkPolyType(tvsToKind(tvs),type);
+ }
+ }
+ break;
+ default:
+ internal("fixupType");
+ }
+ return type;
+}
+
+/* forall as bs. C1 as, C2 as bs => Ts as bs -> T as
+ * => forall as. C1 as => exists bs. C2 as bs => Ts as bs -> T as
+ */
+static Type local fixupConType(line,type)
+Int line;
+Type type; {
+ List sig = NIL;
+ List ctxt = NIL;
+ type = fixupType(line,NIL,type);
+
+ if (isPolyType(type)) {
+ sig = polySigOf(type);
+ type = monotypeOf(type);
+ }
+ if (whatIs(type) == QUAL) {
+ ctxt = fst(snd(type));
+ type = snd(snd(type));
+ }
+ {
+ Type r_ty = type;
+ Int nr2 = 0; /* maximum argnum which is a polytype */
+ Int argnum = 1;
+ while (isAp(r_ty) && getHead(r_ty)==typeArrow) {
+ if (isPolyType(arg(fun(r_ty)))) {
+ nr2 = argnum;
+ }
+ argnum++;
+ r_ty = arg(r_ty);
+ }
+
+ if (nr2>0) {
+ type = ap(RANK2,pair(mkInt(nr2),type));
+ }
+ { /* tyvars which don't appear in result are existentially quant'd */
+ List result_tvs = offsetTyvarsIn(r_ty,NIL);
+ List all_tvs = offsetTyvarsIn(type,NIL);
+ Int etvs = length(all_tvs);
+ Int ntvs = length(result_tvs);
+ if (etvs>ntvs) {
+ /* ToDo: split the context into two parts */
+ type = ap(EXIST,pair(mkInt(etvs-ntvs),type));
+ }
+ }
+ }
+ if (nonNull(ctxt)) {
+ type = ap(QUAL,pair(ctxt,type));
+ }
+ if (nonNull(sig)) {
+ type = mkPolyType(sig,type);
+ }
+ return type;
+}
+
+/* --------------------------------------------------------------------------
+ * Utilities
+ *
+ * None of these do lookups or require that lookups have been resolved
+ * so they can be performed while reading interfaces.
+ * ------------------------------------------------------------------------*/
+
+static Kinds local tvsToKind(tvs)
+List tvs; { /* [(VarId,Kind)] */
+ List rs = NIL;
+ Kinds r = STAR; /* ToDo: hope this works */
+ for(; nonNull(tvs); tvs=tl(tvs)) { /* make reversed list of kinds */
+ rs = cons(snd(hd(tvs)),rs);
+ }
+ for(; nonNull(rs); rs=tl(rs)) { /* build full kind */
+ r = ap(hd(rs),r);
+ }
+ return r;
+}
+
+static Int local arityFromType(type) /* arity of a constructor with this type */
+Type type; {
+ Int arity = 0;
+ if (isPolyType(type)) {
+ type = monotypeOf(type);
+ }
+ if (whatIs(type) == QUAL) {
+ type = snd(snd(type));
+ }
+ if (whatIs(type) == EXIST) {
+ type = snd(snd(type));
+ }
+ if (whatIs(type)==RANK2) {
+ type = snd(snd(type));
+ }
+ while (isAp(type) && getHead(type)==typeArrow) {
+ arity++;
+ type = arg(type);
+ }
+ return arity;
+}
+
+/* --------------------------------------------------------------------------
+ * Dynamic loading code (probably shouldn't be here)
+ *
+ * o .hi file explicitly says which .so file to load.
+ * This avoids the need for a 1-to-1 relationship between .hi and .so files.
+ *
+ * ToDo: when doing a :reload, we ought to check the modification date
+ * on the .so file.
+ *
+ * o module handles are unloaded (dlclosed) when we call dropScriptsFrom.
+ *
+ * ToDo: do the same for foreign functions - but with complication that
+ * there may be multiple .so files
+ * ------------------------------------------------------------------------*/
+
+/* ToDo: move some of this code (back) into dynamic.c and make it portable */
+#include <stdio.h>
+
+static AsmClosure local lookupGHCClosure( Module m, Text t )
+{
+ char symbol[100]; /* ToDo: arbitrary constants must die */
+ void *c;
+ sprintf(symbol,"%s_%s_closure",textToStr(module(m).text),textToStr(t));
+ if (module(m).objectFile == NULL) {
+ ERRMSG(0) "Interface file must \"require\" at least one file"
+ EEND;
+ }
+ c = lookupSymbol(module(m).objectFile,symbol);
+ if (NULL == c) {
+ ERRMSG(0) "Error %s while importing symbol \"%s\"", dlerror(), symbol
+ EEND;
+ }
+ return ((AsmClosure)c);
+}
+
+Void loadSharedLib( String fn )
+{
+ if (module(currentModule).objectFile != NULL) {
+ ERRMSG(0) "Interface file \"require\"s two files"
+ EEND;
+ }
+ module(currentModule).objectFile = loadLibrary(fn);
+ if (NULL == module(currentModule).objectFile) {
+ ERRMSG(0) "Error %s while importing DLL \"%s\"", dlerror(), fn
+ EEND;
+ }
+}
+
+static void bindNameToClosure(n,c)
+Name n;
+AsmClosure c; {
+ StgVar v = mkStgVar(NIL,mkPtr(asmMkObject(c)));
+ name(n).stgVar = v;
+}
+
+/* --------------------------------------------------------------------------
+ * Control:
+ * ------------------------------------------------------------------------*/
+
+Void interface(what)
+Int what; {
+ switch (what) {
+ case RESET:
+ interfaces = NIL;
+ ghcVarDecls = NIL;
+ ghcConDecls = NIL;
+ ghcSynonymDecls = NIL;
+ ghcClassDecls = NIL;
+ ghcInstanceDecls = NIL;
+ break;
+ case MARK:
+ mark(interfaces);
+ mark(ghcVarDecls);
+ mark(ghcConDecls);
+ mark(ghcSynonymDecls);
+ mark(ghcClassDecls);
+ mark(ghcInstanceDecls);
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+
+extern Void loadInterface Args((String));
+
+extern Void openGHCIface Args((Text));
+extern Void loadSharedLib Args((String));
+extern Void addGHCImport Args((Int,Text,String));
+extern Void addGHCVar Args((Int,Text,Type));
+extern Void addGHCSynonym Args((Int,Cell,List,Type));
+extern Void addGHCDataDecl Args((Int,Cell,List,List,List));
+extern Void addGHCNewType Args((Int,Cell,List,Cell));
+extern Void addGHCClass Args((Int,List,Cell,List,List));
+extern Void addGHCInstance Args((Int,Cell,Pair,Text));
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Part of type checker dealing with kind inference
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: kind.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:16 $
+ * ------------------------------------------------------------------------*/
+
+#define newKindvars(n) newTyvars(n) /* to highlight uses of type vars */
+ /* as kind variables */
+
+Bool kindExpert = FALSE; /* TRUE => display kind errors in */
+ /* full detail */
+
+/* --------------------------------------------------------------------------
+ * Kind checking code:
+ * ------------------------------------------------------------------------*/
+
+static Void local kindError(l,c,in,wh,k,o)
+Int l; /* line number near constuctor exp */
+Constr c; /* constructor */
+Constr in; /* context (if any) */
+String wh; /* place in which error occurs */
+Kind k; /* expected kind (k,o) */
+Int o; { /* inferred kind (typeIs,typeOff) */
+ clearMarks();
+
+ if (!kindExpert) { /* for those with a fear of kinds */
+ ERRMSG(l) "Illegal type" ETHEN
+ if (nonNull(in)) {
+ ERRTEXT " \"" ETHEN ERRTYPE(in);
+ ERRTEXT "\"" ETHEN
+ }
+ ERRTEXT " in %s\n", wh
+ EEND;
+ }
+
+ ERRMSG(l) "Kind error in %s", wh ETHEN
+ if (nonNull(in)) {
+ ERRTEXT "\n*** expression : " ETHEN ERRTYPE(in);
+ }
+ ERRTEXT "\n*** constructor : " ETHEN ERRTYPE(c);
+ ERRTEXT "\n*** kind : " ETHEN ERRKIND(copyType(typeIs,typeOff));
+ ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
+ if (unifyFails) {
+ ERRTEXT "\n*** because : %s", unifyFails ETHEN
+ }
+ ERRTEXT "\n"
+ EEND;
+}
+
+#define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \
+ kindError(l,c,in,wh,k,o)
+#define checkKind(l,c,in,wh,k,o) kindConstr(l,c); shouldKind(l,c,in,wh,k,o)
+#define inferKind(k,o) typeIs=k; typeOff=o
+
+static Int locCVars; /* offset to local variable kinds */
+static List unkindTypes; /* types in need of kind annotation*/
+#if TREX
+static Kind extKind; /* Kind of extension, *->row->row */
+#endif
+
+static Void local kindConstr(l,c) /* Determine kind of constructor */
+Int l;
+Cell c; {
+ Cell h = getHead(c);
+ Int n = argCount;
+
+ if (isSynonym(h) && n<tycon(h).arity) {
+ ERRMSG(l) "Not enough arguments for type synonym \"%s\"",
+ textToStr(tycon(h).text)
+ EEND;
+ }
+
+#if TREX
+ if (isExt(h) && n!=2) {
+ ERRMSG(l) "Illegal use of row in " ETHEN ERRTYPE(c);
+ ERRTEXT "\n"
+ EEND;
+ }
+#endif
+
+ if (n==0) /* trivial case, no arguments */
+ typeIs = kindAtom(c);
+ else { /* non-trivial application */
+ static String app = "constructor application";
+ Cell a = c;
+ Int i;
+ Kind k;
+ Int beta;
+
+ varKind(n);
+ beta = typeOff;
+ k = typeIs;
+
+ typeIs = kindAtom(h); /* h :: v1 -> ... -> vn -> w */
+ shouldKind(l,h,c,app,k,beta);
+
+ for (i=n; i>0; --i) { /* ci :: vi for each 1 <- 1..n */
+ checkKind(l,arg(a),c,app,var,beta+i-1);
+ a = fun(a);
+ }
+ tyvarType(beta+n); /* inferred kind is w */
+ }
+}
+
+static Kind local kindAtom(c) /* Find kind of atomic constructor */
+Cell c; {
+ switch (whatIs(c)) {
+ case TUPLE : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */
+ case OFFSET : return mkInt(locCVars+offsetOf(c));
+ case TYCON : return tycon(c).kind;
+#if TREX
+ case EXT : return extKind;
+#endif
+ }
+ internal("kindAtom");
+ return STAR;/* not reached */
+}
+
+static Void local kindPred(line,pred) /* Check kinds of arguments in pred*/
+Int line;
+Cell pred; {
+ static String predicate = "class constraint";
+#if TREX
+ if (isExt(fun(pred))) {
+ checkKind(line,arg(pred),NIL,predicate,ROW,0);
+ return;
+ }
+#endif
+ checkKind(line,arg(pred),NIL,predicate,cclass(fun(pred)).sig,0);
+}
+
+static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
+Int line; /* is well-kinded */
+String wh;
+Type type; {
+ locCVars = 0;
+ if (isPolyType(type)) { /* local constructor vars reqd? */
+ Kind k = polySigOf(type);
+ Int n = 0;
+ for (; isPair(k); k=snd(k))
+ n++;
+ locCVars = newKindvars(n);
+ unkindTypes = cons(pair(mkInt(locCVars),snd(type)),unkindTypes);
+ type = monoTypeOf(type);
+ }
+ if (whatIs(type)==QUAL) { /* examine context (if any) */
+ map1Proc(kindPred,line,fst(snd(type)));
+ type = snd(snd(type));
+ }
+ checkKind(line,type,NIL,wh,STAR,0); /* finally, check type part */
+}
+
+static Void local fixKinds() { /* add kind annotations to types */
+ for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
+ Pair pr = hd(unkindTypes);
+ Int beta = intOf(fst(pr));
+ Cell qts = fst(snd(pr));
+ for (;;) {
+ if (isNull(hd(qts)))
+ hd(qts) = copyKindvar(beta++);
+ else
+ hd(qts) = ap(hd(qts),copyKindvar(beta++));
+ if (nonNull(tl(qts)))
+ qts = tl(qts);
+ else {
+ tl(qts) = STAR;
+ break;
+ }
+ }
+#ifdef DEBUG_KINDS
+ Printf("Type expression: ");
+ printType(stdout,snd(snd(pr)));
+ Printf(" :: ");
+ printKind(stdout,fst(snd(pr)));
+ Printf("\n");
+#endif
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Kind checking of groups of type constructors and classes:
+ * ------------------------------------------------------------------------*/
+
+Void kindTCGroup(tcs) /* find kinds for mutually rec. gp */
+List tcs; { /* of tycons and classes */
+ typeChecker(RESET);
+ mapProc(initTCKind,tcs);
+ mapProc(kindTC,tcs);
+ mapProc(genTC,tcs);
+ fixKinds();
+ typeChecker(RESET);
+}
+
+static Void local initTCKind(c) /* build initial kind/arity for c */
+Cell c; {
+ if (isTycon(c)) { /* Initial kind of tycon is: */
+ Int beta = newKindvars(1); /* v1 -> ... -> vn -> vn+1 */
+ varKind(tycon(c).arity); /* where n is the arity of c. */
+ bindTv(beta,typeIs,typeOff); /* For data definitions, vn+1 == * */
+ switch (whatIs(tycon(c).what)) {
+ case NEWTYPE :
+ case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
+ }
+ tycon(c).kind = mkInt(beta);
+ }
+ else
+ cclass(c).sig = mkInt(newKindvars(1));
+}
+
+static Void local kindTC(c) /* check each part of a tycon/class*/
+Cell c; { /* is well-kinded */
+ if (isTycon(c)) {
+ static String cfun = "constructor function";
+ static String tsyn = "synonym definition";
+ Int line = tycon(c).line;
+
+ locCVars = tyvar(intOf(tycon(c).kind))->offs;
+ switch (whatIs(tycon(c).what)) {
+ case NEWTYPE :
+ case DATATYPE : { List cs = tycon(c).defn;
+ if (whatIs(cs)==QUAL) {
+ map1Proc(kindPred,line,fst(snd(cs)));
+ tycon(c).defn = cs = snd(snd(cs));
+ }
+ for (; hasCfun(cs); cs=tl(cs))
+ kindType(line,cfun,name(hd(cs)).type);
+ break;
+ }
+
+ default : checkKind(line,tycon(c).defn,NIL,
+ tsyn,var,locCVars+tycon(c).arity);
+ }
+ }
+ else { /* scan type exprs in class defn to*/
+ List ms = cclass(c).members; /* determine the class signature */
+ List scs = cclass(c).supers;
+
+ for (; nonNull(scs); scs=tl(scs))
+ if (!kunify(cclass(hd(scs)).sig,0,cclass(c).sig,0)) {
+ ERRMSG(cclass(c).line)
+ "Kind of class \"%s\" does not match superclass \"%s\"",
+ textToStr(cclass(c).text), textToStr(cclass(hd(scs)).text)
+ EEND;
+ }
+
+ for (; nonNull(ms); ms=tl(ms)) {
+ Int line = intOf(fst3(hd(ms)));
+ Type type = thd3(hd(ms));
+ kindType(line,"member function type signature",type);
+ }
+ }
+}
+
+static Void local genTC(c) /* generalise kind inferred for */
+Cell c; { /* given tycon/class */
+ if (isTycon(c)) {
+ tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
+#ifdef DEBUG_KINDS
+ Printf("%s :: ",textToStr(tycon(c).text));
+ printKind(stdout,tycon(c).kind);
+ Putchar('\n');
+#endif
+ }
+ else {
+ cclass(c).sig = copyKindvar(intOf(cclass(c).sig));
+#ifdef DEBUG_KINDS
+ Printf("%s :: ",textToStr(cclass(c).text));
+ printKind(stdout,cclass(c).sig);
+ Putchar('\n');
+#endif
+ }
+}
+
+static Kind local copyKindvar(vn) /* build kind attatched to variable*/
+Int vn; {
+ Tyvar *tyv = tyvar(vn);
+ if (tyv->bound)
+ return copyKind(tyv->bound,tyv->offs);
+ return STAR; /* any unbound variable defaults to*/
+} /* the kind of all types */
+
+static Kind local copyKind(k,o) /* build kind expression from */
+Kind k; /* given skeleton */
+Int o; {
+ switch (whatIs(k)) {
+ case AP : { Kind l = copyKind(fst(k),o); /* ensure correct */
+ Kind r = copyKind(snd(k),o); /* eval. order */
+ return ap(l,r);
+ }
+ case OFFSET : return copyKindvar(o+offsetOf(k));
+ case INTCELL : return copyKindvar(intOf(k));
+ }
+ return k;
+}
+
+/* --------------------------------------------------------------------------
+ * Kind checking of instance declaration headers:
+ * ------------------------------------------------------------------------*/
+
+Void kindInst(in,h) /* check predicates in instance */
+Inst in;
+Cell h; {
+ typeChecker(RESET);
+ locCVars = newKindvars(inst(in).arity);
+ kindPred(inst(in).line,h);
+ map1Proc(kindPred,inst(in).line,inst(in).specifics);
+ typeChecker(RESET);
+}
+
+/* --------------------------------------------------------------------------
+ * Kind checking of individual type signatures:
+ * ------------------------------------------------------------------------*/
+
+Void kindSigType(line,type) /* check that type is well-kinded */
+Int line;
+Type type; {
+ typeChecker(RESET);
+ kindType(line,"type expression",type);
+ fixKinds();
+ typeChecker(RESET);
+}
+
+/* --------------------------------------------------------------------------
+ * Kind checking of default types:
+ * ------------------------------------------------------------------------*/
+
+Void kindDefaults(line,ts) /* check that list of types are */
+Int line; /* well-kinded */
+List ts; {
+ typeChecker(RESET);
+ map2Proc(kindType,line,"default type",ts);
+ fixKinds();
+ typeChecker(RESET);
+}
+
+/* --------------------------------------------------------------------------
+ * Support for `kind preserving substitutions' from unification:
+ * ------------------------------------------------------------------------*/
+
+static Bool local eqKind(k1,k2) /* check that two (mono)kinds are */
+Kind k1, k2; { /* equal */
+ return k1==k2
+ || (isPair(k1) && isPair(k2)
+ && eqKind(fst(k1),fst(k2))
+ && eqKind(snd(k1),snd(k2)));
+}
+
+static Kind local getKind(c,o) /* Find kind of constr during type */
+Cell c; /* checking process */
+Int o; {
+ if (isAp(c)) /* application */
+ return snd(getKind(fst(c),o));
+ switch (whatIs(c)) {
+ case TUPLE : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */
+ case OFFSET : return tyvar(o+offsetOf(c))->kind;
+ case INTCELL: return tyvar(intOf(c))->kind;
+ case TYCON : return tycon(c).kind;
+#if TREX
+ case EXT : return extKind;
+#endif
+ }
+#ifdef DEBUG_KINDS
+ Printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
+#endif
+ internal("getKind");
+ return STAR;/* not reached */
+}
+
+/* --------------------------------------------------------------------------
+ * Two forms of kind expression are used quite frequently:
+ * * -> * -> ... -> * -> * for kinds of ->, [], ->, (,) etc...
+ * v1 -> v2 -> ... -> vn -> vn+1 skeletons for constructor kinds
+ * Expressions of these forms are produced by the following functions which
+ * use a cache to avoid repeated construction of commonly used values.
+ * A similar approach is used to store the types of tuple constructors in the
+ * main type checker.
+ * ------------------------------------------------------------------------*/
+
+#define MAXKINDFUN 10
+static Kind simpleKindCache[MAXKINDFUN];
+static Kind varKindCache[MAXKINDFUN];
+
+static Kind local makeSimpleKind(n) /* construct * -> ... -> * (n args)*/
+Int n; {
+ Kind k = STAR;
+ while (n-- > 0)
+ k = ap(STAR,k);
+ return k;
+}
+
+static Kind local simpleKind(n) /* return (possibly cached) simple */
+Int n; { /* function kind */
+ if (n>=MAXKINDFUN)
+ return makeSimpleKind(n);
+ else if (nonNull(simpleKindCache[n]))
+ return simpleKindCache[n];
+ else if (n==0)
+ return simpleKindCache[0] = STAR;
+ else
+ return simpleKindCache[n] = ap(STAR,simpleKind(n-1));
+}
+
+static Kind local makeVarKind(n) /* construct v0 -> .. -> vn */
+Int n; {
+ Kind k = mkOffset(n);
+ while (n-- > 0)
+ k = ap(mkOffset(n),k);
+ return k;
+}
+
+static Void local varKind(n) /* return (possibly cached) var */
+Int n; { /* function kind */
+ typeOff = newKindvars(n+1);
+ if (n>=MAXKINDFUN)
+ typeIs = makeVarKind(n);
+ else if (nonNull(varKindCache[n]))
+ typeIs = varKindCache[n];
+ else
+ typeIs = varKindCache[n] = makeVarKind(n);
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+#ifdef HEAD
+module Array (
+ module Ix, -- export all of Ix
+ Array, array, listArray, (!), bounds, indices, elems, assocs,
+ accumArray, (//), accum, ixmap ) where
+
+import Ix
+#if STD_PRELUDE
+import List( (\\) )
+
+infixl 9 !, //
+#else
+import PreludeBuiltin
+#endif
+#endif /* HEAD */
+#ifdef BODY
+
+#if STD_PRELUDE
+data Array a b = MkArray (a,a) (a -> b) deriving ()
+
+array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
+array b ivs =
+ if and [inRange b i | (i,_) <- ivs]
+ then MkArray b
+ (\j -> case [v | (i,v) <- ivs, i == j] of
+ [v] -> v
+ [] -> error "Array.!: \
+ \undefined array element"
+ _ -> error "Array.!: \
+ \multiply defined array element")
+ else error "Array.array: out-of-range array association"
+
+listArray :: (Ix a) => (a,a) -> [b] -> Array a b
+listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!) :: (Ix a) => Array a b -> a -> b
+(!) (MkArray _ f) = f
+
+bounds :: (Ix a) => Array a b -> (a,a)
+bounds (MkArray b _) = b
+
+indices :: (Ix a) => Array a b -> [a]
+indices = range . bounds
+
+elems :: (Ix a) => Array a b -> [b]
+elems a = [a!i | i <- indices a]
+
+assocs :: (Ix a) => Array a b -> [(a,b)]
+assocs a = [(i, a!i) | i <- indices a]
+
+(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b
+a // us = array (bounds a)
+ ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
+ ++ us)
+
+accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]
+ -> Array a b
+accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]
+ -> Array a b
+accumArray f z b = accum f (array b [(i,z) | i <- range b])
+
+ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
+ -> Array a c
+ixmap b f a = array b [(i, a ! f i) | i <- range b]
+
+instance (Ix a) => Functor (Array a) where
+ map fn (MkArray b f) = MkArray b (fn . f)
+
+#else /* STD_PRELUDE */
+
+data Ix ix => Array ix elt = Array (ix,ix) (PrimArray elt)
+data Ix ix => ByteArray ix = ByteArray (ix,ix) PrimByteArray
+data Ix ix => MutableArray s ix elt = MutableArray (ix,ix) (PrimMutableArray s elt)
+data Ix ix => MutableByteArray s ix = MutableByteArray (ix,ix) (PrimMutableByteArray s)
+
+array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
+array ixs@(ix_start, ix_end) ivs = runST (do
+ { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom
+ ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs
+ ; arr <- primUnsafeFreezeArray mut_arr
+ ; return (Array ixs arr)
+ }
+ )
+ where
+ arrEleBottom = error "(Array.!): undefined array element"
+
+listArray :: (Ix a) => (a,a) -> [b] -> Array a b
+listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!) :: (Ix a) => Array a b -> a -> b
+(Array bounds arr) ! i = primIndexArray arr (index bounds i)
+
+bounds :: (Ix a) => Array a b -> (a,a)
+bounds (Array b _) = b
+
+indices :: (Ix a) => Array a b -> [a]
+indices = range . bounds
+
+elems :: (Ix a) => Array a b -> [b]
+elems a = [a!i | i <- indices a]
+
+assocs :: (Ix a) => Array a b -> [(a,b)]
+assocs a = [(i, a!i) | i <- indices a]
+
+(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b
+a // us = array (bounds a)
+ ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
+ ++ us)
+
+accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]
+ -> Array a b
+accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]
+ -> Array a b
+accumArray f z b = accum f (array b [(i,z) | i <- range b])
+
+ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
+ -> Array a c
+ixmap b f a = array b [(i, a ! f i) | i <- range b]
+
+instance (Ix a) => Functor (Array a)
+
+
+#endif /* STD_PRELUDE */
+
+#ifdef PROVIDE_ARRAY
+data PrimArray a -- immutable arrays with Int indices
+data PrimByteArray
+
+data Ref s a -- mutable variables
+data PrimMutableArray s a -- mutable arrays with Int indices
+data PrimMutableByteArray s
+
+----------------------------------------------------------------
+-- pointer equality tests:
+----------------------------------------------------------------
+
+instance Eq (Ref s a) where (==) = primSameRef
+instance Eq (PrimMutableArray s a) where (==) = primSameMutableArray
+
+instance Eq (PrimMutableByteArray s) where (==) = primSameMutableByteArray
+
+instance (Ix ix) => Eq (MutableArray s ix elt) where
+ MutableArray _ arr1 == MutableArray _ arr2 = arr1 == arr2
+
+instance (Ix ix) => Eq (MutableByteArray s ix) where
+ MutableByteArray _ arr1 == MutableByteArray _ arr2 = arr1 == arr2
+
+#endif /* PROVIDE_ARRAYS */
+
+instance (Ix a, Eq b) => Eq (Array a b) where
+ a == a' = assocs a == assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+ a <= a' = assocs a <= assocs a'
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a = showParen (p > 9) (
+ showString "array " .
+ shows (bounds a) . showChar ' ' .
+ shows (assocs a) )
+
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+#endif /* BODY */
--- /dev/null
+#ifdef HEAD
+module Char (
+ isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ digitToInt, intToDigit,
+ toUpper, toLower,
+ ord, chr,
+ readLitChar, showLitChar, lexLitChar
+ ) where
+
+import Array -- used for character name table.
+
+import UnicodePrims -- source of primitive Unicode functions.
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+-- Character-testing operations
+isAscii, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool
+
+isAscii c = c < '\x80'
+
+isLatin1 c = c <= '\xff'
+
+-- Only ASCII Chars can be controls
+
+isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
+
+-- This function does not
+
+isPrint = primUnicodeIsPrint
+
+-- Only Latin-1 spaces recognized
+
+isSpace c = c `elem` " \t\n\r\f\v\xA0"
+
+isUpper = primUnicodeIsUpper
+
+isLower = primUnicodeIsLower
+
+isAlpha c = isUpper c || isLower c
+
+isDigit c = c >= '0' && c <= '9'
+
+isOctDigit c = c >= '0' && c <= '7'
+
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
+ c >= 'a' && c <= 'f'
+
+isAlphaNum = primUnicodeIsAlphaNum
+
+
+-- Digit conversion operations
+digitToInt :: Char -> Int
+digitToInt c
+ | isDigit c = fromEnum c - fromEnum '0'
+ | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
+ | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
+ | otherwise = error "Char.digitToInt: not a digit"
+
+intToDigit :: Int -> Char
+intToDigit i
+ | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
+ | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
+ | otherwise = error "Char.intToDigit: not a digit"
+
+
+-- Case-changing operations
+toUpper :: Char -> Char
+toUpper = primUnicodeToUpper
+
+toLower :: Char -> Char
+toLower = primUnicodeToLower
+
+-- Character code functions
+ord :: Char -> Int
+ord = fromEnum
+
+chr :: Int -> Char
+chr = toEnum
+
+-- Text functions
+readLitChar :: ReadS Char
+readLitChar ('\\':s) = readEsc s
+ where
+ readEsc ('a':s) = [('\a',s)]
+ readEsc ('b':s) = [('\b',s)]
+ readEsc ('f':s) = [('\f',s)]
+ readEsc ('n':s) = [('\n',s)]
+ readEsc ('r':s) = [('\r',s)]
+ readEsc ('t':s) = [('\t',s)]
+ readEsc ('v':s) = [('\v',s)]
+ readEsc ('\\':s) = [('\\',s)]
+ readEsc ('"':s) = [('"',s)]
+ readEsc ('\'':s) = [('\'',s)]
+ readEsc ('^':c:s) | c >= '@' && c <= '_'
+ = [(chr (ord c - ord '@'), s)]
+ readEsc s@(d:_) | isDigit d
+ = [(chr n, t) | (n,t) <- readDec s]
+ readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s]
+ readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s]
+ readEsc s@(c:_) | isUpper c
+ = let table = ('\DEL', "DEL") : assocs asciiTab
+ in case [(c,s') | (c, mne) <- table,
+ ([],s') <- [match mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ readEsc _ = []
+readLitChar (c:s) = [(c,s)]
+
+showLitChar :: Char -> ShowS
+showLitChar c | c > '\DEL' = showChar '\\' .
+ protectEsc isDigit (shows (ord c))
+showLitChar '\DEL' = showString "\\DEL"
+showLitChar '\\' = showString "\\\\"
+showLitChar c | c >= ' ' = showChar c
+showLitChar '\a' = showString "\\a"
+showLitChar '\b' = showString "\\b"
+showLitChar '\f' = showString "\\f"
+showLitChar '\n' = showString "\\n"
+showLitChar '\r' = showString "\\r"
+showLitChar '\t' = showString "\\t"
+showLitChar '\v' = showString "\\v"
+showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO")
+showLitChar c = showString ('\\' : asciiTab!c)
+
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+
+match :: (Eq a) => [a] -> [a] -> ([a],[a])
+match (x:xs) (y:ys) | x == y = match xs ys
+match xs ys = (xs,ys)
+
+asciiTab = listArray ('\NUL', ' ')
+ ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
+ "SP"]
+
+lexLitChar :: ReadS String
+lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
+ where
+ lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
+ lexEsc s@(d:_) | isDigit d = lexDigits s
+ lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
+ -- Very crude approximation to \XYZ. Let readers work this out.
+ lexEsc s@(c:_) | isUpper c = [span isCharName s]
+ lexEsc _ = []
+ isCharName c = isUpper c || isDigit c
+
+lexLitChar (c:s) = [([c],s)]
+lexLitChar "" = []
+
+#endif /* BODY */
--- /dev/null
+
+module Complex(Complex((:+)), realPart, imagPart, conjugate, mkPolar,
+ cis, polar, magnitude, phase) where
+
+infix 6 :+
+
+data (RealFloat a) => Complex a = !a :+ !a deriving (Eq,Read,Show)
+
+
+realPart, imagPart :: (RealFloat a) => Complex a -> a
+realPart (x:+y) = x
+imagPart (x:+y) = y
+
+conjugate :: (RealFloat a) => Complex a -> Complex a
+conjugate (x:+y) = x :+ (-y)
+
+mkPolar :: (RealFloat a) => a -> a -> Complex a
+mkPolar r theta = r * cos theta :+ r * sin theta
+
+cis :: (RealFloat a) => a -> Complex a
+cis theta = cos theta :+ sin theta
+
+polar :: (RealFloat a) => Complex a -> (a,a)
+polar z = (magnitude z, phase z)
+
+magnitude, phase :: (RealFloat a) => Complex a -> a
+magnitude (x:+y) = scaleFloat k
+ (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
+ where k = max (exponent x) (exponent y)
+ mk = - k
+
+phase (x:+y) = atan2 y x
+
+
+instance (RealFloat a) => Num (Complex a) where
+ (x:+y) + (x':+y') = (x+x') :+ (y+y')
+ (x:+y) - (x':+y') = (x-x') :+ (y-y')
+ (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x')
+ negate (x:+y) = negate x :+ negate y
+ abs z = magnitude z :+ 0
+ signum 0 = 0
+ signum z@(x:+y) = x/r :+ y/r where r = magnitude z
+ fromInteger n = fromInteger n :+ 0
+
+instance (RealFloat a) => Fractional (Complex a) where
+ (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
+ where x'' = scaleFloat k x'
+ y'' = scaleFloat k y'
+ k = - max (exponent x') (exponent y')
+ d = x'*x'' + y'*y''
+
+ fromRational a = fromRational a :+ 0
+
+instance (RealFloat a) => Floating (Complex a) where
+ pi = pi :+ 0
+ exp (x:+y) = expx * cos y :+ expx * sin y
+ where expx = exp x
+ log z = log (magnitude z) :+ phase z
+
+ sqrt 0 = 0
+ sqrt z@(x:+y) = u :+ (if y < 0 then -v else v)
+ where (u,v) = if x < 0 then (v',u') else (u',v')
+ v' = abs y / (u'*2)
+ u' = sqrt ((magnitude z + abs x) / 2)
+
+ sin (x:+y) = sin x * cosh y :+ cos x * sinh y
+ cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y)
+ tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
+ where sinx = sin x
+ cosx = cos x
+ sinhy = sinh y
+ coshy = cosh y
+
+ sinh (x:+y) = cos y * sinh x :+ sin y * cosh x
+ cosh (x:+y) = cos y * cosh x :+ sin y * sinh x
+ tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
+ where siny = sin y
+ cosy = cos y
+ sinhx = sinh x
+ coshx = cosh x
+
+ asin z@(x:+y) = y':+(-x')
+ where (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
+ acos z@(x:+y) = y'':+(-x'')
+ where (x'':+y'') = log (z + ((-y'):+x'))
+ (x':+y') = sqrt (1 - z*z)
+ atan z@(x:+y) = y':+(-x')
+ where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
+
+ asinh z = log (z + sqrt (1+z*z))
+ acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1)))
+ atanh z = log ((1+z) / sqrt (1-z*z))
--- /dev/null
+module Directory (
+ createDirectory, removeDirectory, removeFile,
+ renameDirectory, renameFile, getDirectoryContents,
+ getCurrentDirectory, setCurrentDirectory ) where
+
+createDirectory :: FilePath -> IO ()
+removeDirectory :: FilePath -> IO ()
+removeFile :: FilePath -> IO ()
+renameDirectory :: FilePath -> FilePath -> IO ()
+renameFile :: FilePath -> FilePath -> IO ()
+getDirectoryContents :: FilePath -> IO [FilePath]
+getCurrentDirectory :: IO FilePath
+setCurrentDirectory :: FilePath -> IO ()
+
+
+
+
--- /dev/null
+module IO (
+ Handle, HandlePosn,
+ IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
+ BufferMode(NoBuffering,LineBuffering,BlockBuffering),
+ SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
+ stdin, stdout, stderr, openFile, hClose, hFileSize, hIsEOF, isEOF,
+ hSetBuffering, hGetBuffering, hFlush, hGetPosn, hSetPosn, hSeek,
+ hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, hReady,
+ hGetChar, hLookAhead, hGetContents, hPutChar, hPutStr, hPrint,
+ isAlreadyExistsError, isAlreadyInUseError, isFullError, isEOFError,
+ isIllegalOperation, isPermissionError, isUserError,
+ ioeGetHandle, ioeGetFileName ) where
+import Ix
+
+data Handle = ...
+instance Eq Handle where ...
+data HandlePosn = ...
+instance Eq HandlePosn where ...
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+ deriving (Eq, Ord, Read, Show)
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+stdin, stdout, stderr :: Handle
+openFile :: FilePath -> IOMode -> IO Handle
+hClose :: Handle -> IO ()
+hFileSize :: Handle -> IO Integer
+hIsEOF :: Handle -> IO Bool
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+hSetBuffering :: Handle -> BufferMode -> IO ()
+hGetBuffering :: Handle -> IO BufferMode
+hFlush :: Handle -> IO ()
+hGetPosn :: Handle -> IO HandlePosn
+hSetPosn :: HandlePosn -> IO ()
+hSeek :: Handle -> SeekMode -> Integer -> IO ()
+hIsOpen :: Handle -> IO Bool
+hIsClosed :: Handle -> IO Bool
+hIsReadable :: Handle -> IO Bool
+hIsWritable :: Handle -> IO Bool
+hIsSeekable :: Handle -> IO Bool
+hReady :: Handle -> IO Bool
+
+try :: IO a -> IO (Either IOError a)
+try f = catch (do r <- f
+ return (Right r))
+ (return . Left)
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after m = do
+ x <- before
+ rs <- try (m x)
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> fail e
+
+-- variant of the above where middle computation doesn't want x
+bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
+bracket_ before after m = do
+ x <- before
+ rs <- try m
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> fail e
--- /dev/null
+-----------------------------------------------------------------------------
+-- Signed Integers
+-- Suitable for use with Hugs 1.4 on 32 bit systems.
+-----------------------------------------------------------------------------
+
+module Int
+ ( Int8
+ , Int16
+ , Int32
+ --, Int64
+ , int8ToInt -- :: Int8 -> Int
+ , intToInt8 -- :: Int -> Int8
+ , int16ToInt -- :: Int16 -> Int
+ , intToInt16 -- :: Int -> Int16
+ , int32ToInt -- :: Int32 -> Int
+ , intToInt32 -- :: Int -> Int32
+ -- plus Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
+ -- Show and Bits instances for each of Int8, Int16 and Int32
+ ) where
+
+import PreludeBuiltin
+import Bits
+
+-----------------------------------------------------------------------------
+-- The "official" coercion functions
+-----------------------------------------------------------------------------
+
+int8ToInt :: Int8 -> Int
+intToInt8 :: Int -> Int8
+int16ToInt :: Int16 -> Int
+intToInt16 :: Int -> Int16
+int32ToInt :: Int32 -> Int
+intToInt32 :: Int -> Int32
+
+-- And some non-exported ones
+
+int8ToInt16 :: Int8 -> Int16
+int8ToInt32 :: Int8 -> Int32
+int16ToInt8 :: Int16 -> Int8
+int16ToInt32 :: Int16 -> Int32
+int32ToInt8 :: Int32 -> Int8
+int32ToInt16 :: Int32 -> Int16
+
+int8ToInt16 = I16 . int8ToInt
+int8ToInt32 = I32 . int8ToInt
+int16ToInt8 = I8 . int16ToInt
+int16ToInt32 = I32 . int16ToInt
+int32ToInt8 = I8 . int32ToInt
+int32ToInt16 = I16 . int32ToInt
+
+-----------------------------------------------------------------------------
+-- Int8
+-----------------------------------------------------------------------------
+
+newtype Int8 = I8 Int
+
+int8ToInt (I8 x) = if x' <= 0x7f then x' else x' - 0x100
+ where x' = x `primAndInt` 0xff
+intToInt8 = I8
+
+instance Eq Int8 where (==) = binop (==)
+instance Ord Int8 where compare = binop compare
+
+instance Num Int8 where
+ x + y = to (binop (+) x y)
+ x - y = to (binop (-) x y)
+ negate = to . negate . from
+ x * y = to (binop (*) x y)
+ abs = absReal
+ signum = signumReal
+ fromInteger = to . fromInteger
+ fromInt = to
+
+instance Bounded Int8 where
+ minBound = 0x80
+ maxBound = 0x7f
+
+instance Real Int8 where
+ toRational x = toInteger x % 1
+
+instance Integral Int8 where
+ x `div` y = to (binop div x y)
+ x `quot` y = to (binop quot x y)
+ x `rem` y = to (binop rem x y)
+ x `mod` y = to (binop mod x y)
+ x `quotRem` y = to2 (binop quotRem x y)
+ toInteger = toInteger . from
+ toInt = toInt . from
+
+instance Ix Int8 where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = from (i - m)
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Int8 where
+ toEnum = to
+ fromEnum = from
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int8)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int8)]
+ where last = if d < c then minBound else maxBound
+
+instance Read Int8 where
+ readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
+
+instance Show Int8 where
+ showsPrec p = showsPrec p . from
+
+binop8 :: (Int32 -> Int32 -> a) -> (Int8 -> Int8 -> a)
+binop8 op x y = int8ToInt32 x `op` int8ToInt32 y
+
+instance Bits Int8 where
+ x .&. y = int32ToInt8 (binop8 (.&.) x y)
+ x .|. y = int32ToInt8 (binop8 (.|.) x y)
+ x `xor` y = int32ToInt8 (binop8 xor x y)
+ complement = int32ToInt8 . complement . int8ToInt32
+ x `shift` i = int32ToInt8 (int8ToInt32 x `shift` i)
+-- rotate
+ bit = int32ToInt8 . bit
+ setBit x i = int32ToInt8 (setBit (int8ToInt32 x) i)
+ clearBit x i = int32ToInt8 (clearBit (int8ToInt32 x) i)
+ complementBit x i = int32ToInt8 (complementBit (int8ToInt32 x) i)
+ testBit x i = testBit (int8ToInt32 x) i
+ bitSize _ = 8
+ isSigned _ = True
+
+-----------------------------------------------------------------------------
+-- Int16
+-----------------------------------------------------------------------------
+
+newtype Int16 = I16 Int
+
+int16ToInt (I16 x) = if x' <= 0x7fff then x' else x' - 0x10000
+ where x' = x `primAndInt` 0xffff
+intToInt16 = I16
+
+instance Eq Int16 where (==) = binop (==)
+instance Ord Int16 where compare = binop compare
+
+instance Num Int16 where
+ x + y = to (binop (+) x y)
+ x - y = to (binop (-) x y)
+ negate = to . negate . from
+ x * y = to (binop (*) x y)
+ abs = absReal
+ signum = signumReal
+ fromInteger = to . fromInteger
+ fromInt = to
+
+instance Bounded Int16 where
+ minBound = 0x8000
+ maxBound = 0x7fff
+
+instance Real Int16 where
+ toRational x = toInteger x % 1
+
+instance Integral Int16 where
+ x `div` y = to (binop div x y)
+ x `quot` y = to (binop quot x y)
+ x `rem` y = to (binop rem x y)
+ x `mod` y = to (binop mod x y)
+ x `quotRem` y = to2 (binop quotRem x y)
+ toInteger = toInteger . from
+ toInt = toInt . from
+
+instance Ix Int16 where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = from (i - m)
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Int16 where
+ toEnum = to
+ fromEnum = from
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int16)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int16)]
+ where last = if d < c then minBound else maxBound
+
+instance Read Int16 where
+ readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
+
+instance Show Int16 where
+ showsPrec p = showsPrec p . from
+
+binop16 :: (Int32 -> Int32 -> a) -> (Int16 -> Int16 -> a)
+binop16 op x y = int16ToInt32 x `op` int16ToInt32 y
+
+instance Bits Int16 where
+ x .&. y = int32ToInt16 (binop16 (.&.) x y)
+ x .|. y = int32ToInt16 (binop16 (.|.) x y)
+ x `xor` y = int32ToInt16 (binop16 xor x y)
+ complement = int32ToInt16 . complement . int16ToInt32
+ x `shift` i = int32ToInt16 (int16ToInt32 x `shift` i)
+-- rotate
+ bit = int32ToInt16 . bit
+ setBit x i = int32ToInt16 (setBit (int16ToInt32 x) i)
+ clearBit x i = int32ToInt16 (clearBit (int16ToInt32 x) i)
+ complementBit x i = int32ToInt16 (complementBit (int16ToInt32 x) i)
+ testBit x i = testBit (int16ToInt32 x) i
+ bitSize _ = 16
+ isSigned _ = True
+
+-----------------------------------------------------------------------------
+-- Int32
+-----------------------------------------------------------------------------
+
+newtype Int32 = I32 Int
+
+int32ToInt (I32 x) = x
+intToInt32 = I32
+
+instance Eq Int32 where (==) = binop (==)
+instance Ord Int32 where compare = binop compare
+
+instance Num Int32 where
+ x + y = to (binop (+) x y)
+ x - y = to (binop (-) x y)
+ negate = to . negate . from
+ x * y = to (binop (*) x y)
+ abs = absReal
+ signum = signumReal
+ fromInteger = to . fromInteger
+ fromInt = to
+
+instance Bounded Int32 where
+ minBound = to minBound
+ maxBound = to maxBound
+
+instance Real Int32 where
+ toRational x = toInteger x % 1
+
+instance Integral Int32 where
+ x `div` y = to (binop div x y)
+ x `quot` y = to (binop quot x y)
+ x `rem` y = to (binop rem x y)
+ x `mod` y = to (binop mod x y)
+ x `quotRem` y = to2 (binop quotRem x y)
+ toInteger = toInteger . from
+ toInt = toInt . from
+
+instance Ix Int32 where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = from (i - m)
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Int32 where
+ toEnum = to
+ fromEnum = from
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int32)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int32)]
+ where last = if d < c then minBound else maxBound
+
+instance Read Int32 where
+ readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
+
+instance Show Int32 where
+ showsPrec p = showsPrec p . from
+
+instance Bits Int32 where
+ (.&.) = lift2 primAndInt
+ (.|.) = lift2 primOrInt
+ xor = lift2 primXorInt
+ complement = lift1 primNotInt
+ shift x n
+ | n >= 0 = to (primShiftLInt (from x) (primIntToWord n))
+ | otherwise = to (primShiftRLInt (from x) (primIntToWord (-n)))
+-- rotate
+ bit = shift 1
+ setBit x i = x .|. bit i
+ clearBit x i = x .&. complement (bit i)
+ complementBit x i = x `xor` bit i
+ testBit x i = x .&. bit i /= 0
+ bitSize _ = 32
+ isSigned _ = True
+
+-----------------------------------------------------------------------------
+-- End of exported definitions
+--
+-- The remainder of this file consists of definitions which are only
+-- used in the implementation.
+-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+-- Coercions - used to make the instance declarations more uniform
+-----------------------------------------------------------------------------
+
+class Coerce a where
+ to :: Int -> a
+ from :: a -> Int
+
+instance Coerce Int32 where
+ from = int32ToInt
+ to = intToInt32
+
+instance Coerce Int8 where
+ from = int8ToInt
+ to = intToInt8
+
+instance Coerce Int16 where
+ from = int16ToInt
+ to = intToInt16
+
+binop :: Coerce int => (Int -> Int -> a) -> (int -> int -> a)
+binop op x y = from x `op` from y
+
+to2 :: Coerce int => (Int, Int) -> (int, int)
+to2 (x,y) = (to x, to y)
+
+lift1 :: Coerce int => (Int -> Int) -> (int -> int)
+lift1 f x = to (f (from x))
+
+lift2 :: Coerce int => (Int -> Int -> Int) -> (int -> int -> int)
+lift2 f x y = to (f (from x) (from y))
+
+-----------------------------------------------------------------------------
+-- Code copied from the Prelude
+-----------------------------------------------------------------------------
+
+absReal x | x >= 0 = x
+ | otherwise = -x
+
+signumReal x | x == 0 = 0
+ | x > 0 = 1
+ | otherwise = -1
+
+-----------------------------------------------------------------------------
+-- End
+-----------------------------------------------------------------------------
--- /dev/null
+#ifdef HEAD
+module Ix ( Ix(range, index, inRange), rangeSize ) where
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+class (Show a, Ord a) => Ix a where
+ range :: (a,a) -> [a]
+ index :: (a,a) -> a -> Int
+ inRange :: (a,a) -> a -> Bool
+
+rangeSize :: Ix a => (a,a) -> Int
+rangeSize b@(l,h) | l > h = 0
+ | otherwise = index b h + 1
+
+#if STD_PRELUDE
+#else
+instance Ix Bool where
+ range (c,c') = [c..c']
+ index b@(c,c') ci
+ | inRange b ci = fromEnum ci - fromEnum c
+ | otherwise = error "Ix.index.Bool: Index out of range."
+ inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
+ where i = fromEnum ci
+#endif
+
+instance Ix Char where
+ range (c,c') = [c..c']
+ index b@(c,c') ci
+ | inRange b ci = fromEnum ci - fromEnum c
+ | otherwise = error "Ix.index.Char: Index out of range."
+ inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
+ where i = fromEnum ci
+
+instance Ix Int where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = i - m
+ | otherwise = error "Ix.index.Int: Index out of range."
+ inRange (m,n) i = m <= i && i <= n
+
+#ifdef PROVIDE_INTEGER
+instance Ix Integer where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+#if STD_PRELUDE
+ | inRange b i = fromInteger (i - m)
+#else
+ /* fromInteger may not have an Integer arg :-) */
+ | inRange b i = toInt (i - m)
+#endif
+ | otherwise = error "Ix.index.Integer: Index out of range."
+ inRange (m,n) i = m <= i && i <= n
+#endif
+
+#if STD_PRELUDE
+instance (Ix a,Ix b) => Ix (a, b) -- as derived, for all tuples
+instance Ix Bool -- as derived
+instance Ix Ordering -- as derived
+instance Ix () -- as derived
+#else
+-- #error "Missing Ix instances"
+#endif
+
+#endif /* BODY */
\ No newline at end of file
--- /dev/null
+#ifdef HEAD
+module List (
+ elemIndex, elemIndices,
+ find, findIndex, findIndices,
+ nub, nubBy, delete, deleteBy, (\\),
+ union, unionBy, intersect, intersectBy,
+ intersperse, transpose, partition, group, groupBy,
+ inits, tails, isPrefixOf, isSuffixOf,
+ mapAccumL, mapAccumR,
+ sort, sortBy, insertBy, maximumBy, minimumBy,
+ genericLength, genericTake, genericDrop,
+ genericSplitAt, genericIndex, genericReplicate,
+ zip4, zip5, zip6, zip7,
+ zipWith4, zipWith5, zipWith6, zipWith7,
+ unzip4, unzip5, unzip6, unzip7
+ ) where
+
+#if STD_PRELUDE
+import Maybe( listToMaybe )
+
+infix 5 \\
+#else
+import PreludeBuiltin
+#endif
+#endif /* HEAD */
+#ifdef BODY
+
+elemIndex :: Eq a => a -> [a] -> Maybe Int
+elemIndex x = findIndex (x ==)
+
+elemIndices :: Eq a => a -> [a] -> [Int]
+elemIndices x = findIndices (x ==)
+
+find :: (a -> Bool) -> [a] -> Maybe a
+find p = listToMaybe . filter p
+
+findIndex :: (a -> Bool) -> [a] -> Maybe Int
+findIndex p = listToMaybe . findIndices p
+
+findIndices :: (a -> Bool) -> [a] -> [Int]
+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ]
+
+nub :: (Eq a) => [a] -> [a]
+nub = nubBy (==)
+
+nubBy :: (a -> a -> Bool) -> [a] -> [a]
+nubBy eq [] = []
+nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs)
+
+delete :: (Eq a) => a -> [a] -> [a]
+delete = deleteBy (==)
+
+deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
+deleteBy eq x [] = []
+deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys
+
+(\\) :: (Eq a) => [a] -> [a] -> [a]
+(\\) = foldl (flip delete)
+
+deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteFirstsBy eq = foldl (flip (deleteBy eq))
+
+union :: (Eq a) => [a] -> [a] -> [a]
+union = unionBy (==)
+
+unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
+
+intersect :: (Eq a) => [a] -> [a] -> [a]
+intersect = intersectBy (==)
+
+intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]
+
+intersperse :: a -> [a] -> [a]
+intersperse sep [] = []
+intersperse sep [x] = [x]
+intersperse sep (x:xs) = x : sep : intersperse sep xs
+
+#if 1
+transpose :: [[a]] -> [[a]]
+transpose = foldr
+ (\xs xss -> zipWith (:) xs (xss ++ repeat []))
+ []
+#else
+-- This variant was posted to the haskell mailing list
+-- by Jonas Holmerin <md93-jho@nada.kth.se> on 31 Mar 1998.
+-- He claims that it is more symmetric since it can handle
+-- transpose (repeat [1..5])
+-- as well as finite lists of infinite lists such as
+-- transpose (map repeat [1..5])
+transpose :: [[a]] -> [[a]]
+transpose = foldr
+ (\xs xss -> zipLazier (:) xs (xss ++ repeat []))
+ []
+ where
+ zipLazier f (x:xs) xss = f x (head xss) : zipLazier f xs (tail xss)
+ zipLazier _ _ _ = []
+#endif
+
+partition :: (a -> Bool) -> [a] -> ([a],[a])
+partition p xs = foldr select ([],[]) xs
+ where select x (ts,fs) | p x = (x:ts,fs)
+ | otherwise = (ts, x:fs)
+
+-- group splits its list argument into a list of lists of equal, adjacent
+-- elements. e.g.,
+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]
+group :: (Eq a) => [a] -> [[a]]
+group = groupBy (==)
+
+groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
+groupBy eq [] = []
+groupBy eq (x:xs) = (x:ys) : groupBy eq zs
+ where (ys,zs) = span (eq x) xs
+
+-- inits xs returns the list of initial segments of xs, shortest first.
+-- e.g., inits "abc" == ["","a","ab","abc"]
+inits :: [a] -> [[a]]
+inits [] = [[]]
+inits (x:xs) = [[]] ++ map (x:) (inits xs)
+
+-- tails xs returns the list of all final segments of xs, longest first.
+-- e.g., tails "abc" == ["abc","bc","c",""]
+tails :: [a] -> [[a]]
+tails [] = [[]]
+tails xxs@(_:xs) = xxs : tails xs
+
+isPrefixOf :: (Eq a) => [a] -> [a] -> Bool
+isPrefixOf [] _ = True
+isPrefixOf _ [] = False
+isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys
+
+isSuffixOf :: (Eq a) => [a] -> [a] -> Bool
+isSuffixOf x y = reverse x `isPrefixOf` reverse y
+
+mapAccumL :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccumL f s [] = (s, [])
+mapAccumL f s (x:xs) = (s'',y:ys)
+ where (s', y ) = f s x
+ (s'',ys) = mapAccumL f s' xs
+
+mapAccumR :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccumR f s [] = (s, [])
+mapAccumR f s (x:xs) = (s'', y:ys)
+ where (s'',y ) = f s' x
+ (s', ys) = mapAccumR f s xs
+
+sort :: (Ord a) => [a] -> [a]
+sort = sortBy compare
+
+sortBy :: (a -> a -> Ordering) -> [a] -> [a]
+sortBy cmp = foldr (insertBy cmp) []
+
+insert :: Ord a => a -> [a] -> [a]
+insert = insertBy compare
+
+insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
+insertBy cmp x [] = [x]
+insertBy cmp x ys@(y:ys')
+ = case cmp x y of
+ GT -> y : insertBy cmp x ys'
+ _ -> x : ys
+
+maximumBy :: (a -> a -> a) -> [a] -> a
+maximumBy max [] = error "List.maximumBy: empty list"
+maximumBy max xs = foldl1 max xs
+
+minimumBy :: (a -> a -> a) -> [a] -> a
+minimumBy min [] = error "List.minimumBy: empty list"
+minimumBy min xs = foldl1 min xs
+
+genericLength :: (Integral a) => [b] -> a
+genericLength [] = 0
+genericLength (x:xs) = 1 + genericLength xs
+
+genericTake :: (Integral a) => a -> [b] -> [b]
+genericTake _ [] = []
+genericTake n (x:xs)
+ | n > 0 = x : genericTake (n-1) xs
+ | otherwise = error "List.genericTake: negative argument"
+
+genericDrop :: (Integral a) => a -> [b] -> [b]
+genericDrop 0 xs = xs
+genericDrop _ [] = []
+genericDrop n (_:xs)
+ | n > 0 = genericDrop (n-1) xs
+ | otherwise = error "List.genericDrop: negative argument"
+
+genericSplitAt :: (Integral a) => a -> [b] -> ([b],[b])
+genericSplitAt 0 xs = ([],xs)
+genericSplitAt _ [] = ([],[])
+genericSplitAt n (x:xs)
+ | n > 0 = (x:xs',xs'')
+ | otherwise = error "List.genericSplitAt: negative argument"
+ where (xs',xs'') = genericSplitAt (n-1) xs
+
+genericIndex :: (Integral a) => [b] -> a -> b
+genericIndex (x:_) 0 = x
+genericIndex (_:xs) n
+ | n > 0 = genericIndex xs (n-1)
+ | otherwise = error "List.genericIndex: negative argument"
+genericIndex _ _ = error "List.genericIndex: index too large"
+
+genericReplicate :: (Integral a) => a -> b -> [b]
+genericReplicate n x = genericTake n (repeat x)
+
+zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
+zip4 = zipWith4 (,,,)
+
+zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
+zip5 = zipWith5 (,,,,)
+
+zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+ [(a,b,c,d,e,f)]
+zip6 = zipWith6 (,,,,,)
+
+zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+ [g] -> [(a,b,c,d,e,f,g)]
+zip7 = zipWith7 (,,,,,,)
+
+zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
+ = z a b c d : zipWith4 z as bs cs ds
+zipWith4 _ _ _ _ _ = []
+
+zipWith5 :: (a->b->c->d->e->f) ->
+ [a]->[b]->[c]->[d]->[e]->[f]
+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
+ = z a b c d e : zipWith5 z as bs cs ds es
+zipWith5 _ _ _ _ _ _ = []
+
+zipWith6 :: (a->b->c->d->e->f->g) ->
+ [a]->[b]->[c]->[d]->[e]->[f]->[g]
+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
+ = z a b c d e f : zipWith6 z as bs cs ds es fs
+zipWith6 _ _ _ _ _ _ _ = []
+
+zipWith7 :: (a->b->c->d->e->f->g->h) ->
+ [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
+ = z a b c d e f g : zipWith7 z as bs cs ds es fs gs
+zipWith7 _ _ _ _ _ _ _ _ = []
+
+unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
+unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
+ (a:as,b:bs,c:cs,d:ds))
+ ([],[],[],[])
+
+unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
+unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
+ (a:as,b:bs,c:cs,d:ds,e:es))
+ ([],[],[],[],[])
+
+unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
+unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
+ (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
+ ([],[],[],[],[],[])
+
+unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
+unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
+ (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
+ ([],[],[],[],[],[],[])
+
+#endif /* BODY */
\ No newline at end of file
--- /dev/null
+#ifdef HEAD
+module Maybe(
+ isJust, fromJust, fromMaybe, listToMaybe, maybeToList,
+ catMaybes, mapMaybe, unfoldr ) where
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+isJust :: Maybe a -> Bool
+isJust (Just a) = True
+isJust Nothing = False
+
+fromJust :: Maybe a -> a
+fromJust (Just a) = a
+fromJust Nothing = error "Maybe.fromJust: Nothing"
+
+fromMaybe :: a -> Maybe a -> a
+fromMaybe d Nothing = d
+fromMaybe d (Just a) = a
+
+maybeToList :: Maybe a -> [a]
+maybeToList Nothing = []
+maybeToList (Just a) = [a]
+
+listToMaybe :: [a] -> Maybe a
+listToMaybe [] = Nothing
+listToMaybe (a:_) = Just a
+
+catMaybes :: [Maybe a] -> [a]
+catMaybes ms = [ m | Just m <- ms ]
+
+mapMaybe :: (a -> Maybe b) -> [a] -> [b]
+mapMaybe f = catMaybes . map f
+
+unfoldr :: ([a] -> Maybe ([a], a)) -> [a] -> ([a],[a])
+unfoldr f x =
+ case f x of
+ Just (x',y) -> let (ys,x'') = unfoldr f x' in (x'',y:ys)
+ Nothing -> (x,[])
+
+#endif /* BODY */
--- /dev/null
+module Monad (
+ join, mapAndUnzipM, zipWithM, zipWithM_, foldM, when, unless, ap,
+ liftM, liftM2, liftM3, liftM4, liftM5
+ ) where
+
+join :: (Monad m) => m (m a) -> m a
+join x = x >>= id
+
+mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
+mapAndUnzipM f xs = accumulate (map f xs) >>= return . unzip
+
+zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+zipWithM f xs ys = accumulate (zipWith f xs ys)
+
+zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
+zipWithM_ f xs ys = sequence (zipWith f xs ys)
+
+foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
+foldM f a [] = return a
+foldM f a (x:xs) = f a x >>= \ y -> foldM f y xs
+
+when :: (Monad m) => Bool -> m () -> m ()
+when p s = if p then s else return ()
+
+unless :: (Monad m) => Bool -> m () -> m ()
+unless p s = when (not p) s
+
+ap :: (Monad m) => m (a -> b) -> m a -> m b
+ap = liftM2 ($)
+
+#if STD_PRELUDE
+liftM :: (Monad m) => (a -> b) -> (m a -> m b)
+liftM f = \a -> [f a' | a' <- a]
+
+liftM2 :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
+liftM2 f = \a b -> [f a' b' | a' <- a, b' <- b]
+
+liftM3 :: (Monad m) => (a -> b -> c -> d) ->
+ (m a -> m b -> m c -> m d)
+liftM3 f = \a b c -> [f a' b' c' | a' <- a, b' <- b, c' <- c]
+
+liftM4 :: (Monad m) => (a -> b -> c -> d -> e) ->
+ (m a -> m b -> m c -> m d -> m e)
+liftM4 f = \a b c d -> [f a' b' c' d' |
+ a' <- a, b' <- b, c' <- c, d' <- d]
+
+liftM5 :: (Monad m) => (a -> b -> c -> d -> e -> f) ->
+ (m a -> m b -> m c -> m d -> m e -> m f)
+liftM5 f = \a b c d e -> [f a' b' c' d' e' |
+ a' <- a, b' <- b,
+ c' <- c, d' <- d, e' <- e]
+#else
+liftM :: (Monad m) => (a -> b) -> (m a -> m b)
+liftM f = \a -> do { a' <- a; return (f a') }
+
+liftM2 :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
+liftM2 f = \a b -> do { a' <- a; b' <- b; return (f a' b') }
+
+liftM3 :: (Monad m) => (a -> b -> c -> d) ->
+ (m a -> m b -> m c -> m d)
+liftM3 f = \a b c -> do { a' <- a; b' <- b; c' <- c
+ ; return (f a' b' c')
+ }
+
+liftM4 :: (Monad m) => (a -> b -> c -> d -> e) ->
+ (m a -> m b -> m c -> m d -> m e)
+liftM4 f = \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d
+ ; return (f a' b' c' d')
+ }
+
+
+liftM5 :: (Monad m) => (a -> b -> c -> d -> e -> f) ->
+ (m a -> m b -> m c -> m d -> m e -> m f)
+liftM5 f = \a b c d e -> do { a' <- a; b' <- b
+ ; c' <- c; d' <- d; e' <- e
+ ; return (f a' b' c' d' e')
+ }
+
+#endif
\ No newline at end of file
--- /dev/null
+#ifdef HEAD
+module Numeric(fromRat,
+ showSigned, showInt,
+ readSigned, readInt,
+ readDec, readOct, readHex,
+ floatToDigits,
+ showEFloat, showFFloat, showGFloat, showFloat,
+ readFloat, lexDigits) where
+
+import Char
+import Array
+
+import PreludeBuiltin
+#endif
+#ifdef BODY
+
+-- This converts a rational to a floating. This should be used in the
+-- Fractional instances of Float and Double.
+
+fromRat :: (RealFloat a) => Rational -> a
+fromRat x =
+ if x == 0 then encodeFloat 0 0 -- Handle exceptional cases
+ else if x < 0 then - fromRat' (-x) -- first.
+ else fromRat' x
+
+-- Conversion process:
+-- Scale the rational number by the RealFloat base until
+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
+-- Then round the rational to an Integer and encode it with the exponent
+-- that we got from the scaling.
+-- To speed up the scaling process we compute the log2 of the number to get
+-- a first guess of the exponent.
+fromRat' :: (RealFloat a) => Rational -> a
+fromRat' x = r
+ where b = floatRadix r
+ p = floatDigits r
+ (minExp0, _) = floatRange r
+ minExp = minExp0 - p -- the real minimum exponent
+ xMin = toRational (expt b (p-1))
+ xMax = toRational (expt b p)
+ p0 = (integerLogBase b (numerator x) -
+ integerLogBase b (denominator x) - p) `max` minExp
+ f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+ (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+ r = encodeFloat (round x') p'
+
+-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
+scaleRat :: Rational -> Int -> Rational -> Rational ->
+ Int -> Rational -> (Rational, Int)
+scaleRat b minExp xMin xMax p x
+ | p <= minExp = (x, p)
+ | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b)
+ | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b)
+ | otherwise = (x, p)
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
+expt :: BIGNUMTYPE -> Int -> BIGNUMTYPE
+expt base n =
+ if base == 2 && n >= minExpt && n <= maxExpt then
+ expts!n
+ else
+ base^n
+
+expts :: Array Int BIGNUMTYPE
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+
+-- Compute the (floor of the) log of i in base b.
+-- Simplest way would be just divide i by b until it's smaller then b,
+-- but that would be very slow! We are just slightly more clever.
+integerLogBase :: BIGNUMTYPE -> BIGNUMTYPE -> Int
+integerLogBase b i =
+ if i < b then
+ 0
+ else
+ -- Try squaring the base first to cut down the number of divisions.
+ let l = 2 * integerLogBase (b*b) i
+ doDiv :: BIGNUMTYPE -> Int -> Int
+ doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
+ in doDiv (i `div` (b^l)) l
+
+
+-- Misc utilities to show integers and floats
+
+showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x | x < 0 = showParen (p > 6)
+ (showChar '-' . showPos (-x))
+ | otherwise = showPos x
+
+-- showInt is used for positive numbers only
+showInt :: Integral a => a -> ShowS
+showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"
+ | otherwise =
+ let (n',d) = quotRem n 10
+ r' = toEnum (fromEnum '0' + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+
+
+readSigned :: (Real a) => ReadS a -> ReadS a
+readSigned readPos = readParen False read'
+ where read' r = read'' r ++
+ [(-x,t) | ("-",s) <- lex r,
+ (x,t) <- read'' s]
+ read'' r = [(n,s) | (str,s) <- lex r,
+ (n,"") <- readPos str]
+
+
+-- readInt reads a string of digits using an arbitrary base.
+-- Leading minus signs must be handled elsewhere.
+
+readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+ [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
+ | (ds,r) <- nonnull isDig s ]
+
+-- Unsigned readers for various bases
+readDec, readOct, readHex :: (Integral a) => ReadS a
+readDec = readInt 10 isDigit digitToInt
+readOct = readInt 8 isOctDigit digitToInt
+readHex = readInt 16 isHexDigit digitToInt
+
+
+showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFloat :: (RealFloat a) => a -> ShowS
+
+showEFloat d x = showString (formatRealFloat FFExponent d x)
+showFFloat d x = showString (formatRealFloat FFFixed d x)
+showGFloat d x = showString (formatRealFloat FFGeneric d x)
+showFloat = showGFloat Nothing
+
+-- These are the format types. This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x = s
+ where base = 10
+ s = if isNaN x then
+ "NaN"
+ else if isInfinite x then
+ if x < 0 then "-Infinity" else "Infinity"
+ else if x < 0 || isNegativeZero x then
+ '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
+ else
+ doFmt fmt (floatToDigits (toInteger base) x)
+ doFmt fmt (is, e) =
+ let ds = map intToDigit is
+ in case fmt of
+ FFGeneric ->
+ doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
+ (is, e)
+ FFExponent ->
+ case decs of
+ Nothing ->
+ case ds of
+ ['0'] -> "0.0e0"
+ [d] -> d : ".0e" ++ show (e-1)
+ d:ds -> d : '.' : ds ++ 'e':show (e-1)
+ Just dec ->
+ let dec' = max dec 1 in
+ case is of
+ [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
+ _ ->
+ let (ei, is') = roundTo base (dec'+1) is
+ d:ds = map intToDigit
+ (if ei > 0 then init is' else is')
+ in d:'.':ds ++ "e" ++ show (e-1+ei)
+ FFFixed ->
+ case decs of
+ Nothing ->
+ let f 0 s ds = mk0 s ++ "." ++ mk0 ds
+ f n s "" = f (n-1) (s++"0") ""
+ f n s (d:ds) = f (n-1) (s++[d]) ds
+ mk0 "" = "0"
+ mk0 s = s
+ in f e "" ds
+ Just dec ->
+ let dec' = max dec 0 in
+ if e >= 0 then
+ let (ei, is') = roundTo base (dec' + e) is
+ (ls, rs) = splitAt (e+ei) (map intToDigit is')
+ in (if null ls then "0" else ls) ++
+ (if null rs then "" else '.' : rs)
+ else
+ let (ei, is') = roundTo base dec'
+ (replicate (-e) 0 ++ is)
+ d : ds = map intToDigit
+ (if ei > 0 then is' else 0:is')
+ in d : '.' : ds
+
+roundTo :: Int -> Int -> [Int] -> (Int, [Int])
+roundTo base d is = case f d is of
+ (0, is) -> (0, is)
+ (1, is) -> (1, 1 : is)
+ where b2 = base `div` 2
+ f n [] = (0, replicate n 0)
+ f 0 (i:_) = (if i >= b2 then 1 else 0, [])
+ f d (i:is) =
+ let (c, ds) = f (d-1) is
+ i' = c + i
+ in if i' == base then (1, 0:ds) else (0, i':ds)
+
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.
+-- This version uses a much slower logarithm estimator. It should be improved.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+
+floatToDigits :: (RealFloat a) => BIGNUMTYPE -> a -> ([Int], Int)
+
+floatToDigits _ 0 = ([0], 0)
+floatToDigits base x =
+ let (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange x
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (f, e) = let n = minExp - e0
+ in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+
+ (r, s, mUp, mDn) =
+ if e >= 0 then
+ let be = b^e in
+ if f == b^(p-1) then
+ (f*be*b*2, 2*b, be*b, b)
+ else
+ (f*be*2, 2, be, be)
+ else
+ if e > minExp && f == b^(p-1) then
+ (f*b*2, b^(-e+1)*2, b, 1)
+ else
+ (f*2, b^(-e)*2, 1, 1)
+ k =
+ let k0 =
+#if 1 /* hack to overcome temporary Hugs bug (fixed size Integers) */
+ 0
+#else
+ if b==2 && base==10 then
+ -- logBase 10 2 is slightly bigger than 3/10 so
+ -- the following will err on the low side. Ignoring
+ -- the fraction will make it err even more.
+ -- Haskell promises that p-1 <= logBase b f < p.
+ (p - 1 + e0) * 3 `div` 10
+ else
+ ceiling ((log (fromInteger (f+1)) +
+ fromInt e * log (fromInteger b)) /
+ log (fromInteger base) `asTypeOf` x)
+#endif
+ fixup n =
+ if n >= 0 then
+ if r + mUp <= expt base n * s then n else fixup (n+1)
+ else
+ if expt base (-n) * (r + mUp) <= s then n
+ else fixup (n+1)
+ in fixup k0
+
+ gen ds rn sN mUpN mDnN =
+ let (dn, rn') = (rn * base) `divMod` sN
+ mUpN' = mUpN * base
+ mDnN' = mDnN * base
+ in case (rn' < mDnN', rn' + mUpN' > sN) of
+ (True, False) -> dn : ds
+ (False, True) -> dn+1 : ds
+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+ rds =
+ if k >= 0 then
+ gen [] r (s * expt base k) mUp mDn
+ else
+ let bk = expt base (-k)
+ in gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ in (map toInt (reverse rds), k)
+
+
+
+-- This floating point reader uses a less restrictive syntax for floating
+-- point than the Haskell lexer. The `.' is optional.
+
+readFloat :: (RealFloat a) => ReadS a
+readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
+ (k,t) <- readExp s]
+ where readFix r = [(read (ds++ds'), length ds', t)
+ | (ds,d) <- lexDigits r,
+ (ds',t) <- lexFrac d ]
+
+ lexFrac ('.':ds) = lexDigits ds
+ lexFrac s = [("",s)]
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = [(0,s)]
+
+ readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+ readExp' ('+':s) = readDec s
+ readExp' s = readDec s
+
+lexDigits :: ReadS String
+lexDigits = nonnull isDigit
+
+nonnull :: (Char -> Bool) -> ReadS String
+nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
+
+#endif /* BODY */
--- /dev/null
+-- Standard functions on rational numbers
+
+#ifdef HEAD
+module Ratio (
+ Ratio, Rational, (%), numerator, denominator, approxRational ) where
+
+#if STD_PRELUDE
+infixl 7 %
+#endif
+
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+data (Integral a) => Ratio a = !a :% !a deriving (Eq)
+type Rational = Ratio BIGNUMTYPE
+
+(%) :: (Integral a) => a -> a -> Ratio a
+numerator, denominator :: (Integral a) => Ratio a -> a
+approxRational :: (RealFrac a) => a -> a -> Rational
+
+
+-- "reduce" is a subsidiary function used only in this module.
+-- It normalises a ratio by dividing both numerator
+-- and denominator by their greatest common divisor.
+--
+-- E.g., 12 `reduce` 8 == 3 :% 2
+-- 12 `reduce` (-8) == 3 :% (-2)
+
+reduce _ 0 = error "Ratio.% : zero denominator"
+reduce x y = (x `quot` d) :% (y `quot` d)
+ where d = gcd x y
+
+x % y = reduce (x * signum y) (abs y)
+
+numerator (x :% _) = x
+
+denominator (_ :% y) = y
+
+
+instance (Integral a) => Ord (Ratio a) where
+ (x:%y) <= (x':%y') = x * y' <= x' * y
+ (x:%y) < (x':%y') = x * y' < x' * y
+
+instance (Integral a) => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x * x') (y * y')
+ negate (x:%y) = (-x) :% y
+ abs (x:%y) = abs x :% y
+ signum (x:%y) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+
+instance (Integral a) => Real (Ratio a) where
+ toRational (x:%y) = toInteger x :% toInteger y
+
+instance (Integral a) => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
+ fromRational (x:%y) = fromInteger x :% fromInteger y
+
+instance (Integral a) => RealFrac (Ratio a) where
+ properFraction (x:%y) = (fromIntegral q, r:%y)
+ where (q,r) = quotRem x y
+
+instance (Integral a) => Enum (Ratio a) where
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo = numericEnumFromTo
+ enumFromThenTo = numericEnumFromThenTo
+ toEnum = fromInteger . toInteger
+ fromEnum n = error "Ratio.fromEnum: can't use\
+ \ fromEnum with Ratio"
+
+instance (Read a, Integral a) => Read (Ratio a) where
+ readsPrec p = readParen (p > 7)
+ (\r -> [(x%y,u) | (x,s) <- reads r,
+ ("%",t) <- lex s,
+ (y,u) <- reads t ])
+
+instance (Integral a) => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > 7)
+ (shows x . showString " % " . shows y)
+
+
+
+approxRational x eps = simplest (x-eps) (x+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr@(n:%d) = toRational x
+ (n':%d') = toRational y
+
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ (n'':%d'') = simplest' d' r' d r
+
+#endif /* BODY */
--- /dev/null
+#ifdef HEAD
+module UnicodePrims
+ ( primUnicodeIsPrint
+ , primUnicodeIsUpper
+ , primUnicodeIsLower
+ , primUnicodeIsAlphaNum
+ ) where
+
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+-- based on GHC's implementation
+primUnicodeIsPrint c = not (isControl c)
+-- The upper case ISO characters have the multiplication sign dumped
+-- randomly in the middle of the range. Go figure.
+primUnicodeIsUpper c = c >= 'A' && c <= 'Z' ||
+ c >= '\xC0' && c <= '\xD6' ||
+ c >= '\xD8' && c <= '\xDE'
+-- The lower case ISO characters have the division sign dumped
+-- randomly in the middle of the range. Go figure.
+primUnicodeIsLower c = c >= 'a' && c <= 'z' ||
+ c >= '\xDF' && c <= '\xF6' ||
+ c >= '\xF8' && c <= '\xFF'
+primUnicodeIsAlphaNum c = isAlpha c || isDigit c
+primUnicodeToUpper c
+ | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
+ | otherwise = c
+primUnicodeToLower c
+ | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
+ | otherwise = c
+
+#endif /* BODY */
--- /dev/null
+-----------------------------------------------------------------------------
+-- Unsigned Integers
+-- Suitable for use with Hugs 1.4 on 32 bit systems.
+-----------------------------------------------------------------------------
+module Word
+ ( Word8
+ , Word16
+ , Word32
+ , Word64
+ , word8ToWord32 -- :: Word8 -> Word32
+ , word32ToWord8 -- :: Word32 -> Word8
+ , word16ToWord32 -- :: Word16 -> Word32
+ , word32ToWord16 -- :: Word32 -> Word16
+ , word8ToInt -- :: Word8 -> Int
+ , intToWord8 -- :: Int -> Word8
+ , word16ToInt -- :: Word16 -> Int
+ , intToWord16 -- :: Int -> Word16
+ , word32ToInt -- :: Word32 -> Int
+ , intToWord32 -- :: Int -> Word32
+ ) where
+
+import PreludeBuiltin
+import Bits
+
+-----------------------------------------------------------------------------
+-- The "official" coercion functions
+-----------------------------------------------------------------------------
+
+word8ToWord32 :: Word8 -> Word32
+word32ToWord8 :: Word32 -> Word8
+word16ToWord32 :: Word16 -> Word32
+word32ToWord16 :: Word32 -> Word16
+
+word8ToInt :: Word8 -> Int
+intToWord8 :: Int -> Word8
+word16ToInt :: Word16 -> Int
+intToWord16 :: Int -> Word16
+word32ToInt :: Word32 -> Int
+intToWord32 :: Int -> Word32
+
+word8ToInt = word32ToInt . word8ToWord32
+intToWord8 = word32ToWord8 . intToWord32
+word16ToInt = word32ToInt . word16ToWord32
+intToWord16 = word32ToWord16 . intToWord32
+
+word32ToInt (W32 x) = primWordToInt x
+intToWord32 x = W32 (primIntToWord x)
+
+
+-----------------------------------------------------------------------------
+-- Word8
+-----------------------------------------------------------------------------
+
+newtype Word8 = W8 Word32
+
+word8ToWord32 (W8 x) = x .&. 0xff
+word32ToWord8 = W8
+
+instance Eq Word8 where (==) = binop (==)
+instance Ord Word8 where compare = binop compare
+
+instance Num Word8 where
+ x + y = to (binop (+) x y)
+ x - y = to (binop (-) x y)
+ negate = to . negate . from
+ x * y = to (binop (*) x y)
+ abs = absReal
+ signum = signumReal
+ fromInteger = to . fromInteger
+ fromInt = intToWord8
+
+instance Bounded Word8 where
+ minBound = 0
+ maxBound = 0xff
+
+instance Real Word8 where
+ toRational x = toInteger x % 1
+
+instance Integral Word8 where
+ x `div` y = to (binop div x y)
+ x `quot` y = to (binop quot x y)
+ x `rem` y = to (binop rem x y)
+ x `mod` y = to (binop mod x y)
+ x `quotRem` y = to2 (binop quotRem x y)
+ divMod = quotRem
+ toInteger = toInteger . from
+ toInt = word8ToInt
+
+instance Ix Word8 where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = word32ToInt (from (i - m))
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Word8 where
+ toEnum = to . intToWord32
+ fromEnum = word32ToInt . from
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word8)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word8)]
+ where last = if d < c then minBound else maxBound
+
+instance Read Word8 where
+ readsPrec p = readDec
+
+instance Show Word8 where
+ showsPrec p = showInt . toInteger -- a particularily counterintuitive name!
+
+instance Bits Word8 where
+ x .&. y = to (binop (.&.) x y)
+ x .|. y = to (binop (.|.) x y)
+ x `xor` y = to (binop xor x y)
+ complement = to . complement . from
+ x `shift` i = to (from x `shift` i)
+-- rotate
+ bit = to . bit
+ setBit x i = to (setBit (from x) i)
+ clearBit x i = to (clearBit (from x) i)
+ complementBit x i = to (complementBit (from x) i)
+ testBit x i = testBit (from x) i
+ bitSize _ = 8
+ isSigned _ = False
+
+-----------------------------------------------------------------------------
+-- Word16
+-----------------------------------------------------------------------------
+
+newtype Word16 = W16 Word32
+
+word16ToWord32 (W16 x) = x .&. 0xffff
+word32ToWord16 = W16
+
+instance Eq Word16 where (==) = binop (==)
+instance Ord Word16 where compare = binop compare
+
+instance Num Word16 where
+ x + y = to (binop (+) x y)
+ x - y = to (binop (-) x y)
+ negate = to . negate . from
+ x * y = to (binop (*) x y)
+ abs = absReal
+ signum = signumReal
+ fromInteger = to . fromInteger
+ fromInt = intToWord16
+
+instance Bounded Word16 where
+ minBound = 0
+ maxBound = 0xffff
+
+instance Real Word16 where
+ toRational x = toInteger x % 1
+
+instance Integral Word16 where
+ x `div` y = to (binop div x y)
+ x `quot` y = to (binop quot x y)
+ x `rem` y = to (binop rem x y)
+ x `mod` y = to (binop mod x y)
+ x `quotRem` y = to2 (binop quotRem x y)
+ divMod = quotRem
+ toInteger = toInteger . from
+ toInt = word16ToInt
+
+instance Ix Word16 where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = word32ToInt (from (i - m))
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Word16 where
+ toEnum = to . intToWord32
+ fromEnum = word32ToInt . from
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word16)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word16)]
+ where last = if d < c then minBound else maxBound
+
+instance Read Word16 where
+ readsPrec p = readDec
+
+instance Show Word16 where
+ showsPrec p = showInt . toInteger -- a particularily counterintuitive name!
+
+instance Bits Word16 where
+ x .&. y = to (binop (.&.) x y)
+ x .|. y = to (binop (.|.) x y)
+ x `xor` y = to (binop xor x y)
+ complement = to . complement . from
+ x `shift` i = to (from x `shift` i)
+-- rotate
+ bit = to . bit
+ setBit x i = to (setBit (from x) i)
+ clearBit x i = to (clearBit (from x) i)
+ complementBit x i = to (complementBit (from x) i)
+ testBit x i = testBit (from x) i
+ bitSize _ = 16
+ isSigned _ = False
+
+-----------------------------------------------------------------------------
+-- Word32
+-----------------------------------------------------------------------------
+
+newtype Word32 = W32 Word
+
+w32 :: Word32 -> Word
+w32 (W32 x) = x
+
+lift0 :: Word -> Word32
+lift1 :: (Word -> Word) -> (Word32 -> Word32)
+lift2 :: (Word -> Word -> Word) -> (Word32 -> Word32 -> Word32)
+lift2' :: (Word -> Word -> (Word,Word)) -> (Word32 -> Word32 -> (Word32,Word32))
+
+lift0 x = W32 x
+lift1 f (W32 x) = W32 (f x)
+lift2 f (W32 x) (W32 y) = W32 (f x y)
+
+lift2' f (W32 x) (W32 y) = case f x y of (a,b) -> (W32 a, W32 b)
+
+instance Eq Word32 where
+ x == y = primEqWord (w32 x) (w32 y)
+ x /= y = primNeWord (w32 x) (w32 y)
+
+instance Ord Word32 where
+ x < y = primLtWord (w32 x) (w32 y)
+ x <= y = primLeWord (w32 x) (w32 y)
+ x >= y = primGeWord (w32 x) (w32 y)
+ x > y = primGtWord (w32 x) (w32 y)
+
+instance Num Word32 where
+ (+) = lift2 primPlusWord
+ (-) = lift2 primMinusWord
+ negate = lift1 primNegateWord
+ (*) = lift2 primTimesWord
+ abs = id
+ signum x = if x == 0 then 0 else 1
+ fromInteger = W32 . primIntegerToWord
+ fromInt = W32 . primIntToWord
+
+instance Bounded Word32 where
+ minBound = 0
+ maxBound = W32 primMaxWord
+
+instance Real Word32 where
+ toRational x = toInteger x % 1
+
+instance Integral Word32 where
+ quotRem = lift2' primQuotRemWord
+ quot = lift2 primQuotWord
+ rem = lift2 primRemWord
+ divMod = lift2' primQuotRemWord -- no difference for unsigned values!
+ div = lift2 primQuotWord
+ mod = lift2 primRemWord
+ toInteger = primWordToInteger . w32
+ toInt = primWordToInt . w32
+
+instance Ix Word32 where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = word32ToInt (i - m)
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Word32 where
+ toEnum = fromInt
+ fromEnum = toInt
+
+ enumFrom w = [w .. maxBound]
+ enumFromTo w1 w2
+ | w1 <= w2 = eft32 w1 w2
+ | otherwise = []
+ enumFromThen w1 w2 = [w1, w2 .. last]
+ where
+ last
+ | w1 < w2 = maxBound::Word32
+ | otherwise = minBound
+ enumFromThenTo w1 w2 last = eftt32 w1 (w2 - w1) (>last)
+
+--------------------------------
+-- Begin stolen from GHC (but then modified!)
+--------------------------------
+
+-- Termination is easy because the step is 1
+eft32 :: Word32 -> Word32 -> [Word32]
+eft32 now last = go now
+ where
+ go x
+ | x == last = [x]
+ | otherwise = x : (go `strict` (x+1))
+
+-- Termination is hard because the step is not 1
+-- Warning: this code is known not to work near maxBound
+eftt32 :: Word32 -> Word32 -> (Word32->Bool) -> [Word32]
+eftt32 now step done = go now
+ where
+ go now
+ | done now = []
+ | otherwise = now : (go `strict` (now+step))
+
+--------------------------------
+-- End stolen from GHC.
+--------------------------------
+
+instance Read Word32 where
+ readsPrec p = readDec
+
+instance Show Word32 where
+ showsPrec p = showInt . toInteger -- a particularily counterintuitive name!
+
+instance Bits Word32 where
+ (.&.) = lift2 primAndWord
+ (.|.) = lift2 primOrWord
+ xor = lift2 primXorWord
+ complement = lift1 primNotWord
+ shift x n
+ | n >= 0 = W32 (primShiftLWord (w32 x) (primIntToWord n))
+ | otherwise = W32 (primShiftRLWord (w32 x) (primIntToWord (-n)))
+-- rotate
+ bit = shift 1
+ setBit x i = x .|. bit i
+ clearBit x i = x .&. complement (bit i)
+ complementBit x i = x `xor` bit i
+ testBit x i = x .&. bit i /= 0
+ bitSize _ = 32
+ isSigned _ = False
+
+-----------------------------------------------------------------------------
+-- Word64
+-----------------------------------------------------------------------------
+
+data Word64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded)
+
+w64ToInteger W64{lo,hi} = toInteger lo + 0x100000000 * toInteger hi
+integerToW64 x = case x `quotRem` 0x100000000 of
+ (h,l) -> W64{lo=fromInteger l, hi=fromInteger h}
+
+instance Show Word64 where
+ showsPrec p = showInt . w64ToInteger
+
+instance Read Word64 where
+ readsPrec p s = [ (integerToW64 x,r) | (x,r) <- readDec s ]
+
+-----------------------------------------------------------------------------
+-- End of exported definitions
+--
+-- The remainder of this file consists of definitions which are only
+-- used in the implementation.
+-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+-- Enumeration code: copied from Prelude
+-----------------------------------------------------------------------------
+
+numericEnumFrom :: Real a => a -> [a]
+numericEnumFromThen :: Real a => a -> a -> [a]
+numericEnumFromTo :: Real a => a -> a -> [a]
+numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
+numericEnumFrom n = n : strict numericEnumFrom (n+1)
+numericEnumFromThen n m = iterate ((m-n)+) n
+numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
+numericEnumFromThenTo n n' m = takeWhile (if n' >= n then (<= m) else (>= m))
+ (numericEnumFromThen n n')
+
+-----------------------------------------------------------------------------
+-- Coercions - used to make the instance declarations more uniform
+-----------------------------------------------------------------------------
+
+class Coerce a where
+ to :: Word32 -> a
+ from :: a -> Word32
+
+instance Coerce Word8 where
+ from = word8ToWord32
+ to = word32ToWord8
+
+instance Coerce Word16 where
+ from = word16ToWord32
+ to = word32ToWord16
+
+binop :: Coerce word => (Word32 -> Word32 -> a) -> (word -> word -> a)
+binop op x y = from x `op` from y
+
+to2 :: Coerce word => (Word32, Word32) -> (word, word)
+to2 (x,y) = (to x, to y)
+
+-----------------------------------------------------------------------------
+-- Code copied from the Prelude
+-----------------------------------------------------------------------------
+
+absReal x | x >= 0 = x
+ | otherwise = -x
+
+signumReal x | x == 0 = 0
+ | x > 0 = 1
+ | otherwise = -1
+
+-----------------------------------------------------------------------------
+-- End
+-----------------------------------------------------------------------------
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Lambda Lifter
+ *
+ * This is a very simple lambda lifter - it doesn't try to do Johnsson-style
+ * lambda lifting (yet).
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: lift.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:17 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+#include "lift.h"
+#include "free.h"
+#include "stgSubst.h"
+/* #include "pp.h" */
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static List liftedBinds = NIL;
+
+static StgExpr abstractExpr ( List vars, StgExpr e );
+static inline Bool isTopLevel( StgVar v );
+static List filterFreeVars( List vs );
+static List liftLetBinds ( List binds );
+static void liftAlt ( StgCaseAlt alt );
+static void liftPrimAlt ( StgPrimAlt alt );
+static void liftExpr ( StgExpr e );
+
+/* --------------------------------------------------------------------------
+ * Lambda lifter
+ * ------------------------------------------------------------------------*/
+
+/* abstract variables out of an expression */
+static StgExpr abstractExpr( List vars, StgExpr e )
+{
+ List args = NIL;
+ List sub = NIL; /* association list */
+ for(; nonNull(vars); vars=tl(vars)) {
+ StgVar var = hd(vars);
+ StgVar arg = mkStgVar(NIL,NIL);
+ args = cons(arg,args);
+ sub = cons(pair(var,arg),sub);
+ }
+ return makeStgLambda(rev(args),substExpr(sub,e));
+}
+
+/* ToDo: should be conservative estimate but isn't */
+/* Will a variable be floated out to top level - conservative estimate? */
+static inline Bool isTopLevel( StgVar v )
+{
+ if (isNull(stgVarBody(v))) {
+ return FALSE; /* only let bound vars can be floated */
+ } else if (stgVarInfo(v) == NONE) {
+ return TRUE; /* those at top level are already there */
+ } else {
+#if LIFT_CONSTANTS
+ StgRhs rhs = stgVarBody(v);
+ switch (whatIs(rhs)) {
+ case STGCON:
+ case STGAPP:
+ return isNull(stgVarInfo(v));
+ default:
+ return FALSE;
+ }
+#else
+ return FALSE;
+#endif
+ }
+}
+
+static List filterFreeVars( List vs )
+{
+ List fvs = NIL;
+ if (vs == NONE) {
+ return NIL;
+ } else {
+ for(; nonNull(vs); vs=tl(vs)) {
+ StgVar v = hd(vs);
+ if (!isTopLevel(v)) {
+ fvs = cons(v,fvs);
+ }
+ }
+ return fvs;
+ }
+}
+
+static List liftLetBinds( List binds )
+{
+ List bs = NIL;
+ for(; nonNull(binds); binds=tl(binds)) {
+ StgVar bind = hd(binds);
+ StgRhs rhs = stgVarBody(bind);
+ List fvs = filterFreeVars(stgVarInfo(bind));
+ /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
+
+ switch (whatIs(rhs)) {
+ case STGCON:
+ case STGAPP:
+#if LIFT_CONSTANTS
+ if (isNull(fvs)) {
+ StgVar v = mkStgVar(rhs,NONE);
+ stgVarBody(bind) = mkStgLet(singleton(v),v);
+ /* ppStg(v); */
+ liftedBinds = cons(bind,liftedBinds);
+ break;
+ }
+ /* deliberate fall through */
+#endif
+ case STGVAR:
+ case NAME:
+ bs = cons(bind,bs);
+ break;
+ default:
+ liftExpr(rhs);
+ if (nonNull(fvs)) {
+ StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
+ /* ppStg(v); */
+ liftedBinds = cons(v,liftedBinds);
+ stgVarBody(bind) = makeStgApp(v, fvs);
+ }
+#if LIFT_CONSTANTS
+ else {
+ StgVar r = mkStgVar(rhs,NIL); /* copy the var */
+ StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
+ stgVarBody(bind) = v; /* indirection to r */
+ /* ppStg(v); */
+ liftedBinds = cons(v,liftedBinds);
+ bs = cons(bind,bs); /* keep the old binding */
+ break;
+ }
+ /* deliberate fall through */
+#endif
+ bs = cons(bind,bs);
+ break;
+ }
+ }
+ return bs;
+}
+
+static void liftAlt( StgCaseAlt alt )
+{
+ liftExpr(stgCaseAltBody(alt));
+}
+
+static void liftPrimAlt( StgPrimAlt alt )
+{
+ liftExpr(stgPrimAltBody(alt));
+}
+
+static void liftExpr( StgExpr e )
+{
+ switch (whatIs(e)) {
+ case LETREC:
+ stgLetBinds(e) = liftLetBinds(stgLetBinds(e));
+ liftExpr(stgLetBody(e));
+ break;
+ case LAMBDA:
+ liftExpr(stgLambdaBody(e));
+ break;
+ case CASE:
+ liftExpr(stgCaseScrut(e));
+ mapProc(liftAlt,stgCaseAlts(e));
+ break;
+ case PRIMCASE:
+ liftExpr(stgPrimCaseScrut(e));
+ mapProc(liftPrimAlt,stgPrimCaseAlts(e));
+ break;
+ case STGPRIM:
+ break;
+ case STGAPP:
+ break;
+ case STGVAR:
+ case NAME:
+ break;
+ default:
+ internal("liftExpr");
+ }
+}
+
+List liftBinds( List binds )
+{
+ List bs;
+ for(bs=binds; nonNull(bs); bs=tl(bs)) {
+ StgVar bind = hd(bs);
+ freeVarsBind(NIL,bind);
+ stgVarInfo(bind) = NONE; /* mark as top level */
+ }
+ liftedBinds = NIL;
+ binds = liftLetBinds(binds);
+ binds = revOnto(liftedBinds,binds);
+ liftedBinds = NIL;
+ return binds;
+}
+
+/* --------------------------------------------------------------------------
+ * Compiler control:
+ * ------------------------------------------------------------------------*/
+
+Void liftControl(what)
+Int what; {
+ switch (what) {
+ case INSTALL:
+ /* deliberate fall though */
+ case RESET:
+ liftedBinds = NIL;
+ break;
+ case MARK:
+ mark(liftedBinds);
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern List liftBinds( List binds );
+extern Void liftControl ( Int what );
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Load symbols required from the Prelude
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: link.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:18 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "static.h"
+#include "translate.h"
+#include "type.h"
+#include "errors.h"
+#include "Assembler.h" /* for asmPrimOps and AsmReps */
+
+#include "link.h"
+
+Module modulePreludeHugs;
+
+Type typeArrow; /* Function spaces */
+
+Type typeChar;
+Type typeInt;
+#ifdef PROVIDE_INT64
+Type typeInt64;
+#endif
+#ifdef PROVIDE_INTEGER
+Type typeInteger;
+#endif
+#ifdef PROVIDE_WORD
+Type typeWord;
+#endif
+#ifdef PROVIDE_ADDR
+Type typeAddr;
+#endif
+#ifdef PROVIDE_ARRAY
+Type typePrimArray;
+Type typePrimByteArray;
+Type typeRef;
+Type typePrimMutableArray;
+Type typePrimMutableByteArray;
+#endif
+Type typeFloat;
+Type typeDouble;
+#ifdef PROVIDE_STABLE
+Type typeStable;
+#endif
+#ifdef PROVIDE_WEAK
+Type typeWeak;
+#endif
+#ifdef PROVIDE_FOREIGN
+Type typeForeign;
+#endif
+#ifdef PROVIDE_CONCURRENT
+Type typeThreadId;
+Type typeMVar;
+#endif
+
+Type typeList;
+Type typeUnit;
+Type typeString;
+Type typeBool;
+Type typeST;
+Type typeIO;
+Type typeException;
+
+Class classEq; /* `standard' classes */
+Class classOrd;
+Class classShow;
+Class classRead;
+Class classIx;
+Class classEnum;
+Class classBounded;
+#if EVAL_INSTANCES
+Class classEval;
+#endif
+
+Class classReal; /* `numeric' classes */
+Class classIntegral;
+Class classRealFrac;
+Class classRealFloat;
+Class classFractional;
+Class classFloating;
+Class classNum;
+
+Class classMonad; /* Monads and monads with a zero */
+Class classMonad0;
+
+List stdDefaults; /* standard default values */
+
+Name nameTrue, nameFalse; /* primitive boolean constructors */
+Name nameNil, nameCons; /* primitive list constructors */
+Name nameUnit; /* primitive Unit type constructor */
+
+Name nameEq;
+Name nameFromInt, nameFromDouble; /* coercion of numerics */
+Name nameFromInteger;
+Name nameReturn, nameBind; /* for translating monad comps */
+Name nameZero; /* for monads with a zero */
+#if EVAL_INSTANCES
+Name nameStrict; /* Members of class Eval */
+Name nameSeq;
+#endif
+
+Name nameId;
+Name nameRunIO;
+Name namePrint;
+
+Name nameOtherwise;
+Name nameUndefined; /* generic undefined value */
+#if NPLUSK
+Name namePmSub;
+#endif
+Name namePMFail;
+Name nameEqChar;
+Name nameEqInt;
+#if !OVERLOADED_CONSTANTS
+Name nameEqInteger;
+#endif
+Name nameEqDouble;
+Name namePmInt;
+Name namePmInteger;
+Name namePmDouble;
+Name namePmLe;
+Name namePmSubtract;
+Name namePmFromInteger;
+Name nameMkIO;
+Name nameUnpackString;
+Name nameError;
+Name nameInd;
+
+Name nameForce;
+
+/* these names are required before we've had a chance to do the right thing */
+Name nameSel;
+
+/* constructors used during translation and codegen */
+Name nameMkC; /* Char# -> Char */
+Name nameMkI; /* Int# -> Int */
+#ifdef PROVIDE_INT64
+Name nameMkInt64; /* Int64# -> Int64 */
+#endif
+#ifdef PROVIDE_INTEGER
+Name nameMkInteger; /* Integer# -> Integer */
+#endif
+#ifdef PROVIDE_WORD
+Name nameMkW; /* Word# -> Word */
+#endif
+#ifdef PROVIDE_ADDR
+Name nameMkA; /* Addr# -> Addr */
+#endif
+Name nameMkF; /* Float# -> Float */
+Name nameMkD; /* Double# -> Double */
+#ifdef PROVIDE_ARRAY
+Name nameMkPrimArray;
+Name nameMkPrimByteArray;
+Name nameMkRef;
+Name nameMkPrimMutableArray;
+Name nameMkPrimMutableByteArray;
+#endif
+#ifdef PROVIDE_STABLE
+Name nameMkStable; /* StablePtr# a -> StablePtr a */
+#endif
+#ifdef PROVIDE_WEAK
+Name nameMkWeak; /* Weak# a -> Weak a */
+#endif
+#ifdef PROVIDE_FOREIGN
+Name nameMkForeign; /* ForeignObj# -> ForeignObj */
+#endif
+#ifdef PROVIDE_CONCURRENT
+Name nameMkThreadId; /* ThreadId# -> ThreadId */
+Name nameMkMVar; /* MVar# -> MVar */
+#endif
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+static Tycon linkTycon( String s );
+static Tycon linkClass( String s );
+static Name linkName ( String s );
+
+static Tycon linkTycon( String s )
+{
+ Tycon tc = findTycon(findText(s));
+ if (nonNull(tc)) {
+ return tc;
+ }
+ ERRMSG(0) "Prelude does not define standard type \"%s\"", s
+ EEND;
+}
+
+static Class linkClass( String s )
+{
+ Class cc = findClass(findText(s));
+ if (nonNull(cc)) {
+ return cc;
+ }
+ ERRMSG(0) "Prelude does not define standard class \"%s\"", s
+ EEND;
+}
+
+static Name linkName( String s )
+{
+ Name n = findName(findText(s));
+ if (nonNull(n)) {
+ return n;
+ }
+ ERRMSG(0) "Prelude does not define standard name \"%s\"", s
+ EEND;
+}
+
+/* ToDo: kill this! */
+static Name predefinePrim ( String s );
+static Name predefinePrim ( String s )
+{
+ Name nm = newName(findText(s));
+ name(nm).defn=PREDEFINED;
+ return nm;
+}
+
+Void linkPreludeTC() { /* Hook to tycons and classes in */
+ static Bool initialised = FALSE; /* prelude when first loaded */
+ if (!initialised) {
+ Int i;
+ initialised = TRUE;
+ setCurrModule(modulePreludeHugs);
+
+ typeChar = linkTycon("Char");
+ typeInt = linkTycon("Int");
+#ifdef PROVIDE_INT64
+ typeInt64 = linkTycon("Int64");
+#endif
+#ifdef PROVIDE_INTEGER
+ typeInteger = linkTycon("Integer");
+#endif
+#ifdef PROVIDE_WORD
+ typeWord = linkTycon("Word");
+#endif
+#ifdef PROVIDE_ADDR
+ typeAddr = linkTycon("Addr");
+#endif
+#ifdef PROVIDE_ARRAY
+ typePrimArray = linkTycon("PrimArray");
+ typePrimByteArray = linkTycon("PrimByteArray");
+ typeRef = linkTycon("Ref");
+ typePrimMutableArray = linkTycon("PrimMutableArray");
+ typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
+#endif
+ typeFloat = linkTycon("Float");
+ typeDouble = linkTycon("Double");
+#ifdef PROVIDE_STABLE
+ typeStable = linkTycon("StablePtr");
+#endif
+#ifdef PROVIDE_WEAK
+ typeWeak = linkTycon("Weak");
+#endif
+#ifdef PROVIDE_FOREIGN
+ typeForeign = linkTycon("ForeignObj");
+#endif
+#ifdef PROVIDE_CONCURRENT
+ typeThreadId = linkTycon("ThreadId");
+ typeMVar = linkTycon("MVar");
+#endif
+
+ typeBool = linkTycon("Bool");
+ typeST = linkTycon("ST");
+ typeIO = linkTycon("IO");
+ typeException = linkTycon("Exception");
+ typeList = linkTycon("[]");
+ typeUnit = linkTycon("()");
+ typeString = linkTycon("String");
+
+ classEq = linkClass("Eq");
+ classOrd = linkClass("Ord");
+ classIx = linkClass("Ix");
+ classEnum = linkClass("Enum");
+ classShow = linkClass("Show");
+ classRead = linkClass("Read");
+ classBounded = linkClass("Bounded");
+#if EVAL_INSTANCES
+ classEval = linkClass("Eval");
+#endif
+ classReal = linkClass("Real");
+ classIntegral = linkClass("Integral");
+ classRealFrac = linkClass("RealFrac");
+ classRealFloat = linkClass("RealFloat");
+ classFractional = linkClass("Fractional");
+ classFloating = linkClass("Floating");
+ classNum = linkClass("Num");
+ classMonad = linkClass("Monad");
+ classMonad0 = linkClass("MonadZero");
+
+ stdDefaults = NIL;
+ stdDefaults = cons(typeDouble,stdDefaults);
+#if DEFAULT_BIGNUM
+ stdDefaults = cons(typeBignum,stdDefaults);
+#else
+ stdDefaults = cons(typeInt,stdDefaults);
+#endif
+ mkTypes();
+
+ nameMkC = addPrimCfun(findText("C#"),1,0,CHAR_REP);
+ nameMkI = addPrimCfun(findText("I#"),1,0,INT_REP);
+#ifdef PROVIDE_INT64
+ nameMkInt64 = addPrimCfun(findText("Int64#"),1,0,INT64_REP);
+#endif
+#ifdef PROVIDE_WORD
+ nameMkW = addPrimCfun(findText("W#"),1,0,WORD_REP);
+#endif
+#ifdef PROVIDE_ADDR
+ nameMkA = addPrimCfun(findText("A#"),1,0,ADDR_REP);
+#endif
+ nameMkF = addPrimCfun(findText("F#"),1,0,FLOAT_REP);
+ nameMkD = addPrimCfun(findText("D#"),1,0,DOUBLE_REP);
+#ifdef PROVIDE_STABLE
+ nameMkStable = addPrimCfun(findText("Stable#"),1,0,STABLE_REP);
+#endif
+
+#ifdef PROVIDE_INTEGER
+ nameMkInteger = addPrimCfun(findText("Integer#"),1,0,0);
+#endif
+#ifdef PROVIDE_FOREIGN
+ nameMkForeign = addPrimCfun(findText("Foreign#"),1,0,0);
+#endif
+#ifdef PROVIDE_WEAK
+ nameMkWeak = addPrimCfun(findText("Weak#"),1,0,0);
+#endif
+#ifdef PROVIDE_ARRAY
+ nameMkPrimArray = addPrimCfun(findText("PrimArray#"),1,0,0);
+ nameMkPrimByteArray = addPrimCfun(findText("PrimByteArray#"),1,0,0);
+ nameMkRef = addPrimCfun(findText("Ref#"),1,0,0);
+ nameMkPrimMutableArray = addPrimCfun(findText("PrimMutableArray#"),1,0,0);
+ nameMkPrimMutableByteArray = addPrimCfun(findText("PrimMutableByteArray#"),1,0,0);
+#endif
+#ifdef PROVIDE_CONCURRENT
+ nameMkThreadId = addPrimCfun(findText("ThreadId#"),1,0,0);
+ nameMkMVar = addPrimCfun(findText("MVar#"),1,0,0);
+#endif
+
+#if EVAL_INSTANCES
+ addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->) */
+#endif
+
+ for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
+#if EVAL_INSTANCES
+ addEvalInst(0,mkTuple(i),i,NIL);
+#endif
+#if DERIVE_EQ
+ addTupInst(classEq,i);
+#endif
+#if DERIVE_ORD
+ addTupInst(classOrd,i);
+#endif
+#if DERIVE_IX
+ addTupInst(classIx,i);
+#endif
+#if DERIVE_SHOW
+ addTupInst(classShow,i);
+#endif
+#if DERIVE_READ
+ addTupInst(classRead,i);
+#endif
+#if DERIVE_BOUNDED
+ addTupInst(classBounded,i);
+#endif
+ }
+ }
+}
+
+Void linkPreludeCM() { /* Hook to cfuns and mfuns in */
+ static Bool initialised = FALSE; /* prelude when first loaded */
+ if (!initialised) {
+ Int i;
+ initialised = TRUE;
+ setCurrModule(modulePreludeHugs);
+ /* constructors */
+ nameFalse = linkName("False");
+ nameTrue = linkName("True");
+ nameNil = linkName("[]");
+ nameCons = linkName(":");
+ nameUnit = linkName("()");
+ /* members */
+ nameEq = linkName("==");
+ nameFromInt = linkName("fromInt");
+ nameFromInteger = linkName("fromInteger");
+ nameFromDouble = linkName("fromDouble");
+#if EVAL_INSTANCES
+ nameStrict = linkName("strict");
+ nameSeq = linkName("seq");
+#endif
+ nameReturn = linkName("return");
+ nameBind = linkName(">>=");
+ nameZero = linkName("zero");
+
+ /* These come before calls to implementPrim */
+ for(i=0; i<NUM_TUPLES; ++i) {
+ implementTuple(i);
+ }
+ }
+}
+
+Void linkPreludeNames() { /* Hook to names defined in Prelude */
+ static Bool initialised = FALSE;
+ if (!initialised) {
+ Int i;
+ initialised = TRUE;
+ setCurrModule(modulePreludeHugs);
+
+ /* primops */
+ nameMkIO = linkName("primMkIO");
+ for (i=0; asmPrimOps[i].name; ++i) {
+ Text t = findText(asmPrimOps[i].name);
+ Name n = findName(t);
+ if (isNull(n)) {
+ n = newName(t);
+ }
+ name(n).line = 0;
+ name(n).defn = NIL;
+ name(n).type = primType(asmPrimOps[i].monad,asmPrimOps[i].args,asmPrimOps[i].results);
+ name(n).arity = strlen(asmPrimOps[i].args);
+ name(n).primop = &(asmPrimOps[i]);
+ implementPrim(n);
+ }
+
+ /* user interface */
+ nameRunIO = linkName("primRunIO");
+ namePrint = linkName("print");
+ /* typechecker (undefined member functions) */
+ nameError = linkName("error");
+ /* desugar */
+ nameId = linkName("id");
+ nameOtherwise = linkName("otherwise");
+ nameUndefined = linkName("undefined");
+ /* pmc */
+#if NPLUSK
+ namePmSub = linkName("primPmSub");
+#endif
+ /* translator */
+ nameUnpackString = linkName("primUnpackString");
+ namePMFail = linkName("primPmFail");
+ nameEqChar = linkName("primEqChar");
+ nameEqInt = linkName("primEqInt");
+#if !OVERLOADED_CONSTANTS
+ nameEqInteger = linkName("primEqInteger");
+#endif /* !OVERLOADED_CONSTANTS */
+ nameEqDouble = linkName("primEqDouble");
+ namePmInt = linkName("primPmInt");
+ namePmInteger = linkName("primPmInteger");
+ namePmDouble = linkName("primPmDouble");
+ namePmLe = linkName("primPmLe");
+ namePmSubtract = linkName("primPmSubtract");
+ namePmFromInteger = linkName("primPmFromInteger");
+ }
+}
+
+Void linkControl(what)
+Int what; {
+ Int i;
+
+ switch (what) {
+ case RESET :
+ case MARK :
+ break;
+
+ case INSTALL : linkControl(RESET);
+
+ modulePreludeHugs = newModule(findText("PreludeBuiltin"));
+
+ setCurrModule(modulePreludeHugs);
+
+ typeArrow = addPrimTycon(findText("(->)"),
+ pair(STAR,pair(STAR,STAR)),
+ 2,DATATYPE,NIL);
+
+ /* ToDo: fix pFun (or eliminate its use) */
+#define pFun(n,s,t) n = predefinePrim(s)
+ /* newtype and USE_NEWTYPE_FOR_DICTS */
+ pFun(nameId, "id", "id");
+ /* desugaring */
+ pFun(nameInd, "_indirect","error");
+ name(nameInd).number = DFUNNAME;
+ /* pmc */
+ pFun(nameSel, "_SEL", "sel");
+ /* strict constructors */
+ pFun(nameForce, "primForce","id");
+ /* implementTagToCon */
+ pFun(namePMFail, "primPmFail","primPmFail");
+#undef pFun
+
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern Void linkPreludeTC Args((Void));
+extern Void linkPreludeCM Args((Void));
+extern Void linkPreludeNames Args((Void));
+
+extern Module modulePreludeHugs;
+
+/* --------------------------------------------------------------------------
+ * Primitive constructor functions
+ * ------------------------------------------------------------------------*/
+
+extern Name nameFalse, nameTrue;
+extern Name nameNil, nameCons;
+extern Name nameUnit;
+
+extern Name nameFromInt, nameFromDouble;/*coercion of numerics */
+extern Name nameFromInteger;
+extern Name nameReturn, nameBind; /* for translating monad comps */
+extern Name nameZero; /* for monads with a zero */
+#if EVAL_INSTANCES
+extern Name nameStrict, nameSeq; /* Members of class Eval */
+#endif
+
+extern Name nameId;
+extern Name nameRunIO;
+extern Name namePrint;
+
+extern Name nameForce;
+
+#if TREX
+extern Name nameInsFld; /* Field insertion routine */
+extern Type typeRec; /* Record formation */
+extern Name nameNoRec; /* The empty record */
+extern Type typeNoRow; /* The empty row */
+#endif
+
+/* The following data constructors are used to box unboxed
+ * arguments and are treated differently by the code generator.
+ * That is, they have primop `elem` {INT_REP,FLOAT_REP,...}.
+ */
+#define boxingConRep(con) ((AsmRep)(name(con).primop))
+#define isBoxingCon(con) (isName(con) && boxingConRep(con) != 0)
+
+extern Name nameMkC;
+extern Name nameMkI;
+#ifdef PROVIDE_INT64
+extern Name nameMkInt64;
+#endif
+#ifdef PROVIDE_WORD
+extern Name nameMkW;
+#endif
+#ifdef PROVIDE_ADDR
+extern Name nameMkA;
+#endif
+extern Name nameMkF;
+extern Name nameMkD;
+#ifdef PROVIDE_STABLE
+extern Name nameMkStable;
+#endif
+
+/* The following data constructors are used to make boxed but
+ * unpointed values pointed and require no special treatment
+ * by the code generator.
+ */
+#ifdef PROVIDE_INTEGER
+extern Name nameMkInteger;
+#endif
+#ifdef PROVIDE_ARRAY
+extern Name nameMkPrimArray;
+extern Name nameMkPrimByteArray;
+extern Name nameMkRef;
+extern Name nameMkPrimMutableArray;
+extern Name nameMkPrimMutableByteArray;
+#endif
+#ifdef PROVIDE_FOREIGN
+extern Name nameMkForeign;
+#endif
+#ifdef PROVIDE_WEAK
+extern Name nameMkWeak;
+#endif
+#ifdef PROVIDE_CONCURRENT
+extern Name nameMkThreadId;
+extern Name nameMkMVar;
+#endif
+
+extern Type typeArrow; /* Builtin type constructors */
+
+#define fn(from,to) ap2(typeArrow,from,to) /* make type: from -> to */
+
+/* For every primitive type provided by the runtime system,
+ * we construct a Haskell type using a declaration of the form:
+ *
+ * data Int -- no constructors given
+ */
+extern Type typeChar;
+extern Type typeInt;
+#ifdef PROVIDE_INT64
+extern Type typeInt64;
+#endif
+#ifdef PROVIDE_INTEGER
+extern Type typeInteger;
+#endif
+#ifdef PROVIDE_WORD
+extern Type typeWord;
+#endif
+#ifdef PROVIDE_ADDR
+extern Type typeAddr;
+#endif
+#ifdef PROVIDE_ARRAY
+Type typePrimArray;
+Type typePrimByteArray;
+Type typeRef;
+Type typePrimMutableArray;
+Type typePrimMutableByteArray;
+#endif
+extern Type typeFloat;
+extern Type typeDouble;
+#ifdef PROVIDE_STABLE
+extern Type typeStable;
+#endif
+#ifdef PROVIDE_WEAK
+extern Type typeWeak;
+#endif
+#ifdef PROVIDE_FOREIGN
+extern Type typeForeign;
+#endif
+#ifdef PROVIDE_CONCURRENT
+extern Type typeThreadId;
+extern Type typeMVar;
+#endif
+
+/* And a smaller number of types defined in plain Haskell */
+extern Type typeList;
+extern Type typeUnit;
+extern Type typeString;
+extern Type typeBool;
+extern Type typeST;
+extern Type typeIO;
+extern Type typeException;
+
+/* copied out of K&R2, Appendix A */
+#define cat(x,y) x ## y
+#define xcat(x,y) cat(x,y)
+
+#ifdef BIGNUMTYPE
+#define typeBignum xcat(type,BIGNUMTYPE)
+#define nameMkBignum xcat(nameMk,BIGNUMTYPE)
+#else
+#warning BIGNUMTYPE undefined
+#endif
+
+extern List stdDefaults; /* List of standard default types */
+
+extern Class classEq; /* `standard' classes */
+extern Class classOrd;
+extern Class classShow;
+extern Class classRead;
+extern Class classIx;
+extern Class classEnum;
+extern Class classBounded;
+#if EVAL_INSTANCES
+extern Class classEval;
+#endif
+
+extern Class classReal; /* `numeric' classes */
+extern Class classIntegral;
+extern Class classRealFrac;
+extern Class classRealFloat;
+extern Class classFractional;
+extern Class classFloating;
+extern Class classNum;
+
+extern Class classMonad; /* Monads and monads with a zero */
+extern Class classMonad0;
+
+/* used in typechecker */
+extern Name nameError;
+extern Name nameInd;
+
+/* used while desugaring */
+extern Name nameId;
+extern Name nameOtherwise;
+extern Name nameUndefined; /* generic undefined value */
+
+/* used in pattern match */
+#if NPLUSK
+extern Name namePmSub;
+#endif
+extern Name nameSel;
+
+/* used in translation */
+extern Name nameEq;
+extern Name namePMFail;
+extern Name nameEqChar;
+extern Name nameEqInt;
+extern Name nameEqInteger;
+extern Name nameEqDouble;
+extern Name namePmInt;
+extern Name namePmInteger;
+extern Name namePmDouble;
+extern Name namePmLe;
+extern Name namePmSubtract;
+extern Name namePmFromInteger;
+extern Name nameMkIO;
+extern Name nameUnpackString;
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Machine dependent code
+ * RISCOS specific code provided by Bryan Scatergood, JBS
+ * Macintosh specific code provided by Hans Aberg (haberg@matematik.su.se)
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: machdep.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:20 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "hugs.h" /* for fromEnv */
+#include "errors.h"
+#include "version.h"
+
+#include "machdep.h"
+
+#include <stdio.h>
+#ifdef HAVE_SIGNAL_H
+# include <signal.h>
+#endif
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#else
+# ifdef HAVE_TYPES_H
+# include <types.h>
+# endif
+#endif
+#if HAVE_SYS_PARAM_H
+# include <sys/param.h>
+#endif
+#ifdef HAVE_SYS_STAT_H
+# include <sys/stat.h>
+#else
+# ifdef HAVE_STAT_H
+# include <stat.h>
+# endif
+#endif
+#ifdef HAVE_TIME_H
+# include <time.h>
+#endif
+
+/* Windows/DOS include files */
+#ifdef HAVE_DOS_H
+# include <dos.h>
+#endif
+#if defined HAVE_CONIO_H && ! HUGS_FOR_WINDOWS
+# include <conio.h>
+#endif
+#ifdef HAVE_IO_H
+# include <io.h>
+#endif
+#ifdef HAVE_STD_H
+# include <std.h>
+#endif
+#ifdef HAVE_WINDOWS_H
+# include <windows.h>
+#endif
+
+#if HUGS_FOR_WINDOWS
+#include <dir.h>
+#include <mem.h>
+
+extern HCURSOR HandCursor; /* Forward references to cursors */
+extern HCURSOR GarbageCursor;
+extern HCURSOR SaveCursor;
+static void local DrawStatusLine Args((HWND));
+#endif
+
+#if DOS
+#include <mem.h>
+extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */
+#endif
+
+#if RISCOS
+#include "swis.h"
+#include "os.h"
+#endif
+
+/* Macintosh include files */
+#ifdef HAVE_CONSOLE_H
+# include <console.h>
+#endif
+#ifdef HAVE_PASCAL_H
+# include <pascal.h>
+#endif
+#ifdef HAVE_FILES_H
+# include <Files.h>
+#endif
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+#ifdef HAVE_ERRNO_H
+# include <errno.h>
+#endif
+#ifdef HAVE_STDLIB_H
+# include <stdlib.h>
+#endif
+#ifdef HAVE_UNIX_H
+#include <unix.h>
+#endif
+
+/* --------------------------------------------------------------------------
+ * Find information about a file:
+ * ------------------------------------------------------------------------*/
+
+static Bool local readable Args((String));
+
+Void getFileInfo(f,tm,sz) /* find time stamp and size of file*/
+String f;
+Time *tm;
+Long *sz; {
+#if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
+ struct stat scbuf;
+ if (!stat(f,&scbuf)) {
+ *tm = scbuf.st_mtime;
+ *sz = (Long)(scbuf.st_size);
+ } else {
+ *tm = 0;
+ *sz = 0;
+ }
+#else /* normally just use stat() */
+ os_regset r; /* RISCOS PRM p.850 and p.837 */
+ r.r[0] = 17; /* Read catalogue, no path */
+ r.r[1] = (int)s;
+ os_swi(OS_File, &r);
+ if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
+ tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
+ tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
+ } else { /* Not found, or not time-stamped */
+ tm->hi = tm->lo = 0;
+ }
+ *sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
+#endif
+}
+
+#if defined HAVE_GETFINFO /* Mac971031 */
+/* --------------------------------------------------------------------------
+ * Define a MacOS version of access():
+ * If the file is not accessible, -1 is returned and errno is set to
+ * the reason for the failure.
+ * If the file is accessible and the dummy is 0 (existence), 2 (write),
+ * or 4 (read), the return is 0.
+ * If the file is accessible, and the dummy is 1 (executable), then if
+ * the file is a program (of type 'APPL'), the return is 0, otherwise -1.
+ * Warnings: Use with caution. UNIX access do no translate to Macs.
+ * Check of write access is not implemented (same as read).
+ * ------------------------------------------------------------------------*/
+
+int access(char *fileName, int dummy) {
+ FInfo fi;
+ short rc;
+
+ errno = getfinfo(fileName, 0, &fi);
+ if (errno != 0) return -1; /* Check file accessible. */
+
+ /* Cases dummy = existence, read, write. */
+ if (dummy == 0 || dummy & 0x6) return 0;
+
+ /* Case dummy = executable. */
+ if (dummy == 1) {
+ if (fi.fdType == 'APPL') return 0;
+ errno = fi.fdType;
+ return -1;
+ }
+
+ return 0;
+}
+#endif
+
+static Bool local readable(f) /* is f a regular, readable file */
+String f; {
+#if DJGPP2 || defined HAVE_GETFINFO /* stat returns bogus mode bits on djgpp2 */
+ return (0 == access(f,4));
+#elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
+ struct stat scbuf;
+ return ( !stat(f,&scbuf)
+ && (scbuf.st_mode & S_IREAD) /* readable */
+ && (scbuf.st_mode & S_IFREG) /* regular file */
+ );
+#elif defined HAVE_OS_SWI /* RISCOS specific */
+ os_regset r; /* RISCOS PRM p.850 -- JBS */
+ assert(dummy == 0);
+ r.r[0] = 17; /* Read catalogue, no path */
+ r.r[1] = (int)f;
+ os_swi(OS_File, &r);
+ return r.r[0] != 1; /* Does this check it's a regular file? ADR */
+#endif
+}
+
+
+/* --------------------------------------------------------------------------
+ * Search for script files on the HUGS path:
+ * ------------------------------------------------------------------------*/
+
+static String local hugsdir Args((Void));
+static String local RealPath Args((String));
+static String local normPath Args((String));
+static Void local searchChr Args((Int));
+static Void local searchStr Args((String));
+static Bool local tryEndings Args((String));
+
+#if DOS_FILENAMES
+# define SLASH '\\'
+# define isSLASH(c) ((c)=='\\' || (c)=='/')
+# define PATHSEP ';'
+# define DLL_ENDING ".dll"
+#elif MAC_FILENAMES
+# define SLASH ':'
+# define isSLASH(c) ((c)==SLASH)
+# define PATHSEP ';'
+/* Mac PEF (Preferred Executable Format) file */
+# define DLL_ENDING ".pef"
+#else
+# define SLASH '/'
+# define isSLASH(c) ((c)==SLASH)
+# define PATHSEP ':'
+# define DLL_ENDING ".so"
+#endif
+
+static String local hugsdir() { /* directory containing lib/Prelude.hs */
+#if HAVE_GETMODULEFILENAME && !DOS
+ /* On Windows, we can find the binary we're running and it's
+ * conventional to put the libraries in the same place.
+ */
+ static char dir[FILENAME_MAX+1] = "";
+ if (dir[0] == '\0') { /* not initialised yet */
+ String slash = 0;
+ GetModuleFileName((HMODULE)0,dir,FILENAME_MAX+1);
+ if (dir[0] == '\0') { /* GetModuleFileName must have failed */
+ return HUGSDIR;
+ }
+ if (slash = strrchr(dir,SLASH)) { /* truncate after directory name */
+ *slash = '\0';
+ }
+ }
+ return dir;
+#else
+ /* On Unix systems, we can't find the binary we're running and
+ * the libraries may not be installed near the binary anyway.
+ * This forces us to use a hardwired path which is set at
+ * configuration time (--datadir=...).
+ */
+ return HUGSDIR;
+#endif
+}
+
+static String local RealPath(s) /* Find absolute pathname of file */
+String s; {
+#if HAVE__FULLPATH /* eg DOS */
+ static char path[FILENAME_MAX+1];
+ _fullpath(path,s,FILENAME_MAX+1);
+#elif HAVE_REALPATH /* eg Unix */
+ static char path[MAXPATHLEN+1];
+ realpath(s,path);
+#else
+ static char path[FILENAME_MAX+1];
+ strcpy(path,s);
+#endif
+ return path;
+}
+
+int pathCmp(p1,p2) /* Compare paths after normalisation */
+String p1;
+String p2; {
+#if HAVE__FULLPATH /* eg DOS */
+ static char path1[FILENAME_MAX+1];
+ static char path2[FILENAME_MAX+1];
+ _fullpath(path1,p1,FILENAME_MAX+1);
+ _fullpath(path2,p2,FILENAME_MAX+1);
+#elif HAVE_REALPATH /* eg Unix */
+ static char path1[MAXPATHLEN+1];
+ static char path2[MAXPATHLEN+1];
+ realpath(p1,path1);
+ realpath(p2,path2);
+#else
+ static char path1[FILENAME_MAX+1];
+ static char path2[FILENAME_MAX+1];
+ strcpy(path1,p1);
+ strcpy(path2,p2);
+#endif
+#if CASE_INSENSITIVE_FILENAMES
+ strlwr(path1);
+ strlwr(path2);
+#endif
+ return filenamecmp(path1,path2);
+}
+
+static String local normPath(s) /* Try, as much as possible, to normalize */
+String s; { /* a pathname in some appropriate manner. */
+#if PATH_CANONICALIZATION
+ String path = RealPath(s);
+#if CASE_INSENSITIVE_FILENAMES
+ strlwr(path); /* and convert to lowercase */
+#endif
+ return path;
+#else /* ! PATH_CANONICALIZATION */
+ return s;
+#endif /* ! PATH_CANONICALIZATION */
+}
+
+static String endings[] = { "", ".myhi", ".hs", ".lhs", 0 };
+static char searchBuf[FILENAME_MAX+1];
+static Int searchPos;
+
+#define searchReset(n) searchBuf[searchPos=(n)]='\0'
+
+static Void local searchChr(c) /* Add single character to search buffer */
+Int c; {
+ if (searchPos<FILENAME_MAX) {
+ searchBuf[searchPos++] = c;
+ searchBuf[searchPos] = '\0';
+ }
+}
+
+static Void local searchStr(s) /* Add string to search buffer */
+String s; {
+ while (*s && searchPos<FILENAME_MAX)
+ searchBuf[searchPos++] = *s++;
+ searchBuf[searchPos] = '\0';
+}
+
+static Bool local tryEndings(s) /* Try each of the listed endings */
+String s; {
+ Int i = 0;
+ searchStr(s);
+ for (; endings[i]; ++i) {
+ Int save = searchPos;
+ searchStr(endings[i]);
+ if (readable(searchBuf))
+ return TRUE;
+ searchReset(save);
+ }
+ return FALSE;
+}
+
+String findPathname(along,nm) /* Look for a file along specified path */
+String along; /* Return NULL if file does not exist */
+String nm; {
+ String s = findMPathname(along,nm);
+ return s ? s : normPath(searchBuf);
+}
+
+String findMPathname(along,nm) /* Look for a file along specified path */
+String along; /* If nonzero, a path prefix from along is */
+String nm; { /* used as the first prefix in the search. */
+ String pathpt = hugsPath;
+
+ searchReset(0);
+ if (along) { /* Was a path for an existing file given? */
+ Int last = (-1);
+ Int i = 0;
+ for (; along[i]; i++) {
+ searchChr(along[i]);
+ if (isSLASH(along[i]))
+ last = i;
+ }
+ searchReset(last+1);
+ }
+ if (tryEndings(nm))
+ return normPath(searchBuf);
+
+ if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
+ Bool more = TRUE;
+ do {
+ searchReset(0);
+ if (*pathpt) {
+ if (*pathpt!=PATHSEP) {
+ /* Pre-define one MPW-style "shell-variable" */
+ if (strncmp(pathpt,"{Hugs}",6)==0) {
+ searchStr(hugsdir());
+ pathpt += 6;
+ }
+ do
+ searchChr(*pathpt++);
+ while (*pathpt && *pathpt!=PATHSEP);
+ searchChr(SLASH);
+ }
+ if (*pathpt==PATHSEP)
+ pathpt++;
+ else
+ more = FALSE;
+ }
+ else
+ more = FALSE;
+ if (tryEndings(nm))
+ return normPath(searchBuf);
+ } while (more);
+ }
+
+ searchReset(0); /* As a last resort, look for file in the current dir */
+ return (tryEndings(nm) ? normPath(searchBuf) : 0);
+}
+
+/* --------------------------------------------------------------------------
+ * Substitute old value of path into empty entries in new path
+ * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
+ * ------------------------------------------------------------------------*/
+
+String substPath(new,sub) /* substitute sub path into new path*/
+String new;
+String sub; {
+ Bool substituted = FALSE; /* only allow one replacement */
+ Int maxlen = strlen(sub) + strlen(new); /* safe upper bound */
+ String r = (String) malloc(maxlen+1); /* result string */
+ String t = r; /* pointer into r */
+ String next = new; /* next uncopied char in new */
+ String start = next; /* start of last path component */
+ if (r == 0) {
+ ERRMSG(0) "String storage space exhausted"
+ EEND;
+ }
+ do {
+ if (*next == PATHSEP || *next == '\0') {
+ if (!substituted && next == start) {
+ String s = sub;
+ for(; *s != '\0'; ++s) {
+ *t++ = *s;
+ }
+ substituted = TRUE;
+ }
+ start = next+1;
+ }
+ } while ((*t++ = *next++) != '\0');
+ return r;
+}
+
+
+/* --------------------------------------------------------------------------
+ * Garbage collection notification:
+ * ------------------------------------------------------------------------*/
+
+Bool gcMessages = FALSE; /* TRUE => print GC messages */
+
+Void gcStarted() { /* notify garbage collector start */
+#if HUGS_FOR_WINDOWS
+ SaveCursor = SetCursor(GarbageCursor);
+#endif
+ if (gcMessages) {
+ printf("{{Gc");
+ FlushStdout();
+ }
+}
+
+Void gcScanning() { /* notify garbage collector scans */
+ if (gcMessages) {
+ Putchar(':');
+ FlushStdout();
+ }
+}
+
+Void gcRecovered(recovered) /* notify garbage collection done */
+Int recovered; {
+ if (gcMessages) {
+ printf("%d}}",recovered);
+ fflush(stdout);
+ }
+#if HUGS_FOR_WINDOWS
+ SetCursor(SaveCursor);
+#endif
+}
+
+Cell *CStackBase; /* Retain start of C control stack */
+
+#if RISCOS /* Stack traversal for RISCOS */
+
+/* Warning: The following code is specific to the Acorn ARM under RISCOS
+ (and C4). We must explicitly walk back through the stack frames, since
+ the stack is extended from the heap. (see PRM pp. 1757). gcCStack must
+ not be modified, since the offset '5' assumes that only v1 is used inside
+ this function. Hence we do all the real work in gcARM.
+*/
+
+#define spreg 13 /* C3 has SP=R13 */
+
+#define previousFrame(fp) ((int *)((fp)[-3]))
+#define programCounter(fp) ((int *)((*(fp)-12) & ~0xFC000003))
+#define isSubSPSP(w) (((w)&dontCare) == doCare)
+#define doCare (0xE24DD000) /* SUB r13,r13,#0 */
+#define dontCare (~0x00100FFF) /* S and # bits */
+#define immediateArg(x) ( ((x)&0xFF) << (((x)&0xF00)>>7) )
+
+static void gcARM(int *fp) {
+ int si = *programCounter(fp); /* Save instruction indicates how */
+ /* many registers in this frame */
+ int *regs = fp - 4;
+ if (si & (1<<0)) markWithoutMove(*regs--);
+ if (si & (1<<1)) markWithoutMove(*regs--);
+ if (si & (1<<2)) markWithoutMove(*regs--);
+ if (si & (1<<3)) markWithoutMove(*regs--);
+ if (si & (1<<4)) markWithoutMove(*regs--);
+ if (si & (1<<5)) markWithoutMove(*regs--);
+ if (si & (1<<6)) markWithoutMove(*regs--);
+ if (si & (1<<7)) markWithoutMove(*regs--);
+ if (si & (1<<8)) markWithoutMove(*regs--);
+ if (si & (1<<9)) markWithoutMove(*regs--);
+ if (previousFrame(fp)) {
+ /* The non-register stack space is for the previous frame is above
+ this fp, and not below the previous fp, because of the way stack
+ extension works. It seems the only way of discovering its size is
+ finding the SUB sp, sp, #? instruction by walking through the code
+ following the entry point.
+ */
+ int *oldpc = programCounter(previousFrame(fp));
+ int fsize = 0, i;
+ for(i = 1; i < 6; ++i)
+ if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
+ for(i=1; i<=fsize; ++i)
+ markWithoutMove(fp[i]);
+ }
+}
+
+void gcCStack() {
+ int dummy;
+ int *fp = 5 + &dummy;
+ while (fp) {
+ gcARM(fp);
+ fp = previousFrame(fp);
+ }
+}
+
+#else /* Garbage collection for standard stack machines */
+
+Void gcCStack() { /* Garbage collect elements off */
+ Cell stackTop = NIL; /* C stack */
+ Cell *ptr = &stackTop;
+#if SIZEOF_INTP == 2
+ if (((long)(ptr) - (long)(CStackBase))&1)
+ fatal("gcCStack");
+#elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
+ if (((long)(ptr) - (long)(CStackBase))&1)
+ fatal("gcCStack");
+#else
+ if (((long)(ptr) - (long)(CStackBase))&3)
+ fatal("gcCStack");
+#endif
+
+#define StackGrowsDown while (ptr<=CStackBase) markWithoutMove(*ptr++)
+#define StackGrowsUp while (ptr>=CStackBase) markWithoutMove(*ptr--)
+#define GuessDirection if (ptr>CStackBase) StackGrowsUp; else StackGrowsDown
+
+#if STACK_DIRECTION > 0
+ StackGrowsUp;
+#elif STACK_DIRECTION < 0
+ StackGrowsDown;
+#else
+ GuessDirection;
+#endif
+
+#if SIZEOF_INTP==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
+ ptr = (Cell *)((long)(&stackTop) + 2);
+ StackGrowsDown;
+#endif
+
+#undef StackGrowsDown
+#undef StackGrowsUp
+#undef GuessDirection
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Terminal dependent stuff:
+ * ------------------------------------------------------------------------*/
+
+#if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
+
+/* This is believed to be redundant! ADR */
+#if HAVE_SYS_IOCTL_H
+# include <sys/ioctl.h>
+#endif
+
+/* The order of these three tests is very important because
+ * some systems have more than one of the requisite header file
+ * but only one of them seems to work.
+ * Anyone changing the order of the tests should try enabling each of the
+ * three branches in turn and write down which ones work as well as which
+ * OS/compiler they're using.
+ *
+ * OS Compiler sgtty termio termios notes
+ * Linux 2.0.18 gcc 2.7.2 absent works works 1
+ *
+ * Notes:
+ * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
+ * implemented using termios.h.
+ * sgtty.h is in /usr/include/bsd which is not on my standard include
+ * path. Adding it does no harm but you might as well use termios.
+ * --
+ * reid-alastair@cs.yale.edu
+ */
+#if HAVE_TERMIOS_H
+
+#include <termios.h>
+typedef struct termios TermParams;
+#define getTerminal(tp) tcgetattr(fileno(stdin), &tp)
+#define setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
+#define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
+ tp.c_cc[VMIN] = 1; \
+ tp.c_cc[VTIME] = 0;
+
+#elif HAVE_SGTTY_H
+
+#include <sgtty.h>
+typedef struct sgttyb TermParams;
+#define getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
+#define setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
+#if HPUX
+#define noEcho(tp) tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
+#else
+#define noEcho(tp) tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
+#endif
+
+#elif HAVE_TERMIO_H
+
+#include <termio.h>
+typedef struct termio TermParams;
+#define getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
+#define setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
+#define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
+ tp.c_cc[VMIN] = 1; \
+ tp.c_cc[VTIME] = 0;
+
+#endif
+
+static Bool messedWithTerminal = FALSE;
+static TermParams originalSettings;
+
+Void normalTerminal() { /* restore terminal initial state */
+ if (messedWithTerminal)
+ setTerminal(originalSettings);
+}
+
+Void noechoTerminal() { /* set terminal into noecho mode */
+ TermParams settings;
+
+ if (!messedWithTerminal) {
+ getTerminal(originalSettings);
+ messedWithTerminal = TRUE;
+ }
+ getTerminal(settings);
+ noEcho(settings);
+ setTerminal(settings);
+}
+
+Int getTerminalWidth() { /* determine width of terminal */
+#ifdef TIOCGWINSZ
+#ifdef _M_UNIX /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
+#include <sys/stream.h> /* Required by sys/ptem.h */
+#include <sys/ptem.h> /* Required to declare winsize */
+#endif
+ static struct winsize terminalSize;
+ ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
+ return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
+#else
+ return 80;
+#endif
+}
+
+Int readTerminalChar() { /* read character from terminal */
+ return getchar(); /* without echo, assuming that */
+} /* noechoTerminal() is active... */
+
+#elif SYMANTEC_C
+
+Int readTerminalChar() { /* read character from terminal */
+ return getchar(); /* without echo, assuming that */
+} /* noechoTerminal() is active... */
+
+Int getTerminalWidth() {
+ return console_options.ncols;
+}
+
+Void normalTerminal() {
+ csetmode(C_ECHO, stdin);
+}
+
+Void noechoTerminal() {
+ csetmode(C_NOECHO, stdin);
+}
+
+#else /* no terminal driver - eg DOS, RISCOS */
+
+static Bool terminalEchoReqd = TRUE;
+
+Int getTerminalWidth() {
+#if RISCOS
+ int dummy, width;
+ (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
+ return width+1;
+#else
+ return 80;
+#endif
+}
+
+Void normalTerminal() { /* restore terminal initial state */
+ terminalEchoReqd = TRUE;
+}
+
+Void noechoTerminal() { /* turn terminal echo on/off */
+ terminalEchoReqd = FALSE;
+}
+
+Int readTerminalChar() { /* read character from terminal */
+ if (terminalEchoReqd) {
+ return getchar();
+ } else {
+ Int c = getch();
+ return c=='\r' ? '\n' : c; /* slight paranoia about CR-LF */
+ }
+}
+
+#endif /* no terminal driver */
+
+/* --------------------------------------------------------------------------
+ * Interrupt handling:
+ * ------------------------------------------------------------------------*/
+
+Bool broken = FALSE;
+static Bool breakReqd = FALSE;
+static sigProto(ignoreBreak);
+static Void local installHandlers Args((Void));
+
+Bool breakOn(reqd) /* set break trapping on if reqd, */
+Bool reqd; { /* or off otherwise, returning old */
+ Bool old = breakReqd;
+
+ breakReqd = reqd;
+ if (reqd) {
+ if (broken) { /* repond to break signal received */
+ broken = FALSE; /* whilst break trap disabled */
+ sigRaise(breakHandler);
+ }
+ ctrlbrk(ignoreBreak);
+ } else {
+ ctrlbrk(ignoreBreak);
+ }
+ return old;
+}
+
+static sigHandler(ignoreBreak) { /* record but don't respond to break*/
+ ctrlbrk(ignoreBreak);
+ broken = TRUE;
+ interruptStgRts();
+ sigResume;
+}
+
+#if !DONT_PANIC
+static sigProto(panic);
+static sigHandler(panic) { /* exit in a panic, on receipt of */
+ everybody(EXIT); /* an unexpected signal */
+ fprintf(stderr,"\nUnexpected signal\n");
+ exit(1);
+ sigResume;/*NOTREACHED*/
+}
+#endif /* !DONT_PANIC */
+
+static Void local installHandlers() { /* Install handlers for all fatal */
+ /* signals except SIGINT and SIGBREAK*/
+#if !DONT_PANIC && !DOS
+# ifdef SIGABRT
+ signal(SIGABRT,panic);
+# endif
+# ifdef SIGBUS
+ signal(SIGBUS,panic);
+# endif
+# ifdef SIGFPE
+ signal(SIGFPE,panic);
+# endif
+# ifdef SIGHUP
+ signal(SIGHUP,panic);
+# endif
+# ifdef SIGILL
+ signal(SIGILL,panic);
+# endif
+# ifdef SIGQUIT
+ signal(SIGQUIT,panic);
+# endif
+# ifdef SIGSEGV
+ signal(SIGSEGV,panic);
+# endif
+# ifdef SIGTERM
+ signal(SIGTERM,panic);
+# endif
+#endif /* !DONT_PANIC && !DOS */
+}
+
+/* --------------------------------------------------------------------------
+ * Shell escapes:
+ * ------------------------------------------------------------------------*/
+
+Bool startEdit(line,nm) /* Start editor on file name at */
+Int line; /* given line. Both name and line */
+String nm; { /* or just line may be zero */
+ static char editorCmd[FILENAME_MAX+1];
+
+#if !SYMANTEC_C
+ if (hugsEdit && *hugsEdit) { /* Check that editor configured */
+#else
+ /* On a Mac, files have creator information, telling which program
+ to launch to, so an editor named to the empty string "" is often
+ desirable. */
+ if (hugsEdit) { /* Check that editor configured */
+#endif
+ Int n = FILENAME_MAX;
+ String he = hugsEdit;
+ String ec = editorCmd;
+ String rd = NULL; /* Set to nonnull to redo ... */
+
+ for (; n>0 && *he && *he!=' '; n--)
+ *ec++ = *he++; /* Copy editor name to buffer */
+ /* assuming filename ends at space */
+
+ if (nm && line && n>1 && *he){ /* Name, line, and enough space */
+ rd = ec; /* save, in case we don't find name*/
+ while (n>0 && *he) {
+ if (*he=='%') {
+ if (*++he=='d' && n>10) {
+ sprintf(ec,"%d",line);
+ he++;
+ }
+ else if (*he=='s' && (size_t)n>strlen(nm)) {
+ strcpy(ec,nm);
+ rd = NULL;
+ he++;
+ }
+ else if (*he=='%' && n>1) {
+ strcpy(ec,"%");
+ he++;
+ }
+ else /* Ignore % char if not followed */
+ *ec = '\0'; /* by one of d, s, or %, */
+ for (; *ec && n>0; n--)
+ ec++;
+ } /* ignore % followed by anything other than d, s, or % */
+ else { /* Copy other characters across */
+ *ec++ = *he++;
+ n--;
+ }
+ }
+ }
+ else
+ line = 0;
+
+ if (rd) { /* If file name was not included */
+ ec = rd;
+ line = 0;
+ }
+
+ if (nm && line==0 && n>1) { /* Name, but no line ... */
+ *ec++ = ' ';
+ for (; n>0 && *nm; n--) /* ... just copy file name */
+ *ec++ = *nm++;
+ }
+
+ *ec = '\0'; /* Add terminating null byte */
+ }
+ else {
+ ERRMSG(0) "Hugs is not configured to use an editor"
+ EEND;
+ }
+
+#if HAVE_WINEXEC
+ WinExec(editorCmd, SW_SHOW);
+ return FALSE;
+#else
+ if (shellEsc(editorCmd))
+ Printf("Warning: Editor terminated abnormally\n");
+ return TRUE;
+#endif
+}
+
+Int shellEsc(s) /* run a shell command (or shell) */
+String s; {
+#if HAVE_MACSYSTEM
+ return macsystem(s);
+#else
+#if HAVE_BIN_SH
+ if (s[0]=='\0') {
+ s = fromEnv("SHELL","/bin/sh");
+ }
+#endif
+ return system(s);
+#endif
+}
+
+#if RISCOS /* RISCOS also needs a chdir() */
+int chdir(char *s) { /* RISCOS PRM p. 885 -- JBS */
+ return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
+}
+#elif defined HAVE_PBHSETVOLSYNC /* Macintosh */
+int chdir(const char *s) {
+ char* str;
+ WDPBRec wd;
+ wd.ioCompletion = 0;
+ str = (char*)malloc(strlen(s) + 1);
+ if (str == 0) return -1;
+ strcpy(str, s);
+ wd.ioNamePtr = C2PStr(str);
+ wd.ioVRefNum = 0;
+ wd.ioWDDirID = 0;
+ errno = PBHSetVolSync(&wd);
+ free(str);
+ if (errno == 0) {
+ return 0;
+ } else {
+ return -1;
+ }
+}
+#endif
+
+
+/*---------------------------------------------------------------------------
+ * Printf-related operations:
+ *-------------------------------------------------------------------------*/
+
+#if !defined(HAVE_VSNPRINTF)
+int vsnprintf(buffer, count, fmt, ap)
+char* buffer;
+int count;
+const char* fmt;
+va_list ap; {
+#if defined(HAVE__VSNPRINTF)
+ return _vsnprintf(buffer, count, fmt, ap);
+#else
+ return 0;
+#endif
+}
+#endif /* HAVE_VSNPRINTF */
+
+#if !defined(HAVE_SNPRINTF)
+int snprintf(char* buffer, int count, const char* fmt, ...) {
+#if defined(HAVE__VSNPRINTF)
+ int r;
+ va_list ap; /* pointer into argument list */
+ va_start(ap, fmt); /* make ap point to first arg after fmt */
+ r = vsnprintf(buffer, count, fmt, ap);
+ va_end(ap); /* clean up */
+ return r;
+#else
+ return 0;
+#endif
+}
+#endif /* HAVE_SNPRINTF */
+
+/* --------------------------------------------------------------------------
+ * Read/write values from/to the registry
+ *
+ * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
+ * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if
+ * user entry doesn't exist).
+ *
+ * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
+ * ------------------------------------------------------------------------*/
+
+#if USE_REGISTRY
+
+#define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
+
+static Bool local createKey Args((HKEY, PHKEY, REGSAM));
+static Bool local queryValue Args((HKEY, String, LPDWORD, LPBYTE, DWORD));
+static Bool local setValue Args((HKEY, String, DWORD, LPBYTE, DWORD));
+
+static Bool local createKey(hKey, phRootKey, samDesired)
+HKEY hKey;
+PHKEY phRootKey;
+REGSAM samDesired; {
+ DWORD dwDisp;
+ return RegCreateKeyEx(hKey, HugsRoot,
+ 0, "", REG_OPTION_NON_VOLATILE,
+ samDesired, NULL, phRootKey, &dwDisp)
+ == ERROR_SUCCESS;
+}
+
+static Bool local queryValue(hKey, var, type, buf, bufSize)
+HKEY hKey;
+String var;
+LPDWORD type;
+LPBYTE buf;
+DWORD bufSize; {
+ HKEY hRootKey;
+
+ if (!createKey(hKey, &hRootKey, KEY_READ)) {
+ return FALSE;
+ } else {
+ LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
+ RegCloseKey(hRootKey);
+ return (res == ERROR_SUCCESS);
+ }
+}
+
+static Bool local setValue(hKey, var, type, buf, bufSize)
+HKEY hKey;
+String var;
+DWORD type;
+LPBYTE buf;
+DWORD bufSize; {
+ HKEY hRootKey;
+
+ if (!createKey(hKey, &hRootKey, KEY_WRITE)) {
+ return FALSE;
+ } else {
+ LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
+ RegCloseKey(hRootKey);
+ return (res == ERROR_SUCCESS);
+ }
+}
+
+String readRegString(var,def) /* read String from registry */
+String var;
+String def; {
+ static char buf[300];
+ DWORD type;
+
+ if (queryValue(HKEY_CURRENT_USER, var, &type, buf, sizeof(buf))
+ && type == REG_SZ) {
+ return (String)buf;
+ } else if (queryValue(HKEY_LOCAL_MACHINE, var, &type, buf, sizeof(buf))
+ && type == REG_SZ) {
+ return (String)buf;
+ } else {
+ return NULL;
+ }
+}
+
+Int readRegInt(var, def) /* read Int from registry */
+String var;
+Int def; {
+ DWORD buf;
+ DWORD type;
+
+ if (queryValue(HKEY_CURRENT_USER, var, &type,
+ (LPBYTE)&buf, sizeof(buf))
+ && type == REG_DWORD) {
+ return (Int)buf;
+ } else if (queryValue(HKEY_LOCAL_MACHINE, var, &type,
+ (LPBYTE)&buf, sizeof(buf))
+ && type == REG_DWORD) {
+ return (Int)buf;
+ } else {
+ return def;
+ }
+}
+
+Bool writeRegString(var,val) /* write String to registry */
+String var;
+String val; {
+ if (NULL == val) {
+ val = "";
+ }
+ return setValue(HKEY_CURRENT_USER, var,
+ REG_SZ, (LPBYTE)val, lstrlen(val)+1);
+}
+
+Bool writeRegInt(var,val) /* write String to registry */
+String var;
+Int val; {
+ return setValue(HKEY_CURRENT_USER, var,
+ REG_DWORD, (LPBYTE)&val, sizeof(val));
+}
+
+#endif /* USE_REGISTRY */
+
+/* --------------------------------------------------------------------------
+ * Machine dependent control:
+ * ------------------------------------------------------------------------*/
+
+Void machdep(what) /* Handle machine specific */
+Int what; { /* initialisation etc.. */
+ switch (what) {
+ case MARK : break;
+ case INSTALL : installHandlers();
+ break;
+ case RESET :
+ case BREAK :
+ case EXIT : normalTerminal();
+#if HUGS_FOR_WINDOWS
+ if (what==EXIT)
+ DestroyWindow(hWndMain);
+ else
+ SetCursor(LoadCursor(NULL,IDC_ARROW));
+#endif
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/*---------------------------------------------------------------------------
+ * Interrupting execution (signals, allowBreak):
+ *-------------------------------------------------------------------------*/
+
+extern Bool breakOn Args((Bool));
+
+extern Bool broken; /* indicates interrupt received */
+
+#ifndef SIGBREAK /* Sigh, not defined in cygwin32 beta release 16 */
+# define SIGBREAK 21
+#endif
+
+/* allowBreak: call to allow user to interrupt computation
+ * ctrlbrk: set control break handler
+ */
+
+#if HUGS_FOR_WINDOWS
+# define ctrlbrk(bh)
+# define allowBreak() kbhit()
+#else /* !HUGS_FOR_WINDOWS */
+# define ctrlbrk(bh) signal(SIGINT,bh); signal(SIGBREAK,bh)
+# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); }
+#endif /* !HUGS_FOR_WINDOWS */
+
+/*---------------------------------------------------------------------------
+ * Environment variables and the registry
+ *-------------------------------------------------------------------------*/
+
+/* On Win32 we can use the registry to supplement info in environment
+ * variables.
+ */
+#define USE_REGISTRY (HAVE_WINDOWS_H && !__MSDOS__)
+
+#ifdef USE_REGISTRY
+Bool writeRegString Args((String var, String val));
+String readRegString Args((String var, String def));
+Int readRegInt Args((String var, Int def));
+Bool writeRegInt Args((String var, Int val));
+#endif
+
+/*---------------------------------------------------------------------------
+ * File operations:
+ *-------------------------------------------------------------------------*/
+
+#if HAVE_UNISTD_H
+# include <sys/types.h>
+# include <unistd.h>
+#elif !HUGS_FOR_WINDOWS
+extern int chdir Args((const char*));
+#endif
+
+#if HAVE_STDLIB_H
+# include <stdlib.h>
+#else
+extern int system Args((const char *));
+extern double atof Args((const char *));
+extern void exit Args((int));
+#endif
+
+#ifndef FILENAME_MAX /* should already be defined in an ANSI compiler*/
+#define FILENAME_MAX 256
+#else
+#if FILENAME_MAX < 256
+#undef FILENAME_MAX
+#define FILENAME_MAX 256
+#endif
+#endif
+
+/* Hack, hack: if you have dos.h, you probably have a DOS filesystem */
+#define DOS_FILENAMES HAVE_DOS_H
+/* ToDo: can we replace this with a feature test? */
+#define MAC_FILENAMES SYMANTEC_C
+
+#define CASE_INSENSITIVE_FILENAMES (DOS_FILENAMES | RISCOS)
+
+#if CASE_INSENSITIVE_FILENAMES
+# if HAVE_STRCASECMP
+# define filenamecmp(s1,s2) strcasecmp(s1,s2)
+# elif HAVE__STRICMP
+# define filenamecmp(s1,s2) _stricmp(s1,s2)
+# elif HAVE_STRICMP
+# define filenamecmp(s1,s2) stricmp(s1,s2)
+# elif HAVE_STRCMPI
+# define filenamecmp(s1,s2) strcmpi(s1,s2)
+# endif
+#else
+# define filenamecmp(s1,s2) strcmp(s1,s2)
+#endif
+
+/*---------------------------------------------------------------------------
+ * Pipe-related operations:
+ *
+ * On Windows, many standard Unix names acquire a leading underscore.
+ * Irritating, but easy to work around.
+ *-------------------------------------------------------------------------*/
+
+#if !defined(HAVE_POPEN) && defined(HAVE__POPEN)
+#define popen(x,y) _popen(x,y)
+#endif
+#if !defined(HAVE_PCLOSE) && defined(HAVE__PCLOSE)
+#define pclose(x) _pclose(x)
+#endif
+
+/*---------------------------------------------------------------------------
+ * Bit manipulation:
+ *-------------------------------------------------------------------------*/
+
+#define bitArraySize(n) ((n)/bitsPerWord + 1)
+#define placeInSet(n) ((-(n)-1)>>wordShift)
+#define maskInSet(n) (1<<((-(n)-1)&wordMask))
+
+/*---------------------------------------------------------------------------
+ * Function prototypes for code in machdep.c
+ *-------------------------------------------------------------------------*/
+
+#if RISCOS
+typedef struct { unsigned hi, lo; } Time;
+#define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo)
+#define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo
+#else
+typedef time_t Time;
+#define timeChanged(now,thn) (now!=thn)
+#define timeSet(var,tm) var = tm
+#endif
+
+extern Void getFileInfo Args((String, Time *, Long *));
+extern int pathCmp Args((String, String));
+extern String substPath Args((String,String));
+extern Bool startEdit Args((Int,String));
+
+extern String findPathname Args((String,String));
+extern String findMPathname Args((String,String));
+
+extern Int shellEsc Args((String));
+extern Int getTerminalWidth Args((Void));
+extern Void normalTerminal Args((Void));
+extern Void noechoTerminal Args((Void));
+extern Int readTerminalChar Args((Void));
+extern Void gcStarted Args((Void));
+extern Void gcScanning Args((Void));
+extern Void gcRecovered Args((Int));
+extern Void gcCStack Args((Void));
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Import-Export processing for Hugs
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: modules.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:21 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "static.h"
+#include "errors.h"
+#include "link.h"
+#include "modules.h"
+
+/* --------------------------------------------------------------------------
+ * local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Name local lookupName Args((Text,List));
+static List local checkSubentities Args((List,List,List,String,Text));
+static List local checkExportTycon Args((List,Text,Cell,Tycon));
+static List local checkExportClass Args((List,Text,Cell,Class));
+static List local checkExport Args((List,Text,Cell));
+static List local checkImportEntity Args((List,Module,Cell));
+static List local resolveImportList Args((Module,Cell));
+
+static Void local importName Args((Module,Name));
+static Void local importTycon Args((Module,Tycon));
+static Void local importClass Args((Module,Class));
+
+/* --------------------------------------------------------------------------
+ * Static analysis of modules:
+ * ------------------------------------------------------------------------*/
+
+Void startModule(nm) /* switch to a new module */
+Cell nm; {
+ Module m;
+ if (!isCon(nm)) internal("startModule");
+ if (isNull(m = findModule(textOf(nm)))) {
+ m = newModule(textOf(nm));
+ } else if (m != modulePreludeHugs) {
+ ERRMSG(0) "Module \"%s\" already loaded", textToStr(textOf(nm))
+ EEND;
+ }
+ setCurrModule(m);
+}
+
+Void setExportList(exps) /* Add export list to current module */
+List exps; {
+ module(currentModule).exports = exps;
+}
+
+Void addQualImport(orig,new) /* Add to qualified import list */
+Cell orig; /* Original name of module */
+Cell new; { /* Name module is called within this module (or NIL) */
+ module(currentModule).qualImports =
+ cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports);
+}
+
+Void addUnqualImport(mod,entities) /* Add to unqualified import list */
+Cell mod; /* Name of module */
+List entities; { /* List of entity names */
+ unqualImports = cons(pair(mod,entities),unqualImports);
+}
+
+Void checkQualImport(i) /* Process qualified import */
+Pair i; {
+ Module m = findModid(snd(i));
+ if (isNull(m)) {
+ ERRMSG(0) "Module \"%s\" not previously loaded",
+ textToStr(textOf(snd(i)))
+ EEND;
+ }
+ snd(i)=m;
+}
+
+Void checkUnqualImport(i) /* Process unqualified import */
+Pair i; {
+ Module m = findModid(fst(i));
+ if (isNull(m)) {
+ ERRMSG(0) "Module \"%s\" not previously loaded",
+ textToStr(textOf(fst(i)))
+ EEND;
+ }
+ fst(i)=m;
+}
+
+static Name local lookupName(t,nms) /* find text t in list of Names */
+Text t;
+List nms; { /* :: [Name] */
+ for(; nonNull(nms); nms=tl(nms)) {
+ if (t == name(hd(nms)).text)
+ return hd(nms);
+ }
+ return NIL;
+}
+
+static List local checkSubentities(imports,named,wanted,description,textParent)
+List imports;
+List named; /* :: [ Q?(Var|Con)(Id|Op) ] */
+List wanted; /* :: [Name] */
+String description; /* "<constructor>|<member> of <type>|<class>" */
+Text textParent; {
+ for(; nonNull(named); named=tl(named)) {
+ Pair x = hd(named);
+ /* ToDo: ignores qualifier; doesn't check that entity is in scope */
+ Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x);
+ Name n = lookupName(t,wanted);
+ if (isNull(n)) {
+ ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"",
+ textToStr(t),
+ description,
+ textToStr(textParent)
+ EEND;
+ }
+ imports = cons(n,imports);
+ }
+ return imports;
+}
+
+static List local checkImportEntity(imports,exporter,entity)
+List imports; /* Accumulated list of things to import */
+Module exporter;
+Cell entity; { /* Entry from import list */
+ List oldImports = imports;
+ Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity));
+ List es = module(exporter).exports;
+ for(; nonNull(es); es=tl(es)) {
+ Cell e = hd(es); /* :: Entity | (Entity, NIL|DOTDOT) */
+ if (isPair(e)) {
+ Cell f = fst(e);
+ if (isTycon(f)) {
+ if (tycon(f).text == t) {
+ imports = cons(f,imports);
+ if (!isIdent(entity)) {
+ switch (tycon(f).what) {
+ case NEWTYPE:
+ case DATATYPE:
+ if (DOTDOT == snd(entity)) {
+ imports=revDupOnto(tycon(f).defn,imports);
+ } else {
+ imports=checkSubentities(imports,snd(entity),tycon(f).defn,"constructor of type",t);
+ }
+ break;
+ default:;
+ /* deliberate fall thru */
+ }
+ }
+ }
+ } else if (isClass(f)) {
+ if (cclass(f).text == t) {
+ imports = cons(f,imports);
+ if (!isIdent(entity)) {
+ if (DOTDOT == snd(entity)) {
+ return revDupOnto(cclass(f).members,imports);
+ } else {
+ return checkSubentities(imports,snd(entity),cclass(f).members,"member of class",t);
+ }
+ }
+ }
+ } else {
+ internal("checkImportEntity2");
+ }
+ } else if (isName(e)) {
+ if (isIdent(entity) && name(e).text == t) {
+ imports = cons(e,imports);
+ }
+ } else {
+ internal("checkImportEntity3");
+ }
+ }
+ if (imports == oldImports) {
+ ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"",
+ textToStr(t),
+ textToStr(module(exporter ).text)
+ EEND;
+ }
+ return imports;
+}
+
+static List local resolveImportList(m,impList)
+Module m; /* exporting module */
+Cell impList; {
+ List imports = NIL;
+ if (DOTDOT == impList) {
+ List es = module(m).exports;
+ for(; nonNull(es); es=tl(es)) {
+ Cell e = hd(es);
+ if (isName(e)) {
+ imports = cons(e,imports);
+ } else {
+ Cell c = fst(e);
+ List subentities = NIL;
+ imports = cons(c,imports);
+ if (isTycon(c)
+ && (tycon(c).what == DATATYPE
+ || tycon(c).what == NEWTYPE))
+ subentities = tycon(c).defn;
+ else if (isClass(c))
+ subentities = cclass(c).members;
+ if (DOTDOT == snd(e)) {
+ imports = revDupOnto(subentities,imports);
+ }
+ }
+ }
+ } else {
+ map1Accum(checkImportEntity,imports,m,impList);
+ }
+ return imports;
+}
+
+Void checkImportList(thisModule,importSpec) /* Import a module unqualified */
+Module thisModule;
+Pair importSpec; {
+ Module m = fst(importSpec);
+ Cell impList = snd(importSpec);
+
+ List imports = NIL; /* entities we want to import */
+ List hidden = NIL; /* entities we want to hide */
+
+ if (m == thisModule) {
+ ERRMSG(0) "Module \"%s\" recursively imports itself",
+ textToStr(module(m).text)
+ EEND;
+ }
+ if (isPair(impList) && HIDDEN == fst(impList)) {
+ /* Somewhat inefficient - but obviously correct:
+ * imports = importsOf("module Foo") `setDifference` hidden;
+ */
+ hidden = resolveImportList(m, snd(impList));
+ imports = resolveImportList(m, DOTDOT);
+ } else {
+ imports = resolveImportList(m, impList);
+ }
+ for(; nonNull(imports); imports=tl(imports)) {
+ Cell e = hd(imports);
+ if (!cellIsMember(e,hidden))
+ importEntity(m,e);
+ }
+ /* ToDo: hang onto the imports list for processing export list entries
+ * of the form "module Foo"
+ */
+}
+
+Void importEntity(source,e)
+Module source;
+Cell e; {
+ switch (whatIs(e)) {
+ case NAME : importName(source,e);
+ break;
+ case TYCON : importTycon(source,e);
+ break;
+ case CLASS : importClass(source,e);
+ break;
+ default: internal("importEntity");
+ }
+}
+
+static Void local importName(source,n)
+Module source;
+Name n; {
+ Name clash = addName(n);
+ if (nonNull(clash) && clash!=n) {
+ ERRMSG(0) "Entity \"%s\" imported from module \"%s\" already defined in module \"%s\"",
+ textToStr(name(n).text),
+ textToStr(module(source).text),
+ textToStr(module(name(clash).mod).text)
+ EEND;
+ }
+}
+
+static Void local importTycon(source,tc)
+Module source;
+Tycon tc; {
+ Tycon clash=addTycon(tc);
+ if (nonNull(clash) && clash!=tc) {
+ ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"",
+ textToStr(tycon(tc).text),
+ textToStr(module(source).text),
+ textToStr(module(tycon(clash).mod).text)
+ EEND;
+ }
+ if (nonNull(findClass(tycon(tc).text))) {
+ ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"",
+ textToStr(tycon(tc).text),
+ textToStr(module(tycon(tc).mod).text)
+ EEND;
+ }
+}
+
+static Void local importClass(source,c)
+Module source;
+Class c; {
+ Class clash=addClass(c);
+ if (nonNull(clash) && clash!=c) {
+ ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"",
+ textToStr(cclass(c).text),
+ textToStr(module(source).text),
+ textToStr(module(cclass(clash).mod).text)
+ EEND;
+ }
+ if (nonNull(findTycon(cclass(c).text))) {
+ ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"",
+ textToStr(cclass(c).text),
+ textToStr(module(source).text)
+ EEND;
+ }
+}
+
+static List local checkExportTycon(exports,mt,spec,tc)
+List exports;
+Text mt;
+Cell spec;
+Tycon tc; {
+ if (DOTDOT == spec || SYNONYM == tycon(tc).what) {
+ return cons(pair(tc,DOTDOT), exports);
+ } else {
+ return cons(pair(tc,NIL), exports);
+ }
+}
+
+static List local checkExportClass(exports,mt,spec,cl)
+List exports;
+Text mt;
+Class cl;
+Cell spec; {
+ if (DOTDOT == spec) {
+ return cons(pair(cl,DOTDOT), exports);
+ } else {
+ return cons(pair(cl,NIL), exports);
+ }
+}
+
+static List local checkExport(exports,mt,e) /* Process entry in export list*/
+List exports;
+Text mt;
+Cell e; {
+ if (isIdent(e)) {
+ Cell export = NIL;
+ List origExports = exports;
+ if (nonNull(export=findQualName(0,e))) {
+ exports=cons(export,exports);
+ }
+ if (isQCon(e) && nonNull(export=findQualTycon(e))) {
+ exports = checkExportTycon(exports,mt,NIL,export);
+ }
+ if (isQCon(e) && nonNull(export=findQualClass(e))) {
+ /* opaque class export */
+ exports = checkExportClass(exports,mt,NIL,export);
+ }
+ if (exports == origExports) {
+ ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"",
+ identToStr(e),
+ textToStr(mt)
+ EEND;
+ }
+ return exports;
+ } else if (MODULEENT == fst(e)) {
+ Module m = findModid(snd(e));
+ /* ToDo: shouldn't allow export of module we didn't import */
+ if (isNull(m)) {
+ ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"",
+ textToStr(textOf(snd(e))),
+ textToStr(mt)
+ EEND;
+ }
+ if (m == currentModule) {
+ /* Exporting the current module exports local definitions */
+ List xs;
+ for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) {
+ if (cclass(hd(xs)).mod==m)
+ exports = checkExportClass(exports,mt,DOTDOT,hd(xs));
+ }
+ for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) {
+ if (tycon(hd(xs)).mod==m)
+ exports = checkExportTycon(exports,mt,DOTDOT,hd(xs));
+ }
+ for(xs=module(m).names; nonNull(xs); xs=tl(xs)) {
+ if (name(hd(xs)).mod==m)
+ exports = cons(hd(xs),exports);
+ }
+ } else {
+ /* Exporting other modules imports all things imported
+ * unqualified from it.
+ * ToDo: we reexport everything exported by a module -
+ * whether we imported it or not. This gives the wrong
+ * result for "module M(module N) where import N(x)"
+ */
+ exports = revDupOnto(module(m).exports,exports);
+ }
+ return exports;
+ } else {
+ Cell ident = fst(e); /* class name or type name */
+ Cell parts = snd(e); /* members or constructors */
+ Cell nm;
+ if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) {
+ switch (tycon(nm).what) {
+ case SYNONYM:
+ if (DOTDOT!=parts) {
+ ERRMSG(0) "Explicit constructor list given for type synonym \"%s\" in export list of module \"%s\"",
+ identToStr(ident),
+ textToStr(mt)
+ EEND;
+ }
+ return cons(pair(nm,DOTDOT),exports);
+ case RESTRICTSYN:
+ ERRMSG(0) "Transparent export of restricted type synonym \"%s\" in export list of module \"%s\"",
+ identToStr(ident),
+ textToStr(mt)
+ EEND;
+ return exports; /* Not reached */
+ case NEWTYPE:
+ case DATATYPE:
+ if (DOTDOT==parts) {
+ return cons(pair(nm,DOTDOT),exports);
+ } else {
+ exports = checkSubentities(exports,parts,tycon(nm).defn,
+ "constructor of type",
+ tycon(nm).text);
+ return cons(pair(nm,DOTDOT), exports);
+ }
+ default:
+ internal("checkExport1");
+ }
+ } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) {
+ if (DOTDOT == parts) {
+ return cons(pair(nm,DOTDOT),exports);
+ } else {
+ exports = checkSubentities(exports,parts,cclass(nm).members,
+ "member of class",cclass(nm).text);
+ return cons(pair(nm,DOTDOT), exports);
+ }
+ } else {
+ ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"",
+ identToStr(ident),
+ textToStr(mt)
+ EEND;
+ }
+ }
+}
+
+List checkExports(thisModule,exports)
+Module thisModule;
+List exports; {
+ Text mt = module(thisModule).text;
+ List es = NIL;
+
+ map1Accum(checkExport,es,mt,exports);
+
+#if DEBUG_MODULES
+ for(xs=es; nonNull(xs); xs=tl(xs)) {
+ printf(" %s", textToStr(textOfEntity(hd(xs))));
+ }
+#endif
+ return es;
+}
+
+/*-------------------------------------------------------------------------*/
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+Void checkQualImport Args((Pair));
+Void checkUnqualImport Args((Triple));
+Void checkImportList Args((Module,Pair));
+List checkExports Args((Module,List));
+
+Void importEntity Args((Module,Cell));
+
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Optimiser
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: optimise.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:23 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+#include "optimise.h"
+
+/* --------------------------------------------------------------------------
+ * Local functions
+ * ------------------------------------------------------------------------*/
+
+static StgAtom optimiseAtom Args((StgAtom));
+static StgVar optimiseVar Args((StgVar));
+static StgCaseAlt optimiseAlt Args((StgCaseAlt));
+static StgPrimAlt optimisePrimAlt Args((StgPrimAlt));
+static StgExpr optimiseExpr Args((StgExpr));
+
+/* --------------------------------------------------------------------------
+ * A simple optimiser
+ * ------------------------------------------------------------------------*/
+
+static StgAtom optimiseAtom(StgAtom a)
+{
+ switch (whatIs(a)) {
+ case STGVAR:
+ return optimiseVar(a);
+ /* Note that NAMEs have no free vars. */
+ default:
+ return a;
+ }
+}
+
+static StgVar optimiseVar(StgVar v)
+{
+ StgRhs rhs = stgVarBody(v);
+ /* short circuit: let x = y in ...x... --> let x = y ...y... */
+ if (whatIs(rhs) == STGVAR && rhs != v) {
+ StgVar v1 = rhs;
+
+ /* find last variable in chain */
+ rhs = stgVarBody(v1);
+ while (whatIs(rhs) == STGVAR
+ && rhs != v /* infinite loop */
+ ) {
+ v1 = rhs;
+ rhs = stgVarBody(rhs);
+ }
+
+ /* Make all variables in chain point to v1
+ * This makes sure we always resolve cycles the same way
+ * as well as making things faster if we call optimiseVar again
+ */
+ while (v != v1) {
+ StgRhs r = stgVarBody(v);
+ assert(whatIs(r) == STGVAR);
+ stgVarBody(v) = v1;
+ v = r;
+ }
+ return v1;
+ }
+ return v;
+}
+
+void optimiseBind( StgVar v )
+{
+ StgRhs rhs = stgVarBody(v);
+ switch (whatIs(rhs)) {
+ case STGCON:
+ mapOver(optimiseAtom,stgConArgs(rhs));
+ break;
+ default:
+ stgVarBody(v) = optimiseExpr(rhs);
+ break;
+ }
+}
+
+static StgCaseAlt optimiseAlt( StgCaseAlt alt )
+{
+ /* StgPat pat = stgCaseAltPat(alt); */
+ stgCaseAltBody(alt) = optimiseExpr(stgCaseAltBody(alt));
+ return alt;
+}
+
+static StgPrimAlt optimisePrimAlt( StgPrimAlt alt )
+{
+ /* List vs = stgPrimAltPats(alt); */
+ stgPrimAltBody(alt) = optimiseExpr(stgPrimAltBody(alt));
+ return alt;
+}
+
+static StgExpr optimiseExpr( StgExpr e )
+{
+ switch (whatIs(e)) {
+ case LETREC:
+ {
+ List binds = stgLetBinds(e);
+ {
+ /* First we filter out trivial bindings.
+ * this has to be done before optimising the individual
+ * bindings so that we don't get confused by the results
+ * of other optimisations.
+ */
+ List bs = binds;
+ binds = NIL;
+ for(; nonNull(bs); bs=tl(bs)) {
+ StgVar b = optimiseVar(hd(bs));
+ StgRhs rhs = stgVarBody(b);
+ if (whatIs(rhs) == STGVAR && b != rhs) {
+ /* This variable will be short-circuited
+ * by optimiseVar so we can drop the binding
+ * right now.
+ */
+ } else {
+ binds = cons(hd(bs),binds);
+ }
+ }
+ binds = rev(binds); /* preserve original order */
+ }
+ stgLetBody(e) = optimiseExpr(stgLetBody(e));
+ if (isNull(binds)) {
+ return stgLetBody(e);
+ } else {
+ mapProc(optimiseBind,binds);
+ stgLetBinds(e) = binds;
+ }
+ break;
+ }
+ case LAMBDA:
+ stgLambdaBody(e) = optimiseExpr(stgLambdaBody(e));
+ break;
+ case CASE:
+ {
+ StgExpr scrut = optimiseExpr(stgCaseScrut(e));
+ StgExpr alts = stgCaseAlts(e);
+ if (whatIs(scrut) == STGVAR
+ && whatIs(stgVarBody(scrut)) == STGCON
+ ) {
+ StgRhs rhs = stgVarBody(scrut);
+ StgDiscr d = stgConCon(rhs);
+ List args = stgConArgs(rhs);
+ for(; nonNull(alts); alts=tl(alts)) {
+ StgCaseAlt alt = hd(alts);
+ StgPat pat = stgCaseAltPat(alt);
+ if (isDefaultPat(pat)) { /* the easy case */
+ StgExpr body = stgCaseAltBody(alt);
+ stgVarBody(pat) = rhs;
+ return optimiseExpr(body);
+ } else if (stgPatDiscr(pat) == d) {
+ /* The tricky case:
+ * rebind all the pattern args to the con args
+ * and rebind the pattern var to con
+ * and run optimiser (to eliminate the binding)
+ */
+ StgExpr body = stgCaseAltBody(alt);
+ List binds = stgPatVars(pat);
+ {
+ List vs = binds;
+ for(;
+ nonNull(vs) && nonNull(args);
+ vs = tl(vs), args=tl(args)
+ ) {
+ stgVarBody(hd(vs)) = hd(args);
+ }
+ }
+ binds = cons(pat,binds); /* turn patvar into a var! */
+ stgVarBody(pat) = rhs;
+
+ /* This letrec will always be optimised away */
+ body = makeStgLet(binds,body);
+ return optimiseExpr(body);
+ }
+ }
+ internal("optimiseExpr: no patterns matched");
+ }
+ stgCaseScrut(e) = scrut;
+ mapOver(optimiseAlt,alts);
+ break;
+ }
+ case PRIMCASE:
+ mapOver(optimisePrimAlt,stgPrimCaseAlts(e));
+ stgPrimCaseScrut(e) = optimiseExpr(stgPrimCaseScrut(e));
+ break;
+ case STGPRIM:
+ mapOver(optimiseAtom,stgPrimArgs(e));
+ /* primop is not a var */
+ break;
+ case STGAPP:
+ stgAppFun(e) = optimiseExpr(stgAppFun(e));
+ mapOver(optimiseAtom,stgAppArgs(e));
+ break;
+ case STGVAR:
+ return optimiseVar(e);
+ case NAME:
+ break; /* Names are never free vars */
+ default:
+ internal("optimiseExpr");
+ }
+ return e;
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern Void optimiseBind Args((StgVar));
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Unparse expressions and types - for use in error messages, type checker
+ * and for debugging.
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: output.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:24 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "input.h" /* for textPlus */
+#include "errors.h"
+#include "link.h"
+#include <ctype.h>
+
+#define DEPTH_LIMIT 15
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Void local putChr Args((Int));
+static Void local putStr Args((String));
+static Void local putInt Args((Int));
+
+static Void local put Args((Int,Cell));
+static Void local putFlds Args((Cell,List));
+static Void local putComp Args((Cell,List));
+static Void local putQual Args((Cell));
+static Bool local isDictVal Args((Cell));
+static Cell local maySkipDict Args((Cell));
+static Void local putAp Args((Int,Cell));
+static Void local putOverInfix Args((Int,Text,Syntax,Cell));
+static Void local putInfix Args((Int,Text,Syntax,Cell,Cell));
+static Void local putSimpleAp Args((Cell,Int));
+static Void local putTuple Args((Int,Cell));
+static Int local unusedTups Args((Int,Cell));
+static Void local unlexVar Args((Text));
+static Void local unlexOp Args((Text));
+static Void local unlexCharConst Args((Cell));
+static Void local unlexStrConst Args((Text));
+
+static Void local putSigType Args((Cell));
+static Void local putContext Args((List,Int));
+static Void local putPred Args((Cell,Int));
+static Void local putType Args((Cell,Int,Int));
+static Void local putTyVar Args((Int));
+static Bool local putTupleType Args((Cell,Int));
+static Void local putApType Args((Type,Int,Int));
+
+static Void local putKind Args((Kind));
+static Void local putKinds Args((Kinds));
+
+/* --------------------------------------------------------------------------
+ * Basic output routines:
+ * ------------------------------------------------------------------------*/
+
+static FILE *outputStream; /* current output stream */
+
+#define OPEN(b) if (b) putChr('(');
+#define CLOSE(b) if (b) putChr(')');
+
+static Void local putChr(c) /* print single character */
+Int c; {
+ Putc(c,outputStream);
+}
+
+static Void local putStr(s) /* print string */
+String s; {
+ for (; *s; s++) {
+ Putc(*s,outputStream);
+ }
+}
+
+static Void local putInt(n) /* print integer */
+Int n; {
+ static char intBuf[16];
+ sprintf(intBuf,"%d",n);
+ putStr(intBuf);
+}
+
+/* --------------------------------------------------------------------------
+ * Precedence values (See Haskell 1.3 report, p.12):
+ * ------------------------------------------------------------------------*/
+
+#define ALWAYS FUN_PREC /* Always use parens (unless atomic)*/
+ /* User defined operators have prec */
+ /* in the range MIN_PREC..MAX_PREC */
+#define ARROW_PREC MAX_PREC /* for printing -> in type exprs */
+#define COCO_PREC (MIN_PREC-1) /* :: is left assoc, low precedence */
+#define COND_PREC (MIN_PREC-2) /* conditional expressions */
+#define WHERE_PREC (MIN_PREC-3) /* where expressions */
+#define LAM_PREC (MIN_PREC-4) /* lambda abstraction */
+#define NEVER LAM_PREC /* Never use parentheses */
+
+
+/* --------------------------------------------------------------------------
+ * Print an expression (used to display context of type errors):
+ * ------------------------------------------------------------------------*/
+
+static Int putDepth = 0; /* limits depth of printing DBG */
+
+static Void local put(d,e) /* print expression e in context of */
+Int d; /* operator of precedence d */
+Cell e; {
+ List xs;
+
+ if (putDepth>DEPTH_LIMIT) {
+ putStr("...");
+ return;
+ }
+ else
+ putDepth++;
+
+ switch (whatIs(e)) {
+ case FINLIST : putChr('[');
+ xs = snd(e);
+ if (nonNull(xs)) {
+ put(NEVER,hd(xs));
+ while (nonNull(xs=tl(xs))) {
+ putChr(',');
+ put(NEVER,hd(xs));
+ }
+ }
+ putChr(']');
+ break;
+
+ case AP : putAp(d,e);
+ break;
+
+ case NAME : unlexVar(name(e).text);
+ break;
+
+ case VARIDCELL :
+ case VAROPCELL :
+ case DICTVAR :
+ case CONIDCELL :
+ case CONOPCELL : unlexVar(textOf(e));
+ break;
+
+#if TREX
+ case RECSEL : putChr('#');
+ unlexVar(extText(snd(e)));
+ break;
+#endif
+
+ case FREECELL : putStr("{free!}");
+ break;
+
+ case TUPLE : putTuple(tupleOf(e),e);
+ break;
+
+ case WILDCARD : putChr('_');
+ break;
+
+ case ASPAT : put(NEVER,fst(snd(e)));
+ putChr('@');
+ put(ALWAYS,snd(snd(e)));
+ break;
+
+ case LAZYPAT : putChr('~');
+ put(ALWAYS,snd(e));
+ break;
+
+ case DOCOMP : putStr("do {...}");
+ break;
+
+ case COMP : putComp(fst(snd(e)),snd(snd(e)));
+ break;
+
+ case CHARCELL : unlexCharConst(charOf(e));
+ break;
+
+ case INTCELL : putInt(intOf(e));
+ break;
+
+ case BIGCELL : putStr(bignumToString(e));
+ break;
+
+ case FLOATCELL : putStr(floatToString(e));
+ break;
+
+ case STRCELL : unlexStrConst(textOf(e));
+ break;
+
+ case LETREC : OPEN(d>WHERE_PREC);
+#if DEBUG_CODE
+ putStr("let {");
+ put(NEVER,fst(snd(e)));
+ putStr("} in ");
+#else
+ putStr("let {...} in ");
+#endif
+ put(WHERE_PREC+1,snd(snd(e)));
+ CLOSE(d>WHERE_PREC);
+ break;
+
+ case COND : OPEN(d>COND_PREC);
+ putStr("if ");
+ put(COND_PREC+1,fst3(snd(e)));
+ putStr(" then ");
+ put(COND_PREC+1,snd3(snd(e)));
+ putStr(" else ");
+ put(COND_PREC+1,thd3(snd(e)));
+ CLOSE(d>COND_PREC);
+ break;
+
+ case LAMBDA : xs = fst(snd(e));
+ if (whatIs(xs)==BIGLAM)
+ xs = snd(snd(e));
+ while (nonNull(xs) && isDictVal(hd(xs)))
+ xs = tl(xs);
+ if (isNull(xs)) {
+ put(d,snd(snd(snd(e))));
+ break;
+ }
+ OPEN(d>LAM_PREC);
+ putChr('\\');
+ if (nonNull(xs)) {
+ put(ALWAYS,hd(xs));
+ while (nonNull(xs=tl(xs))) {
+ putChr(' ');
+ put(ALWAYS,hd(xs));
+ }
+ }
+ putStr(" -> ");
+ put(LAM_PREC,snd(snd(snd(e))));
+ CLOSE(d>LAM_PREC);
+ break;
+
+ case ESIGN : OPEN(d>COCO_PREC);
+ put(COCO_PREC,fst(snd(e)));
+ putStr(" :: ");
+ putSigType(snd(snd(e)));
+ CLOSE(d>COCO_PREC);
+ break;
+
+ case BIGLAM : put(d,snd(snd(e)));
+ break;
+
+ case CASE : putStr("case ");
+ put(NEVER,fst(snd(e)));
+#if DEBUG_CODE
+ putStr(" of {");
+ put(NEVER,snd(snd(e)));
+ putChr('}');
+#else
+ putStr(" of {...}");
+#endif
+ break;
+
+ case CONFLDS : putFlds(fst(snd(e)),snd(snd(e)));
+ break;
+
+ case UPDFLDS : putFlds(fst3(snd(e)),thd3(snd(e)));
+ break;
+
+ default : /*internal("put");*/
+ putChr('$');
+ putInt(e);
+ break;
+ }
+ putDepth--;
+}
+
+static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
+Cell exp;
+List fs; {
+ put(ALWAYS,exp);
+ putChr('{');
+ for (; nonNull(fs); fs=tl(fs)) {
+ Cell v = hd(fs);
+ if (isVar(v))
+ put(NEVER,v);
+ else {
+ Cell f = fst(v);
+ Cell e = snd(v);
+ Text t = isName(f) ? name(f).text :
+ isVar(f) ? textOf(f) : inventText();
+ Text s = isName(e) ? name(e).text :
+ isVar(e) ? textOf(e) : inventText();
+
+ put(NEVER,f);
+ if (s!=t) {
+ putStr(" = ");
+ put(NEVER,e);
+ }
+ }
+ if (nonNull(tl(fs)))
+ putStr(", ");
+ }
+ putChr('}');
+}
+
+static Void local putComp(e,qs) /* print comprehension */
+Cell e;
+List qs; {
+ putStr("[ ");
+ put(NEVER,e);
+ if (nonNull(qs)) {
+ putStr(" | ");
+ putQual(hd(qs));
+ while (nonNull(qs=tl(qs))) {
+ putStr(", ");
+ putQual(hd(qs));
+ }
+ }
+ putStr(" ]");
+}
+
+static Void local putQual(q) /* print list comp qualifier */
+Cell q; {
+ switch (whatIs(q)) {
+ case BOOLQUAL : put(NEVER,snd(q));
+ return;
+
+ case QWHERE : putStr("let {...}");
+ return;
+
+ case FROMQUAL : put(ALWAYS,fst(snd(q)));
+ putStr("<-");
+ put(NEVER,snd(snd(q)));
+ return;
+ }
+}
+
+static Bool local isDictVal(e) /* Look for dictionary value */
+Cell e; {
+#if !DEBUG_CODE
+ Cell h = getHead(e);
+ switch (whatIs(h)) {
+ case DICTVAR : return TRUE;
+ case NAME : return isDfun(h);
+ }
+#endif
+ return FALSE;
+}
+
+static Cell local maySkipDict(e) /* descend function application, */
+Cell e; { /* ignoring dict aps */
+ while (isAp(e) && isDictVal(arg(e)))
+ e = fun(e);
+ return e;
+}
+
+static Void local putAp(d,e) /* print application (args>=1) */
+Int d;
+Cell e; {
+ Cell h;
+ Text t;
+ Syntax sy;
+ Int args = 0;
+
+ for (h=e; isAp(h); h=fun(h)) /* find head of expression, looking*/
+ if (!isDictVal(arg(h))) /* for dictionary arguments */
+ args++;
+
+ if (args==0) { /* Special case when *all* args */
+ put(d,h); /* are dictionary values */
+ return;
+ }
+
+ switch (whatIs(h)) {
+#if NPLUSK
+ case ADDPAT : if (args==1)
+ putInfix(d,textPlus,syntaxOf(textPlus),
+ arg(e),snd(h));
+ else
+ putStr("ADDPAT");
+ return;
+#endif
+
+ case TUPLE : OPEN(args>tupleOf(h) && d>=FUN_PREC);
+ putTuple(tupleOf(h),e);
+ CLOSE(args>tupleOf(h) && d>=FUN_PREC);
+ return;
+
+ case NAME : if (args==1 &&
+ ((h==nameFromInt && isInt(arg(e))) ||
+ (h==nameFromInteger && isBignum(arg(e))) ||
+ (h==nameFromDouble && isFloat(arg(e))))) {
+ put(d,arg(e));
+ return;
+ }
+ sy = syntaxOf(t = name(h).text);
+ break;
+
+ case VARIDCELL :
+ case VAROPCELL :
+ case DICTVAR :
+ case CONIDCELL :
+ case CONOPCELL : sy = syntaxOf(t = textOf(h));
+ break;
+
+#if TREX
+ case EXT : if (args==2) {
+ String punc = "(";
+ do {
+ putStr(punc);
+ punc = ", ";
+ putStr(textToStr(extText(h)));
+ putStr("=");
+ put(NEVER,extField(e));
+ args = 0;
+ e = extRow(e);
+ for (h=e; isAp(h); h=fun(h))
+ if (!isDictVal(arg(h)))
+ args++;
+ } while (isExt(h) && args==2);
+ if (e!=nameNoRec) {
+ putStr(" | ");
+ put(NEVER,e);
+ }
+ putChr(')');
+ return;
+ }
+ else if (args<2)
+ internal("putExt");
+ else
+ args-=2;
+ break;
+#endif
+
+ default : sy = APPLIC;
+ break;
+ }
+
+ e = maySkipDict(e);
+
+ if (sy==APPLIC) { /* print simple application */
+ OPEN(d>=FUN_PREC);
+ putSimpleAp(e,args);
+ CLOSE(d>=FUN_PREC);
+ return;
+ }
+ else if (args==1) { /* print section of the form (e+) */
+ putChr('(');
+ put(FUN_PREC-1,arg(e));
+ putChr(' ');
+ unlexOp(t);
+ putChr(')');
+ }
+ else if (args==2) /* infix expr of the form e1 + e2 */
+ putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
+ else { /* o/w (e1 + e2) e3 ... en (n>=3) */
+ OPEN(d>=FUN_PREC);
+ putOverInfix(args,t,sy,e);
+ CLOSE(d>=FUN_PREC);
+ }
+}
+
+static Void local putOverInfix(args,t,sy,e)
+Int args; /* infix applied to >= 3 arguments */
+Text t;
+Syntax sy;
+Cell e; {
+ if (args>2) {
+ putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
+ putChr(' ');
+ put(FUN_PREC,arg(e));
+ }
+ else
+ putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
+}
+
+static Void local putInfix(d,t,sy,e,f) /* print infix expression */
+Int d;
+Text t; /* Infix operator symbol */
+Syntax sy; /* with name t, syntax s */
+Cell e, f; { /* Left and right operands */
+ Syntax a = assocOf(sy);
+ Int p = precOf(sy);
+
+ OPEN(d>p);
+ put((a==LEFT_ASS ? p : 1+p), e);
+ putChr(' ');
+ unlexOp(t);
+ putChr(' ');
+ put((a==RIGHT_ASS ? p : 1+p), f);
+ CLOSE(d>p);
+}
+
+static Void local putSimpleAp(e,n) /* print application e0 e1 ... en */
+Cell e;
+Int n; {
+ if (n>0) {
+ putSimpleAp(maySkipDict(fun(e)),n-1);
+ putChr(' ');
+ put(FUN_PREC,arg(e));
+ }
+ else
+ put(FUN_PREC,e);
+}
+
+static Void local putTuple(ts,e) /* Print tuple expression, allowing*/
+Int ts; /* for possibility of either too */
+Cell e; { /* few or too many args to constr */
+ Int i;
+ putChr('(');
+ if ((i=unusedTups(ts,e))>0) {
+ while (--i>0)
+ putChr(',');
+ putChr(')');
+ }
+}
+
+static Int local unusedTups(ts,e) /* print first part of tuple expr */
+Int ts; /* returning number of constructor */
+Cell e; { /* args not yet printed ... */
+ if (isAp(e)) {
+ if ((ts=unusedTups(ts,fun(e))-1)>=0) {
+ put(NEVER,arg(e));
+ putChr(ts>0?',':')');
+ }
+ else {
+ putChr(' ');
+ put(FUN_PREC,arg(e));
+ }
+ }
+ return ts;
+}
+
+static Void local unlexVar(t) /* print text as a variable name */
+Text t; { /* operator symbols must be enclosed*/
+ String s = textToStr(t); /* in parentheses... except [] ... */
+
+ if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
+ putStr(s);
+ else {
+ putChr('(');
+ putStr(s);
+ putChr(')');
+ }
+}
+
+static Void local unlexOp(t) /* print text as operator name */
+Text t; { /* alpha numeric symbols must be */
+ String s = textToStr(t); /* enclosed by backquotes */
+
+ if (isascii(s[0]) && isalpha(s[0])) {
+ putChr('`');
+ putStr(s);
+ putChr('`');
+ }
+ else
+ putStr(s);
+}
+
+static Void local unlexCharConst(c)
+Cell c; {
+ putChr('\'');
+ putStr(unlexChar(c,'\''));
+ putChr('\'');
+}
+
+static Void local unlexStrConst(t)
+Text t; {
+ String s = textToStr(t);
+ static Char SO = 14; /* ASCII code for '\SO' */
+ Bool lastWasSO = FALSE;
+ Bool lastWasDigit = FALSE;
+ Bool lastWasEsc = FALSE;
+
+ putChr('\"');
+ for (; *s; s++) {
+ String ch = unlexChar(*s,'\"');
+ Char c = ' ';
+
+ if ((lastWasSO && *ch=='H') ||
+ (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
+ putStr("\\&");
+
+ lastWasEsc = (*ch=='\\');
+ lastWasSO = (*s==SO);
+ for (; *ch; c = *ch++)
+ putChr(*ch);
+ lastWasDigit = (isascii(c) && isdigit(c));
+ }
+ putChr('\"');
+}
+
+/* --------------------------------------------------------------------------
+ * Print type expression:
+ * ------------------------------------------------------------------------*/
+
+static Void local putSigType(t) /* print (possibly) generic type */
+Cell t; {
+ Int fr = 0;
+ if (isPolyType(t)) {
+ Kinds ks = polySigOf(t);
+ for (; isAp(ks); ks=tl(ks))
+ fr++;
+ t = monotypeOf(t);
+ }
+
+ putType(t,NEVER,fr); /* Finally, print rest of type ... */
+}
+
+static Void local putContext(qs,fr) /* print context list */
+List qs;
+Int fr; {
+ if (isNull(qs))
+ putStr("()");
+ else {
+ Int nq = length(qs);
+ if (nq!=1) putChr('(');
+ putPred(hd(qs),fr);
+ while (nonNull(qs=tl(qs))) {
+ putStr(", ");
+ putPred(hd(qs),fr);
+ }
+ if (nq!=1) putChr(')');
+ }
+}
+
+static Void local putPred(pi,fr) /* Output predicate */
+Cell pi;
+Int fr; {
+ if (isAp(pi)) {
+#if TREX
+ if (isExt(fun(pi))) {
+ putType(arg(pi),ALWAYS,fr);
+ putChr('\\');
+ putStr(textToStr(extText(fun(pi))));
+ return;
+ }
+#endif
+ putPred(fun(pi),fr);
+ putChr(' ');
+ putType(arg(pi),ALWAYS,fr);
+ }
+ else if (isClass(pi))
+ putStr(textToStr(cclass(pi).text));
+ else if (isCon(pi))
+ putStr(textToStr(textOf(pi)));
+ else
+ putStr("<unknownPredicate>");
+}
+
+static Void local putType(t,prec,fr) /* print nongeneric type expression*/
+Cell t;
+Int prec;
+Int fr; {
+ switch(whatIs(t)) {
+ case TYCON : putStr(textToStr(tycon(t).text));
+ break;
+
+ case TUPLE : { Int n = tupleOf(t);
+ putChr('(');
+ while (--n > 0)
+ putChr(',');
+ putChr(')');
+ }
+ break;
+
+ case POLYTYPE : { Kinds ks = polySigOf(t);
+ OPEN(prec>=ARROW_PREC);
+ putStr("forall ");
+ for (; isAp(ks); ks=tl(ks)) {
+ putTyVar(fr++);
+ if (isAp(tl(ks)))
+ putChr(',');
+ }
+ putStr(". ");
+ putType(monotypeOf(t),NEVER,fr);
+ CLOSE(prec>=ARROW_PREC);
+ }
+ break;
+
+ case QUAL : OPEN(prec>=ARROW_PREC);
+ putContext(fst(snd(t)),fr);
+ putStr(" => ");
+ putType(snd(snd(t)),NEVER,fr);
+ CLOSE(prec>=ARROW_PREC);
+ break;
+
+ case EXIST :
+ case RANK2 : putType(snd(snd(t)),prec,fr);
+ break;
+
+ case OFFSET : putTyVar(offsetOf(t));
+ break;
+
+ case VARIDCELL :
+ case VAROPCELL : putChr('_');
+ unlexVar(textOf(t));
+ break;
+
+ case INTCELL : putChr('_');
+ putInt(intOf(t));
+ break;
+
+/* #ifdef DEBUG_TYPES */
+ case STAR : putChr('*');
+ break;
+/* #endif */
+
+ case AP : { Cell typeHead = getHead(t);
+ Bool brackets = (argCount!=0 && prec>=ALWAYS);
+ Int args = argCount;
+
+ if (typeHead==typeList) {
+ if (argCount==1) {
+ putChr('[');
+ putType(arg(t),NEVER,fr);
+ putChr(']');
+ return;
+ }
+ }
+ else if (typeHead==typeArrow) {
+ if (argCount==2) {
+ OPEN(prec>=ARROW_PREC);
+ putType(arg(fun(t)),ARROW_PREC,fr);
+ putStr(" -> ");
+ putType(arg(t),NEVER,fr);
+ CLOSE(prec>=ARROW_PREC);
+ return;
+ }
+ else if (argCount==1) {
+ putChr('(');
+ putType(arg(t),ARROW_PREC,fr);
+ putStr("->)");
+ return;
+ }
+ }
+ else if (isTuple(typeHead)) {
+ if (argCount==tupleOf(typeHead)) {
+ putChr('(');
+ putTupleType(t,fr);
+ putChr(')');
+ return;
+ }
+ }
+#if TREX
+ else if (isExt(typeHead)) {
+ if (args==2) {
+ String punc = "(";
+ do {
+ putStr(punc);
+ punc = ", ";
+ putStr(textToStr(extText(typeHead)));
+ putStr("::");
+ putType(extField(t),NEVER,fr);
+ t = extRow(t);
+ typeHead = getHead(t);
+ } while (isExt(typeHead) && argCount==2);
+ if (t!=typeNoRow) {
+ putStr(" | ");
+ putType(t,NEVER,fr);
+ }
+ putChr(')');
+ return;
+ }
+ else if (args<2)
+ internal("putExt");
+ else
+ args-=2;
+ }
+#endif
+ OPEN(brackets);
+ putApType(t,args,fr);
+ CLOSE(brackets);
+ }
+ break;
+
+ default : putStr("(bad type)");
+ }
+}
+
+static Void local putTyVar(n) /* print type variable */
+Int n; {
+ static String alphabet /* for the benefit of EBCDIC :-) */
+ ="abcdefghijklmnopqrstuvwxyz";
+ putChr(alphabet[n%26]);
+ if (n /= 26) /* just in case there are > 26 vars*/
+ putInt(n);
+}
+
+static Bool local putTupleType(e,fr) /* print tuple of types, returning */
+Cell e; /* TRUE if something was printed, */
+Int fr; { /* FALSE otherwise; used to control*/
+ if (isAp(e)) { /* printing of intermed. commas */
+ if (putTupleType(fun(e),fr))
+ putChr(',');
+ putType(arg(e),NEVER,fr);
+ return TRUE;
+ }
+ return FALSE;
+}
+
+static Void local putApType(t,n,fr) /* print type application */
+Cell t;
+Int n;
+Int fr; {
+ if (n>0) {
+ putApType(fun(t),n-1,fr);
+ putChr(' ');
+ putType(arg(t),ALWAYS,fr);
+ }
+ else
+ putType(t,ALWAYS,fr);
+}
+
+/* --------------------------------------------------------------------------
+ * Print kind expression:
+ * ------------------------------------------------------------------------*/
+
+static Void local putKind(k) /* print kind expression */
+Kind k; {
+ switch (whatIs(k)) {
+ case AP : if (isAp(fst(k))) {
+ putChr('(');
+ putKind(fst(k));
+ putChr(')');
+ }
+ else
+ putKind(fst(k));
+ putStr(" -> ");
+ putKind(snd(k));
+ break;
+
+#if TREX
+ case ROW : putStr("row");
+ break;
+#endif
+
+ case STAR : putChr('*');
+ break;
+
+ case OFFSET : putTyVar(offsetOf(k));
+ break;
+
+ case INTCELL : putChr('_');
+ putInt(intOf(k));
+ break;
+
+ default : putStr("(bad kind)");
+ }
+}
+
+static Void local putKinds(ks) /* Print list of kinds */
+Kinds ks; {
+ if (isNull(ks))
+ putStr("()");
+ else if (nonNull(tl(ks))) {
+ putChr('(');
+ putKind(hd(ks));
+ while (nonNull(ks=tl(ks))) {
+ putChr(',');
+ putKind(hd(ks));
+ }
+ putChr(')');
+ }
+ else
+ putKind(hd(ks));
+}
+
+/* --------------------------------------------------------------------------
+ * Main drivers:
+ * ------------------------------------------------------------------------*/
+
+Void printExp(fp,e) /* print expr on specified stream */
+FILE *fp;
+Cell e; {
+ outputStream = fp;
+ putDepth = 0;
+ put(NEVER,e);
+}
+
+Void printType(fp,t) /* print type on specified stream */
+FILE *fp;
+Cell t; {
+ outputStream = fp;
+ putSigType(t);
+}
+
+Void printContext(fp,qs) /* print context on spec. stream */
+FILE *fp;
+List qs; {
+ outputStream = fp;
+ putContext(qs,0);
+}
+
+Void printPred(fp,pi) /* print predicate pi on stream */
+FILE *fp;
+Cell pi; {
+ outputStream = fp;
+ putPred(pi,0);
+}
+
+Void printKind(fp,k) /* print kind k on stream */
+FILE *fp;
+Kind k; {
+ outputStream = fp;
+ putKind(k);
+}
+
+Void printKinds(fp,ks) /* print list of kinds on stream */
+FILE *fp;
+Kinds ks; {
+ outputStream = fp;
+ putKinds(ks);
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+extern Void printExp Args((FILE *,Cell));
+extern Void printType Args((FILE *,Cell));
+extern Void printContext Args((FILE *,List));
+extern Void printPred Args((FILE *,Cell));
+extern Void printKind Args((FILE *,Kind));
+extern Void printKinds Args((FILE *,Kinds));
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Hugs parser (included as part of input.c)
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * Expect 24 shift/reduce conflicts when passing this grammar through yacc,
+ * but don't worry; they will all be resolved in an appropriate manner.
+ *
+ * $RCSfile: parser.y,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:26 $
+ * ------------------------------------------------------------------------*/
+
+%{
+#ifndef lint
+#define lint
+#endif
+#define defTycon(n,l,lhs,rhs,w) tyconDefn(intOf(l),lhs,rhs,w); sp-=n
+#define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t))
+#define grded(gs) ap(GUARDED,gs)
+#define bang(t) ap(BANG,t)
+#define only(t) ap(ONLY,t)
+#define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
+#define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
+#define yyerror(s) /* errors handled elsewhere */
+#define YYSTYPE Cell
+
+static Cell local gcShadow Args((Int,Cell));
+static Void local syntaxError Args((String));
+static String local unexpected Args((Void));
+static Cell local checkPrec Args((Cell));
+static Void local fixDefn Args((Syntax,Cell,Cell,List));
+static Void local setSyntax Args((Int,Syntax,Cell));
+static Cell local buildTuple Args((List));
+static List local checkContext Args((List));
+static Cell local checkPred Args((Cell));
+static Pair local checkDo Args((List));
+static Cell local checkTyLhs Args((Cell));
+#if !TREX
+static Void local noTREX Args((String));
+#endif
+static Cell local tidyInfix Args((Cell));
+
+/* For the purposes of reasonably portable garbage collection, it is
+ * necessary to simulate the YACC stack on the Hugs stack to keep
+ * track of all intermediate constructs. The lexical analyser
+ * pushes a token onto the stack for each token that is found, with
+ * these elements being removed as reduce actions are performed,
+ * taking account of look-ahead tokens as described by gcShadow()
+ * below.
+ *
+ * Of the non-terminals used below, only start, topDecl, fixDecl & begin
+ * do not leave any values on the Hugs stack. The same is true for the
+ * terminals EXPR and SCRIPT. At the end of a successful parse, there
+ * should only be one element left on the stack, containing the result
+ * of the parse.
+ */
+
+#define gc0(e) gcShadow(0,e)
+#define gc1(e) gcShadow(1,e)
+#define gc2(e) gcShadow(2,e)
+#define gc3(e) gcShadow(3,e)
+#define gc4(e) gcShadow(4,e)
+#define gc5(e) gcShadow(5,e)
+#define gc6(e) gcShadow(6,e)
+#define gc7(e) gcShadow(7,e)
+
+%}
+
+%token EXPR SCRIPT
+%token CASEXP OF DATA TYPE IF
+%token THEN ELSE WHERE LET IN
+%token INFIX INFIXL INFIXR FOREIGN TNEWTYPE
+%token DEFAULT DERIVING DO TCLASS TINSTANCE
+%token REPEAT ALL
+%token VAROP VARID NUMLIT CHARLIT STRINGLIT
+%token CONOP CONID
+%token QVAROP QVARID QCONOP QCONID
+/*#if TREX*/
+%token RECSELID
+/*#endif*/
+%token COCO '=' UPTO '@' '\\'
+%token '|' '-' FROM ARROW '~'
+%token '!' IMPLIES '(' ',' ')'
+%token '[' ';' ']' '`' '.'
+%token MODULETOK IMPORT HIDING QUALIFIED ASMOD
+%token EXPORT INTERFACE REQUIRES UNSAFE
+
+%%
+/*- Top level script/module structure: ------------------------------------*/
+
+start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
+ | SCRIPT topModule {valDefns = $2; sp-=1;}
+ | INTERFACE iface {sp-=1;}
+ | error {syntaxError("input");}
+ ;
+
+/*- GHC interface file parsing: -------------------------------------------*/
+
+/* Reading in an interface file is surprisingly like reading
+ * a normal Haskell module: we read in a bunch of declarations,
+ * construct symbol table entries, etc. The "only" differences
+ * are that there's no syntactic sugar to deal with and we don't
+ * have to read in expressions.
+ */
+
+iface : INTERFACE ifaceName NUMLIT checkVersion ifaceDecls { $$ = gc5(NIL); }
+ | INTERFACE error {syntaxError("interface file");}
+ ;
+
+ifaceName : CONID {openGHCIface(textOf($1)); $$ = gc1(NIL);}
+ ;
+
+ifaceDecls: {$$=gc0(NIL);}
+ | ifaceDecl ';' ifaceDecls {$$=gc3(cons($1,$2));}
+ ;
+
+/* We use ifaceData in data decls so as to include () */
+ifaceDecl : IMPORT CONID NUMLIT { extern String scriptFile;
+ String fileName = findPathname(scriptFile,textToStr(textOf($2)));
+ addGHCImport(intOf($1),textOf($2),fileName);
+ $$ = gc3(NIL);
+ }
+ | EXPORT CONID ifaceEntities {}
+ | REQUIRES STRINGLIT { extern String scriptFile;
+ String fileName = findPathname(scriptFile,textToStr(textOf($2)));
+ loadSharedLib(fileName);
+ $$ = gc2(NIL);
+ }
+ | INFIXL optdigit op { fixDefn(LEFT_ASS,$1,$2,$3); $$ = gc3(NIL); }
+ | INFIXR optdigit op { fixDefn(RIGHT_ASS,$1,$2,$3); $$ = gc3(NIL); }
+ | INFIX optdigit op { fixDefn(NON_ASS,$1,$2,$3); $$ = gc3(NIL); }
+ | TINSTANCE ifaceQuant ifaceClass '=' ifaceVar { addGHCInstance(intOf($1),$2,$3,textOf($5)); $$ = gc5(NIL); }
+ | NUMLIT TYPE ifaceTCName ifaceTVBndrs '=' ifaceType { addGHCSynonym(intOf($2),$3,$4,$6); $$ = gc6(NIL); }
+ | NUMLIT DATA ifaceData ifaceTVBndrs ifaceConstrs ifaceSels { addGHCDataDecl(intOf($2),$3,$4,$5,$6); $$ = gc6(NIL); }
+ | NUMLIT TNEWTYPE ifaceTCName ifaceTVBndrs ifaceNewTypeConstr { addGHCNewType(intOf($2),$3,$4,$5); $$ = gc5(NIL); }
+ | NUMLIT TCLASS ifaceDeclContext ifaceTCName ifaceTVBndrs ifaceCSigs { addGHCClass(intOf($2),$3,$4,$5,$6); $$ = gc6(NIL); }
+ | NUMLIT ifaceVar COCO ifaceType { addGHCVar(intOf($3),textOf($2),$4); $$ = gc4(NIL); }
+ | error { syntaxError("interface declaration"); }
+ ;
+
+checkVersion
+ : NUMLIT { $$ = gc1(NIL); }
+ ;
+
+ifaceSels /* [(VarId,Type)] */
+ : { $$ = gc0(NIL); }
+ | WHERE '{' ifaceSels1 '}' { $$ = gc4($3); }
+ ;
+
+ifaceSels1 /* [(VarId,Type)] */
+ : ifaceSel { $$ = gc1(singleton($1)); }
+ | ifaceSel ';' ifaceSels1 { $$ = gc3(cons($1,$3)); }
+ ;
+
+ifaceSel /* (VarId,Type) */
+ : ifaceVarName COCO ifaceType { $$ = gc3(pair($1,$3)); }
+ ;
+
+ifaceCSigs /* [(VarId,Type)] */
+ : { $$ = gc0(NIL); }
+ | WHERE '{' ifaceCSigs1 '}' { $$ = gc4($3); }
+ ;
+
+ifaceCSigs1 /* [(VarId,Type)] */
+ : ifaceCSig { $$ = gc1(singleton($1)); }
+ | ifaceCSig ';' ifaceCSigs1 { $$ = gc3(cons($1,$3)); }
+ ;
+
+ifaceCSig /* (VarId,Type) */
+ : ifaceVarName COCO ifaceType { $$ = gc3(pair($1,$3)); }
+ | ifaceVarName '=' COCO ifaceType { $$ = gc4(pair($1,$4)); } /* has default method */
+ ;
+
+ifaceConstrs /* [(ConId,[VarId],Type)] */
+ : { $$ = gc0(NIL); }
+ | '=' ifaceConstrs1 { $$ = gc2($2); }
+ ;
+
+ifaceConstrs1 /* [(ConId,[VarId],Type)] */
+ : ifaceConstr { $$ = gc1(singleton($1)); }
+ | ifaceConstr '|' ifaceConstrs1 { $$ = gc3(cons($1,$3)); }
+ ;
+
+/* We use ifaceData so as to include () */
+ifaceConstr /* (ConId,[VarId],Type) */
+ : ifaceData COCO ifaceType { $$ = gc3(triple($1,NIL,$3)); }
+ | ifaceData '{' ifaceVarNames1 '}' COCO ifaceType { $$ = gc6(triple($1,$3,$6)); }
+ ;
+
+ifaceNewTypeConstr /* (ConId,Type) */
+ : { $$ = gc0(NIL); }
+ | '=' ifaceDataName COCO ifaceType { $$ = gc4(pair($2,$4)); }
+ ;
+
+ifaceQuant /* Maybe ([(VarId,Kind)],[(ConId, [Type])]) */
+ : { $$ = gc0(NIL); }
+ | ALL ifaceForall ifaceContext IMPLIES { $$ = gc4(pair($2,$3)); }
+ ;
+
+ifaceType
+ : ALL ifaceForall ifaceContext IMPLIES ifaceType { $$ = gc5(ap(POLYTYPE,triple($2,$3,$5))); }
+ | ifaceBType ARROW ifaceType { $$ = gc3(fn($1,$3)); }
+ | ifaceBType { $$ = gc1($1); }
+ ;
+
+ifaceForall /* [(VarId,Kind)] */
+ : '[' ifaceTVBndrs ']' { $$ = gc3($2); }
+ ;
+
+ifaceDeclContext /* [(ConId, [Type])] */
+ : { $$ = gc0(NIL); }
+ | '{' ifaceContextList1 '}' IMPLIES { $$ = gc4($2); }
+ ;
+
+ifaceContext /* [(ConId, [Type])] */
+ : { $$ = gc0(NIL); }
+ | '{' ifaceContextList1 '}' { $$ = gc3($2); }
+ ;
+
+ifaceContextList1 /* [(ConId, [Type])] */
+ : ifaceClass { $$ = gc1(singleton($1)); }
+ | ifaceClass ',' ifaceContextList1 { $$ = gc3(cons($1,$3)); }
+ ;
+
+ifaceClass /* (ConId, [Type]) */
+ : ifaceQTCName ifaceATypes { $$ = gc2(pair($1,$2)); }
+ ;
+
+ifaceTypes2
+ : ifaceType ',' ifaceType { $$ = gc3(doubleton($1,$3)); }
+ | ifaceType ',' ifaceTypes2 { $$ = gc3(cons($1,$3)); }
+ ;
+
+ifaceBType
+ : ifaceAType { $$ = gc1($1); }
+ | ifaceBType ifaceAType { $$ = gc2(ap($1,$2)); }
+ ;
+
+ifaceAType
+ : ifaceQTCName { $$ = gc1($1); }
+ | ifaceTVName { $$ = gc1($1); }
+ | '(' ')' { $$ = gc2(conPreludeUnit); }
+ | '(' ifaceTypes2 ')' { $$ = gc3(buildTuple($2)); }
+ | '[' ifaceType ']' { $$ = gc3(ap(conPreludeList,$2));}
+ | '{' ifaceQTCName ifaceATypes '}' { $$ = gc4(ap(DICTAP,pair($2,$3))); }
+ | '(' ifaceType ')' { $$ = gc3($2); }
+ ;
+
+ifaceATypes
+ : { $$ = gc0(NIL); }
+ | ifaceAType ifaceATypes { $$ = gc2(cons($1,$2)); }
+ ;
+
+ifaceEntities
+ : { $$ = gc0(NIL); }
+ | ifaceEntity ifaceEntities { $$ = gc2(cons($1,$2)); }
+ ;
+
+ifaceEntity
+ : ifaceEntityOcc {}
+ | ifaceEntityOcc ifaceStuffInside {}
+| ifaceEntityOcc '|' ifaceStuffInside {} /* exporting datacons but not tycon */
+ ;
+
+ifaceEntityOcc
+ : ifaceVar { $$ = gc1($1); }
+ | ifaceData { $$ = gc1($1); }
+ | ARROW { $$ = gc3(typeArrow); }
+ | '(' ARROW ')' { $$ = gc3(typeArrow); } /* why allow both? */
+ ;
+
+ifaceStuffInside
+ : '{' ifaceValOccs '}' { $$ = gc1($1); }
+ ;
+
+
+ifaceValOccs
+ : ifaceValOcc { $$ = gc1(singleton($1)); }
+ | ifaceValOcc ifaceValOccs { $$ = gc2(cons($1,$2)); }
+ ;
+
+ifaceValOcc
+ : ifaceVar {$$ = gc1($1); }
+ | ifaceData {$$ = gc1($1); }
+ ;
+
+ifaceVar : VARID {$$ = gc1($1); }
+ | VAROP {$$ = gc1($1); }
+ | '!' {$$ = gc1(varBang); }
+ | '.' {$$ = gc1(varDot); }
+ | '-' {$$ = gc1(varMinus);}
+ ;
+
+ifaceData /* ConId | QualConId */
+ : CONID {$$ = gc1($1);}
+ | CONOP {$$ = gc1($1);}
+ | '(' ')' {$$ = gc2(conPreludeUnit);}
+ | '[' ']' {$$ = gc2(conPreludeList);}
+ ;
+
+ifaceVarName /* VarId */
+ : ifaceVar { $$ = gc1($1); }
+ ;
+
+ifaceDataName /* ConId|QualConId */
+ : ifaceData { $$ = gc1($1); }
+ ;
+
+ifaceVarNames1 /* [VarId] */
+ : ifaceVarName { $$ = gc1(singleton($1)); }
+ | ifaceVarName ifaceVarNames1 { $$ = gc2(cons($1,$2)); }
+ ;
+
+ifaceTVName /* VarId */
+ : VARID { $$ = gc1($1); }
+ ;
+
+ifaceTVBndrs /* [(VarId,Kind)] */
+ : { $$ = gc0(NIL); }
+ | ifaceTVBndr ifaceTVBndrs { $$ = gc2(cons($1,$2)); }
+ ;
+
+ifaceTVBndr /* (VarId,Kind) */
+ : ifaceTVName { $$ = gc1(pair($1,STAR)); }
+ | ifaceTVName COCO ifaceAKind { $$ = gc3(pair($1,$3)); }
+ ;
+
+ifaceKind
+ : ifaceAKind { $$ = gc1($1); }
+ | ifaceAKind ARROW ifaceKind { $$ = gc3(fn($1,$3)); }
+ ;
+
+ifaceAKind
+ : VAROP { $$ = gc1(STAR); } /* should be '*' */
+ | '(' ifaceKind ')' { $$ = gc1($1); }
+ ;
+
+ifaceTCName
+ : CONID { $$ = gc1($1); }
+ | CONOP { $$ = gc1($1); }
+ | '(' ARROW ')' { $$ = gc3(typeArrow); }
+ | '[' ']' { $$ = gc1(conPreludeList); }
+ ;
+
+ifaceQTCName
+ : ifaceTCName { $$ = gc1($1); }
+ | QCONID { $$ = gc1($1); }
+ | QCONOP { $$ = gc1($1); }
+ ;
+
+/*- Haskell module header/import parsing: ---------------------------------*/
+
+/* In Haskell 1.2, the default module header was "module Main where"
+ * In 1.3, this changed to "module Main(main) where".
+ * We use the 1.2 header because it breaks much less pre-module code.
+ */
+topModule : startMain begin modBody end {
+ setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
+ $$ = gc3($3);
+ }
+ | MODULETOK modname expspec WHERE '{' modBody end
+ {setExportList($3); $$ = gc7($6);}
+ | MODULETOK error {syntaxError("module definition");}
+ ;
+/* To implement the Haskell module system, we have to keep track of the
+ * current module. We rely on the use of LALR parsing to ensure that this
+ * side effect happens before any declarations within the module.
+ */
+startMain : /* empty */ {startModule(conMain);
+ $$ = gc0(NIL);}
+ ;
+modname : CONID {startModule($1); $$ = gc1(NIL);}
+ ;
+modid : CONID {$$ = gc1($1);}
+ | STRINGLIT { extern String scriptFile;
+ String modName = findPathname(scriptFile,textToStr(textOf($1)));
+ if (modName) { /* fillin pathname if known */
+ $$ = mkStr(findText(modName));
+ } else {
+ $$ = $1;
+ }
+ }
+ ;
+modBody : topDecls {$$ = gc1($1);}
+ | fixDecls ';' topDecls {$$ = gc3($3);}
+ | impDecls chase {$$ = gc2(NIL);}
+ | impDecls ';' chase topDecls {$$ = gc4($4);}
+ | impDecls ';' chase fixDecls ';' topDecls
+ {$$ = gc6($6);}
+ ;
+
+/*- Exports: --------------------------------------------------------------*/
+
+expspec : /* empty */ {$$ = gc0(exportSelf());}
+ | '(' ')' {$$ = gc2(NIL);}
+ | '(' exports ')' {$$ = gc3($2);}
+ | '(' exports ',' ')' {$$ = gc4($2);}
+ ;
+exports : exports ',' export {$$ = gc3(cons($3,$1));}
+ | export {$$ = gc1(singleton($1));}
+ ;
+/* The qcon should be qconid.
+ * Relaxing the rule lets us explicitly export (:) from the Prelude.
+ */
+export : qvar {$$ = gc1($1);}
+ | qcon {$$ = gc1($1);}
+ | qcon2 '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
+ | qcon2 '(' qnames ')' {$$ = gc4(pair($1,$3));}
+ | MODULETOK modid {$$ = gc2(ap(MODULEENT,$2));}
+ ;
+qnames : /* empty */ {$$ = gc0(NIL);}
+ | ',' {$$ = gc1(NIL);}
+ | qnames1 {$$ = gc1($1);}
+ | qnames1 ',' {$$ = gc2($1);}
+ ;
+qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
+ | qname {$$ = gc1(singleton($1));}
+ ;
+qname : qvar {$$ = gc1($1);}
+ | qcon {$$ = gc1($1);}
+ | '(' ')' {$$ = gc2(conPreludeUnit);}
+ | '[' ']' {$$ = gc2(conPreludeList);}
+ ;
+qcon2 : '(' ')' {$$ = gc2(conPreludeUnit);}
+ | '[' ']' {$$ = gc2(conPreludeList);}
+ | qconid {$$ = gc1($1);}
+ ;
+
+/*- Import declarations: --------------------------------------------------*/
+
+impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);}
+ | impDecl {imps = singleton($1); $$=gc1(NIL);}
+ ;
+chase : /* empty */ {if (chase(imps)) {
+ clearStack();
+ onto(imps);
+ done();
+ closeAnyInput();
+ return 0;
+ }
+ $$ = gc0(NIL);
+ }
+ ;
+/* Note that qualified import ignores the import list. */
+impDecl : IMPORT modid impspec {addQualImport($2,$2);
+ addUnqualImport($2,$3);
+ $$ = gc3($2);}
+ | IMPORT modid ASMOD modid impspec
+ {addQualImport($2,$4);
+ addUnqualImport($2,$5);
+ $$ = gc5($2);}
+ | IMPORT QUALIFIED modid ASMOD modid impspec
+ {addQualImport($3,$5);
+ $$ = gc6($3);}
+ | IMPORT QUALIFIED modid impspec
+ {addQualImport($3,$3);
+ $$ = gc4($3);}
+ | IMPORT error {syntaxError("import declaration");}
+ ;
+impspec : /* empty */ {$$ = gc0(DOTDOT);}
+ | HIDING '(' imports ')' {$$ = gc4(ap(HIDDEN,$3));}
+ | '(' imports ')' {$$ = gc3($2);}
+ ;
+imports : /* empty */ {$$ = gc0(NIL);}
+ | ',' {$$ = gc1(NIL);}
+ | imports1 {$$ = gc1($1);}
+ | imports1 ',' {$$ = gc2($1);}
+ ;
+imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
+ | import {$$ = gc1(singleton($1));}
+ ;
+import : var {$$ = gc1($1);}
+ | CONID {$$ = gc1($1);}
+ | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
+ | CONID '(' names ')' {$$ = gc4(pair($1,$3));}
+ ;
+names : /* empty */ {$$ = gc0(NIL);}
+ | ',' {$$ = gc1(NIL);}
+ | names1 {$$ = gc1($1);}
+ | names1 ',' {$$ = gc2($1);}
+ ;
+names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
+ | name {$$ = gc1(singleton($1));}
+ ;
+name : var {$$ = gc1($1);}
+ | con {$$ = gc1($1);}
+ ;
+
+/*- Fixity declarations: --------------------------------------------------*/
+
+fixDecls : fixDecls ';' fixDecl {$$ = gc2(NIL);}
+ | fixDecl {$$ = gc0(NIL);}
+ ;
+fixDecl : INFIXL optdigit ops {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;}
+ | INFIXR optdigit ops {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;}
+ | INFIX optdigit ops {fixDefn(NON_ASS,$1,$2,$3); sp-=3;}
+ ;
+optdigit : NUMLIT {$$ = gc1(checkPrec($1));}
+ | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
+ ;
+ops : ops ',' op {$$ = gc3(cons($3,$1));}
+ | op {$$ = gc1(cons($1,NIL));}
+ ;
+
+/*- Top-level declarations: -----------------------------------------------*/
+
+topDecls : /* empty */ {$$ = gc0(NIL);}
+ | ';' {$$ = gc1(NIL);}
+ | topDecls1 {$$ = gc1($1);}
+ | topDecls1 ';' {$$ = gc2($1);}
+ ;
+topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);}
+ | topDecls1 ';' decl {$$ = gc3(cons($3,$1));}
+ | topDecl {$$ = gc0(NIL);}
+ | decl {$$ = gc1(cons($1,NIL));}
+ ;
+
+/*- Type declarations: ----------------------------------------------------*/
+
+topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);}
+ | TYPE tyLhs '=' type IN invars
+ {defTycon(6,$3,$2,
+ ap($4,$6),RESTRICTSYN);}
+ | DATA btype2 '=' constrs deriving
+ {defTycon(5,$3,checkTyLhs($2),
+ ap(rev($4),$5),DATATYPE);}
+ | DATA context IMPLIES tyLhs '=' constrs deriving
+ {defTycon(7,$5,$4,
+ ap(ap(QUAL,pair($2,rev($6))),
+ $7),DATATYPE);}
+ | DATA btype2 {defTycon(2,$1,checkTyLhs($2),
+ ap(NIL,NIL),DATATYPE);}
+ | DATA context IMPLIES tyLhs {defTycon(4,$1,$4,
+ ap(ap(QUAL,pair($2,NIL)),
+ NIL),DATATYPE);}
+ | TNEWTYPE btype2 '=' nconstr deriving
+ {defTycon(5,$3,checkTyLhs($2),
+ ap($4,$5),NEWTYPE);}
+ | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
+ {defTycon(7,$5,$4,
+ ap(ap(QUAL,pair($2,$6)),
+ $7),NEWTYPE);}
+ ;
+tyLhs : tyLhs varid1 {$$ = gc2(ap($1,$2));}
+ | CONID {$$ = gc1($1);}
+ | '[' type ']' {$$ = gc3(ap(conList,$2));}
+ | '(' ')' {$$ = gc2(conUnit);}
+ | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
+ | error {syntaxError("type defn lhs");}
+ ;
+invars : invars ',' invar {$$ = gc3(cons($3,$1));}
+ | invar {$$ = gc1(cons($1,NIL));}
+ ;
+invar : qvar COCO topType {$$ = gc3(sigdecl($2,singleton($1),
+ $3));}
+ | qvar {$$ = gc1($1);}
+ ;
+constrs : constrs '|' constr {$$ = gc3(cons($3,$1));}
+ | constr {$$ = gc1(cons($1,NIL));}
+ ;
+constr : '!' btype conop bbtype {$$ = gc4(ap2($3,bang($2),$4));}
+ | btype1 conop bbtype {$$ = gc3(ap2($2,$1,$3));}
+ | btype2 conop bbtype {$$ = gc3(ap2($2,$1,$3));}
+ | bpolyType conop bbtype {$$ = gc3(ap2($2,$1,$3));}
+ | btype2 {$$ = gc1($1);}
+ | btype3 {$$ = gc1($1);}
+ | btype4 {$$ = gc1($1);}
+ | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
+ | '[' ']' {$$ = gc2(conNil);}
+ | '(' ')' {$$ = gc2(conUnit);}
+ | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
+ | error {syntaxError("data type definition");}
+ ;
+btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
+ | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));}
+ | btype3 atype {$$ = gc2(ap($1,$2));}
+ ;
+btype4 : btype2 bpolyType {$$ = gc2(ap($1,$2));}
+ | btype3 bpolyType {$$ = gc2(ap($1,$2));}
+ | btype4 bpolyType {$$ = gc2(ap($1,$2));}
+ | btype4 atype {$$ = gc2(ap($1,$2));}
+ | btype4 '!' atype {$$ = gc3(ap($1,bang($3)));}
+ ;
+bbtype : '!' btype {$$ = gc2(bang($2));}
+ | btype {$$ = gc1($1);}
+ | bpolyType {$$ = gc1($1);}
+ ;
+fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
+ | fieldspec {$$ = gc1(cons($1,NIL));}
+ ;
+fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
+ | vars COCO type {$$ = gc3(pair(rev($1),$3));}
+ ;
+nconstr : con atype {$$ = gc2(singleton(ap($1,$2)));}
+ | con bpolyType {$$ = gc2(singleton(ap($1,$2)));}
+ ;
+deriving : /* empty */ {$$ = gc0(NIL);}
+ | DERIVING qconid {$$ = gc2(singleton($2));}
+ | DERIVING '(' derivs0 ')' {$$ = gc4($3);}
+ ;
+derivs0 : /* empty */ {$$ = gc0(NIL);}
+ | derivs {$$ = gc1(rev($1));}
+ ;
+derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));}
+ | qconid {$$ = gc1(singleton($1));}
+ ;
+
+/*- Processing definitions of primitives ----------------------------------*/
+
+topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
+ {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
+ | FOREIGN EXPORT callconv ext_name qvarid COCO type
+ {foreignExport($1,$4,$5,$7); sp-=7;}
+ ;
+
+callconv : var {$$ = gc1(NIL); /* ignored */ }
+ ;
+ext_loc : STRINGLIT {$$ = $1;}
+ ;
+ext_name : STRINGLIT {$$ = $1;}
+ ;
+unsafe_flag: /* empty */ {$$ = gc0(NIL);}
+ | UNSAFE {$$ = gc1(NIL); /* ignored */ }
+ ;
+
+
+/*- Class declarations: ---------------------------------------------------*/
+
+topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;}
+ | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
+ | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
+ ;
+crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
+ | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
+ ;
+irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
+ | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
+ ;
+dtypes : /* empty */ {$$ = gc0(NIL);}
+ | dtypes1 {$$ = gc1(rev($1));}
+ ;
+dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));}
+ | type {$$ = gc1(cons($1,NIL));}
+ ;
+
+/*- Type expressions: -----------------------------------------------------*/
+
+sigType : context IMPLIES type {$$ = gc3(ap(QUAL,pair($1,$3)));}
+ | type {$$ = gc1($1);}
+ ;
+topType : context IMPLIES topType1 {$$ = gc3(ap(QUAL,pair($1,$3)));}
+ | topType1 {$$ = gc1($1);}
+ ;
+topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
+ | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
+ | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
+ | btype {$$ = gc1($1);}
+ ;
+polyType : ALL varid1s '.' sigType {$$ = gc4(ap(POLYTYPE,
+ pair(rev($2),$4)));}
+ | bpolyType {$$ = gc1($1);}
+ ;
+bpolyType : '(' polyType ')' {$$ = gc3($2);}
+ ;
+varid1s : varid1s ',' varid1 {$$ = gc3(cons($3,$1));}
+ | varid1 {$$ = gc1(cons($1,NIL));}
+ ;
+context : '(' ')' {$$ = gc2(NIL);}
+ | btype2 {$$ = gc1(singleton(checkPred($1)));}
+ | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
+ | '(' btypes2 ')' {$$ = gc3(checkContext($2));}
+/*#if TREX*/
+ | lacks {$$ = gc1(singleton($1));}
+ | '(' lacks1 ')' {$$ = gc3(checkContext($2));}
+ ;
+lacks : varid1 '\\' varid1 {
+#if TREX
+ $$ = gc3(ap(mkExt(textOf($3)),$1));
+#else
+ noTREX("a type context");
+#endif
+ }
+ ;
+lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));}
+ | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));}
+ | lacks1 ',' lacks {$$ = gc3(cons($3,$1));}
+ | btype2 ',' lacks {$$ = gc3(cons($3,cons($1,NIL)));}
+ | lacks {$$ = gc1(singleton($1));}
+ ;
+/*#endif*/
+
+type : type1 {$$ = gc1($1);}
+ | btype2 {$$ = gc1($1);}
+ ;
+type1 : btype1 {$$ = gc1($1);}
+ | btype1 ARROW type {$$ = gc3(fn($1,$3));}
+ | btype2 ARROW type {$$ = gc3(fn($1,$3));}
+ | error {syntaxError("type expression");}
+ ;
+btype : btype1 {$$ = gc1($1);}
+ | btype2 {$$ = gc1($1);}
+ ;
+btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
+ | atype1 {$$ = gc1($1);}
+ ;
+btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
+ | qconid {$$ = gc1($1);}
+ ;
+atype : atype1 {$$ = gc1($1);}
+ | qconid {$$ = gc1($1);}
+ ;
+atype1 : varid1 {$$ = gc1($1);}
+ | '(' ')' {$$ = gc2(conPreludeUnit);}
+ | '(' ARROW ')' {$$ = gc3(typeArrow);}
+ | '(' type1 ')' {$$ = gc3($2);}
+ | '(' btype2 ')' {$$ = gc3($2);}
+ | '(' tupCommas ')' {$$ = gc3($2);}
+ | '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
+ | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
+/*#if TREX*/
+ | '(' tfields ')' {
+#if TREX
+ $$ = gc3(revOnto($2,typeNoRow));
+#else
+ noTREX("a type");
+#endif
+ }
+ | '(' tfields '|' type ')' {$$ = gc5(revOnto($2,$4));}
+/*#endif*/
+ | '[' type ']' {$$ = gc3(ap(conPreludeList,$2));}
+ | '[' ']' {$$ = gc2(conPreludeList);}
+ | '_' {$$ = gc1(inventVar());}
+ ;
+tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
+ | ',' {$$ = gc1(mkTuple(2));}
+ ;
+btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
+ | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
+ ;
+typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));}
+ | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));}
+ | btypes2 ',' type1 {$$ = gc3(cons($3,$1));}
+ | typeTuple ',' type {$$ = gc3(cons($3,$1));}
+ ;
+/*#if TREX*/
+tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));}
+ | tfield {$$ = gc1(singleton($1));}
+ ;
+tfield : varid COCO type {$$ = gc3(ap(mkExt(textOf($1)),$3));}
+ ;
+/*#endif*/
+
+/*- Value declarations: ---------------------------------------------------*/
+
+decllist : '{' decls end {$$ = gc3($2);}
+ ;
+decls : /* empty */ {$$ = gc0(NIL);}
+ | ';' {$$ = gc1(NIL);}
+ | decls1 {$$ = gc1($1);}
+ | decls1 ';' {$$ = gc2($1);}
+ ;
+decls1 : decls1 ';' decl {$$ = gc3(cons($3,$1));}
+ | decl {$$ = gc1(cons($1,NIL));}
+ ;
+/* Sneakily using qvars to eliminate a conflict... */
+decl : qvars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
+ | opExp rhs {$$ = gc2(pair($1,$2));}
+ ;
+rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
+ | error {syntaxError("declaration");}
+ ;
+rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
+ | gdefs {$$ = gc1(grded(rev($1)));}
+ ;
+wherePart : WHERE decllist {$$ = gc2($2);}
+ | /*empty*/ {$$ = gc0(NIL);}
+ ;
+gdefs : gdefs gdef {$$ = gc2(cons($2,$1));}
+ | gdef {$$ = gc1(cons($1,NIL));}
+ ;
+gdef : '|' exp '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
+ ;
+vars : vars ',' var {$$ = gc3(cons($3,$1));}
+ | var {$$ = gc1(cons($1,NIL));}
+ ;
+qvars : qvars ',' qvar {$$ = gc3(cons($3,$1));}
+ | qvar {$$ = gc1(cons($1,NIL));}
+ ;
+
+
+
+var : varid {$$ = gc1($1);}
+ | '(' '-' ')' {$$ = gc3(varMinus);}
+ ;
+varid : varid1 {$$ = gc1($1);}
+ | '(' VAROP ')' {$$ = gc3($2);}
+ | '(' '!' ')' {$$ = gc3(varBang);}
+ | '(' '.' ')' {$$ = gc3(varDot);}
+ ;
+varid1 : VARID {$$ = gc1($1);}
+ | HIDING {$$ = gc1(varHiding);}
+ | QUALIFIED {$$ = gc1(varQualified);}
+ | ASMOD {$$ = gc1(varAsMod);}
+ ;
+qvar : qvarid {$$ = gc1($1);}
+ | '(' qvarsym ')' {$$ = gc3($2);}
+ | '(' '.' ')' {$$ = gc3(varDot);}
+ | '(' '!' ')' {$$ = gc3(varBang);}
+ | '(' '-' ')' {$$ = gc3(varMinus);}
+ ;
+qvarid : varid1 {$$ = gc1($1);}
+ | QVARID {$$ = gc1($1);}
+ ;
+
+op : varop {$$ = gc1($1);}
+ | conop {$$ = gc1($1);}
+ | '-' {$$ = gc1(varMinus);}
+ ;
+qop : qvarop {$$ = gc1($1);}
+ | qconop {$$ = gc1($1);}
+ | '-' {$$ = gc1(varMinus);}
+ ;
+
+varop : VAROP {$$ = gc1($1);}
+ | '!' {$$ = gc1(varBang);}
+ | '.' {$$ = gc1(varDot);}
+ | '`' varid1 '`' {$$ = gc3($2);}
+ ;
+qvarop : qvarsym {$$ = gc1($1);}
+ | '!' {$$ = gc1(varBang);}
+ | '.' {$$ = gc1(varDot);}
+ | '`' qvarid '`' {$$ = gc3($2);}
+ ;
+qvarsym : VAROP {$$ = gc1($1);}
+ | QVAROP {$$ = gc1($1);}
+ ;
+
+con : CONID {$$ = gc1($1);}
+ | '(' CONOP ')' {$$ = gc3($2);}
+ ;
+qcon : qconid {$$ = gc1($1);}
+ | '(' qconsym ')' {$$ = gc3($2);}
+ ;
+qconid : CONID {$$ = gc1($1);}
+ | QCONID {$$ = gc1($1);}
+ ;
+qconsym : CONOP {$$ = gc1($1);}
+ | QCONOP {$$ = gc1($1);}
+ ;
+
+conop : CONOP {$$ = gc1($1);}
+ | '`' CONID '`' {$$ = gc3($2);}
+ ;
+qconop : qconsym {$$ = gc1($1);}
+ | '`' qconid '`' {$$ = gc3($2);}
+ ;
+
+/*- Expressions: ----------------------------------------------------------*/
+
+exp : exp1 {$$ = gc1($1);}
+ | error {syntaxError("expression");}
+ ;
+exp1 : opExp COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
+ | opExp {$$ = gc1($1);}
+ ;
+opExp : opExp0 {$$ = gc1(tidyInfix($1));}
+ | pfxExp {$$ = gc1($1);}
+ ;
+opExp0 : opExp0 qop '-' pfxExp {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
+ | opExp0 qop pfxExp {$$ = gc3(ap2($2,$1,$3));}
+ | '-' pfxExp {$$ = gc2(ap(NEG,only($2)));}
+ | pfxExp qop pfxExp {$$ = gc3(ap(ap($2,only($1)),$3));}
+ | pfxExp qop '-' pfxExp {$$ = gc4(ap(NEG,
+ ap(ap($2,only($1)),$4)));}
+ ;
+pfxExp : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
+ pair(rev($2),
+ pair($3,$4))));}
+ | LET decllist IN exp {$$ = gc4(letrec($2,$4));}
+ | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));}
+ | CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
+ | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
+ | appExp {$$ = gc1($1);}
+ ;
+pats : pats atomic {$$ = gc2(cons($2,$1));}
+ | atomic {$$ = gc1(cons($1,NIL));}
+ ;
+appExp : appExp atomic {$$ = gc2(ap($1,$2));}
+ | atomic {$$ = gc1($1);}
+ ;
+atomic : qvar {$$ = gc1($1);}
+ | qvar '@' atomic {$$ = gc3(ap(ASPAT,pair($1,$3)));}
+ | '~' atomic {$$ = gc2(ap(LAZYPAT,$2));}
+ | '_' {$$ = gc1(WILDCARD);}
+ | qcon {$$ = gc1($1);}
+ | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
+ | atomic '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
+ triple($1,NIL,$3)));}
+ | '(' ')' {$$ = gc2(conPreludeUnit);}
+ | NUMLIT {$$ = gc1($1);}
+ | CHARLIT {$$ = gc1($1);}
+ | STRINGLIT {$$ = gc1($1);}
+ | REPEAT {$$ = gc1($1);}
+ | '(' exp ')' {$$ = gc3($2);}
+ | '(' exps2 ')' {$$ = gc3(buildTuple($2));}
+/*#if TREX*/
+ | '(' vfields ')' {
+#if TREX
+ $$ = gc3(revOnto($2,nameNoRec));
+#else
+ $$ = gc3(NIL);
+#endif
+ }
+ | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
+ | RECSELID {$$ = gc1($1);}
+/*#endif*/
+ | '[' list ']' {$$ = gc3($2);}
+ | '(' pfxExp qop ')' {$$ = gc4(ap($3,$2));}
+ | '(' qvarop atomic ')' {$$ = gc4(ap2(varFlip,$2,$3));}
+ | '(' qconop atomic ')' {$$ = gc4(ap2(varFlip,$2,$3));}
+ | '(' tupCommas ')' {$$ = gc3($2);}
+ ;
+exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
+ | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
+ ;
+/*#if TREX*/
+vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
+ | vfield {$$ = gc1(singleton($1));}
+ ;
+vfield : qvarid '=' exp {
+#if TREX
+ $$ = gc3(ap(mkExt(textOf($1)),$3));
+#else
+ noTREX("an expression");
+#endif
+ }
+ ;
+/*#endif*/
+alts : alts1 {$$ = gc1($1);}
+ | alts1 ';' {$$ = gc2($1);}
+ ;
+alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
+ | alt {$$ = gc1(cons($1,NIL));}
+ ;
+alt : opExp altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
+ ;
+altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
+ | ARROW exp {$$ = gc2(pair($1,$2));}
+ | error {syntaxError("case expression");}
+ ;
+guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
+ | guardAlt {$$ = gc1(cons($1,NIL));}
+ ;
+guardAlt : '|' opExp ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
+ ;
+stmts : stmts1 ';' {$$ = gc2($1);}
+ | stmts1 {$$ = gc1($1);}
+ ;
+stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
+ | stmt {$$ = gc1(cons($1,NIL));}
+ ;
+stmt : exp1 FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
+ | LET decllist {$$ = gc2(ap(QWHERE,$2));}
+ | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}
+ | exp1 {$$ = gc1(ap(DOQUAL,$1));}
+ ;
+fbinds : /* empty */ {$$ = gc0(NIL);}
+ | fbinds1 {$$ = gc1(rev($1));}
+ ;
+fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
+ | fbind {$$ = gc1(singleton($1));}
+ ;
+fbind : var {$$ = gc1($1);}
+ | qvar '=' exp {$$ = gc3(pair($1,$3));}
+ ;
+
+/*- List Expressions: -------------------------------------------------------*/
+
+list : /* empty */ {$$ = gc0(conPreludeNil);}
+ | exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
+ | exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
+ | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));}
+ | exp UPTO exp {$$ = gc3(ap2(varEnumFromTo,$1,$3));}
+ | exp ',' exp UPTO {$$ = gc4(ap2(varEnumFromThen,$1,$3));}
+ | exp UPTO {$$ = gc2(ap1(varEnumFrom,$1));}
+ | exp ',' exp UPTO exp {$$ = gc5(ap3(varEnumFromThenTo,
+ $1,$3,$5));}
+ ;
+quals : quals ',' qual {$$ = gc3(cons($3,$1));}
+ | qual {$$ = gc1(cons($1,NIL));}
+ ;
+qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
+ | exp {$$ = gc1(ap(BOOLQUAL,$1));}
+ | LET decllist {$$ = gc2(ap(QWHERE,$2));}
+ ;
+
+/*- Tricks to force insertion of leading and closing braces ---------------*/
+
+begin : error {yyerrok; goOffside(startColumn);}
+ ;
+ /* deal with trailing semicolon */
+end : '}' {$$ = gc1($1);}
+ | error {yyerrok;
+ if (canUnOffside()) {
+ unOffside();
+ /* insert extra token on stack*/
+ push(NIL);
+ pushed(0) = pushed(1);
+ pushed(1) = mkInt(column);
+ }
+ else
+ syntaxError("definition");
+ }
+ ;
+
+/*-------------------------------------------------------------------------*/
+
+%%
+
+static Cell local gcShadow(n,e) /* keep parsed fragments on stack */
+Int n;
+Cell e; {
+ /* If a look ahead token is held then the required stack transformation
+ * is:
+ * pushed: n 1 0 1 0
+ * x1 | ... | xn | la ===> e | la
+ * top() top()
+ *
+ * Othwerwise, the transformation is:
+ * pushed: n-1 0 0
+ * x1 | ... | xn ===> e
+ * top() top()
+ */
+ if (yychar>=0) {
+ pushed(n-1) = top();
+ pushed(n) = e;
+ }
+ else
+ pushed(n-1) = e;
+ sp -= (n-1);
+ return e;
+}
+
+static Void local syntaxError(s) /* report on syntax error */
+String s; {
+ ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
+ EEND;
+}
+
+static String local unexpected() { /* find name for unexpected token */
+ static char buffer[100];
+ static char *fmt = "%s \"%s\"";
+ static char *kwd = "keyword";
+
+ switch (yychar) {
+ case 0 : return "end of input";
+
+#define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
+ case INFIXL : keyword("infixl");
+ case INFIXR : keyword("infixr");
+ case INFIX : keyword("infix");
+ case FOREIGN : keyword("foreign");
+ case UNSAFE : keyword("unsafe");
+ case TINSTANCE : keyword("instance");
+ case TCLASS : keyword("class");
+ case CASEXP : keyword("case");
+ case OF : keyword("of");
+ case IF : keyword("if");
+ case THEN : keyword("then");
+ case ELSE : keyword("else");
+ case WHERE : keyword("where");
+ case TYPE : keyword("type");
+ case DATA : keyword("data");
+ case TNEWTYPE : keyword("newtype");
+ case LET : keyword("let");
+ case IN : keyword("in");
+ case DERIVING : keyword("deriving");
+ case DEFAULT : keyword("default");
+ case IMPORT : keyword("import");
+ case EXPORT : keyword("export");
+ case MODULETOK : keyword("module");
+ case INTERFACE : keyword("interface");
+ case WILDCARD : keyword("_");
+ case ALL : keyword("forall");
+#undef keyword
+
+ case ARROW : return "`->'";
+ case '=' : return "`='";
+ case COCO : return "`::'";
+ case '-' : return "`-'";
+ case '!' : return "`!'";
+ case ',' : return "comma";
+ case '@' : return "`@'";
+ case '(' : return "`('";
+ case ')' : return "`)'";
+ case '{' : return "`{'";
+ case '}' : return "`}'";
+ case '_' : return "`_'";
+ case '|' : return "`|'";
+ case '.' : return "`.'";
+ case ';' : return "`;'";
+ case UPTO : return "`..'";
+ case '[' : return "`['";
+ case ']' : return "`]'";
+ case FROM : return "`<-'";
+ case '\\' : return "backslash (lambda)";
+ case '~' : return "tilde";
+ case '`' : return "backquote";
+#if TREX
+ case RECSELID : sprintf(buffer,"selector \"#%s\"",
+ textToStr(extText(snd(yylval))));
+ return buffer;
+#endif
+ case VAROP :
+ case VARID :
+ case CONOP :
+ case CONID : sprintf(buffer,"symbol \"%s\"",
+ textToStr(textOf(yylval)));
+ return buffer;
+ case QVAROP :
+ case QVARID :
+ case QCONOP :
+ case QCONID : sprintf(buffer,"symbol \"%s\"",
+ identToStr(yylval));
+ return buffer;
+ case HIDING : return "symbol \"hiding\"";
+ case QUALIFIED : return "symbol \"qualified\"";
+ case ASMOD : return "symbol \"as\"";
+ case NUMLIT : return "numeric literal";
+ case CHARLIT : return "character literal";
+ case STRINGLIT : return "string literal";
+ case IMPLIES : return "`=>'";
+ default : return "token";
+ }
+}
+
+static Cell local checkPrec(p) /* Check for valid precedence value */
+Cell p; {
+ if ((!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC)
+ && (!isBignum(p) || bignumOf(p)<MIN_PREC || bignumOf(p)>MAX_PREC)
+ ) {
+ ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
+ MIN_PREC, MAX_PREC
+ EEND;
+ }
+ if (isBignum(p)) {
+ return mkInt(bignumOf(p));
+ } else {
+ return p;
+ }
+}
+
+static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators */
+Syntax a;
+Cell line;
+Cell p;
+List ops; {
+ Int l = intOf(line);
+ a = mkSyntax(a,intOf(p));
+ map2Proc(setSyntax,l,a,ops);
+}
+
+static Void local setSyntax(line,sy,op)/* set syntax of individ. operator */
+Int line;
+Syntax sy;
+Cell op; {
+ addSyntax(line,textOf(op),sy);
+ opDefns = cons(op,opDefns);
+}
+
+static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from list*/
+List tup; { /* [xn,...,x1] */
+ Int n = 0;
+ Cell t = tup;
+ Cell x;
+
+ do { /* . . */
+ x = fst(t); /* / \ / \ */
+ fst(t) = snd(t); /* xn . . xn */
+ snd(t) = x; /* . ===> . */
+ x = t; /* . . */
+ t = fun(x); /* . . */
+ n++; /* / \ / \ */
+ } while (nonNull(t)); /* x1 NIL (n) x1 */
+ fst(x) = mkTuple(n);
+ return tup;
+}
+
+static List local checkContext(con) /* validate context */
+Type con; {
+ mapOver(checkPred, con);
+ return con;
+}
+
+static Cell local checkPred(c) /* check that type expr is a valid */
+Cell c; { /* constraint */
+ Cell cn = getHead(c);
+#if TREX
+ if (isExt(cn) && argCount==1)
+ return c;
+#endif
+ if (!isQCon(cn) || argCount==0)
+ syntaxError("class expression");
+ return c;
+}
+
+static Pair local checkDo(dqs) /* convert reversed list of dquals */
+List dqs; { /* to an (expr,quals) pair */
+ if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
+ ERRMSG(row) "Last generator in do {...} must be an expression"
+ EEND;
+ }
+ fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
+ snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
+ return dqs;
+}
+
+static Cell local checkTyLhs(c) /* check that lhs is of the form */
+Cell c; { /* T a1 ... a */
+ Cell tlhs = c;
+ while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL)
+ tlhs = fun(tlhs);
+ switch (whatIs(tlhs)) {
+ case CONIDCELL : return c;
+
+ default :
+ ERRMSG(row) "Illegal left hand side in datatype definition"
+ EEND;
+ }
+}
+
+#if !TREX
+static Void local noTREX(where)
+String where; {
+ ERRMSG(row) "Attempt to use Typed Records with Extensions\nwhile parsing %s. This feature is disabled in this build of Hugs.",
+ where
+ EEND;
+}
+#endif
+
+/* Expressions involving infix operators or unary minus are parsed as elements
+ * of the following type:
+ *
+ * data OpExp = Only Exp | Neg OpExp | Infix OpExp Op Exp
+ *
+ * (The algorithms here do not assume that negation can be applied only once,
+ * i.e., that - - x is a syntax error, as required by the Haskell report.
+ * Instead, that restriction is captured by the grammar itself, given above.)
+ *
+ * There are rules of precedence and grouping, expressed by two functions:
+ *
+ * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R})
+ *
+ * OpExp values are rearranged accordingly when a complete expression has
+ * been read using a simple shift-reduce parser whose result may be taken
+ * to be a value of the following type:
+ *
+ * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String
+ *
+ * The machine on which this parser is based can be defined as follows:
+ *
+ * tidy :: OpExp -> [(Op,Exp)] -> Exp
+ * tidy (Only a) [] = a
+ * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss
+ * tidy (Infix a o b) [] = tidy a [(o,b)]
+ * tidy (Infix a o b) ((p,c):ss)
+ * | shift o p = tidy a ((o,b):(p,c):ss)
+ * | red o p = tidy (Infix a o (Apply p b c)) ss
+ * | ambig o p = Error "ambiguous use of operators"
+ * tidy (Neg e) [] = tidy (tidyNeg e) []
+ * tidy (Neg e) ((o,b):ss)
+ * | nshift o = tidy (Neg (underNeg o b e)) ss
+ * | nred o = tidy (tidyNeg e) ((o,b):ss)
+ * | nambig o = Error "illegal use of negation"
+ *
+ * At each stage, the parser can either shift, reduce, accept, or error.
+ * The transitions when dealing with juxtaposed operators o and p are
+ * determined by the following rules:
+ *
+ * shift o p = (prec o > prec p)
+ * || (prec o == prec p && assoc o == L && assoc p == L)
+ *
+ * red o p = (prec o < prec p)
+ * || (prec o == prec p && assoc o == R && assoc p == R)
+ *
+ * ambig o p = (prec o == prec p)
+ * && (assoc o == N || assoc p == N || assoc o /= assoc p)
+ *
+ * The transitions when dealing with juxtaposed unary minus and infix operators
+ * are as follows. The precedence of unary minus (infixl 6) is hardwired in
+ * to these definitions, as it is to the definitions of the Haskell grammar
+ * in the official report.
+ *
+ * nshift o = (prec o > 6)
+ * nred o = (prec o < 6) || (prec o == 6 && assoc o == L)
+ * nambig o = prec o == 6 && (assoc o == R || assoc o == N)
+ *
+ * An OpExp of the form (Neg e) means negate the last thing in the OpExp e;
+ * we can force this negation using:
+ *
+ * tidyNeg :: OpExp -> OpExp
+ * tidyNeg (Only e) = Only (Negate e)
+ * tidyNeg (Infix a o b) = Infix a o (Negate b)
+ * tidyNeg (Neg e) = tidyNeg (tidyNeg e)
+ *
+ * On the other hand, if we want to sneak application of an infix operator
+ * under a negation, then we use:
+ *
+ * underNeg :: Op -> Exp -> OpExp -> OpExp
+ * underNeg o b (Only e) = Only (Apply o e b)
+ * underNeg o b (Neg e) = Neg (underNeg o b e)
+ * underNeg o b (Infix e p f) = Infix e p (Apply o f b)
+ *
+ * As a concession to efficiency, we lower the number of calls to syntaxOf
+ * by keeping track of the values of sye, sys throughout the process. The
+ * value APPLIC is used to indicate that the syntax value is unknown.
+ */
+
+#define UMINUS_PREC 6 /* Change these settings at your */
+#define UMINUS_ASSOC LEFT_ASS /* own risk; they may not work! */
+
+static Cell local tidyInfix(e) /* convert OpExp to Expr */
+Cell e; { /* :: OpExp */
+ Cell s = NIL; /* :: [(Op,Exp)] */
+ Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/
+ Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/
+
+ for (;;)
+ switch (whatIs(e)) {
+ case ONLY : e = snd(e);
+ while (nonNull(s)) {
+ Cell next = arg(fun(s));
+ arg(fun(s)) = e;
+ e = s;
+ s = next;
+ }
+ return e;
+
+ case NEG : if (nonNull(s)) {
+
+ if (sys==APPLIC) { /* calculate sys */
+ sys = identSyntax(fun(fun(s)));
+ if (sys==APPLIC) sys=DEF_OPSYNTAX;
+ }
+
+ if (precOf(sys)==UMINUS_PREC && /* nambig */
+ assocOf(sys)!=UMINUS_ASSOC) {
+ ERRMSG(row)
+ "Ambiguous use of unary minus with \"%s\"",
+ textToStr(textOf(fun(fun(s))))
+ EEND;
+ }
+
+ if (precOf(sys)>UMINUS_PREC) { /* nshift */
+ Cell e1 = snd(e);
+ Cell t = s;
+ s = arg(fun(s));
+ while (whatIs(e1)==NEG)
+ e1 = snd(e1);
+ arg(fun(t)) = arg(e1);
+ arg(e1) = t;
+ sys = APPLIC;
+ continue;
+ }
+
+ }
+
+ /* Intentional fall-thru for nreduce and isNull(s) */
+ { Cell prev = e; /* e := tidyNeg e */
+ Cell temp = arg(prev);
+ Int nneg = 1;
+ for (; whatIs(temp)==NEG; nneg++) {
+ fun(prev) = varNegate;
+ prev = temp;
+ temp = arg(prev);
+ }
+ /* These special cases are required for
+ * pattern matching.
+ */
+ if (isInt(arg(temp))) { /* special cases */
+ if (nneg&1) /* for literals */
+ arg(temp) = intNegate(arg(temp));
+ }
+ else if (isBignum(arg(temp))) {
+ if (nneg&1)
+ arg(temp) = bignumNegate(arg(temp));
+ }
+ else if (isFloat(arg(temp))) {
+ if (nneg&1)
+ arg(temp) = floatNegate(arg(temp));
+ }
+ else {
+ fun(prev) = varNegate;
+ arg(prev) = arg(temp);
+ arg(temp) = e;
+ }
+ e = temp;
+ }
+ continue;
+
+ default : if (isNull(s)) {/* Move operation onto empty stack */
+ Cell next = arg(fun(e));
+ s = e;
+ arg(fun(s)) = NIL;
+ e = next;
+ sys = sye;
+ sye = APPLIC;
+ }
+ else { /* deal with pair of operators */
+
+ if (sye==APPLIC) { /* calculate sys and sye */
+ sye = identSyntax(fun(fun(e)));
+ if (sye==APPLIC) sye=DEF_OPSYNTAX;
+ }
+ if (sys==APPLIC) {
+ sys = identSyntax(fun(fun(s)));
+ if (sys==APPLIC) sys=DEF_OPSYNTAX;
+ }
+
+ if (precOf(sye)==precOf(sys) && /* ambig */
+ (assocOf(sye)!=assocOf(sys) ||
+ assocOf(sye)==NON_ASS)) {
+ ERRMSG(row)
+ "Ambiguous use of operator \"%s\" with \"%s\"",
+ textToStr(textOf(fun(fun(e)))),
+ textToStr(textOf(fun(fun(s))))
+ EEND;
+ }
+
+ if (precOf(sye)>precOf(sys) || /* shift */
+ (precOf(sye)==precOf(sys) &&
+ assocOf(sye)==LEFT_ASS &&
+ assocOf(sys)==LEFT_ASS)) {
+ Cell next = arg(fun(e));
+ arg(fun(e)) = s;
+ s = e;
+ e = next;
+ sys = sye;
+ sye = APPLIC;
+ }
+ else { /* reduce */
+ Cell next = arg(fun(s));
+ arg(fun(s)) = arg(e);
+ arg(e) = s;
+ s = next;
+ sys = APPLIC;
+ /* sye unchanged */
+ }
+ }
+ continue;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Desugarer
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: pat.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:28 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "link.h"
+
+#include "pat.h"
+#include "desugar.h"
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Cell local refutePat Args((Cell));
+static Cell local refutePatAp Args((Cell));
+static Cell local matchPat Args((Cell));
+static List local remPat1 Args((Cell,Cell,List));
+
+/* --------------------------------------------------------------------------
+ * Elimination of pattern bindings:
+ *
+ * The following code adopts the definition of failure free patterns as given
+ * in the Haskell 1.3 report; the term "irrefutable" is also used there for
+ * a subset of the failure free patterns described here, but has no useful
+ * role in this implementation. Basically speaking, the failure free patterns
+ * are: variable, wildcard, ~apat
+ * var@apat, if apat is failure free
+ * C apat1 ... apatn if C is a product constructor
+ * (i.e. an only constructor) and
+ * apat1,...,apatn are failure free
+ * Note that the last case automatically covers the case where C comes from
+ * a newtype construction.
+ * ------------------------------------------------------------------------*/
+
+Bool failFree(pat) /* is pattern failure free? (do we need */
+Cell pat; { /* a conformality check?) */
+ Cell c = getHead(pat);
+
+ switch (whatIs(c)) {
+ case ASPAT : return failFree(snd(snd(pat)));
+
+ case NAME : if (!isCfun(c) || cfunOf(c)!=0)
+ return FALSE;
+ /*intentional fall-thru*/
+ case TUPLE : for (; isAp(pat); pat=fun(pat))
+ if (!failFree(arg(pat)))
+ return FALSE;
+ /*intentional fall-thru*/
+ case LAZYPAT :
+ case VAROPCELL :
+ case VARIDCELL :
+ case DICTVAR :
+ case WILDCARD : return TRUE;
+
+#if TREX
+ case EXT : return failFree(extField(pat)) &&
+ failFree(extRow(pat));
+#endif
+
+ case CONFLDS : if (cfunOf(fst(snd(c)))==0) {
+ List fs = snd(snd(c));
+ for (; nonNull(fs); fs=tl(fs))
+ if (!failFree(snd(hd(fs))))
+ return FALSE;
+ return TRUE;
+ }
+ /*intentional fall-thru*/
+ default : return FALSE;
+ }
+}
+
+static Cell local refutePat(pat) /* find pattern to refute in conformality*/
+Cell pat; { /* test with pat. */
+ /* e.g. refPat (x:y) == (_:_) */
+ /* refPat ~(x:y) == _ etc.. */
+
+ switch (whatIs(pat)) {
+ case ASPAT : return refutePat(snd(snd(pat)));
+
+ case FINLIST : { Cell ys = snd(pat);
+ Cell xs = NIL;
+ for (; nonNull(ys); ys=tl(ys)) {
+ xs = ap2(nameCons,refutePat(hd(ys)),xs);
+ }
+ return revOnto(xs,nameNil);
+ }
+
+ case CONFLDS : { Cell ps = NIL;
+ Cell fs = snd(snd(pat));
+ for (; nonNull(fs); fs=tl(fs)) {
+ Cell p = refutePat(snd(hd(fs)));
+ ps = cons(pair(fst(hd(fs)),p),ps);
+ }
+ return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
+ }
+
+ case VAROPCELL :
+ case VARIDCELL :
+ case DICTVAR :
+ case WILDCARD :
+ case LAZYPAT : return WILDCARD;
+
+ case STRCELL :
+ case CHARCELL :
+#if NPLUSK
+ case ADDPAT :
+#endif
+ case TUPLE :
+ case NAME : return pat;
+
+ case AP : return refutePatAp(pat);
+
+ default : internal("refutePat");
+ return NIL; /*NOTREACHED*/
+ }
+}
+
+static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
+Cell p; {
+ Cell h = getHead(p);
+ if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
+ return p;
+#if NPLUSK
+ else if (whatIs(h)==ADDPAT)
+ return ap(fun(p),refutePat(arg(p)));
+#endif
+#if TREX
+ else if (isExt(h)) {
+ Cell pf = refutePat(extField(p));
+ Cell pr = refutePat(extRow(p));
+ return ap2(fun(fun(p)),pf,pr);
+ }
+#endif
+ else {
+ List as = getArgs(p);
+ mapOver(refutePat,as);
+ return applyToArgs(h,as);
+ }
+}
+
+static Cell local matchPat(pat) /* find pattern to match against */
+Cell pat; { /* replaces parts of pattern that do not */
+ /* include variables with wildcards */
+ switch (whatIs(pat)) {
+ case ASPAT : { Cell p = matchPat(snd(snd(pat)));
+ return (p==WILDCARD) ? fst(snd(pat))
+ : ap(ASPAT,
+ pair(fst(snd(pat)),p));
+ }
+
+ case FINLIST : { Cell ys = snd(pat);
+ Cell xs = NIL;
+ for (; nonNull(ys); ys=tl(ys))
+ xs = cons(matchPat(hd(ys)),xs);
+ while (nonNull(xs) && hd(xs)==WILDCARD)
+ xs = tl(xs);
+ for (ys=nameNil; nonNull(xs); xs=tl(xs))
+ ys = ap2(nameCons,hd(xs),ys);
+ return ys;
+ }
+
+ case CONFLDS : { Cell ps = NIL;
+ Name c = fst(snd(pat));
+ Cell fs = snd(snd(pat));
+ Bool avar = FALSE;
+ for (; nonNull(fs); fs=tl(fs)) {
+ Cell p = matchPat(snd(hd(fs)));
+ ps = cons(pair(fst(hd(fs)),p),ps);
+ if (p!=WILDCARD)
+ avar = TRUE;
+ }
+ return avar ? pair(CONFLDS,pair(c,rev(ps)))
+ : WILDCARD;
+ }
+
+ case VAROPCELL :
+ case VARIDCELL :
+ case DICTVAR : return pat;
+
+ case LAZYPAT : { Cell p = matchPat(snd(pat));
+ return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
+ }
+
+ case WILDCARD :
+ case STRCELL :
+ case CHARCELL : return WILDCARD;
+
+ case TUPLE :
+ case NAME :
+ case AP : { Cell h = getHead(pat);
+ if (h==nameFromInt ||
+ h==nameFromInteger || h==nameFromDouble)
+ return WILDCARD;
+#if NPLUSK
+ else if (whatIs(h)==ADDPAT)
+ return pat;
+#endif
+#if TREX
+ else if (isExt(h)) {
+ Cell pf = matchPat(extField(pat));
+ Cell pr = matchPat(extRow(pat));
+ return (pf==WILDCARD && pr==WILDCARD)
+ ? WILDCARD
+ : ap2(fun(fun(pat)),pf,pr);
+ }
+#endif
+ else {
+ List args = NIL;
+ Bool avar = FALSE;
+ for (; isAp(pat); pat=fun(pat)) {
+ Cell p = matchPat(arg(pat));
+ if (p!=WILDCARD)
+ avar = TRUE;
+ args = cons(p,args);
+ }
+ return avar ? applyToArgs(pat,args)
+ : WILDCARD;
+ }
+ }
+
+ default : internal("matchPat");
+ return NIL; /*NOTREACHED*/
+ }
+}
+
+#define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
+
+List remPat(pat,expr,lds)
+Cell pat; /* Produce list of definitions for eqn */
+Cell expr; /* pat = expr, including a conformality */
+List lds; { /* check if required. */
+
+ /* Conformality test (if required):
+ * pat = expr ==> nv = LETREC confCheck nv@pat = nv
+ * IN confCheck expr
+ * remPat1(pat,nv,.....);
+ */
+
+ if (!failFree(pat)) {
+ Cell confVar = inventVar();
+ Cell nv = inventVar();
+ Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
+ singleton(pair(singleton(ap(ASPAT,
+ pair(nv,
+ refutePat(pat)))),
+ nv)));
+
+ if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
+ lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
+ expr = nv;
+ nv = inventVar();
+ }
+
+ if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
+ nv = fst(snd(pat)); /* a variable is already given*/
+ pat = snd(snd(pat)); /* by an as-pattern */
+ }
+
+ lds = addEqn(nv, /* nv = */
+ ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
+ ap(confVar,expr))), /* IN confVar expr */
+ lds);
+
+ return remPat1(matchPat(pat),nv,lds);
+ }
+
+ return remPat1(matchPat(pat),expr,lds);
+}
+
+static List local remPat1(pat,expr,lds)
+Cell pat; /* Add definitions for: pat = expr to */
+Cell expr; /* list of local definitions in lds. */
+List lds; {
+ Cell c;
+
+ switch (whatIs(c=getHead(pat))) {
+ case WILDCARD :
+ case STRCELL :
+ case CHARCELL : break;
+
+ case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
+ fst(snd(pat)),
+ addEqn(fst(snd(pat)),expr,lds));
+
+ case LAZYPAT : { Cell nv;
+
+ if (isVar(expr) || isName(expr))
+ nv = expr;
+ else {
+ nv = inventVar();
+ lds = addEqn(nv,expr,lds);
+ }
+
+ return remPat(snd(pat),nv,lds);
+ }
+
+#if NPLUSK
+ case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
+ ap3(namePmSub, arg(fun(pat)), snd(c),
+ expr),
+ lds);
+#endif
+
+ case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
+
+ case CONFLDS : { Name h = fst(snd(pat));
+ Int m = name(h).arity;
+ Cell p = h;
+ List fs = snd(snd(pat));
+ Int i = m;
+ while (0<i--)
+ p = ap(p,WILDCARD);
+ for (; nonNull(fs); fs=tl(fs)) {
+ Cell r = p;
+ for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
+ r = fun(r);
+ arg(r) = snd(hd(fs));
+ }
+ return remPat1(p,expr,lds);
+ }
+
+ case DICTVAR : /* shouldn't really occur */
+ assert(0); /* so let's test for it then! ADR */
+ case VARIDCELL :
+ case VAROPCELL : return addEqn(pat,expr,lds);
+
+ case NAME : if (c==nameFromInt || c==nameFromInteger
+ || c==nameFromDouble) {
+ if (argCount==2)
+ arg(fun(pat)) = translate(arg(fun(pat)));
+ break;
+ }
+
+ if (argCount==1 && isCfun(c) /* for newtype */
+ && cfunOf(c)==0 && name(c).defn==nameId)
+ return remPat1(arg(pat),expr,lds);
+
+ /* intentional fall-thru */
+ case TUPLE : { List ps = getArgs(pat);
+
+ if (nonNull(ps)) {
+ Cell nv, sel;
+ Int i;
+
+ if (isVar(expr) || isName(expr))
+ nv = expr;
+ else {
+ nv = inventVar();
+ lds = addEqn(nv,expr,lds);
+ }
+
+ sel = ap2(nameSel,c,nv);
+ for (i=1; nonNull(ps); ++i, ps=tl(ps))
+ lds = remPat1(hd(ps),
+ ap(sel,mkInt(i)),
+ lds);
+ }
+ }
+ break;
+
+#if TREX
+ case EXT : { Cell nv = inventVar();
+ arg(fun(fun(pat)))
+ = translate(arg(fun(fun(pat))));
+ lds = addEqn(nv,
+ ap2(nameRecBrk,
+ arg(fun(fun(pat))),
+ expr),
+ lds);
+ lds = remPat1(extField(pat),ap(nameFst,nv),lds);
+ lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
+ }
+ break;
+#endif
+
+ default : internal("remPat1");
+ break;
+ }
+ return lds;
+}
+
+/* --------------------------------------------------------------------------
+ * Pattern control:
+ * ------------------------------------------------------------------------*/
+
+Void patControl( Int what )
+{
+ switch (what) {
+ case INSTALL :
+ /* Fall through */
+ case RESET : break;
+ case MARK : break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern Void patControl Args((Int what));
+extern List remPat Args((Cell,Cell,List));
+extern Cell mkConsList Args((List));
+extern Bool failFree Args((Cell));
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Pattern matching Compiler
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: pmc.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:29 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "link.h"
+
+#include "desugar.h"
+#include "pat.h"
+#include "pmc.h"
+
+/* --------------------------------------------------------------------------
+ * Eliminate pattern matching in function definitions -- pattern matching
+ * compiler:
+ *
+ * The original Gofer/Hugs pattern matching compiler was based on Wadler's
+ * algorithms described in `Implementation of functional programming
+ * languages'. That should still provide a good starting point for anyone
+ * wanting to understand this part of the system. However, the original
+ * algorithm has been generalized and restructured in order to implement
+ * new features added in Haskell 1.3.
+ *
+ * During the translation, in preparation for later stages of compilation,
+ * all local and bound variables are replaced by suitable offsets, and
+ * locally defined function symbols are given new names (which will
+ * eventually be their names when lifted to make top level definitions).
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Cell local pmcPair Args((Int,List,Pair));
+static Cell local pmcTriple Args((Int,List,Triple));
+static Cell local pmcVar Args((List,Text));
+static Void local pmcLetrec Args((Int,List,Pair));
+static Cell local pmcVarDef Args((Int,List,List));
+static Void local pmcFunDef Args((Int,List,Triple));
+static Cell local joinMas Args((Int,List));
+static Bool local canFail Args((Cell));
+static List local addConTable Args((Cell,Cell,List));
+static Void local advance Args((Int,Int,Cell));
+static Bool local emptyMatch Args((Cell));
+static Cell local maDiscr Args((Cell));
+static Bool local isNumDiscr Args((Cell));
+static Bool local eqNumDiscr Args((Cell,Cell));
+#if TREX
+static Bool local isExtDiscr Args((Cell));
+static Bool local eqExtDiscr Args((Cell,Cell));
+#endif
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+Cell pmcTerm(co,sc,e) /* apply pattern matching compiler */
+Int co; /* co = current offset */
+List sc; /* sc = scope */
+Cell e; { /* e = expr to transform */
+ switch (whatIs(e)) {
+ case GUARDED : map2Over(pmcPair,co,sc,snd(e));
+ break;
+
+ case LETREC : pmcLetrec(co,sc,snd(e));
+ break;
+
+ case VARIDCELL:
+ case VAROPCELL:
+ case DICTVAR : return pmcVar(sc,textOf(e));
+
+ case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
+
+ case AP : return pmcPair(co,sc,e);
+
+#if NPLUSK
+ case ADDPAT :
+#endif
+#if TREX
+ case EXT :
+#endif
+ case TUPLE :
+ case NAME :
+ case CHARCELL :
+ case INTCELL :
+ case BIGCELL :
+ case FLOATCELL:
+ case STRCELL : break;
+
+ default : internal("pmcTerm");
+ break;
+ }
+ return e;
+}
+
+static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
+Int co; /* to a pair of exprs */
+List sc;
+Pair pr; {
+ return pair(pmcTerm(co,sc,fst(pr)),
+ pmcTerm(co,sc,snd(pr)));
+}
+
+static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
+Int co; /* to a triple of exprs */
+List sc;
+Triple tr; {
+ return triple(pmcTerm(co,sc,fst3(tr)),
+ pmcTerm(co,sc,snd3(tr)),
+ pmcTerm(co,sc,thd3(tr)));
+}
+
+static Cell local pmcVar(sc,t) /* find translation of variable */
+List sc; /* in current scope */
+Text t; {
+ List xs;
+ Name n;
+
+ for (xs=sc; nonNull(xs); xs=tl(xs)) {
+ Cell x = hd(xs);
+ if (t==textOf(fst(x)))
+ if (isOffset(snd(x))) { /* local variable ... */
+ return snd(x);
+ }
+ else { /* local function ... */
+ return fst3(snd(x));
+ }
+ }
+
+ n = findName(t);
+ assert(nonNull(n));
+ return n;
+}
+
+static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
+Int co; /* to LETREC, splitting decls into */
+List sc; /* two sections */
+Pair e; {
+ List fs = NIL; /* local function definitions */
+ List vs = NIL; /* local variable definitions */
+ List ds;
+
+ for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
+ Cell v = fst(hd(ds));
+ Int arity = length(fst(hd(snd(hd(ds)))));
+
+ if (arity==0) { /* Variable declaration */
+ vs = cons(snd(hd(ds)),vs);
+ sc = cons(pair(v,mkOffset(++co)),sc);
+ }
+ else { /* Function declaration */
+ fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
+ sc = cons(pair(v,hd(fs)),sc);
+ }
+ }
+ vs = rev(vs); /* Put declaration lists back in */
+ fs = rev(fs); /* original order */
+ fst(e) = pair(vs,fs); /* Store declaration lists */
+ map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
+ map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
+ snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
+}
+
+static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
+Int co; /* to variable definition */
+List sc;
+List vd; { /* vd :: [ ([], rhs) ] */
+ Cell d = snd(hd(vd));
+ if (nonNull(tl(vd)) && canFail(d))
+ return ap(FATBAR,pair(pmcTerm(co,sc,d),
+ pmcVarDef(co,sc,tl(vd))));
+ return pmcTerm(co,sc,d);
+}
+
+static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
+Int co; /* to function definition */
+List sc;
+Triple fd; { /* fd :: (Var, Arity, [Alt]) */
+ Int arity = intOf(snd3(fd));
+ Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
+ Cell xs;
+
+ temp = match(co+arity,temp);
+ thd3(fd) = triple(NIL,NIL,temp); /* used to be freevar info */
+
+}
+
+/* ---------------------------------------------------------------------------
+ * Main part of pattern matching compiler: convert [Alt] to case constructs
+ *
+ * This section of Hugs has been almost completely rewritten to be more
+ * general, in particular, to allow pattern matching in orders other than the
+ * strictly left-to-right approach of the previous version. This is needed
+ * for the implementation of the so-called Haskell 1.3 `record' syntax.
+ *
+ * At each stage, the different branches for the cases to be considered
+ * are represented by a list of values of type:
+ * Match ::= { maPats :: [Pat], patterns to match
+ * maOffs :: [Offs], offsets of corresponding values
+ * maSc :: Scope, mapping from vars to offsets
+ * maRhs :: Rhs } right hand side
+ * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
+ *
+ * The Scope component has type:
+ * Scope ::= [(Var,Expr)]
+ * and provides a mapping from variable names to offsets used in the matching
+ * process.
+ *
+ * Matches can be normalized by reducing them to a form in which the list
+ * of patterns is empty (in which case the match itself is described as an
+ * empty match), or in which the list is non-empty and the first pattern is
+ * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
+ * ------------------------------------------------------------------------*/
+
+#define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
+#define maPats(ma) fst(fst(ma))
+#define maOffs(ma) snd(fst(ma))
+#define maSc(ma) fst(snd(ma))
+#define maRhs(ma) snd(snd(ma))
+#define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
+
+List altsMatch(co,n,sc,as) /* Make a list of matches from list*/
+Int co; /* of Alts, with initial offsets */
+Int n; /* reverse (take n [co..]) */
+List sc;
+List as; {
+ List mas = NIL;
+ List us = NIL;
+ for (; n>0; n--)
+ us = cons(mkOffset(co++),us);
+ for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
+ mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
+ return rev(mas);
+}
+
+Cell match(co,mas) /* Generate case statement for Matches mas */
+Int co; /* at current offset co */
+List mas; { /* N.B. Assumes nonNull(mas). */
+ Cell srhs = NIL; /* Rhs for selected matches */
+ List smas = mas; /* List of selected matches */
+ mas = tl(mas);
+ tl(smas) = NIL;
+
+ if (emptyMatch(hd(smas))) { /* The case for empty matches: */
+ while (nonNull(mas) && emptyMatch(hd(mas))) {
+ List temp = tl(mas);
+ tl(mas) = smas;
+ smas = mas;
+ mas = temp;
+ }
+ srhs = joinMas(co,rev(smas));
+ }
+ else { /* Non-empty match */
+ Int o = offsetOf(hd(maOffs(hd(smas))));
+ Cell d = maDiscr(hd(smas));
+ if (isNumDiscr(d)) { /* Numeric match */
+ Int da = discrArity(d);
+ Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
+ while (nonNull(mas) && !emptyMatch(hd(mas))
+ && o==offsetOf(hd(maOffs(hd(mas))))
+ && isNumDiscr(d=maDiscr(hd(mas)))
+ && eqNumDiscr(d,d1)) {
+ List temp = tl(mas);
+ tl(mas) = smas;
+ smas = mas;
+ mas = temp;
+ }
+ smas = rev(smas);
+ map2Proc(advance,co,da,smas);
+ srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
+ }
+#if TREX
+ else if (isExtDiscr(d)) { /* Record match */
+ Int da = discrArity(d);
+ Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
+ while (nonNull(mas) && !emptyMatch(hd(mas))
+ && o==offsetOf(hd(maOffs(hd(mas))))
+ && isExtDiscr(d=maDiscr(hd(mas)))
+ && eqExtDiscr(d,d1)) {
+ List temp = tl(mas);
+ tl(mas) = smas;
+ smas = mas;
+ mas = temp;
+ }
+ smas = rev(smas);
+ map2Proc(advance,co,da,smas);
+ srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
+ }
+#endif
+ else { /* Constructor match */
+ List tab = addConTable(d,hd(smas),NIL);
+ Int da;
+ while (nonNull(mas) && !emptyMatch(hd(mas))
+ && o==offsetOf(hd(maOffs(hd(mas))))
+ && !isNumDiscr(d=maDiscr(hd(mas)))) {
+ tab = addConTable(d,hd(mas),tab);
+ mas = tl(mas);
+ }
+ for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
+ d = fst(hd(tab));
+ smas = snd(hd(tab));
+ da = discrArity(d);
+ map2Proc(advance,co,da,smas);
+ srhs = cons(pair(d,match(co+da,smas)),srhs);
+ }
+ srhs = ap(CASE,pair(mkOffset(o),srhs));
+ }
+ }
+ return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
+}
+
+static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
+Int co; /* using FATBARs as necessary */
+List mas; { /* Non-empty list of empty matches */
+ Cell ma = hd(mas);
+ Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
+ if (nonNull(tl(mas)) && canFail(rhs))
+ return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
+ else
+ return rhs;
+}
+
+static Bool local canFail(rhs) /* Determine if expression (as rhs) */
+Cell rhs; { /* might ever be able to fail */
+ switch (whatIs(rhs)) {
+ case LETREC : return canFail(snd(snd(rhs)));
+ case GUARDED : return TRUE; /* could get more sophisticated ..? */
+ default : return FALSE;
+ }
+}
+
+/* type Table a b = [(a, [b])]
+ *
+ * addTable :: a -> b -> Table a b -> Table a b
+ * addTable x y [] = [(x,[y])]
+ * addTable x y (z@(n,sws):zs)
+ * | n == x = (n,sws++[y]):zs
+ * | otherwise = (n,sws):addTable x y zs
+ */
+
+static List local addConTable(x,y,tab) /* add element (x,y) to table */
+Cell x, y;
+List tab; {
+ if (isNull(tab))
+ return singleton(pair(x,singleton(y)));
+ else if (fst(hd(tab))==x)
+ snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
+ else
+ tl(tab) = addConTable(x,y,tl(tab));
+
+ return tab;
+}
+
+static Void local advance(co,a,ma) /* Advance non-empty match by */
+Int co; /* processing head pattern */
+Int a; /* discriminator arity */
+Cell ma; {
+ Cell p = hd(maPats(ma));
+ List ps = tl(maPats(ma));
+ List us = tl(maOffs(ma));
+ if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
+ Name c = fst(snd(p));
+ List fs = snd(snd(p));
+ List qs = NIL;
+ List vs = NIL;
+ for (; nonNull(fs); fs=tl(fs)) {
+ vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
+ qs = cons(snd(hd(fs)),qs);
+ }
+ ps = revOnto(qs,ps);
+ us = revOnto(vs,us);
+ }
+ else /* Normally just spool off patterns*/
+ for (; a>0; --a) { /* and corresponding offsets ... */
+ us = cons(mkOffset(++co),us);
+ ps = cons(arg(p),ps);
+ p = fun(p);
+ }
+
+ maPats(ma) = ps;
+ maOffs(ma) = us;
+}
+
+/* --------------------------------------------------------------------------
+ * Normalize and test for empty match:
+ * ------------------------------------------------------------------------*/
+
+static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
+Cell ma; { /* match, ma, is empty. */
+
+ while (nonNull(maPats(ma))) {
+ Cell p;
+tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
+ case LAZYPAT : { Cell nv = inventVar();
+ maRhs(ma) = ap(LETREC,
+ pair(remPat(snd(p),nv,NIL),
+ maRhs(ma)));
+ p = nv;
+ }
+ /* intentional fall-thru */
+ case VARIDCELL :
+ case VAROPCELL :
+ case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
+ case WILDCARD : maPats(ma) = tl(maPats(ma));
+ maOffs(ma) = tl(maOffs(ma));
+ continue;
+
+ /* So-called "as-patterns"are really just pattern intersections:
+ * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
+ * (But the input grammar probably doesn't let us take
+ * advantage of this, so we stick with the special case
+ * when p1 is a variable.)
+ */
+ case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
+ hd(maPats(ma)) = snd(snd(p));
+ goto tidyHd;
+
+ case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
+ return FALSE;
+
+ case STRCELL : { String s = textToStr(textOf(p));
+ for (p=NIL; *s!='\0'; ++s) {
+ if (*s!='\\' || *++s=='\\') {
+ p = ap2(nameCons,mkChar(*s),p);
+ } else {
+ p = ap2(nameCons,mkChar('\0'),p);
+ }
+ }
+ hd(maPats(ma)) = revOnto(p,nameNil);
+ }
+ return FALSE;
+
+ case AP : if (isName(fun(p)) && isCfun(fun(p))
+ && cfunOf(fun(p))==0
+ && name(fun(p)).defn==nameId) {
+ hd(maPats(ma)) = arg(p);
+ goto tidyHd;
+ }
+ /* intentional fall-thru */
+ case CHARCELL :
+#if !OVERLOADED_CONSTANTS
+ case INTCELL :
+ case BIGCELL :
+ case FLOATCELL :
+#endif
+ case NAME :
+ case CONFLDS :
+ return FALSE;
+
+ default : internal("emptyMatch");
+ }
+ }
+ return TRUE;
+}
+
+/* --------------------------------------------------------------------------
+ * Discriminators:
+ * ------------------------------------------------------------------------*/
+
+static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
+Cell ma; { /* match, ma. */
+ Cell p = hd(maPats(ma));
+ Cell h = getHead(p);
+ switch (whatIs(h)) {
+ case CONFLDS : return fst(snd(p));
+#if NPLUSK
+ case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
+ return fun(p);
+#endif
+#if TREX
+ case EXT : h = fun(fun(p));
+ arg(h) = translate(arg(h));
+ return h;
+#endif
+#if OVERLOADED_CONSTANTS
+ case NAME : if (h==nameFromInt || h==nameFromInteger
+ || h==nameFromDouble) {
+ if (argCount==2)
+ arg(fun(p)) = translate(arg(fun(p)));
+ return p;
+ }
+#endif
+ }
+ return h;
+}
+
+static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
+Cell d; {
+ switch (whatIs(d)) {
+ case NAME :
+ case TUPLE :
+ case CHARCELL : return FALSE;
+#if OVERLOADED_CONSTANTS
+#if TREX
+ case AP : return !isExt(fun(d));
+#else
+ case AP : return TRUE; /* must be a literal or (n+k) */
+#endif
+#else
+ case INTCELL :
+ case BIGCELL :
+ case FLOATCELL:
+ return TRUE;
+#endif
+ }
+ internal("isNumDiscr");
+ return 0;/*NOTREACHED*/
+}
+
+Int discrArity(d) /* Find arity of discriminator */
+Cell d; {
+ switch (whatIs(d)) {
+ case NAME : return name(d).arity;
+ case TUPLE : return tupleOf(d);
+ case CHARCELL : return 0;
+#if !OVERLOADED_CONSTANTS
+ case INTCELL :
+ case BIGCELL :
+ case FLOATCELL : return 0;
+#endif /* !OVERLOADED_CONSTANTS */
+
+#if TREX
+ case AP : switch (whatIs(fun(d))) {
+#if NPLUSK
+ case ADDPAT : return 1;
+#endif
+ case EXT : return 2;
+ default : return 0;
+ }
+#else
+#if NPLUSK
+ case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
+#else
+ case AP : return 0; /* must be an Int or Float lit */
+#endif
+#endif
+ }
+ internal("discrArity");
+ return 0;/*NOTREACHED*/
+}
+
+static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
+Cell d1, d2; { /* descriptors have same value */
+#if NPLUSK
+ if (whatIs(fun(d1))==ADDPAT)
+ return whatIs(fun(d2))==ADDPAT && bignumEq(snd(fun(d1)),snd(fun(d2)));
+#endif
+#if OVERLOADED_CONSTANTS
+ d1 = arg(d1);
+ d2 = arg(d2);
+#endif
+ if (isInt(d1))
+ return isInt(d2) && intEq(d1,d2);
+ if (isFloat(d1))
+ return isFloat(d2) && floatEq(d1,d2);
+ if (isBignum(d1))
+ return isBignum(d2) && bignumEq(d1,d2);
+ internal("eqNumDiscr");
+ return FALSE;/*NOTREACHED*/
+}
+
+#if TREX
+static Bool local isExtDiscr(d) /* Test of extension discriminator */
+Cell d; {
+ return isAp(d) && isExt(fun(d));
+}
+
+static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
+Cell d1, d2; { /* discriminators have same label */
+ return fun(d1)==fun(d2);
+}
+#endif
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern Cell pmcTerm Args((Int,List,Cell));
+extern List altsMatch Args((Int,Int,List,List));
+extern Cell match Args((Int,List));
+extern Int discrArity Args((Cell));
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * STG pretty printer
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: pp.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:31 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+#include "pp.h"
+#include "hugs.h" /* for debugCode */
+#include "input.h" /* for unlexChar */
+
+/* --------------------------------------------------------------------------
+ * Local functions
+ * ------------------------------------------------------------------------*/
+
+static Void local pIndent Args((Int));
+static Void local unlexVar Args((Text));
+static Void local unlexCharConst Args((Cell));
+static Void local unlexStrConst Args((Text));
+
+static Void local putStgVar Args((StgVar));
+static Void local putStgVars Args((List));
+static Void local putStgAtom Args((StgAtom a));
+static Void local putStgAtoms Args((List as));
+static Void local putStgBinds Args((List));
+static Void local putStgExpr Args((StgExpr));
+static Void local putStgRhs Args((StgRhs));
+static Void local putStgPat Args((StgPat));
+static Void local putStgPrimPat Args((StgPrimPat));
+
+/* --------------------------------------------------------------------------
+ * Basic output routines:
+ * ------------------------------------------------------------------------*/
+
+static FILE *outputStream; /* current output stream */
+static Int outColumn = 0; /* current output column number */
+
+static Void local putChr( Int c );
+static Void local putStr( String s );
+static Void local putInt( Int n );
+static Void local putPtr( Ptr p );
+
+static Void local putChr(c) /* print single character */
+Int c; {
+ Putc(c,outputStream);
+ outColumn++;
+}
+
+static Void local putStr(s) /* print string */
+String s; {
+ for (; *s; s++) {
+ Putc(*s,outputStream);
+ outColumn++;
+ }
+}
+
+static Void local putInt(n) /* print integer */
+Int n; {
+ static char intBuf[16];
+ sprintf(intBuf,"%d",n);
+ putStr(intBuf);
+}
+
+static Void local putPtr(p) /* print pointer */
+Ptr p; {
+ static char intBuf[16];
+ sprintf(intBuf,"%p",p);
+ putStr(intBuf);
+}
+
+/* --------------------------------------------------------------------------
+ * Indentation and showing names/constants
+ * ------------------------------------------------------------------------*/
+
+static Void local pIndent(n) /* indent to particular position */
+Int n; {
+ outColumn = n;
+ while (0<n--) {
+ Putc(' ',outputStream);
+ }
+}
+
+static Void local unlexVar(t) /* print text as a variable name */
+Text t; { /* operator symbols must be enclosed*/
+ String s = textToStr(t); /* in parentheses... except [] ... */
+
+ if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || s[0]=='[' || s[0]=='(')
+ putStr(s);
+ else {
+ putChr('(');
+ putStr(s);
+ putChr(')');
+ }
+}
+
+static Void local unlexCharConst(c)
+Cell c; {
+ putChr('\'');
+ putStr(unlexChar(c,'\''));
+ putChr('\'');
+}
+
+static Void local unlexStrConst(t)
+Text t; {
+ String s = textToStr(t);
+ static Char SO = 14; /* ASCII code for '\SO' */
+ Bool lastWasSO = FALSE;
+ Bool lastWasDigit = FALSE;
+ Bool lastWasEsc = FALSE;
+
+ putChr('\"');
+ for (; *s; s++) {
+ String ch = unlexChar(*s,'\"');
+ Char c = ' ';
+
+ if ((lastWasSO && *ch=='H') ||
+ (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
+ putStr("\\&");
+
+ lastWasEsc = (*ch=='\\');
+ lastWasSO = (*s==SO);
+ for (; *ch; c = *ch++)
+ putChr(*ch);
+ lastWasDigit = (isascii(c) && isdigit(c));
+ }
+ putChr('\"');
+}
+
+/* --------------------------------------------------------------------------
+ * Pretty printer for stg code:
+ * ------------------------------------------------------------------------*/
+
+static Void putStgAlts ( Int left, List alts );
+static Void putStgPrimAlt ( Int left, List vs, StgExpr body );
+
+static Void local putStgVar(StgVar v)
+{
+ if (isName(v)) {
+ unlexVar(name(v).text);
+ } else {
+ putStr("id");
+ putInt(-v);
+ }
+}
+
+static Void local putStgVars( List vs )
+{
+ for(; nonNull(vs); vs=tl(vs)) {
+ putStgVar(hd(vs));
+ putChr(' ');
+ }
+}
+
+static Void local putStgAtom( StgAtom a )
+{
+ switch (whatIs(a)) {
+ case STGVAR:
+ case NAME:
+ putStgVar(a);
+ break;
+ case CHARCELL:
+ unlexCharConst(charOf(a));
+ putChr('#');
+ break;
+ case INTCELL:
+ putInt(intOf(a));
+ putChr('#');
+ break;
+ case BIGCELL:
+ putStr(bignumToString(a));
+ putChr('#');
+ break;
+ case FLOATCELL:
+ putStr(floatToString(a));
+ putChr('#');
+ break;
+ case STRCELL:
+ unlexStrConst(textOf(a));
+ break;
+ case PTRCELL:
+ putPtr(ptrOf(a));
+ putChr('#');
+ break;
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
+ internal("putStgAtom");
+ }
+}
+
+Void putStgAtoms( List as )
+{
+ putChr('{');
+ while (nonNull(as)) {
+ putStgAtom(hd(as));
+ as=tl(as);
+ if (nonNull(as)) {
+ putChr(',');
+ }
+ }
+ putChr('}');
+}
+
+Void putStgPat( StgPat pat )
+{
+ putStgVar(pat);
+ if (nonNull(stgVarBody(pat))) {
+ StgDiscr d = stgConCon(stgVarBody(pat));
+ List vs = stgConArgs(stgVarBody(pat));
+ putChr('@');
+ switch (whatIs(d)) {
+ case NAME:
+ {
+ unlexVar(name(d).text);
+ for (; nonNull(vs); vs=tl(vs)) {
+ putChr(' ');
+ putStgVar(hd(vs));
+ }
+ break;
+ }
+ case TUPLE:
+ {
+ putChr('(');
+ putStgVar(hd(vs));
+ vs=tl(vs);
+ while (nonNull(vs)) {
+ putChr(',');
+ putStgVar(hd(vs));
+ vs=tl(vs);
+ }
+ putChr(')');
+ break;
+ }
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
+ internal("putStgPat");
+ }
+ }
+}
+
+Void putStgPrimPat( StgPrimPat pat )
+{
+ putStgVar(pat);
+ if (nonNull(stgVarBody(pat))) {
+ StgExpr d = stgVarBody(pat);
+ putChr('@');
+ switch (whatIs(d)) {
+ case INTCELL:
+ {
+ putInt(intOf(d));
+ putChr('#');
+ break;
+ }
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
+ internal("putStgPrimPat");
+ }
+ }
+ putChr(' ');
+}
+
+Void putStgBinds(binds) /* pretty print locals */
+List binds; {
+ Int left = outColumn;
+
+ putStr("let { ");
+ while (nonNull(binds)) {
+ Cell bind = hd(binds);
+ putStgVar(bind);
+ putStr(" = ");
+ putStgRhs(stgVarBody(bind));
+ putStr("\n");
+ binds = tl(binds);
+ if (nonNull(binds))
+ pIndent(left+6);
+ }
+ pIndent(left);
+ putStr("} in ");
+}
+
+static Void putStgAlts( Int left, List alts )
+{
+ if (length(alts) == 1) {
+ StgCaseAlt alt = hd(alts);
+ putStr("{ ");
+ putStgPat(stgCaseAltPat(alt));
+ putStr(" ->\n");
+ pIndent(left);
+ putStgExpr(stgCaseAltBody(alt));
+ putStr("}");
+ } else {
+ putStr("{\n");
+ for (; nonNull(alts); alts=tl(alts)) {
+ StgCaseAlt alt = hd(alts);
+ pIndent(left+2);
+ putStgPat(stgCaseAltPat(alt));
+ putStr(" -> ");
+ putStgExpr(stgCaseAltBody(alt));
+ putStr("\n");
+ }
+ pIndent(left);
+ putStr("}\n");
+ }
+}
+
+static Void putStgPrimAlts( Int left, List alts )
+{
+ if (length(alts) == 1) {
+ StgPrimAlt alt = hd(alts);
+ putStr("{ ");
+ mapProc(putStgPrimPat,stgPrimAltPats(alt));
+ putStr(" ->\n");
+ pIndent(left);
+ putStgExpr(stgPrimAltBody(alt));
+ putStr("}");
+ } else {
+ putStr("{\n");
+ for (; nonNull(alts); alts=tl(alts)) {
+ StgPrimAlt alt = hd(alts);
+ pIndent(left+2);
+ mapProc(putStgPrimPat,stgPrimAltPats(alt));
+ putStr(" -> ");
+ putStgExpr(stgPrimAltBody(alt));
+ putStr("\n");
+ }
+ pIndent(left);
+ putStr("}\n");
+ }
+}
+
+Void putStgExpr( StgExpr e ) /* pretty print expr */
+{
+ switch (whatIs(e)) {
+ case LETREC:
+ putStgBinds(stgLetBinds(e));
+ putStgExpr(stgLetBody(e));
+ break;
+ case LAMBDA:
+ {
+ Int left = outColumn;
+ putStr("\\ ");
+ putStgVars(stgLambdaArgs(e));
+ putStr("->\n");
+ pIndent(left+2);
+ putStgExpr(stgLambdaBody(e));
+ break;
+ }
+ case CASE:
+ {
+ Int left = outColumn;
+ putStr("case ");
+ putStgExpr(stgCaseScrut(e));
+ putStr(" of ");
+ putStgAlts(left,stgCaseAlts(e));
+ break;
+ }
+ case PRIMCASE:
+ {
+ Int left = outColumn;
+ putStr("case# ");
+ putStgExpr(stgPrimCaseScrut(e));
+ putStr(" of ");
+ putStgPrimAlts(left,stgPrimCaseAlts(e));
+ break;
+ }
+ case STGPRIM:
+ {
+ Cell op = stgPrimOp(e);
+ unlexVar(name(op).text);
+ putStgAtoms(stgPrimArgs(e));
+ break;
+ }
+ case STGAPP:
+ putStgVar(stgAppFun(e));
+ putStgAtoms(stgAppArgs(e));
+ break;
+ case STGVAR:
+ case NAME:
+ putStgVar(e);
+ break;
+ default:
+ fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ internal("putStgExpr");
+ }
+}
+
+Void putStgRhs( StgRhs e ) /* print lifted definition */
+{
+ switch (whatIs(e)) {
+ case STGCON:
+ {
+ Name con = stgConCon(e);
+ if (isTuple(con)) {
+ putStr("Tuple");
+ putInt(tupleOf(con));
+ } else {
+ unlexVar(name(con).text);
+ }
+ putStgAtoms(stgConArgs(e));
+ break;
+ }
+ default:
+ putStgExpr(e);
+ break;
+ }
+}
+
+static void beginStgPP( FILE* fp );
+static void endStgPP( FILE* fp );
+
+static void beginStgPP( FILE* fp )
+{
+ outputStream = fp;
+ putChr('\n');
+ outColumn = 0;
+}
+
+static void endStgPP( FILE* fp )
+{
+ fflush(fp);
+}
+
+Void printStg(fp,b) /* Pretty print sc defn on fp */
+FILE *fp;
+StgVar b;
+{
+ beginStgPP(fp);
+ putStgVar(b);
+ putStr(" = ");
+ putStgRhs(stgVarBody(b));
+ putStr("\n");
+ endStgPP(fp);
+}
+
+#if DEBUG_PRINTER
+Void ppStg( StgVar v )
+{
+ if (debugCode) {
+ printStg(stdout,v);
+ }
+}
+
+Void ppStgExpr( StgExpr e )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgExpr(e);
+ endStgPP(stdout);
+ }
+}
+
+Void ppStgRhs( StgRhs rhs )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgRhs(rhs);
+ endStgPP(stdout);
+ }
+}
+
+Void ppStgAlts( List alts )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgAlts(0,alts);
+ endStgPP(stdout);
+ }
+}
+
+extern Void ppStgPrimAlts( List alts )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ putStgPrimAlts(0,alts);
+ endStgPP(stdout);
+ }
+}
+
+extern Void ppStgVars( List vs )
+{
+ if (debugCode) {
+ beginStgPP(stdout);
+ printf("Vars: ");
+ putStgVars(vs);
+ printf("\n");
+ endStgPP(stdout);
+ }
+}
+#endif
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Pretty printer for stg code:
+ * ------------------------------------------------------------------------*/
+
+Void printStg( FILE *fp, StgVar b);
+
+#if DEBUG_PRINTER
+extern Void ppStg ( StgVar v );
+extern Void ppStgExpr ( StgExpr e );
+extern Void ppStgRhs ( StgRhs rhs );
+extern Void ppStgAlts ( List alts );
+extern Void ppStgPrimAlts( List alts );
+extern Void ppStgVars ( List vs );
+#endif
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * preds.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
+ * See NOTICE for details and conditions of use etc...
+ * Hugs version 1.3c, March 1998
+ *
+ * Part of type checker dealing with predicates and entailment.
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Cell local assumeEvid Args((Cell,Int));
+static List local makePredAss Args((List,Int));
+static List local copyPreds Args((List));
+static Void local qualify Args((List,Cell));
+static Void local qualifyBinding Args((List,Cell));
+static Cell local qualifyExpr Args((Int,List,Cell));
+static Void local overEvid Args((Cell,Cell));
+
+static Cell local scFind Args((Cell,Cell,Int,Cell,Int));
+static Cell local scEntail Args((List,Cell,Int));
+static Cell local entail Args((List,Cell,Int));
+static Cell local inEntail Args((List,Cell,Int));
+#if TREX
+static Cell local lacksNorm Args((Type,Int,Cell));
+#endif
+
+static List local scSimplify Args((List));
+static Void local elimTauts Args((Void));
+static Bool local anyGenerics Args((Type,Int));
+static List local elimOuterPreds Args((List));
+static List local elimPredsUsing Args((List,List));
+static Void local reducePreds Args((Void));
+static Void local normPreds Args((Int));
+
+static Bool local resolveDefs Args((List));
+static Bool local resolveVar Args((Int));
+static Class local classConstraining Args((Int,Cell,Int));
+
+/* --------------------------------------------------------------------------
+ * Predicate assignments:
+ *
+ * A predicate assignment is represented by a list of triples (pi,o,ev)
+ * where o is the offset for types in pi, with evidence required at the
+ * node pointed to by ev (which is taken as a dictionary parameter if
+ * no other evidence is available). Note that the ev node will be
+ * overwritten at a later stage if evidence for that predicate is found
+ * subsequently.
+ * ------------------------------------------------------------------------*/
+
+static List preds; /* Current predicate assignment */
+
+static Cell local assumeEvid(pi,o) /* Add predicate pi (offset o) to */
+Cell pi; /* preds with new dict var nd */
+Int o; {
+ Cell nd = inventDictVar();
+ preds = cons(triple(pi,mkInt(o),nd),preds);
+ return nd;
+}
+
+static List local makePredAss(qs,o) /* Make list of predicate assumps. */
+List qs; /* from qs (offset o), w/ new dict */
+Int o; { /* vars for each predicate */
+ List result = NIL;
+ for (; nonNull(qs); qs=tl(qs))
+ result = cons(triple(hd(qs),mkInt(o),inventDictVar()),result);
+ return rev(result);
+}
+
+static List local copyPreds(qs) /* Copy list of predicates */
+List qs; {
+ List result = NIL;
+ for (; nonNull(qs); qs=tl(qs)) {
+ Cell pi = hd(qs);
+ result = cons(copyPred(fst3(pi),intOf(snd3(pi))),result);
+ }
+ return rev(result);
+}
+
+static Void local qualify(qs,alt) /* Add extra dictionary args to */
+List qs; /* qualify alt by predicates in qs */
+Cell alt; { /* :: ([Pat],Rhs) */
+ List ds;
+ for (ds=NIL; nonNull(qs); qs=tl(qs))
+ ds = cons(thd3(hd(qs)),ds);
+ fst(alt) = revOnto(ds,fst(alt));
+}
+
+static Void local qualifyBinding(qs,b) /* Add extra dict args to each */
+List qs; /* alternative in function binding */
+Cell b ; {
+ if (!isVar(fst(b))) /* check for function binding */
+ internal("qualifyBinding");
+ map1Proc(qualify,qs,snd(snd(b)));
+}
+
+static Cell local qualifyExpr(l,ps,e) /* Add dictionary params to expr */
+Int l;
+List ps;
+Cell e; {
+ if (nonNull(ps)) { /* Qualify input expression with */
+ if (whatIs(e)!=LAMBDA) /* additional dictionary params */
+ e = ap(LAMBDA,pair(NIL,pair(mkInt(l),e)));
+ qualify(ps,snd(e));
+ }
+ return e;
+}
+
+static Void local overEvid(dv,ev) /* Overwrite dict var dv with */
+Cell dv; /* evidence ev */
+Cell ev; {
+ fst(dv) = nameInd;
+ snd(dv) = ev;
+}
+
+/* --------------------------------------------------------------------------
+ * Predicate entailment:
+ *
+ * Entailment plays a prominent role in the theory of qualified types, and
+ * so, unsurprisingly, in the implementation too. For practical reasons,
+ * we break down entailment into two pieces. The first, scEntail, uses
+ * only the information provided by class declarations, while the second,
+ * entail, also uses the information in instance declarations.
+ *
+ * scEntail uses the following auxiliary function to do its work:
+ *
+ * scFind (e : pi') pi : Find evidence for predicate pi using only
+ * equality of predicates, superclass entailment,
+ * and the evidence e for pi'.
+ *
+ * scFind (e : pi') pi =
+ *
+ * if pi = pi' then
+ * return e
+ *
+ * if (pi.class.level < pi'.class.level)
+ * get superclass entailment pi' ||- P
+ * for each (sc, pi0) in P
+ * if (ev := scFind (sc e : pi0) pi) /= NIL
+ * return ev
+ *
+ * return NIL
+ *
+ * This code assumes that the class hierarchy is acyclic, and that
+ * each class has been assigned a `level', which is its height in
+ * the hierachy. The first of the assumptions guarantees that the
+ * algorithm will terminate. The comparison of levels is an
+ * optimization that cuts down the search space: given that superclass
+ * entailments can only be used to descend the hierarchy, there is no
+ * way we can reach a higher level than the one that we start with,
+ * and hence there is no point in looking if we reach such a position.
+ *
+ * scEntail extends scFind to work on whole predicate assignments:
+ *
+ * scEntail P pi : Find evidence for predicate pi using the evidence
+ * provided by the predicate assignment P, and using
+ * only superclass entailments.
+ *
+ * scEntail P pi =
+ *
+ * for each (v:pi') in P
+ * if (ev := scFind (v:pi') pi) /= NIL
+ * return ev;
+ * return NIL
+ *
+ * ------------------------------------------------------------------------*/
+
+static Cell local scFind(e,pi1,o1,pi,o) /* Use superclass entailment to */
+Cell e; /* find evidence for (pi,o) using */
+Cell pi1; /* the evidence e for (pi1,o1). */
+Int o1;
+Cell pi;
+Int o; {
+ Class h1 = getHead(pi1);
+ Class h = getHead(pi);
+
+ if (h==h1 && samePred(pi1,o1,pi,o))
+ return e;
+
+ if (isClass(h1) && (!isClass(h) || cclass(h).level<cclass(h1).level)) {
+ Int beta = newKindedVars(cclass(h1).kinds);
+ List scs = cclass(h1).supers;
+ List dsels = cclass(h1).dsels;
+ if (!matchPred(pi1,o1,cclass(h1).head,beta))
+ internal("scFind");
+ for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels)) {
+ Cell ev = scFind(ap(hd(dsels),e),hd(scs),beta,pi,o);
+ if (nonNull(ev))
+ return ev;
+ }
+ }
+
+ return NIL;
+}
+
+static Cell local scEntail(ps,pi,o) /* Calc evidence for (pi,o) from ps*/
+List ps; /* Using superclasses and equality.*/
+Cell pi;
+Int o; {
+ for (; nonNull(ps); ps=tl(ps)) {
+ Cell pi1 = hd(ps);
+ Cell ev = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o);
+ if (nonNull(ev))
+ return ev;
+ }
+ return NIL;
+}
+
+/* --------------------------------------------------------------------------
+ * Now we reach the main entailment routine:
+ *
+ * entail P pi : Find evidence for predicate pi using the evidence
+ * provided by the predicate assignment P.
+ *
+ * entail P pi =
+ *
+ * if (ev := scEntail P pi) /= NIL
+ * return ev;
+ *
+ * if there is an instance entailment i : Q ||- pi
+ * for each pi' in Q
+ * if (ev := entail P pi') /= NIL
+ * i := ap(i,ev)
+ * else
+ * return NIL
+ * return i
+ *
+ * return NIL;
+ *
+ * The form of evidence expressions produced by scEntail can be described
+ * by the grammar:
+ *
+ * e = v | sc e (v = evidence var, sc = superclass sel)
+ *
+ * while entail extends this to include dictionary expressions given by:
+ *
+ * d = e | mki d1 ... dn (mki = dictionary constructor)
+ *
+ * A full grammar for evidence expressions is:
+ *
+ * d = v | sc d | mki d1 ... dn
+ *
+ * and this includes evidence expressions of the form sc (mki d1 ... dn)
+ * that can never be produced by either of the entail functions described
+ * above. This is good, from a practical perspective, because t means
+ * that we won't waste effort building a dictionary (mki d1 ... dn) only
+ * to extract just one superclass component and throw the rest away.
+ * Moreover, conditions on instance decls already guarantee that any
+ * expression of this form can be rewritten in the form mki' d1' ... dn'.
+ * (Minor point: they don't guarantee that such rewritings will lead to
+ * smaller terms, and hence to termination. However, we have already
+ * accepted the benefits of an undecidable entailment relation over
+ * guarantees of termination, and this additional quirk is unlikely
+ * to cause any further concern, except in pathological cases.)
+ * ------------------------------------------------------------------------*/
+
+static Cell local entail(ps,pi,o) /* Calc evidence for (pi,o) from ps*/
+List ps; /* Uses superclasses, equality, */
+Cell pi; /* tautology, and construction */
+Int o; {
+ Cell ev = scEntail(ps,pi,o);
+ return nonNull(ev) ? ev : inEntail(ps,pi,o);
+}
+
+static Cell local inEntail(ps,pi,o) /* Calc evidence for (pi,o) from ps*/
+List ps; /* using a top-level instance */
+Cell pi; /* entailment */
+Int o; {
+#if TREX
+ if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */
+ Cell e = fun(pi);
+ Cell l;
+ l = lacksNorm(arg(pi),o,e);
+ if (isNull(l) || isInt(l))
+ return l;
+ else {
+ List qs = ps;
+ for (; nonNull(qs); qs=tl(qs)) {
+ Cell qi = fst3(hd(qs));
+ if (isAp(qi) && fun(qi)==e) {
+ Cell lq = lacksNorm(arg(qi),intOf(snd3(hd(qs))),e);
+ if (isAp(lq) && intOf(fst(l))==intOf(fst(lq))) {
+ Int f = intOf(snd(l)) - intOf(snd(lq));
+ return (f==0) ? thd3(hd(qs)) : ap2(nameAddEv,
+ mkInt(f),
+ thd3(hd(qs)));
+ }
+ }
+ }
+ return NIL;
+ }
+ }
+ else {
+#endif
+ Inst in = findInstFor(pi,o); /* Class predicates */
+ if (nonNull(in)) {
+ Int beta = typeOff;
+ Cell d = inst(in).builder;
+ Cell ds = inst(in).specifics;
+ for (; nonNull(ds); ds=tl(ds)) {
+ Cell ev = entail(ps,hd(ds),beta);
+ if (nonNull(ev))
+ d = ap(d,ev);
+ else
+ return NIL;
+ }
+ return d;
+ }
+ return NIL;
+#if TREX
+ }
+#endif
+}
+
+Cell provePred(ks,ps,pi) /* Find evidence for predicate pi */
+Kinds ks; /* assuming ps. If ps is null, */
+List ps; /* then we get to decide whether */
+Cell pi; { /* is tautological, and we can use */
+ Int beta; /* the evidence as a dictionary. */
+ Cell ev;
+ emptySubstitution();
+ beta = newKindedVars(ks); /* (ks provides kinds for any */
+ ps = makePredAss(ps,beta); /* vars that appear in pi.) */
+ ev = entail(ps,pi,beta);
+ emptySubstitution();
+ return ev;
+}
+
+#if TREX
+static Cell local lacksNorm(t,o,e) /* Normalize lacks pred (t,o)\l */
+Type t; /* returning NIL (unsatisfiable), */
+Int o; /* Int (tautological) or pair (v,a)*/
+Cell e; { /* such that, if e is evid for v\l,*/
+ Text l = extText(e); /* then (e+a) is evid for (t,o)\l. */
+ Int a = 0;
+ for (;;) {
+ Tyvar *tyv;
+ deRef(tyv,t,o);
+ if (tyv)
+ return pair(mkInt(tyvNum(tyv)),mkInt(a));
+ else {
+ Cell h = getDerefHead(t,o);
+ if (h==typeNoRow && argCount==0)
+ return mkInt(a);
+ else if (isExt(h) && argCount==2) {
+ Text l1 = extText(h);
+ if (l1==l)
+ return NIL;
+ else if (strcmp(textToStr(l1),textToStr(l))<0)
+ a++;
+ t = arg(t);
+ }
+ else
+ return NIL;
+ }
+ }
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Predicate set Simplification:
+ *
+ * Calculate a minimal equivalent subset of a given set of predicates.
+ * ------------------------------------------------------------------------*/
+
+static List local scSimplify(qs) /* Simplify predicates in qs, */
+List qs; { /* returning equiv minimal subset */
+ Int n = length(qs);
+
+ while (0<n--) {
+ Cell pi = hd(qs);
+ Cell ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)));
+ if (nonNull(ev)) {
+ overEvid(thd3(pi),ev); /* Overwrite dict var with evidence*/
+ qs = tl(qs); /* ... and discard predicate */
+ }
+ else { /* Otherwise, retain predicate */
+ Cell tmp = tl(qs);
+ tl(qs) = NIL;
+ qs = appendOnto(tmp,qs);
+ }
+ }
+ return qs;
+}
+
+List simpleContext(ps,o) /* Simplify context of skeletons */
+List ps; /* skeletons, offset o, using */
+Int o; { /* superclass hierarchy */
+ return copyPreds(scSimplify(makePredAss(ps,o)));
+}
+
+/* --------------------------------------------------------------------------
+ * Context splitting --- tautological and locally tautological predicates:
+ * ------------------------------------------------------------------------*/
+
+static Void local elimTauts() { /* Remove tautological constraints */
+ List ps = preds; /* from preds */
+ preds = NIL;
+ while (nonNull(ps)) {
+ Cell pi = hd(ps);
+ Cell ev = entail(NIL,fst3(pi),intOf(snd3(pi)));
+ if (nonNull(ev)) {
+ overEvid(thd3(pi),ev);
+ ps = tl(ps);
+ }
+ else {
+ List tmp = tl(ps);
+ tl(ps) = preds;
+ preds = ps;
+ ps = tmp;
+ }
+ }
+}
+
+static Int numFixedVars = 0; /* Number of fixed vars found */
+
+static Bool local anyGenerics(t,o) /* Test for generic vars, and count*/
+Type t; /* fixed variables */
+Int o; {
+ Type h = getDerefHead(t,o); /* This code is careful to expand */
+ Int a = argCount; /* synonyms; mark* & copy* do not. */
+ if (isSynonym(h) && a>=tycon(h).arity) {
+ expandSyn(h,a,&t,&o);
+ return anyGenerics(t,o);
+ }
+ else {
+ Tyvar* tyv;
+ for (; 0<a--; t=fun(t)) { /* cycle through any arguments */
+ deRef(tyv,t,o);
+ if (anyGenerics(arg(t),o))
+ return TRUE;
+ }
+ deRef(tyv,t,o);
+ if (tyv)
+ if (tyv->offs == FIXED_TYVAR) {
+ numFixedVars++;
+ return FALSE;
+ }
+ else
+ return TRUE;
+ else
+ return FALSE;
+ }
+}
+
+static List local elimOuterPreds(sps) /* Simplify and defer any remaining*/
+List sps; { /* preds that contain no generics. */
+ List qs = NIL;
+ elimTauts();
+ for (preds=scSimplify(preds); nonNull(preds); ) {
+ Cell pi = hd(preds);
+ Cell nx = tl(preds);
+ if (anyGenerics(fst3(pi),intOf(snd3(pi)))) { /* Retain predicate*/
+ tl(preds) = qs;
+ qs = preds;
+ }
+ else { /* Defer predicate */
+ tl(preds) = sps;
+ sps = preds;
+ }
+ preds = nx;
+ }
+ preds = qs;
+ return sps;
+}
+
+static List local elimPredsUsing(ps,sps)/* Try to discharge or defer preds,*/
+List ps; /* splitting if necessary to match */
+List sps; { /* context ps. sps = savePreds. */
+ List rems = NIL;
+ while (nonNull(preds)) { /* Pick a predicate from preds */
+ Cell p = preds;
+ Cell pi = fst3(hd(p));
+ Int o = intOf(snd3(hd(p)));
+ Cell ev = entail(ps,pi,o);
+ preds = tl(preds);
+
+ if (nonNull(ev)) /* Discharge if ps ||- (pi,o) */
+ overEvid(thd3(hd(p)),ev);
+ else if (!anyGenerics(pi,o)) { /* Defer if no generics */
+ tl(p) = sps;
+ sps = p;
+ }
+ else { /* Try to split generics and fixed */
+ Inst in;
+ if (numFixedVars>0 && nonNull(in=findInstFor(pi,o))) {
+ List qs = inst(in).specifics;
+ for (ev=inst(in).builder; nonNull(qs); qs=tl(qs))
+ ev = ap(ev,assumeEvid(hd(qs),typeOff));
+ overEvid(thd3(hd(p)),ev);
+ }
+ else { /* No worthwhile progress possible */
+ tl(p) = rems;
+ rems = p;
+ }
+ }
+ }
+ preds = rems; /* Return any remaining predicates */
+ return sps;
+}
+
+static Void local reducePreds() { /* Context reduce predicates: uggh!*/
+ List rems = NIL; /* (A last resort for defaulting) */
+ while (nonNull(preds)) { /* Pick a predicate from preds */
+ Cell p = preds;
+ Cell pi = fst3(hd(p));
+ Int o = intOf(snd3(hd(p)));
+ Inst in = findInstFor(pi,o);
+ preds = tl(preds);
+ if (nonNull(in)) {
+ List qs = inst(in).specifics;
+ Cell ev = inst(in).builder;
+ for (; nonNull(qs); qs=tl(qs))
+ ev = ap(ev,assumeEvid(hd(qs),typeOff));
+ overEvid(thd3(hd(p)),ev);
+ }
+ else { /* No worthwhile progress possible */
+ tl(p) = rems;
+ rems = p;
+ }
+ }
+ preds = scSimplify(rems); /* Return any remaining predicates */
+}
+
+static Void local normPreds(line) /* Normalize each element of preds */
+Int line; { /* in some appropriate manner */
+#if TREX
+ List ps = preds;
+ List pr = NIL;
+ while (nonNull(ps)) {
+ Cell pi = fst3(hd(ps));
+ Cell ev = thd3(hd(ps));
+ if (isAp(pi) && isExt(fun(pi))) {
+ Cell r = lacksNorm(arg(pi),intOf(snd3(hd(ps))),fun(pi));
+ if (isNull(r)) {
+ ERRMSG(line) "Cannot satisfy constraint " ETHEN
+ ERRPRED(copyPred(pi,intOf(snd3(hd(ps)))));
+ ERRTEXT "\n"
+ EEND;
+ }
+ else if (isInt(r)) {
+ overEvid(ev,r);
+ ps = tl(ps);
+ if (isNull(pr))
+ preds = ps;
+ else
+ tl(pr) = ps;
+ }
+ else if (intOf(snd(r))!=0) {
+ Cell nd = inventDictVar();
+ Cell ev1 = ap2(nameAddEv,snd(r),nd);
+ pi = ap(fun(pi),aVar);
+ hd(ps) = triple(pi,fst(r),nd);
+ overEvid(ev,ev1);
+ pr = ps;
+ ps = tl(ps);
+ }
+ else {
+ fst3(hd(ps)) = ap(fun(pi),fst(r));
+ pr = ps;
+ ps = tl(ps);
+ }
+ }
+ else {
+ pr = ps;
+ ps = tl(ps);
+ }
+ }
+#endif
+}
+
+/* --------------------------------------------------------------------------
+ * Mechanisms for dealing with defaults:
+ * ------------------------------------------------------------------------*/
+
+static Bool local resolveDefs(vs) /* Attempt to resolve defaults */
+List vs; { /* for variables vs subject to */
+ List pvs = NIL; /* constraints in preds */
+ List qs = preds;
+ Bool defaulted = FALSE;
+
+#ifdef DEBUG_DEFAULTS
+ printf("Attempt to resolve variables ");
+ printExp(stdout,vs);
+ printf(" with context ");
+ printContext(stdout,copyPreds(preds));
+ printf("\n");
+#endif
+
+ resetGenerics(); /* find type variables in ps */
+ for (; nonNull(qs); qs=tl(qs)) {
+ Cell pi = fst3(hd(qs));
+ Int o = intOf(snd3(hd(qs)));
+ for (; isAp(pi); pi=fun(pi))
+ pvs = genvarType(arg(pi),o,pvs);
+ }
+
+ for (; nonNull(pvs); pvs=tl(pvs)) { /* now try defaults */
+ Int vn = intOf(hd(pvs));
+
+#ifdef DEBUG_DEFAULTS
+ printf("is var %d included in ",vn);
+ printExp(stdout,vs);
+ printf("?\n");
+#endif
+
+ if (!intIsMember(vn,vs))
+ defaulted |= resolveVar(vn);
+#ifdef DEBUG_DEFAULTS
+ else
+ printf("Yes, so no ambiguity!\n");
+#endif
+ }
+
+ return defaulted;
+}
+
+static Bool local resolveVar(vn) /* Determine whether an ambig. */
+Int vn; { /* variable vn can be resolved */
+ List ps = preds; /* by default in the context of */
+ List cs = NIL; /* the predicates in ps */
+ Bool aNumClass = FALSE;
+
+ if (tyvar(vn)->bound == SKOLEM)
+ return FALSE;
+
+ /* According to the Haskell definition, we can only default an ambiguous
+ * variable if the set of classes that constrain it:
+ * (a) includes at least one numeric class.
+ * (b) includes only numeric or standard classes.
+ * In addition, we will not allow a variable to be defaulted unless it
+ * appears only in predicates of the form (Class var).
+ */
+
+#ifdef DEBUG_DEFAULTS
+ printf("Trying to default variable %d\n",vn);
+#endif
+
+ for (; nonNull(ps); ps=tl(ps)) {
+ Cell pi = hd(ps);
+ Class c = classConstraining(vn,fst3(pi),intOf(snd3(pi)));
+ if (nonNull(c)) {
+ if (c==classRealFrac || c==classRealFloat ||
+ c==classFractional || c==classFloating ||
+ c==classReal || c==classIntegral || c==classNum)
+ aNumClass = TRUE;
+ else if (c!=classEq && c!=classOrd && c!=classShow &&
+ c!=classRead && c!=classIx && c!=classEnum &&
+#if EVAL_INSTANCES
+ c!=classEval &&
+#endif
+ c!=classBounded)
+ return FALSE;
+
+ { Type t = arg(fst3(pi));/* Check for single var as arg */
+ Int o = intOf(snd3(pi));
+ Tyvar *tyv;
+ deRef(tyv,t,o);
+ if (!tyv || tyvNum(tyv)!=vn)
+ return FALSE;
+ }
+ if (!cellIsMember(c,cs))
+ cs = cons(c,cs);
+ }
+ }
+
+ /* Now find the first class (if any) in the list of defaults that
+ * is an instance of all of the required classes.
+ *
+ * If we get this far, then cs only mentions classes from the list
+ * above, all of which have only a single parameter of kind *.
+ */
+
+ if (aNumClass) {
+ List ds = defaultDefns; /* N.B. guaranteed to be monotypes */
+#ifdef DEBUG_DEFAULTS
+ printf("Default conditions met, looking for type\n");
+#endif
+ for (; nonNull(ds); ds=tl(ds)) {
+ List cs1 = cs;
+ while (nonNull(cs1) && nonNull(entail(NIL,ap(hd(cs1),hd(ds)),0)))
+ cs1 = tl(cs1);
+ if (isNull(cs1)) {
+ bindTv(vn,hd(ds),0);
+#ifdef DEBUG_DEFAULTS
+ printf("Default type for variable %d is ",vn);
+ printType(stdout,hd(ds));
+ printf("\n");
+#endif
+ return TRUE;
+ }
+ }
+ }
+
+#ifdef DEBUG_DEFAULTS
+ printf("No default permitted/found\n");
+#endif
+ return FALSE;
+}
+
+static Class local classConstraining(vn,pi,o)
+Int vn; /* Return class constraining var*/
+Cell pi; /* vn in predicate pi, or NIL if*/
+Int o; { /* vn is not involved */
+ for (; isAp(pi); pi=fun(pi))
+ if (!doesntOccurIn(tyvar(vn),arg(pi),o))
+ return getHead(pi);
+ return NIL;
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Basic data type definitions, prototypes and standard macros including
+ * machine dependent variations...
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: prelude.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:33 $
+ * ------------------------------------------------------------------------*/
+
+#include "config.h"
+#include "options.h"
+#include <stdio.h>
+
+/*---------------------------------------------------------------------------
+ * Most of the configuration code from earlier versions of Hugs has been moved
+ * into config.h (which is usually automatically generated).
+ *
+ * Most of the configuration code is "feature based". That is, the
+ * configure script looks to see if a particular feature (or misfeature)
+ * is present on the compiler/OS.
+ *
+ * A small amount of configuration code is still "system based": it tests
+ * flags to determine what kind of compiler/system it's running on - from
+ * which it infers what features the compiler/system has. Use of system
+ * based tests generally indicates that we can't remember/figure out
+ * what the original problem was and so we can't add an appropriate feature
+ * test to the configure script.
+ *-------------------------------------------------------------------------*/
+
+#ifdef __RISCOS__ /* Acorn DesktopC running RISCOS2 or 3 */
+# define RISCOS 1
+#else
+# define RISCOS 0
+#endif
+
+#if defined __DJGPP__ && __DJGPP__==2
+# define DJGPP2 1
+#else
+# define DJGPP2 0
+#endif
+
+#if defined __MSDOS__ && __MSDOS__ && !DJGPP2
+# define DOS 1
+#else
+# define DOS 0
+#endif
+
+#if defined _WIN32 | defined __WIN32__
+# define IS_WIN32 1
+#else
+# define IS_WIN32 0
+#endif
+
+/*---------------------------------------------------------------------------
+ * Platform-dependent settings:
+ *-------------------------------------------------------------------------*/
+
+/*---------------------------------------------------------------------------
+ * Include windows.h and friends:
+ *-------------------------------------------------------------------------*/
+
+#if HAVE_WINDOWS_H
+#include <windows.h> /* Misc. Windows hackery */
+#endif
+
+#if HUGS_FOR_WINDOWS
+
+#if __MSDOS__
+# define INT int
+# define UNSIGNED unsigned
+# define CHAR char
+# define TCHAR char
+# define UCHAR UNSIGNED CHAR
+# define ULONG unsigned long
+# define APIENTRY PASCAL
+# define HUGE huge
+# define LPOFNHOOKPROC FARPROC
+# define CMDdata(w,l) (HIWORD(l)) /* decoding WM_COMMAND message */
+# define CMDitem(w,l) (w)
+# define CMDhwnd(w,l) ((HWND)(LOWORD(l)))
+#else
+# define HUGE
+# define CMDdata(w,l) (HIWORD(w)) /* decoding WM_COMMAND message */
+# define CMDitem(w,l) (LOWORD(w))
+# define CMDhwnd(w,l) ((HWND)(l))
+#endif
+
+#include "win-menu.h"
+extern char *appName;
+extern HWND hWndText; /* text output window handle */
+extern HWND hWndMain; /* main window handle */
+#include "win-text.h"
+#endif
+
+
+/*---------------------------------------------------------------------------
+ * Macros used in declarations:
+ * function prototypes
+ * local/far declarations
+ * HUGS_noreturn/HUGS_unused (prevent spurious warnings)
+ * result type of main
+ * dynamic linking declarations
+ *-------------------------------------------------------------------------*/
+
+#if HAVE_PROTOTYPES /* To enable use of prototypes whenever possible */
+#define Args(x) x
+#else
+#define Args(x) ()
+#endif
+
+/* local = prefix for locally defined functions */
+/* far = prefix for far pointers */
+#if DOS
+# define local near pascal
+#else
+# define local
+# define far
+#endif
+
+#ifdef __GNUC__ /* Avoid spurious warnings */
+#if __GNUC__ >= 2 && __GNUC_MINOR__ >= 7
+#define HUGS_noreturn __attribute__ ((noreturn))
+#define HUGS_unused __attribute__ ((unused))
+#else
+#define HUGS_noreturn
+#define HUGS_unused
+#endif
+#else
+#define HUGS_noreturn
+#define HUGS_unused
+#endif
+
+/* result type of main function */
+/* Hugs 1.01 could be configured to return void on Unix-like systems
+ * but I don't think this is necessary. ADR
+ */
+#define Main int
+#define MainDone() return 0/*NOTUSED*/
+
+/*---------------------------------------------------------------------------
+ * String operations:
+ *-------------------------------------------------------------------------*/
+
+#if HAVE_STRING_H
+# include <string.h>
+#else
+extern int strcmp Args((const char*, const char*));
+extern int strncmp Args((const char*, const char*, int));
+extern char *strchr Args((const char*, int));
+extern char *strrchr Args((const char*, int));
+extern size_t strlen Args((const char *));
+extern char *strcpy Args((char *, const char*));
+extern char *strcat Args((char *, const char*));
+#endif
+#if HAVE_STRCMP
+#define strCompare strcmp
+#else /* probably only used for DOS - ADR */
+extern int stricmp Args((const char *, const char*));
+#define strCompare stricmp
+#endif
+
+#if HAVE_CTYPE_H
+# include <ctype.h>
+#endif
+#ifndef isascii
+#define isascii(c) (((unsigned)(c))<128)
+#endif
+
+/*---------------------------------------------------------------------------
+ * Memory allocation
+ *-------------------------------------------------------------------------*/
+
+#if HAVE_FARCALLOC
+# include <alloc.h>
+# define farCalloc(n,s) farcalloc((unsigned long)n,(unsigned long)s)
+#elif HAVE_VALLOC
+# include <stdlib.h>
+# include <malloc.h>
+# define farCalloc(n,s) (Void *)valloc(((unsigned)n)*((unsigned)s))
+#else
+# define farCalloc(n,s) (Void *)calloc(((unsigned)n),((unsigned)s))
+#endif
+
+/* bison-generated parsers like to have alloca - so try to define it */
+#if HAVE__ALLOCA
+#include <malloc.h>
+#ifndef alloca
+#define alloca _alloca
+#endif
+#endif
+
+/*---------------------------------------------------------------------------
+ * Interrupting execution (signals, allowBreak):
+ *-------------------------------------------------------------------------*/
+
+#if !DOS && VOID_INT_SIGNALS
+# define sigProto(nm) void nm Args((int))
+# define sigRaise(nm) nm(1)
+# define sigHandler(nm) void nm(sig_arg) int sig_arg;
+# define sigResume return
+#else
+# define sigProto(nm) int nm Args((Void))
+# define sigRaise(nm) nm()
+# define sigHandler(nm) int nm(Void)
+# define sigResume return 1
+#endif
+
+/*---------------------------------------------------------------------------
+ * Assertions
+ *-------------------------------------------------------------------------*/
+
+#if HAVE_ASSERT_H
+#include <assert.h>
+#else
+#define assert(x) doNothing()
+#endif
+
+/*---------------------------------------------------------------------------
+ * General settings:
+ *-------------------------------------------------------------------------*/
+
+#define Void void /* older compilers object to: typedef void Void; */
+typedef unsigned Bool;
+#define TRUE 1
+#define FALSE 0
+typedef char *String;
+typedef int Int;
+typedef long Long;
+typedef int Char;
+typedef unsigned int Word; /* at least 32 bits */
+typedef void* Ptr;
+typedef void* Addr;
+typedef Word* HpPtr;
+
+/* ToDo: this should probably go in dynamic.h - but then
+ * storage.h has to include dynamic.h!
+ */
+#if HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
+typedef void* ObjectFile;
+#elif HAVE_DL_H /* eg HPUX */
+typedef shl_t ObjectFile;
+#elif HAVE_WINDOWS_H && !defined(__MSDOS__)
+typedef HINSTANCE ObjectFile;
+#else
+#warning GHC file loading not available on this machine
+#endif
+
+#define doNothing() do { } while (0) /* Null statement */
+
+#ifndef STD_PRELUDE
+#if RISCOS
+#define STD_PRELUDE "prelude"
+#else
+#define STD_PRELUDE "Prelude.hs"
+#endif
+#endif
+
+#if DYN_TABLES /* Tables may be alloc'd at runtime*/
+#define DECTABLE(tab) far *tab /* macros for declaration & defn */
+#define DEFTABLE(tab,sz) far *tab = 0
+#else /* or at compile-time: */
+#define DECTABLE(tab) tab[]
+#define DEFTABLE(tab,sz) tab[sz]
+#endif
+
+/*---------------------------------------------------------------------------
+ * Printf-related operations:
+ *-------------------------------------------------------------------------*/
+
+#ifdef HAVE_STDARG_H
+#include <stdarg.h>
+#else
+#include <varargs.h>
+#endif
+
+#if !defined(HAVE_SNPRINTF)
+extern int snprintf Args((char*, int, const char*, ...));
+#endif
+
+#if !defined(HAVE_VSNPRINTF)
+extern int vsnprintf Args((char*, int, const char*, va_list));
+#endif
+
+/*---------------------------------------------------------------------------
+ * Compiler output
+ * Tweaking this lets us redirect prompts, error messages, etc - but has no
+ * effect on output of Haskell programs (which should use hPutStr and friends).
+ *-------------------------------------------------------------------------*/
+
+#if REDIRECT_OUTPUT
+
+extern Void hugsPrintf Args((const char *, ...));
+extern Void hugsPutchar Args((int));
+extern Void hugsFlushStdout Args((Void));
+extern Void hugsEnableOutput Args((Bool));
+extern String hugsClearOutputBuffer Args((Void));
+
+extern Void hugsFFlush Args((FILE*));
+extern Void hugsFPrintf Args((FILE*, const char*, ...));
+extern Void hugsPutc Args((int, FILE*));
+
+#define Printf hugsPrintf
+#define Putchar hugsPutchar
+#define FlushStdout hugsFlushStdout
+#define EnableOutput hugsEnableOutput
+#define ClearOutputBuffer hugsClearOutputBuffer
+
+#define FFlush hugsFFlush
+#define FPrintf hugsFPrintf
+#define Putc hugsPutc
+
+#else
+
+#define Printf printf
+#define Putchar putchar
+#define FlushStdout() fflush(stdout)
+#define EnableOutput(f) doNothing()
+#define ClearOutputBuffer() 0
+
+#define FFlush fflush
+#define FPrintf fprintf
+#define Putc putc
+
+#endif
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+#include "options.h"
+
+#ifndef PROVIDE_CONCURRENT
+module PrelConc () where
+#else
+#ifdef HEAD
+module PrelConc (
+
+ -- Thread Ids
+ ThreadId,
+
+ -- Forking and suchlike
+ forkIO,
+ killThread,
+ --par, fork,
+ {-threadDelay, threadWaitRead, threadWaitWrite, -}
+
+ -- MVars
+ MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
+
+ ) where
+
+--infixr 0 `par`, `fork`
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+data ThreadId
+
+forkIO :: IO () -> IO ThreadId
+forkIO action = primFork (unsafePerformIO action)
+
+killThread :: ThreadId -> IO ()
+killThread = primKillThread
+
+data MVar a
+
+instance Eq (MVar a) where (==) = primSameMVar
+
+newEmptyMVar :: IO (MVar a)
+newMVar :: a -> IO (MVar a)
+putMVar :: MVar a -> a -> IO ()
+takeMVar :: MVar a -> IO a
+readMVar :: MVar a -> IO a
+swapMVar :: MVar a -> a -> IO a
+
+newEmptyMVar = primNewMVar
+putMVar = primPutMVar
+takeMVar = primTakeMVar
+
+newMVar value =
+ newEmptyMVar >>= \ mvar ->
+ putMVar mvar value >>
+ return mvar
+
+readMVar mvar =
+ takeMVar mvar >>= \ value ->
+ putMVar mvar value >>
+ return value
+
+swapMVar mvar new =
+ takeMVar mvar >>= \ old ->
+ putMVar mvar new >>
+ return old
+
+#endif /* BODY */
+
+#endif /* PROVIDE_CONCURRENT */
+
--- /dev/null
+#include "options.h"
+
+#if BIGNUM_IS_INT64
+#define primToBignum(t) prim/**/t/**/ToInt64
+#define primFromBignum(t) primInt64To/**/t
+#define primInt64ToInt64 id
+#define primEncodeFloat primEncodeFloatz
+#define primDecodeFloat primDecodeFloatz
+#define primEncodeDouble primEncodeDoublez
+#define primDecodeDouble primDecodeDoublez
+#elif BIGNUM_IS_INTEGER
+#define primToBignum(t) prim/**/t/**/ToInteger
+#define primFromBignum(t) primIntegerTo/**/t
+#define primIntegerToInteger id
+#define primEncodeFloat primEncodeFloatZ
+#define primDecodeFloat primDecodeFloatZ
+#define primEncodeDouble primEncodeDoubleZ
+#define primDecodeDouble primDecodeDoubleZ
+#else
+#warning No BIGNUM type
+#endif
+
+#ifdef HEAD
+module Prelude (
+ module PreludeList, module PreludeText, module PreludeIO,
+ Bool(False, True),
+ Maybe(Nothing, Just),
+ Either(Left, Right),
+ Ordering(LT, EQ, GT),
+ Char, String, Int,
+#ifdef PROVIDE_INTEGER
+ Integer,
+#endif
+ Float, Double, IO,
+#if STD_PRELUDE
+#else
+ Void,
+#endif
+ Ratio, Rational,
+#if STD_PRELUDE
+-- List type: []((:), [])
+#else
+ (:),
+#endif
+-- Tuple types: (,), (,,), etc.
+-- Trivial type: ()
+-- Functions: (->)
+ Eq((==), (/=)),
+ Ord(compare, (<), (<=), (>=), (>), max, min),
+ Enum(toEnum, fromEnum, enumFrom, enumFromThen,
+ enumFromTo, enumFromThenTo),
+ Bounded(minBound, maxBound),
+#if EVAL_INSTANCES
+ Eval(seq, strict),
+#else
+ seq, strict,
+#endif
+ Num((+), (-), (*), negate, abs, signum, fromInteger),
+ Real(toRational),
+ Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
+ Fractional((/), recip, fromRational),
+ Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
+ asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
+ RealFrac(properFraction, truncate, round, ceiling, floor),
+ RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
+ encodeFloat, exponent, significand, scaleFloat, isNaN,
+ isInfinite, isDenormalized, isIEEE, isNegativeZero),
+ Monad((>>=), (>>), return),
+ MonadZero(zero),
+ MonadPlus((++)),
+ Functor(map),
+ succ, pred,
+ mapM, mapM_, guard, accumulate, sequence, filter, concat, applyM,
+ maybe, either,
+ (&&), (||), not, otherwise,
+ subtract, even, odd, gcd, lcm, (^), (^^),
+ fromIntegral, fromRealFrac, atan2,
+ fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
+ asTypeOf, error, undefined ) where
+
+import PreludeBuiltin -- Contains all `prim' values
+import PreludeList
+import PreludeText
+import PreludeIO
+import Ratio(Ratio, Rational, (%), numerator, denominator)
+
+#endif /* HEAD */
+#ifdef BODY
+module PreludeBuiltin
+ ( module PreludeBuiltin
+ ) where
+
+#if STD_PRELUDE
+import PreludeBuiltin -- Contains all `prim' values
+import PreludeList
+import PreludeText
+import PreludeIO
+import Ratio(Ratio, Rational, (%), numerator, denominator)
+#endif
+
+infixr 9 .
+infixr 8 ^, ^^, **
+infixl 7 *, /, `quot`, `rem`, `div`, `mod`
+infixl 6 +, -
+infixr 5 :, ++
+infix 4 ==, /=, <, <=, >=, >
+infixr 3 &&
+infixr 2 ||
+infixl 1 >>, >>=
+infixr 0 $, `seq`
+
+#if STD_PRELUDE
+#else
+-- Fixities from List
+infix 5 \\
+-- Fixities from PreludeList
+infixl 9 !!
+infix 4 `elem`, `notElem`
+-- Fixities from Ratio (why do I have the :% fixity??)
+infixl 7 %, :%
+-- Fixities from Array
+infixl 9 !, //
+
+#include "PreludeList.hs"
+#include "PreludeText.hs"
+#include "PreludeIO.hs"
+#include "Ratio.hs"
+#include "Ix.hs"
+#include "Char.hs"
+#include "Numeric.hs"
+#include "Array.hs"
+#include "List.hs"
+#include "Maybe.hs"
+#include "UnicodePrims.hs"
+#include "PreludePackString.hs"
+#include "PrelConc.hs"
+
+-- The following bits of GHC are too good to pass up!
+#include "PrelIOBase.unlit"
+#include "PrelHandle.unlit"
+#include "PrelException.unlit"
+#include "PrelDynamic.unlit"
+#include "IO.unlit"
+#endif
+
+-- Standard types, classes, instances and related functions
+
+-- Equality and Ordered classes
+
+class Eq a where
+ (==), (/=) :: a -> a -> Bool
+
+ x /= y = not (x == y)
+ x == y = not (x /= y)
+
+class (Eq a) => Ord a where
+ compare :: a -> a -> Ordering
+ (<), (<=),
+ (>=), (>) :: a -> a -> Bool
+ max, min :: a -> a -> a
+
+-- An instance of Ord should define either compare or <=
+-- Using compare can be more efficient for complex types.
+ compare x y
+ | x == y = EQ
+ | x <= y = LT
+ | otherwise = GT
+
+ x <= y = compare x y /= GT
+ x < y = compare x y == LT
+ x >= y = compare x y /= LT
+ x > y = compare x y == GT
+
+-- note that (min x y, max x y) = (x,y) or (y,x)
+ max x y
+ | x >= y = x
+ | otherwise = y
+ min x y
+ | x < y = x
+ | otherwise = y
+
+-- Enumeration and Bounded classes
+
+class Enum a where
+ toEnum :: Int -> a
+ fromEnum :: a -> Int
+ enumFrom :: a -> [a] -- [n..]
+ enumFromThen :: a -> a -> [a] -- [n,n'..]
+ enumFromTo :: a -> a -> [a] -- [n..m]
+ enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
+
+ enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]
+ enumFromThenTo x y z =
+ map toEnum [fromEnum x, fromEnum y .. fromEnum z]
+
+succ, pred :: Enum a => a -> a
+succ = toEnum . (+1) . fromEnum
+pred = toEnum . (subtract 1) . fromEnum
+
+class Bounded a where
+ minBound :: a
+ maxBound :: a
+
+-- Numeric classes
+
+#if EVAL_INSTANCES
+class (Eq a, Show a, Eval a) => Num a where
+#else
+class (Eq a, Show a) => Num a where
+#endif
+ (+), (-), (*) :: a -> a -> a
+ negate :: a -> a
+ abs, signum :: a -> a
+ fromInteger :: BIGNUMTYPE -> a
+#if STD_PRELUDE
+#else
+ fromInt :: Int -> a
+ fromInt = fromInteger . primToBignum(Int)
+#endif
+
+ x - y = x + negate y
+
+class (Num a, Ord a) => Real a where
+ toRational :: a -> Rational
+#if STD_PRELUDE
+#else
+ toDouble :: a -> Double
+ toDouble = rationalToRealFloat . toRational
+#endif
+
+class (Real a, Enum a) => Integral a where
+ quot, rem :: a -> a -> a
+ div, mod :: a -> a -> a
+ quotRem, divMod :: a -> a -> (a,a)
+ toInteger :: a -> BIGNUMTYPE
+#if STD_PRELUDE
+#else
+ toInt :: a -> Int
+ toInt = fromInteger . toInteger
+#endif
+
+ n `quot` d = q where (q,r) = quotRem n d
+ n `rem` d = r where (q,r) = quotRem n d
+ n `div` d = q where (q,r) = divMod n d
+ n `mod` d = r where (q,r) = divMod n d
+ divMod n d = if signum r == - signum d then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
+
+class (Num a) => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+#if STD_PRELUDE
+#else
+ fromDouble :: Double -> a
+ fromDouble = fromRational . realFloatToRational
+#endif
+
+ recip x = 1 / x
+
+class (Fractional a) => Floating a where
+ pi :: a
+ exp, log, sqrt :: a -> a
+ (**), logBase :: a -> a -> a
+ sin, cos, tan :: a -> a
+ asin, acos, atan :: a -> a
+ sinh, cosh, tanh :: a -> a
+ asinh, acosh, atanh :: a -> a
+
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** 0.5
+ tan x = sin x / cos x
+ tanh x = sinh x / cosh x
+
+class (Real a, Fractional a) => RealFrac a where
+ properFraction :: (Integral b) => a -> (b,a)
+ truncate, round :: (Integral b) => a -> b
+ ceiling, floor :: (Integral b) => a -> b
+
+ truncate x = m where (m,_) = properFraction x
+
+ round x = let (n,r) = properFraction x
+ m = if r < 0 then n - 1 else n + 1
+ in case signum (abs r - 0.5) of
+ -1 -> n
+ 0 -> if even n then n else m
+ 1 -> m
+
+ ceiling x = if r > 0 then n + 1 else n
+ where (n,r) = properFraction x
+
+ floor x = if r < 0 then n - 1 else n
+ where (n,r) = properFraction x
+
+class (RealFrac a, Floating a) => RealFloat a where
+ floatRadix :: a -> BIGNUMTYPE
+ floatDigits :: a -> Int
+ floatRange :: a -> (Int,Int)
+ decodeFloat :: a -> (BIGNUMTYPE,Int)
+ encodeFloat :: BIGNUMTYPE -> Int -> a
+ exponent :: a -> Int
+ significand :: a -> a
+ scaleFloat :: Int -> a -> a
+ isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+ :: a -> Bool
+
+ exponent x = if m == 0 then 0 else n + floatDigits x
+ where (m,n) = decodeFloat x
+
+ significand x = encodeFloat m (- floatDigits x)
+ where (m,_) = decodeFloat x
+
+ scaleFloat k x = encodeFloat m (n+k)
+ where (m,n) = decodeFloat x
+
+-- Numeric functions
+
+subtract :: (Num a) => a -> a -> a
+subtract = flip (-)
+
+even, odd :: (Integral a) => a -> Bool
+even n = n `rem` 2 == 0
+odd = not . even
+
+gcd :: (Integral a) => a -> a -> a
+gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' x 0 = x
+ gcd' x y = gcd' y (x `rem` y)
+
+lcm :: (Integral a) => a -> a -> a
+lcm _ 0 = 0
+lcm 0 _ = 0
+lcm x y = abs ((x `quot` (gcd x y)) * y)
+
+(^) :: (Num a, Integral b) => a -> b -> a
+x ^ 0 = 1
+x ^ n | n > 0 = f x (n-1) x
+ where f _ 0 y = y
+ f x n y = g x n where
+ g x n | even n = g (x*x) (n `quot` 2)
+ | otherwise = f x (n-1) (x*y)
+_ ^ _ = error "Prelude.^: negative exponent"
+
+(^^) :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n = if n >= 0 then x^n else recip (x^(-n))
+
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+fromRealFrac :: (RealFrac a, Fractional b) => a -> b
+fromRealFrac = fromRational . toRational
+
+atan2 :: (RealFloat a) => a -> a -> a
+atan2 y x = case (signum y, signum x) of
+ ( 0, 1) -> 0
+ ( 1, 0) -> pi/2
+ ( 0,-1) -> pi
+ (-1, 0) -> -pi/2
+ ( _, 1) -> atan (y/x)
+ ( _,-1) -> atan (y/x) + pi
+ ( 0, 0) -> error "Prelude.atan2: atan2 of origin"
+
+
+-- Monadic classes
+
+class Functor f where
+ map :: (a -> b) -> f a -> f b
+
+class Monad m where
+ (>>=) :: m a -> (a -> m b) -> m b
+ (>>) :: m a -> m b -> m b
+ return :: a -> m a
+
+ m >> k = m >>= \_ -> k
+
+class (Monad m) => MonadZero m where
+ zero :: m a
+
+class (MonadZero m) => MonadPlus m where
+ (++) :: m a -> m a -> m a
+
+accumulate :: Monad m => [m a] -> m [a]
+accumulate = foldr mcons (return [])
+ where mcons p q = p >>= \x -> q >>= \y -> return (x:y)
+
+sequence :: Monad m => [m a] -> m ()
+sequence = foldr (>>) (return ())
+
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+mapM f as = accumulate (map f as)
+
+mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f as = sequence (map f as)
+
+guard :: MonadZero m => Bool -> m ()
+guard p = if p then return () else zero
+
+-- This subsumes the list-based filter function.
+
+filter :: MonadZero m => (a -> Bool) -> m a -> m a
+filter p = applyM (\x -> if p x then return x else zero)
+
+-- This subsumes the list-based concat function.
+
+concat :: MonadPlus m => [m a] -> m a
+concat = foldr (++) zero
+
+applyM :: Monad m => (a -> m b) -> m a -> m b
+applyM f x = x >>= f
+
+#if EVAL_INSTANCES
+-- Eval Class
+
+class Eval a where
+ seq :: a -> b -> b
+ strict :: (a -> b) -> a -> b
+
+ seq x y = case primForce x of () -> y
+ strict f x = case primForce x of () -> f x
+
+#else
+
+seq :: a -> b -> b
+strict :: (a -> b) -> a -> b
+
+seq x y = case primForce x of () -> y
+strict f x = case primForce x of () -> f x
+
+#endif
+
+-- Trivial type
+
+#if STD_PRELUDE
+data () = () deriving (Eq, Ord, Enum, Bounded)
+#else
+data () => () = () deriving (Eq, Ord, Enum, Bounded)
+#endif
+
+-- Function type
+
+#if STD_PRELUDE
+data a -> b -- No constructor for functions is exported.
+#endif
+
+-- identity function
+id :: a -> a
+id x = x
+
+-- constant function
+const :: a -> b -> a
+const x _ = x
+
+-- function composition
+(.) :: (b -> c) -> (a -> b) -> a -> c
+f . g = \ x -> f (g x)
+
+-- flip f takes its (first) two arguments in the reverse order of f.
+flip :: (a -> b -> c) -> b -> a -> c
+flip f x y = f y x
+
+-- right-associating infix application operator (useful in continuation-
+-- passing style)
+($) :: (a -> b) -> a -> b
+f $ x = f x
+
+#if STD_PRELUDE
+#else
+-- Empty type
+
+data Void -- No constructor for Void is exported. Import/Export
+ -- lists must use Void instead of Void(..) or Void()
+#endif
+
+-- Boolean type
+
+data Bool = False | True deriving (Eq, Ord, Enum, Read, Show, Bounded)
+
+-- Boolean functions
+
+(&&), (||) :: Bool -> Bool -> Bool
+True && x = x
+False && _ = False
+True || _ = True
+False || x = x
+
+not :: Bool -> Bool
+not True = False
+not False = True
+
+otherwise :: Bool
+otherwise = True
+
+
+-- Character type
+
+#if STD_PRELUDE
+data Char = ... 'a' | 'b' ... -- 2^16 unicode values
+#else
+data Char
+#endif
+
+instance Eq Char where
+ c == c' = fromEnum c == fromEnum c'
+#if STD_PRELUDE
+#else
+--#warning "Could use primEqChar and primNeChar"
+#endif
+
+instance Ord Char where
+ c <= c' = fromEnum c <= fromEnum c'
+#if STD_PRELUDE
+#else
+--#warning "Could use primLeChar and friends"
+#endif
+
+instance Enum Char where
+ toEnum = primIntToChar
+ fromEnum = primCharToInt
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
+ enumFromThen c c' = map toEnum [fromEnum c,
+ fromEnum c' .. fromEnum lastChar]
+ where lastChar :: Char
+ lastChar | c' < c = minBound
+ | otherwise = maxBound
+
+instance Bounded Char where
+ minBound = '\0'
+#if STD_PRELUDE
+ maxBound = '\xffff'
+#else
+--#warning "literal char constants too small"
+ maxBound = '\xff'
+#endif
+
+type String = [Char]
+
+
+-- Maybe type
+
+data Maybe a = Nothing | Just a deriving (Eq, Ord, Read, Show)
+
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f Nothing = n
+maybe n f (Just x) = f x
+
+instance Functor Maybe where
+ map f Nothing = Nothing
+ map f (Just x) = Just (f x)
+
+instance Monad Maybe where
+ (Just x) >>= k = k x
+ Nothing >>= k = Nothing
+ return = Just
+
+instance MonadZero Maybe where
+ zero = Nothing
+
+instance MonadPlus Maybe where
+ Nothing ++ ys = ys
+ xs ++ ys = xs
+
+-- Either type
+
+data Either a b = Left a | Right b deriving (Eq, Ord, Read, Show)
+
+either :: (a -> c) -> (b -> c) -> Either a b -> c
+either f g (Left x) = f x
+either f g (Right y) = g y
+
+-- IO type
+
+#if STD_PRELUDE
+data IO a -- abstract
+
+instance Functor IO where
+ map f x = x >>= (return . f)
+
+instance Monad IO where ...
+#else
+newtype ST s a = ST (s -> (a,s))
+
+runST :: (forall s. ST s a) -> a
+runST m = fst (unST m theWorld)
+ where
+ theWorld :: RealWorld
+ theWorld = error "runST: entered the world"
+
+unST (ST a) = a
+
+instance Functor (ST s) where
+ map f x = x >>= (return . f)
+
+instance Monad (ST s) where
+ m >> k = m >>= \ _ -> k
+ return x = ST $ \ s -> (x,s)
+ m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
+
+fixST :: (a -> ST s a) -> ST s a
+fixST k = ST $ \ s ->
+ let
+ result = unST (k (fst result)) s
+ in
+ result
+
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
+
+fixIO :: (a -> IO a) -> IO a
+fixIO = fixST
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO m = fst (unST m realWorld)
+ where
+ realWorld :: RealWorld
+ realWorld = error "panic: Hugs shouldnae enter the real world"
+
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO = unsafeInterleaveST
+
+-- This is one of the main uses of unsafeInterleaveIO
+mkLazyList :: IO (Maybe a) -> IO [a]
+mkLazyList m = unsafeInterleaveIO $ do
+ mx <- m
+ case mx of
+ Nothing -> return []
+ Just x -> do
+ xs <- mkLazyList m
+ return (x:xs)
+
+-- used in desugaring Foreign functions
+primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+primMkIO = ST
+
+-- used when Hugs invokes top level function
+primRunIO :: IO () -> ()
+primRunIO m = fst (unST (protect 5 m) realWorld)
+ where
+ realWorld :: RealWorld
+ realWorld = error "panic: Hugs shouldnae enter the real world"
+
+ -- make sure there's always an error handler on the stack
+ protect :: Int -> IO () -> IO ()
+ protect 0 m = putStr "\nProgram error: too many nested errors\n"
+ protect (n+1) m = m `catchException` \ e -> protect n (putStr "\nProgram error: " >> print e)
+
+data RealWorld -- no constructors
+type IO a = ST RealWorld a
+#endif
+
+-- Ordering type
+
+data Ordering = LT | EQ | GT
+ deriving (Eq, Ord, Enum, Read, Show, Bounded)
+
+
+-- Standard numeric types. The data declarations for these types cannot
+-- be expressed directly in Haskell since the constructor lists would be
+-- far too large.
+
+#if STD_PRELUDE
+data Int = minBound ... -1 | 0 | 1 ... maxBound
+instance Eq Int where ...
+instance Ord Int where ...
+instance Num Int where ...
+instance Real Int where ...
+instance Integral Int where ...
+instance Enum Int where ...
+instance Bounded Int where ...
+#else
+data Int
+
+instance Eq Int where
+ (==) = primEqInt
+ (/=) = primNeInt
+
+instance Ord Int where
+ (<) = primLtInt
+ (<=) = primLeInt
+ (>=) = primGeInt
+ (>) = primGtInt
+
+instance Num Int where
+ (+) = primPlusInt
+ (-) = primMinusInt
+ negate = primNegateInt
+ (*) = primTimesInt
+ abs = absReal
+ signum = signumReal
+ fromInteger = primFromBignum(Int)
+ fromInt = id
+
+instance Real Int where
+ toRational x = toInteger x % 1
+
+instance Integral Int where
+ quotRem = primQuotRemInt
+ toInteger = primToBignum(Int)
+ toInt x = x
+
+instance Enum Int where
+ toEnum = id
+ fromEnum = id
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo = numericEnumFromTo
+ enumFromThenTo= numericEnumFromThenTo
+
+instance Bounded Int where
+ minBound = primMinInt
+ maxBound = primMaxInt
+#endif
+
+#ifdef PROVIDE_WORD
+data Word
+
+instance Eq Word where
+ (==) = primEqWord
+ (/=) = primNeWord
+
+instance Ord Word where
+ (<) = primLtWord
+ (<=) = primLeWord
+ (>=) = primGeWord
+ (>) = primGtWord
+
+--and = primAndWord
+--or = primOrWord
+--not = primNotWord
+--shiftL = primShiftL
+--shiftRA = primShiftRA
+--shiftRL = primShiftRL
+--toInt = primWord2Int
+--fromInt = primInt2Word
+#endif
+
+#ifdef PROVIDE_ADDR
+data Addr
+
+nullAddr = primIntToAddr 0
+
+instance Eq Addr where
+ (==) = primEqAddr
+ (/=) = primNeAddr
+
+instance Ord Addr where
+ (<) = primLtAddr
+ (<=) = primLeAddr
+ (>=) = primGeAddr
+ (>) = primGtAddr
+
+--toInt = addr2Int
+--fromInt = int2Addr
+#endif
+
+#if STD_PRELUDE
+data Integer = ... -1 | 0 | 1 ...
+instance Eq Integer where ...
+instance Ord Integer where ...
+instance Num Integer where ...
+instance Real Integer where ...
+instance Integral Integer where ...
+instance Enum Integer where ...
+#else
+#ifdef PROVIDE_INTEGER
+data Integer
+
+instance Eq Integer where
+ (==) x y = primCompareInteger x y == 0
+
+instance Ord Integer where
+ compare x y = case primCompareInteger x y of
+ -1 -> LT
+ 0 -> EQ
+ 1 -> GT
+
+instance Num Integer where
+ (+) = primPlusInteger
+ (-) = primMinusInteger
+ negate = primNegateInteger
+ (*) = primTimesInteger
+ abs = absReal
+ signum = signumReal
+ fromInteger = primFromBignum(Integer)
+ fromInt = primIntToInteger
+
+instance Real Integer where
+ toRational x = toInteger x % 1
+
+instance Integral Integer where
+ quotRem = primQuotRemInteger
+ divMod = primDivModInteger
+ toInteger = primToBignum(Integer)
+ toInt = primIntegerToInt
+
+instance Enum Integer where
+ toEnum = primIntToInteger
+ fromEnum = primIntegerToInt
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo = numericEnumFromTo
+ enumFromThenTo= numericEnumFromThenTo
+#endif /* PROVIDE_INTEGER */
+#endif
+
+#ifdef PROVIDE_INT64
+data Int64
+
+instance Eq Int64 where
+ (==) = primEqInt64
+ (/=) = primNeInt64
+
+instance Ord Int64 where
+ (<) = primLtInt64
+ (<=) = primLeInt64
+ (>=) = primGeInt64
+ (>) = primGtInt64
+ compare x y
+ | x `primLtInt64` y = LT
+ | x `primEqInt64` y = EQ
+ | otherwise = GT
+
+instance Num Int64 where
+ (+) = primPlusInt64
+ (-) = primMinusInt64
+ negate = primNegateInt64
+ (*) = primTimesInt64
+ abs = absReal
+ signum = signumReal
+ fromInteger = primFromBignum(Int64)
+ fromInt = primIntToInt64
+
+instance Real Int64 where
+ toRational x = toInteger x % 1
+
+instance Integral Int64 where
+ quotRem = primQuotRemInt64
+ toInteger = primToBignum(Int64)
+ toInt = primInt64ToInt
+
+instance Enum Int64 where
+ toEnum = primIntToInt64
+ fromEnum = primInt64ToInt
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo = numericEnumFromTo
+ enumFromThenTo= numericEnumFromThenTo
+#endif /* PROVIDE_INT64 */
+
+#if STD_PRELUDE
+#else
+absReal x | x >= 0 = x
+ | otherwise = -x
+
+signumReal x | x == 0 = 0
+ | x > 0 = 1
+ | otherwise = -1
+#endif
+
+#if STD_PRELUDE
+data Float
+instance Eq Float where ...
+instance Ord Float where ...
+instance Num Float where ...
+instance Real Float where ...
+instance Fractional Float where ...
+instance Floating Float where ...
+instance RealFrac Float where ...
+instance RealFloat Float where ...
+#else
+data Float
+
+instance Eq Float where
+ (==) = primEqFloat
+ (/=) = primNeFloat
+
+instance Ord Float where
+ (<) = primLtFloat
+ (<=) = primLeFloat
+ (>=) = primGeFloat
+ (>) = primGtFloat
+
+instance Num Float where
+ (+) = primPlusFloat
+ (-) = primMinusFloat
+ negate = primNegateFloat
+ (*) = primTimesFloat
+ abs = absReal
+ signum = signumReal
+ fromInteger = primFromBignum(Float)
+ fromInt = primIntToFloat
+
+instance Bounded Float where
+ minBound = primMinFloat
+ maxBound = primMaxFloat
+
+instance Real Float where
+ toRational = realFloatToRational
+
+instance Fractional Float where
+ (/) = primDivideFloat
+ fromRational = rationalToRealFloat
+ fromDouble = primDoubleToFloat
+
+instance Floating Float where
+ pi = 3.14159265358979323846
+ exp = primExpFloat
+ log = primLogFloat
+ sqrt = primSqrtFloat
+ sin = primSinFloat
+ cos = primCosFloat
+ tan = primTanFloat
+ asin = primAsinFloat
+ acos = primAcosFloat
+ atan = primAtanFloat
+
+instance RealFrac Float where
+ properFraction = floatProperFraction
+
+instance RealFloat Float where
+ floatRadix _ = toInteger primRadixFloat
+ floatDigits _ = primDigitsFloat
+ floatRange _ = (primMinExpFloat,primMaxExpFloat)
+ encodeFloat = primEncodeFloat
+ decodeFloat = primDecodeFloat
+ isNaN = primIsNaNFloat
+ isInfinite = primIsInfiniteFloat
+ isDenormalized= primIsDenormalizedFloat
+ isNegativeZero= primIsNegativeZeroFloat
+ isIEEE = const primIsIEEEFloat
+#endif
+
+#if STD_PRELUDE
+data Double
+instance Eq Double where ...
+instance Ord Double where ...
+instance Num Double where ...
+instance Real Double where ...
+instance Fractional Double where ...
+instance Floating Double where ...
+instance RealFrac Double where ...
+instance RealFloat Double where ...
+#else
+data Double
+
+instance Eq Double where
+ (==) = primEqDouble
+ (/=) = primNeDouble
+
+instance Ord Double where
+ (<) = primLtDouble
+ (<=) = primLeDouble
+ (>=) = primGeDouble
+ (>) = primGtDouble
+
+instance Num Double where
+ (+) = primPlusDouble
+ (-) = primMinusDouble
+ negate = primNegateDouble
+ (*) = primTimesDouble
+ abs = absReal
+ signum = signumReal
+ fromInteger = primFromBignum(Double)
+ fromInt = primIntToDouble
+
+instance Bounded Double where
+ minBound = primMinDouble
+ maxBound = primMaxDouble
+
+instance Real Double where
+ toRational = realFloatToRational
+
+realFloatToRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Double where
+ (/) = primDivideDouble
+ fromRational = rationalToRealFloat
+ fromDouble x = x
+
+rationalToRealFloat x = x'
+ where x' = f e
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1%b)^^e)) e
+ (_,e') = decodeFloat y
+ (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
+ b = floatRadix x'
+
+instance Floating Double where
+ pi = 3.14159265358979323846
+ exp = primExpDouble
+ log = primLogDouble
+ sqrt = primSqrtDouble
+ sin = primSinDouble
+ cos = primCosDouble
+ tan = primTanDouble
+ asin = primAsinDouble
+ acos = primAcosDouble
+ atan = primAtanDouble
+
+instance RealFrac Double where
+ properFraction = floatProperFraction
+
+floatProperFraction x
+ | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
+ | otherwise = (fromInteger w, encodeFloat r n)
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+ (w,r) = quotRem m (b^(-n))
+
+instance RealFloat Double where
+ floatRadix _ = toInteger primRadixDouble
+ floatDigits _ = primDigitsDouble
+ floatRange _ = (primMinExpDouble,primMaxExpDouble)
+ encodeFloat = primEncodeDouble
+ decodeFloat = primDecodeDouble
+ isNaN = primIsNaNDouble
+ isInfinite = primIsInfiniteDouble
+ isDenormalized= primIsDenormalizedDouble
+ isNegativeZero= primIsNegativeZeroDouble
+ isIEEE = const primIsIEEEDouble
+#endif
+
+-- The Enum instances for Floats and Doubles are slightly unusual.
+-- The `toEnum' function truncates numbers to Int. The definitions
+-- of enumFrom and enumFromThen allow floats to be used in arithmetic
+-- series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat
+-- dubious. This example may have either 10 or 11 elements, depending on
+-- how 0.1 is represented.
+
+instance Enum Float where
+ toEnum = fromIntegral
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo = numericEnumFromTo
+ enumFromThenTo = numericEnumFromThenTo
+
+instance Enum Double where
+ toEnum = fromIntegral
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo = numericEnumFromTo
+ enumFromThenTo = numericEnumFromThenTo
+
+numericEnumFrom :: (Real a) => a -> [a]
+numericEnumFromThen :: (Real a) => a -> a -> [a]
+numericEnumFromTo :: (Real a) => a -> a -> [a]
+numericEnumFromThenTo :: (Real a) => a -> a -> a -> [a]
+numericEnumFrom = iterate (+1)
+numericEnumFromThen n m = iterate (+(m-n)) n
+numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
+numericEnumFromThenTo n n' m
+ = takeWhile (if n' >= n then (<= m) else (>= m))
+ (numericEnumFromThen n n')
+
+
+-- Lists
+
+#if STD_PRELUDE
+data [a] = [] | a : [a] deriving (Eq, Ord)
+#else
+data () => [a] = [] | a : [a] deriving (Eq, Ord)
+#endif
+
+instance Functor [] where
+ map f [] = []
+ map f (x:xs) = f x : map f xs
+
+instance Monad [] where
+ m >>= k = concat (map k m)
+ return x = [x]
+
+instance MonadZero [] where
+ zero = []
+
+instance MonadPlus [] where
+ xs ++ ys = foldr (:) ys xs
+
+-- Tuples
+
+#if STD_PRELUDE
+data (a,b) = (a,b) deriving (Eq, Ord, Bounded)
+data (a,b,c) = (a,b,c) deriving (Eq, Ord, Bounded)
+#endif
+
+
+-- component projections for pairs:
+-- (NB: not provided for triples, quadruples, etc.)
+fst :: (a,b) -> a
+fst (x,y) = x
+
+snd :: (a,b) -> b
+snd (x,y) = y
+
+-- curry converts an uncurried function to a curried function;
+-- uncurry converts a curried function to a function on pairs.
+curry :: ((a, b) -> c) -> a -> b -> c
+curry f x y = f (x, y)
+
+uncurry :: (a -> b -> c) -> ((a, b) -> c)
+uncurry f p = f (fst p) (snd p)
+
+-- Misc functions
+
+-- until p f yields the result of applying f until p holds.
+until :: (a -> Bool) -> (a -> a) -> a -> a
+until p f x
+ | p x = x
+ | otherwise = until p f (f x)
+
+-- asTypeOf is a type-restricted version of const. It is usually used
+-- as an infix operator, and its typing forces its first argument
+-- (which is usually overloaded) to have the same type as the second.
+asTypeOf :: a -> a -> a
+asTypeOf = const
+
+-- error stops execution and displays an error message
+
+#if STD_PRELUDE
+error :: String -> a
+error = primError
+#else
+error :: String -> a
+error msg = primRaise (IOException (userError msg))
+#endif
+
+-- It is expected that compilers will recognize this and insert error
+-- messages that are more appropriate to the context in which undefined
+-- appears.
+
+undefined :: a
+undefined = error "Prelude.undefined"
+
+#if STD_PRELUDE
+#else
+--Missing primOps and magic funs
+
+-- Used for pattern match failure.
+-- ToDo: make the message more informative.
+primPmFail :: a
+primPmFail = error "Pattern Match Failure"
+
+-- used in derived compare functions, must be exported from Prelude
+primCompAux :: Ord a => a -> a -> Ordering -> Ordering
+primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
+
+-- used in derived show functions, must be exported from Prelude
+primShowField :: Show a => String -> a -> ShowS
+primShowField m v = showString m . showChar '=' . shows v
+
+-- used in derived read functions, must be exported from Prelude
+primReadField :: Read a => String -> ReadS a
+primReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
+ ("=",s2) <- lex s1,
+ r <- readsPrec 10 s2 ]
+
+-- These 4 primitives are used in pattern matching.
+primPmInt :: Num a => Int -> a -> Bool
+primPmInt x y = fromInt x == y
+
+primPmInteger :: Num a => BIGNUMTYPE -> a -> Bool
+primPmInteger x y = fromInteger x == y
+
+primPmDouble :: Fractional a => Double -> a -> Bool
+primPmDouble x y = fromDouble x == y
+
+-- The following primitives are only needed if (n+k) patterns are enabled
+-- The first two look trivial but they're selecting a method from a
+-- superclass of their argument...
+primPmLe :: Integral a => a -> a -> Bool
+primPmLe x y = x <= y
+
+primPmSubtract :: Integral a => a -> a -> a
+primPmSubtract x y = x - y
+
+primPmFromInteger :: Integral a => BIGNUMTYPE -> a
+primPmFromInteger = fromInteger
+
+primPmSub :: Integral a => Int -> a -> a
+primPmSub n x = x - fromInt n
+
+#ifdef PROVIDE_STABLE
+data StablePtr a
+#endif
+#ifdef PROVIDE_FOREIGN
+data ForeignObj
+
+makeForeignObj :: Addr -> IO ForeignObj
+makeForeignObj = primMakeForeignObj
+
+#endif
+#ifdef PROVIDE_WEAK
+data Weak a
+
+mkWeak :: k -- key
+ -> v -- value
+ -> IO () -- finaliser
+ -> IO (Weak v) -- weak pointer
+
+mkWeak k v f = primMakeWeak k v (unsafePerformIO f)
+
+deRefWeak :: Weak v -> IO (Maybe v)
+deRefWeak w = do
+ { (stillThere,v) <- primDeRefWeak w
+ -- Warning: you'd better ignore v unless stillThere is 1
+ ; return (if stillThere == 0 then Nothing else Just v)
+ }
+
+mkWeakPtr :: k -> IO () -> IO (Weak k)
+mkWeakPtr key finaliser = mkWeak key key finaliser
+
+mkWeakPair :: k -> v -> IO () -> IO (Weak (k,v))
+mkWeakPair key val finaliser = mkWeak key (key,val) finaliser
+
+addFinaliser :: key -> IO () -> IO ()
+addFinaliser key finaliser = do
+ mkWeakPtr key finaliser -- throw it away
+ return ()
+
+addForeignFinaliser :: ForeignObj -> IO () -> IO ()
+addForeignFinaliser fo finaliser = addFinaliser fo finaliser
+
+{-
+finalise :: Weak v -> IO ()
+finalise (Weak w) = finaliseWeak# w
+
+instance Eq (Weak v) where
+ (Weak w1) == (Weak w2) = w1 `sameWeak#` w2
+-}
+
+#endif
+
+#endif
+#endif /* BODY */
--- /dev/null
+#ifdef HEAD
+module PreludeIO (
+ FilePath, IOError, fail, userError, catch,
+ putChar, putStr, putStrLn, print,
+ getChar, getLine, getContents, interact,
+ readFile, writeFile, appendFile, readIO, readLn
+ ) where
+
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+#if STD_PRELUDE
+type FilePath = String
+
+data IOError -- The internals of this type are system dependent
+
+instance Show IOError where ...
+instance Eq IOError where ...
+#endif
+
+#if STD_PRELUDE
+fail :: IOError -> IO a
+fail = primFail
+
+userError :: String -> IOError
+userError = primUserError
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch = primCatch
+#else
+#endif
+
+#if STD_PRELUDE
+#else
+-- this guy can go in either monad
+primFail :: Exception -> ST s a
+primFail err = ST (\ s -> primRaise err)
+#endif
+
+#if STD_PRELUDE
+putChar :: Char -> IO ()
+putChar = primPutChar
+
+putStr :: String -> IO ()
+putStr s = mapM_ putChar s
+
+putStrLn :: String -> IO ()
+putStrLn s = do putStr s
+ putStr "\n"
+
+print :: Show a => a -> IO ()
+print x = putStrLn (show x)
+
+getChar :: IO Char
+getContents = primGetChar
+
+getLine :: IO String
+getLine = do c <- getChar
+ if c == '\n' then return "" else
+ do s <- getLine
+ return (c:s)
+
+getContents :: IO String
+getContents = primGetContents
+
+interact :: (String -> String) -> IO ()
+interact f = do s <- getContents
+ putStr (f s)
+
+readFile :: FilePath -> IO String
+readFile = primReadFile
+
+writeFile :: FilePath -> String -> IO ()
+writeFile = primWriteFile
+
+appendFile :: FilePath -> String -> IO ()
+appendFile = primAppendFile
+#endif
+
+ -- raises an exception instead of an error
+readIO :: Read a => String -> IO a
+readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> return x
+ [] -> fail (userError "PreludeIO.readIO: no parse")
+ _ -> fail (userError
+ "PreludeIO.readIO: ambiguous parse")
+
+#if STD_PRELUDE
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+#endif
+
+#endif /* BODY */
--- /dev/null
+-- Standard list functions
+
+#ifdef HEAD
+module PreludeList (
+ head, last, tail, init, null, length, (!!),
+ foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+ iterate, repeat, replicate, cycle,
+ take, drop, splitAt, takeWhile, dropWhile, span, break,
+ lines, words, unlines, unwords, reverse, and, or,
+ any, all, elem, notElem, lookup,
+ sum, product, maximum, minimum, concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3)
+ where
+
+import qualified Char(isSpace)
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+infixl 9 !!
+infix 4 `elem`, `notElem`
+
+-- head and tail extract the first element and remaining elements,
+-- respectively, of a list, which must be non-empty. last and init
+-- are the dual functions working from the end of a finite list,
+-- rather than the beginning.
+
+head :: [a] -> a
+head (x:_) = x
+head [] = error "PreludeList.head: empty list"
+
+last :: [a] -> a
+last [x] = x
+last (_:xs) = last xs
+last [] = error "PreludeList.last: empty list"
+
+tail :: [a] -> [a]
+tail (_:xs) = xs
+tail [] = error "PreludeList.tail: empty list"
+
+init :: [a] -> [a]
+init [x] = []
+init (x:xs) = x : init xs
+init [] = error "PreludeList.init: empty list"
+
+null :: [a] -> Bool
+null [] = True
+null (_:_) = False
+
+-- length returns the length of a finite list as an Int.
+length :: [a] -> Int
+length [] = 0
+length (_:l) = 1 + length l
+
+-- List index (subscript) operator, 0-origin
+(!!) :: [a] -> Int -> a
+(x:_) !! 0 = x
+(_:xs) !! n | n > 0 = xs !! (n-1)
+(_:_) !! _ = error "PreludeList.!!: negative index"
+[] !! _ = error "PreludeList.!!: index too large"
+
+-- foldl, applied to a binary operator, a starting value (typically the
+-- left-identity of the operator), and a list, reduces the list using
+-- the binary operator, from left to right:
+-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
+-- foldl1 is a variant that has no starting value argument, and thus must
+-- be applied to non-empty lists. scanl is similar to foldl, but returns
+-- a list of successive reduced values from the left:
+-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
+-- Note that last (scanl f z xs) == foldl f z xs.
+-- scanl1 is similar, again without the starting element:
+-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+
+foldl :: (a -> b -> a) -> a -> [b] -> a
+foldl f z [] = z
+foldl f z (x:xs) = foldl f (f z x) xs
+
+foldl1 :: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs) = foldl f x xs
+foldl1 _ [] = error "PreludeList.foldl1: empty list"
+
+scanl :: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q xs = q : (case xs of
+ [] -> []
+ x:xs -> scanl f (f q x) xs)
+
+scanl1 :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs) = scanl f x xs
+scanl1 _ [] = error "PreludeList.scanl1: empty list"
+
+-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
+-- above functions.
+
+foldr :: (a -> b -> b) -> b -> [a] -> b
+foldr f z [] = z
+foldr f z (x:xs) = f x (foldr f z xs)
+
+foldr1 :: (a -> a -> a) -> [a] -> a
+foldr1 f [x] = x
+foldr1 f (x:xs) = f x (foldr1 f xs)
+foldr1 _ [] = error "PreludeList.foldr1: empty list"
+
+scanr :: (a -> b -> b) -> b -> [a] -> [b]
+scanr f q0 [] = [q0]
+scanr f q0 (x:xs) = f x q : qs
+ where qs@(q:_) = scanr f q0 xs
+
+scanr1 :: (a -> a -> a) -> [a] -> [a]
+scanr1 f [x] = [x]
+scanr1 f (x:xs) = f x q : qs
+ where qs@(q:_) = scanr1 f xs
+scanr1 _ [] = error "PreludeList.scanr1: empty list"
+
+-- iterate f x returns an infinite list of repeated applications of f to x:
+-- iterate f x == [x, f x, f (f x), ...]
+iterate :: (a -> a) -> a -> [a]
+iterate f x = x : iterate f (f x)
+
+-- repeat x is an infinite list, with x the value of every element.
+repeat :: a -> [a]
+repeat x = xs where xs = x:xs
+
+-- replicate n x is a list of length n with x the value of every element
+replicate :: Int -> a -> [a]
+replicate n x = take n (repeat x)
+
+-- cycle ties a finite list into a circular one, or equivalently,
+-- the infinite repetition of the original list. It is the identity
+-- on infinite lists.
+
+cycle :: [a] -> [a]
+#if STD_PRELUDE
+#else
+-- check proposed by Friedhelm Wrensch <fwr@1772228662.hostid.net>
+-- doesn't seem to affect strictness
+cycle [] = error "PreludeList.cycle []"
+#endif
+cycle xs = xs' where xs' = xs ++ xs'
+
+-- take n, applied to a list xs, returns the prefix of xs of length n,
+-- or xs itself if n > length xs. drop n xs returns the suffix of xs
+-- after the first n elements, or [] if n > length xs. splitAt n xs
+-- is equivalent to (take n xs, drop n xs).
+
+take :: Int -> [a] -> [a]
+take 0 _ = []
+take _ [] = []
+take n (x:xs) | n > 0 = x : take (n-1) xs
+take _ _ = error "PreludeList.take: negative argument"
+
+drop :: Int -> [a] -> [a]
+drop 0 xs = xs
+drop _ [] = []
+drop n (_:xs) | n > 0 = drop (n-1) xs
+drop _ _ = error "PreludeList.drop: negative argument"
+
+splitAt :: Int -> [a] -> ([a],[a])
+splitAt 0 xs = ([],xs)
+splitAt _ [] = ([],[])
+splitAt n (x:xs) | n > 0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
+splitAt _ _ = error "PreludeList.splitAt: negative argument"
+
+-- takeWhile, applied to a predicate p and a list xs, returns the longest
+-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs
+-- returns the remaining suffix. Span p xs is equivalent to
+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
+
+takeWhile :: (a -> Bool) -> [a] -> [a]
+takeWhile p [] = []
+takeWhile p (x:xs)
+ | p x = x : takeWhile p xs
+ | otherwise = []
+
+dropWhile :: (a -> Bool) -> [a] -> [a]
+dropWhile p [] = []
+dropWhile p xs@(x:xs')
+ | p x = dropWhile p xs'
+ | otherwise = xs
+
+span, break :: (a -> Bool) -> [a] -> ([a],[a])
+span p [] = ([],[])
+span p xs@(x:xs')
+ | p x = (x:ys,zs)
+ | otherwise = ([],xs)
+ where (ys,zs) = span p xs'
+break p = span (not . p)
+
+-- lines breaks a string up into a list of strings at newline characters.
+-- The resulting strings do not contain newlines. Similary, words
+-- breaks a string up into a list of words, which were delimited by
+-- white space. unlines and unwords are the inverse operations.
+-- unlines joins lines with terminating newlines, and unwords joins
+-- words with separating spaces.
+
+lines :: String -> [String]
+lines "" = []
+lines s = let (l, s') = break (== '\n') s
+ in l : case s' of
+ [] -> []
+ (_:s'') -> lines s''
+
+words :: String -> [String]
+#if STD_PRELUDE
+words s = case dropWhile Char.isSpace s of
+#else
+words s = case dropWhile isSpace s of
+#endif
+ "" -> []
+ s' -> w : words s''
+#if STD_PRELUDE
+ where (w, s'') = break Char.isSpace s'
+#else
+ where (w, s'') = break isSpace s'
+#endif
+
+unlines :: [String] -> String
+unlines = concatMap (++ "\n")
+
+unwords :: [String] -> String
+unwords [] = ""
+unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
+
+-- reverse xs returns the elements of xs in reverse order. xs must be finite.
+reverse :: [a] -> [a]
+reverse = foldl (flip (:)) []
+
+-- and returns the conjunction of a Boolean list. For the result to be
+-- True, the list must be finite; False, however, results from a False
+-- value at a finite index of a finite or infinite list. or is the
+-- disjunctive dual of and.
+and, or :: [Bool] -> Bool
+and = foldr (&&) True
+or = foldr (||) False
+
+-- Applied to a predicate and a list, any determines if any element
+-- of the list satisfies the predicate. Similarly, for all.
+any, all :: (a -> Bool) -> [a] -> Bool
+any p = or . map p
+all p = and . map p
+
+-- elem is the list membership predicate, usually written in infix form,
+-- e.g., x `elem` xs. notElem is the negation.
+elem, notElem :: (Eq a) => a -> [a] -> Bool
+elem x = any (== x)
+notElem x = all (/= x)
+
+-- lookup key assocs looks up a key in an association list.
+lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
+lookup key [] = Nothing
+lookup key ((x,y):xys)
+ | key == x = Just y
+ | otherwise = lookup key xys
+
+-- sum and product compute the sum or product of a finite list of numbers.
+sum, product :: (Num a) => [a] -> a
+sum = foldl (+) 0
+product = foldl (*) 1
+
+-- maximum and minimum return the maximum or minimum value from a list,
+-- which must be non-empty, finite, and of an ordered type.
+maximum, minimum :: (Ord a) => [a] -> a
+maximum [] = error "PreludeList.maximum: empty list"
+maximum xs = foldl1 max xs
+
+minimum [] = error "PreludeList.minimum: empty list"
+minimum xs = foldl1 min xs
+
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = concat . map f
+
+-- zip takes two lists and returns a list of corresponding pairs. If one
+-- input list is short, excess elements of the longer list are discarded.
+-- zip3 takes three lists and returns a list of triples. Zips for larger
+-- tuples are in the List library
+
+zip :: [a] -> [b] -> [(a,b)]
+zip = zipWith (,)
+
+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
+zip3 = zipWith3 (,,)
+
+-- The zipWith family generalises the zip family by zipping with the
+-- function given as the first argument, instead of a tupling function.
+-- For example, zipWith (+) is applied to two lists to produce the list
+-- of corresponding sums.
+
+zipWith :: (a->b->c) -> [a]->[b]->[c]
+zipWith z (a:as) (b:bs)
+ = z a b : zipWith z as bs
+zipWith _ _ _ = []
+
+zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith3 z (a:as) (b:bs) (c:cs)
+ = z a b c : zipWith3 z as bs cs
+zipWith3 _ _ _ _ = []
+
+
+-- unzip transforms a list of pairs into a pair of lists.
+
+unzip :: [(a,b)] -> ([a],[b])
+unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
+
+unzip3 :: [(a,b,c)] -> ([a],[b],[c])
+unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
+ ([],[],[])
+
+
+#endif /* BODY */
\ No newline at end of file
--- /dev/null
+-- Standard list functions
+
+#ifdef HEAD
+module PreludePackString
+ ( primUnpackString -- unpack Hugs-generated string constants
+ , primPackString -- pack String into ByteArray
+ , primUnpackCString -- unpack null-terminated string
+ , unsafeUnpackCString -- unpack null-terminated string
+ )
+ where
+
+import qualified Char(isSpace)
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+-- Unpack strings generated by the Hugs code generator.
+-- Strings can contain \0 provided they're coded right.
+--
+-- ToDo: change this (and Hugs code generator) to use ByteArrays
+primUnpackString :: Addr -> String
+primUnpackString a = unpack 0
+ where
+ -- The following decoding is based on evalString in the old machine.c
+ unpack i
+ | c == '\0' = []
+ | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
+ then '\\' : unpack (i+2)
+ else '\0' : unpack (i+2)
+ | otherwise = c : unpack (i+1)
+ where
+ c = primIndexCharOffAddr a i
+
+primPackString :: [Char] -> PrimByteArray
+primPackString str = runST (do
+ { let len = length str
+ ; arr <- primNewByteArray (len+1)
+ ; sequence (zipWith (primWriteCharArray arr) [0..] str)
+ ; primWriteCharArray arr len '\0'
+ ; primUnsafeFreezeByteArray arr
+ })
+
+-- Note that this version is in the IO monad and copies the whole string
+-- immediately!
+primUnpackCString :: Addr -> IO String
+primUnpackCString a = unpack 0 []
+ where
+ unpack i acc = do
+ { c <- primReadCharOffAddr a i
+ ; if c == '\0'
+ then return (reverse acc)
+ else unpack (i+1) (c:acc)
+ }
+
+primUnpackCStringAcc :: Addr -> Int -> String -> IO String
+primUnpackCStringAcc a n acc = unpack n acc
+ where
+ unpack 0 acc
+ = return acc
+ unpack (n+1) acc
+ = do
+ { c <- primReadCharOffAddr a n
+ ; unpack n (c:acc)
+ }
+
+unsafeUnpackCString :: Addr -> String
+unsafeUnpackCString = unsafePerformIO . primUnpackCString
+
+#endif /* BODY */
--- /dev/null
+#ifdef HEAD
+module PreludeText (
+ ReadS, ShowS,
+ Read(readsPrec, readList),
+ Show(showsPrec, showList),
+ reads, shows, show, read, lex,
+ showChar, showString, readParen, showParen ) where
+
+-- The omitted instances can be implemented in standard Haskell but
+-- they have been omitted for the sake of brevity
+
+#if STD_PRELUDE
+import Char(isSpace, isAlpha, isDigit, isAlphanum, isHexDigit,
+ showLitChar, readLitChar, lexLitChar)
+
+import Numeric(showSigned, showInt, readSigned, readDec, showFloat,
+ readFloat, lexDigits)
+#endif
+
+import PreludeBuiltin
+#endif /* HEAD */
+#ifdef BODY
+
+type ReadS a = String -> [(a,String)]
+type ShowS = String -> String
+
+class Read a where
+ readsPrec :: Int -> ReadS a
+ readList :: ReadS [a]
+
+ readList = readParen False (\r -> [pr | ("[",s) <- lex r,
+ pr <- readl s])
+ where readl s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,u) | (x,t) <- reads s,
+ (xs,u) <- readl' t]
+ readl' s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,v) | (",",t) <- lex s,
+ (x,u) <- reads t,
+ (xs,v) <- readl' u]
+
+class Show a where
+ showsPrec :: Int -> a -> ShowS
+ showList :: [a] -> ShowS
+
+ showList [] = showString "[]"
+ showList (x:xs) = showChar '[' . shows x . showl xs
+ where showl [] = showChar ']'
+ showl (x:xs) = showChar ',' . shows x .
+ showl xs
+
+reads :: (Read a) => ReadS a
+reads = readsPrec 0
+
+shows :: (Show a) => a -> ShowS
+shows = showsPrec 0
+
+read :: (Read a) => String -> a
+read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error "PreludeText.read: no parse"
+ _ -> error "PreludeText.read: ambiguous parse"
+
+show :: (Show a) => a -> String
+show x = shows x ""
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showString :: String -> ShowS
+showString = (++)
+
+showParen :: Bool -> ShowS -> ShowS
+showParen b p = if b then showChar '(' . p . showChar ')' else p
+
+readParen :: Bool -> ReadS a -> ReadS a
+readParen b g = if b then mandatory else optional
+ where optional r = g r ++ mandatory r
+ mandatory r = [(x,u) | ("(",s) <- lex r,
+ (x,t) <- optional s,
+ (")",u) <- lex t ]
+
+-- This lexer is not completely faithful to the Haskell lexical syntax.
+-- Current limitations:
+-- Qualified names are not handled properly
+-- A `--' does not terminate a symbol
+-- Octal and hexidecimal numerics are not recognized as a single token
+
+lex :: ReadS String
+lex "" = [("","")]
+lex (c:s)
+ | isSpace c = lex (dropWhile isSpace s)
+lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
+ ch /= "'" ]
+lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
+ where
+ lexString ('"':s) = [("\"",s)]
+ lexString s = [(ch++str, u)
+ | (ch,t) <- lexStrItem s,
+ (str,u) <- lexString t ]
+
+ lexStrItem ('\\':'&':s) = [("\\&",s)]
+ lexStrItem ('\\':c:s) | isSpace c
+ = [("\\&",t) |
+ '\\':t <-
+ [dropWhile isSpace s]]
+ lexStrItem s = lexLitChar s
+
+lex (c:s) | isSingle c = [([c],s)]
+ | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
+ | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
+ | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
+ (fe,t) <- lexFracExp s ]
+ | otherwise = [] -- bad character
+ where
+ isSingle c = c `elem` ",;()[]{}_`"
+ isSym c = isPrint c && not (isAlphaNum c) &&
+ not (isSingle c) && not (c `elem` "_'")
+ && not (isSpace c)
+ isIdChar c = isAlphaNum c || c `elem` "_'"
+
+ lexFracExp ('.':c:cs) | isDigit c
+ = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),
+ (e,u) <- lexExp t]
+ lexFracExp s = [("",s)]
+
+ lexExp (e:s) | e `elem` "eE"
+ = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
+ (ds,u) <- lexDigits t] ++
+ [(e:ds,t) | (ds,t) <- lexDigits s]
+ lexExp s = [("",s)]
+
+#if 1
+instance Show Int where
+ showsPrec p n
+ | n == minBound = showSigned showInt p (toInteger n)
+ | otherwise = showSigned showInt p n
+#else /* This version only goes slightly faster */
+instance Show Int where
+ showsPrec p n
+ | n == minBound = showSigned showInt p (toInteger n)
+ | otherwise = showSigned primShowInt p n
+
+primShowInt n r = unsafeUnpackCString (primShowInt' n) ++ r
+
+foreign import stdcall "" "prim_showInt" primShowInt' :: Int -> Addr
+#endif
+
+instance Read Int where
+ readsPrec p = readSigned readDec
+
+#ifdef PROVIDE_INTEGER
+instance Show Integer where
+ showsPrec = showSigned showInt
+
+instance Read Integer where
+ readsPrec p = readSigned readDec
+#endif
+
+#ifdef PROVIDE_INT64
+instance Show Int64 where
+ showsPrec = showSigned showInt
+
+instance Read Int64 where
+ readsPrec p = readSigned readDec
+#endif
+
+instance Show Float where
+ showsPrec p = showFloat
+
+instance Read Float where
+ readsPrec p = readSigned readFloat
+
+instance Show Double where
+ showsPrec p = showFloat
+
+instance Read Double where
+ readsPrec p = readSigned readFloat
+
+instance Show () where
+ showsPrec p () = showString "()"
+
+instance Read () where
+ readsPrec p = readParen False
+ (\r -> [((),t) | ("(",s) <- lex r,
+ (")",t) <- lex s ] )
+instance Show Char where
+ showsPrec p '\'' = showString "'\\''"
+ showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
+
+ showList cs = showChar '"' . showl cs
+ where showl "" = showChar '"'
+ showl ('"':cs) = showString "\\\"" . showl cs
+ showl (c:cs) = showLitChar c . showl cs
+
+instance Read Char where
+ readsPrec p = readParen False
+ (\r -> [(c,t) | ('\'':s,t)<- lex r,
+ (c,"\'") <- readLitChar s])
+
+ readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
+ (l,_) <- readl s ])
+ where readl ('"':s) = [("",s)]
+ readl ('\\':'&':s) = readl s
+ readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
+ (cs,u) <- readl t ]
+
+instance (Show a) => Show [a] where
+ showsPrec p = showList
+
+instance (Read a) => Read [a] where
+ readsPrec p = readList
+
+-- Tuples
+
+#if STD_PRELUDE
+instance (Show a, Show b) => Show (a,b) where
+ showsPrec p (x,y) = showChar '(' . shows x . showString ", " .
+ shows y . showChar ')'
+
+instance (Read a, Read b) => Read (a,b) where
+ readsPrec p = readParen False
+ (\r -> [((x,y), w) | ("(",s) <- lex r,
+ (x,t) <- reads s,
+ (",",u) <- lex t,
+ (y,v) <- reads u,
+ (")",w) <- lex v ] )
+
+-- Other tuples have similar Read and Show instances
+#endif
+
+-- Functions
+
+instance Show (a->b) where
+ showsPrec p f = showString "<<function>>"
+
+
+instance Show (IO a) where
+ showsPrec p f = showString "<<IO action>>"
+
+#endif /* BODY */
\ No newline at end of file
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Strongly connected components algorithm for static.c.
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: scc.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:34 $
+ * ------------------------------------------------------------------------*/
+
+#ifndef SCC_C
+#define SCC_C
+#define visited(d) (isInt(DEPENDS(d))) /* binding already visited ? */
+
+static Cell daSccs = NIL;
+static Int daCount;
+
+static Int local sccMin Args((Int,Int));
+
+static Int local sccMin(x,y) /* calculate minimum of x,y (unless */
+Int x,y; { /* y is zero) */
+ return (x<=y || y==0) ? x : y;
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * A couple of parts of this program require an algorithm for sorting a list
+ * of values (with some added dependency information) into a list of strongly
+ * connected components in which each value appears before its dependents.
+ *
+ * The algorithm used here is based on those described in:
+ * 1) Robert Tarjan, Depth-first search and Linear Graph Algorithms,
+ * SIAM J COMPUT, vol 1, no 2, June 1972, pp.146-160.
+ * 2) Aho, Hopcroft and Ullman, Design and Analysis of Algorithms,
+ * Addison Wesley, 1972. pp.189-195.
+ * The version used here probably owes most to the latter presentation but
+ * has been modified to simplify the algorithm and improve the use of space.
+ *
+ * This would probably have been a good application for C++ templates ...
+ * ------------------------------------------------------------------------*/
+
+static Int local LOWLINK Args((Cell)); /* local function */
+static Int local LOWLINK(v) /* calculate `lowlink' of v */
+Cell v; {
+ Int low = daCount;
+ Int dfn = daCount; /* depth first search no. of v */
+ List ws = DEPENDS(v); /* adjacency list for v */
+
+ SETDEPENDS(v,mkInt(daCount++)); /* push v onto stack */
+ push(v);
+
+ while (nonNull(ws)) { /* scan adjacency list for v */
+ Cell w = hd(ws);
+ ws = tl(ws);
+ low = sccMin(low, (visited(w) ? intOf(DEPENDS(w)) : LOWLINK(w)));
+ }
+
+ if (low == dfn) { /* start a new scc? */
+ List temp=NIL;
+ do { /* take elements from stack */
+ SETDEPENDS(top(),mkInt(0));
+ temp = cons(top(),temp);
+ } while (pop()!=v);
+ daSccs = cons(temp,daSccs); /* make new strongly connected comp*/
+ }
+
+ return low;
+}
+
+#ifdef SCC
+static List local SCC(bs) /* sort list with added dependency */
+List bs; { /* info into SCCs */
+ clearStack();
+ daSccs = NIL; /* clear current list of SCCs */
+
+ for (daCount=1; nonNull(bs); bs=tl(bs)) /* visit each binding */
+ if (!visited(hd(bs)))
+ LOWLINK(hd(bs));
+
+ return rev(daSccs); /* reverse to obtain correct order */
+}
+#endif
+
+#ifdef SCC2 /* Two argument version */
+static List local SCC2(bs,cs) /* sort lists with added dependency*/
+List bs, cs; { /* info into SCCs */
+ clearStack();
+ daSccs = NIL; /* clear current list of SCCs */
+
+ for (daCount=1; nonNull(bs); bs=tl(bs)) /* visit each binding */
+ if (!visited(hd(bs)))
+ LOWLINK(hd(bs));
+ for (; nonNull(cs); cs=tl(cs))
+ if (!visited(hd(cs)))
+ LOWLINK(hd(cs));
+
+ return rev(daSccs); /* reverse to obtain correct order */
+}
+#endif
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Static Analysis for Hugs
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: static.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:35 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "input.h"
+#include "type.h"
+#include "static.h"
+#include "translate.h"
+#include "hugs.h" /* for target */
+#include "errors.h"
+#include "subst.h"
+#include "link.h"
+#include "modules.h"
+#include "derive.h"
+
+/* --------------------------------------------------------------------------
+ * local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Module thisModule = 0; /* module currently being processed*/
+
+static Void local kindError Args((Int,Constr,Constr,String,Kind,Int));
+
+static Void local checkTyconDefn Args((Tycon));
+static Void local depConstrs Args((Tycon,List,Cell));
+static List local addSels Args((Int,Name,List,List));
+static List local selectCtxt Args((List,List));
+static Void local checkSynonyms Args((List));
+static List local visitSyn Args((List,Tycon,List));
+#if EVAL_INSTANCES
+static Void local deriveEval Args((List));
+static List local calcEvalContexts Args((Tycon,List,List));
+#endif
+static Void local checkBanged Args((Name,Kinds,List,Type));
+static Type local instantiateSyn Args((Type,Type));
+
+static Void local checkClassDefn Args((Class));
+static Void local depPredExp Args((Int,List,Cell));
+static Void local checkMems Args((Class,List,Cell));
+static Void local addMembers Args((Class));
+static Name local newMember Args((Int,Int,Cell,Type));
+static Name local newDSel Args((Class,Int));
+static Name local newDBuild Args((Class));
+static Text local generateText Args((String, Class));
+static Int local visitClass Args((Class));
+
+static List local classBindings Args((String,Class,List));
+static Name local memberName Args((Class,Text));
+static List local numInsert Args((Int,Cell,List));
+
+static List local typeVarsIn Args((Cell,List,List));
+static List local maybeAppendVar Args((Cell,List));
+
+static Type local checkSigType Args((Int,String,Cell,Type));
+static Type local depTopType Args((Int,List,Type));
+static Type local depCompType Args((Int,List,Type));
+static Type local depTypeExp Args((Int,List,Type));
+static Type local depTypeVar Args((Int,List,Text));
+static Void local kindConstr Args((Int,Int,Int,Constr));
+static Kind local kindAtom Args((Int,Constr));
+static Void local kindPred Args((Int,Int,Int,Cell));
+static Void local kindType Args((Int,String,Type));
+static Void local fixKinds Args((Void));
+
+static Void local kindTCGroup Args((List));
+static Void local initTCKind Args((Cell));
+static Void local kindTC Args((Cell));
+static Void local genTC Args((Cell));
+
+static Void local checkInstDefn Args((Inst));
+static Void local insertInst Args((Inst));
+static Bool local instCompare Args((Inst,Inst));
+static Name local newInstImp Args((Inst));
+static Void local kindInst Args((Inst,Int));
+static Void local checkDerive Args((Tycon,List,List,Cell));
+static Void local addDerInst Args((Int,Class,List,List,Type,Int));
+
+static Void local deriveContexts Args((List));
+static Void local initDerInst Args((Inst));
+static Void local calcInstPreds Args((Inst));
+static Void local maybeAddPred Args((Cell,Int,Int,List));
+static Cell local copyAdj Args((Cell,Int,Int));
+static Void local tidyDerInst Args((Inst));
+
+static Void local addDerivImp Args((Inst));
+
+static Void local checkDefaultDefns Args((Void));
+
+static Void local checkForeignImport Args((Name));
+static Void local checkForeignExport Args((Name));
+
+static Cell local checkPat Args((Int,Cell));
+static Cell local checkMaybeCnkPat Args((Int,Cell));
+static Cell local checkApPat Args((Int,Int,Cell));
+static Void local addPatVar Args((Int,Cell));
+static Name local conDefined Args((Int,Cell));
+static Void local checkIsCfun Args((Int,Name));
+static Void local checkCfunArgs Args((Int,Cell,Int));
+static Cell local applyBtyvs Args((Cell));
+static Cell local bindPat Args((Int,Cell));
+static Void local bindPats Args((Int,List));
+
+static List local extractSigdecls Args((List));
+static List local extractBindings Args((List));
+static List local eqnsToBindings Args((List));
+static Void local notDefined Args((Int,List,Cell));
+static Cell local findBinding Args((Text,List));
+static Void local addSigDecl Args((List,Cell));
+static Void local setType Args((Int,Cell,Cell,List));
+
+static List local dependencyAnal Args((List));
+static List local topDependAnal Args((List));
+static Void local addDepField Args((Cell));
+static Void local remDepField Args((List));
+static Void local remDepField1 Args((Cell));
+static Void local clearScope Args((Void));
+static Void local withinScope Args((List));
+static Void local leaveScope Args((Void));
+
+static Void local depBinding Args((Cell));
+static Void local depDefaults Args((Class));
+static Void local depInsts Args((Inst));
+static Void local depClassBindings Args((List));
+static Void local depAlt Args((Cell));
+static Void local depRhs Args((Cell));
+static Void local depGuard Args((Cell));
+static Cell local depExpr Args((Int,Cell));
+static Void local depPair Args((Int,Cell));
+static Void local depTriple Args((Int,Cell));
+static Void local depComp Args((Int,Cell,List));
+static Void local depCaseAlt Args((Int,Cell));
+static Cell local depVar Args((Int,Cell));
+static Cell local depQVar Args((Int,Cell));
+static Void local depConFlds Args((Int,Cell,Bool));
+static Void local depUpdFlds Args((Int,Cell));
+static List local depFields Args((Int,Cell,List,Bool));
+#if TREX
+static Cell local depRecord Args((Int,Cell));
+#endif
+
+static List local tcscc Args((List,List));
+static List local bscc Args((List));
+
+static Void local addRSsigdecls Args((Pair));
+static Void local opDefined Args((List,Cell));
+static Void local allNoPrevDef Args((Cell));
+static Void local noPrevDef Args((Int,Cell));
+static Void local duplicateError Args((Int,Module,Text,String));
+static Void local checkTypeIn Args((Pair));
+
+/* --------------------------------------------------------------------------
+ * The code in this file is arranged in roughly the following order:
+ * - Kind inference preliminaries
+ * - Type declarations (data, type, newtype, type in)
+ * - Class declarations
+ * - Type signatures
+ * - Instance declarations
+ * - Default declarations
+ * - Patterns
+ * - Value definitions
+ * - Top-level static analysis and control
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Kind checking preliminaries:
+ * ------------------------------------------------------------------------*/
+
+Bool kindExpert = FALSE; /* TRUE => display kind errors in */
+ /* full detail */
+
+static Void local kindError(l,c,in,wh,k,o)
+Int l; /* line number near constuctor exp */
+Constr c; /* constructor */
+Constr in; /* context (if any) */
+String wh; /* place in which error occurs */
+Kind k; /* expected kind (k,o) */
+Int o; { /* inferred kind (typeIs,typeOff) */
+ clearMarks();
+
+ if (!kindExpert) { /* for those with a fear of kinds */
+ ERRMSG(l) "Illegal type" ETHEN
+ if (nonNull(in)) {
+ ERRTEXT " \"" ETHEN ERRTYPE(in);
+ ERRTEXT "\"" ETHEN
+ }
+ ERRTEXT " in %s\n", wh
+ EEND;
+ }
+
+ ERRMSG(l) "Kind error in %s", wh ETHEN
+ if (nonNull(in)) {
+ ERRTEXT "\n*** expression : " ETHEN ERRTYPE(in);
+ }
+ ERRTEXT "\n*** constructor : " ETHEN ERRTYPE(c);
+ ERRTEXT "\n*** kind : " ETHEN ERRKIND(copyType(typeIs,typeOff));
+ ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
+ if (unifyFails) {
+ ERRTEXT "\n*** because : %s", unifyFails ETHEN
+ }
+ ERRTEXT "\n"
+ EEND;
+}
+
+#define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \
+ kindError(l,c,in,wh,k,o)
+#define checkKind(l,a,m,c,in,wh,k,o) kindConstr(l,a,m,c); \
+ shouldKind(l,c,in,wh,k,o)
+#define inferKind(k,o) typeIs=k; typeOff=o
+
+static List unkindTypes; /* types in need of kind annotation*/
+#if TREX
+Kind extKind; /* Kind of extension, *->row->row */
+#endif
+
+/* --------------------------------------------------------------------------
+ * Static analysis of type declarations:
+ *
+ * Type declarations come in two forms:
+ * - data declarations - define new constructed data types
+ * - type declarations - define new type synonyms
+ *
+ * A certain amount of work is carried out as the declarations are
+ * read during parsing. In particular, for each type constructor
+ * definition encountered:
+ * - check that there is no previous definition of constructor
+ * - ensure type constructor not previously used as a class name
+ * - make a new entry in the type constructor table
+ * - record line number of declaration
+ * - Build separate lists of newly defined constructors for later use.
+ * ------------------------------------------------------------------------*/
+
+Void tyconDefn(line,lhs,rhs,what) /* process new type definition */
+Int line; /* definition line number */
+Cell lhs; /* left hand side of definition */
+Cell rhs; /* right hand side of definition */
+Cell what; { /* SYNONYM/DATATYPE/etc... */
+ Text t = textOf(getHead(lhs));
+
+ if (nonNull(findTycon(t))) {
+ ERRMSG(line) "Repeated definition of type constructor \"%s\"",
+ textToStr(t)
+ EEND;
+ }
+ else if (nonNull(findClass(t))) {
+ ERRMSG(line) "\"%s\" used as both class and type constructor",
+ textToStr(t)
+ EEND;
+ }
+ else {
+ Tycon nw = newTycon(t);
+ tyconDefns = cons(nw,tyconDefns);
+ tycon(nw).line = line;
+ tycon(nw).arity = argCount;
+ tycon(nw).what = what;
+ if (what==RESTRICTSYN) {
+ typeInDefns = cons(pair(nw,snd(rhs)),typeInDefns);
+ rhs = fst(rhs);
+ }
+ tycon(nw).defn = pair(lhs,rhs);
+ }
+}
+
+Void setTypeIns(bs) /* set local synonyms for given */
+List bs; { /* binding group */
+ List cvs = typeInDefns;
+ for (; nonNull(cvs); cvs=tl(cvs)) {
+ Tycon c = fst(hd(cvs));
+ List vs = snd(hd(cvs));
+ for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
+ if (nonNull(findBinding(textOf(hd(vs)),bs))) {
+ tycon(c).what = SYNONYM;
+ break;
+ }
+ }
+ }
+}
+
+Void clearTypeIns() { /* clear list of local synonyms */
+ for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
+ tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
+}
+
+/* --------------------------------------------------------------------------
+ * Further analysis of Type declarations:
+ *
+ * In order to allow the definition of mutually recursive families of
+ * data types, the static analysis of the right hand sides of type
+ * declarations cannot be performed until all of the type declarations
+ * have been read.
+ *
+ * Once parsing is complete, we carry out the following:
+ *
+ * - check format of lhs, extracting list of bound vars and ensuring that
+ * there are no repeated variables and no Skolem variables.
+ * - run dependency analysis on rhs to check that only bound type vars
+ * appear in type and that all constructors are defined.
+ * Replace type variables by offsets, constructors by Tycons.
+ * - use list of dependents to sort into strongly connected components.
+ * - ensure that there is not more than one synonym in each group.
+ * - kind-check each group of type definitions.
+ *
+ * - check that there are no previous definitions for constructor
+ * functions in data type definitions.
+ * - install synonym expansions and constructor definitions.
+ * ------------------------------------------------------------------------*/
+
+static List tcDeps = NIL; /* list of dependent tycons/classes*/
+
+static Void local checkTyconDefn(d) /* validate type constructor defn */
+Tycon d; {
+ Cell lhs = fst(tycon(d).defn);
+ Cell rhs = snd(tycon(d).defn);
+ Int line = tycon(d).line;
+ List tyvars = getArgs(lhs);
+ List temp;
+ /* check for repeated tyvars on lhs*/
+ for (temp=tyvars; nonNull(temp); temp=tl(temp))
+ if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
+ ERRMSG(line) "Repeated type variable \"%s\" on left hand side",
+ textToStr(textOf(hd(temp)))
+ EEND;
+ }
+
+ tcDeps = NIL; /* find dependents */
+ switch (whatIs(tycon(d).what)) {
+ case RESTRICTSYN :
+ case SYNONYM : rhs = depTypeExp(line,tyvars,rhs);
+ if (cellIsMember(d,tcDeps)) {
+ ERRMSG(line) "Recursive type synonym \"%s\"",
+ textToStr(tycon(d).text)
+ EEND;
+ }
+ break;
+
+ case DATATYPE :
+ case NEWTYPE : depConstrs(d,tyvars,rhs);
+ rhs = fst(rhs);
+ break;
+
+ default : internal("checkTyconDefn");
+ break;
+ }
+
+ tycon(d).defn = rhs;
+ tycon(d).kind = tcDeps;
+ tcDeps = NIL;
+}
+
+static Void local depConstrs(t,tyvars,cd)
+Tycon t; /* Define constructor functions and*/
+List tyvars; /* do dependency analysis for data */
+Cell cd; { /* definitions (w or w/o deriving) */
+ Int line = tycon(t).line;
+ List ctxt = NIL;
+ Int conNo = 1;
+ Type lhs = t;
+ List cs = fst(cd);
+ List derivs = snd(cd);
+ List compTypes = NIL;
+ List sels = NIL;
+ Int ntvs = length(tyvars);
+ Int i;
+
+ for (i=0; i<tycon(t).arity; ++i) /* build representation for tycon */
+ lhs = ap(lhs,mkOffset(i)); /* applied to full comp. of args */
+
+ if (whatIs(cs)==QUAL) { /* allow for possible context */
+ ctxt = fst(snd(cs));
+ cs = snd(snd(cs));
+ map2Proc(depPredExp,line,tyvars,ctxt);
+ }
+
+ if (nonNull(cs) && isNull(tl(cs))) /* Single constructor datatype? */
+ conNo = 0;
+
+ for (; nonNull(cs); cs=tl(cs)) { /* For each constructor function: */
+ Cell con = hd(cs);
+ List sig = typeVarsIn(con,NIL,dupList(tyvars));
+ Int etvs = length(sig);
+ List ctxt1 = ctxt; /* constructor function context */
+ List scs = NIL; /* strict components */
+ List fs = NONE; /* selector names */
+ Type type = lhs; /* constructor function type */
+ Int arity = 0; /* arity of constructor function */
+ Int nr2 = 0; /* Number of rank 2 args */
+ Name n; /* name for constructor function */
+
+ if (whatIs(con)==LABC) { /* Skeletize constr components */
+ Cell fls = snd(snd(con)); /* get field specifications */
+ con = fst(snd(con));
+ fs = NIL;
+ for (; nonNull(fls); fls=tl(fls)) { /* for each field spec: */
+ List vs = fst(hd(fls));
+ Type t = snd(hd(fls)); /* - scrutinize type */
+ Bool banged = whatIs(t)==BANG;
+ t = depCompType(line,sig,(banged ? arg(t) : t));
+ while (nonNull(vs)) { /* - add named components */
+ Cell us = tl(vs);
+ tl(vs) = fs;
+ fs = vs;
+ vs = us;
+ con = ap(con,t);
+ arity++;
+ if (banged)
+ scs = cons(mkInt(arity),scs);
+ }
+ }
+ fs = rev(fs);
+ scs = rev(scs); /* put strict comps in ascend ord */
+ }
+ else { /* Non-labelled constructor */
+ Cell c = con;
+ Int compNo;
+ for (; isAp(c); c=fun(c))
+ arity++;
+ for (compNo=arity, c=con; isAp(c); c=fun(c)) {
+ Type t = arg(c);
+ if (whatIs(t)==BANG) {
+ scs = cons(mkInt(compNo),scs);
+ t = arg(t);
+ }
+ compNo--;
+ arg(c) = depCompType(line,sig,t);
+ }
+ }
+
+ if (nonNull(ctxt1)) /* Extract relevant part of context*/
+ ctxt1 = selectCtxt(ctxt1,offsetTyvarsIn(con,NIL));
+
+ for (i=arity; isAp(con); i--) { /* Calculate type of constructor */
+ Type t = fun(con);
+ Type cmp = arg(con);
+ fun(con) = typeArrow;
+ if (isPolyType(cmp)) {
+ if (nonNull(derivs)) {
+ ERRMSG(line) "Cannot derive instances for types" ETHEN
+ ERRTEXT " with polymorphic components"
+ EEND;
+ }
+ if (nr2==0)
+ nr2 = i;
+ }
+ if (nonNull(derivs)) /* and build list of components */
+ compTypes = cons(cmp,compTypes);
+ type = ap(con,type);
+ con = t;
+ }
+
+ if (nr2>0) /* Add rank 2 annotation */
+ type = ap(RANK2,pair(mkInt(nr2),type));
+
+ if (etvs>ntvs) { /* Add existential annotation */
+ if (nonNull(derivs)) {
+ ERRMSG(line) "Cannot derive instances for types" ETHEN
+ ERRTEXT " with existentially typed components"
+ EEND;
+ }
+ if (fs!=NONE) {
+ ERRMSG(line)
+ "Cannot use selectors with existentially typed components"
+ EEND;
+ }
+ type = ap(EXIST,pair(mkInt(etvs-ntvs),type));
+ }
+ if (nonNull(ctxt1)) { /* Add context part to type */
+ type = ap(QUAL,pair(ctxt1,type));
+ }
+ if (nonNull(sig)) { /* Add quantifiers to type */
+ List ts1 = sig;
+ for (; nonNull(ts1); ts1=tl(ts1)) {
+ hd(ts1) = NIL;
+ }
+ type = mkPolyType(sig,type);
+ }
+
+ n = findName(textOf(con)); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(textOf(con));
+ } else if (name(n).defn!=PREDEFINED) {
+ duplicateError(line,name(n).mod,name(n).text,
+ "constructor function");
+ }
+ name(n).arity = arity; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(conNo++);
+ name(n).type = type;
+ if (tycon(t).what==NEWTYPE) {
+ name(n).defn = nameId;
+ } else {
+ implementCfun(n,scs);
+ }
+ hd(cs) = n;
+ if (fs!=NONE) {
+ sels = addSels(line,n,fs,sels);
+ }
+ }
+
+ if (nonNull(sels)) {
+ sels = rev(sels);
+ fst(cd) = appendOnto(fst(cd),sels);
+ selDefns = cons(sels,selDefns);
+ }
+
+ if (nonNull(derivs)) { /* Generate derived instances */
+ map3Proc(checkDerive,t,ctxt,compTypes,derivs);
+ }
+}
+
+static List local addSels(line,c,fs,ss) /* Add fields to selector list */
+Int line; /* line number of constructor */
+Name c; /* corresponding constr function */
+List fs; /* list of fields (varids) */
+List ss; { /* list of existing selectors */
+ Int sn = 1;
+#if DERIVE_SHOW | DERIVE_READ
+ cfunSfuns = cons(pair(c,fs),cfunSfuns);
+#endif
+ for (; nonNull(fs); fs=tl(fs), ++sn) {
+ List ns = ss;
+ Text t = textOf(hd(fs));
+
+ if (nonNull(varIsMember(t,tl(fs)))) {
+ ERRMSG(line) "Repeated field name \"%s\" for constructor \"%s\"",
+ textToStr(t), textToStr(name(c).text)
+ EEND;
+ }
+
+ while (nonNull(ns) && t!=name(hd(ns)).text) {
+ ns = tl(ns);
+ }
+ if (nonNull(ns)) {
+ name(hd(ns)).defn = cons(pair(c,mkInt(sn)),name(hd(ns)).defn);
+ } else {
+ Name n = findName(t);
+ if (nonNull(n)) {
+ ERRMSG(line) "Repeated definition for selector \"%s\"",
+ textToStr(t)
+ EEND;
+ }
+ n = newName(t);
+ name(n).line = line;
+ name(n).number = SELNAME;
+ name(n).defn = singleton(pair(c,mkInt(sn)));
+ ss = cons(n,ss);
+ }
+ }
+ return ss;
+}
+
+static List local selectCtxt(ctxt,vs) /* calculate subset of context */
+List ctxt;
+List vs; {
+ if (isNull(vs)) {
+ return NIL;
+ } else {
+ List ps = NIL;
+ for (; nonNull(ctxt); ctxt=tl(ctxt)) {
+ List us = offsetTyvarsIn(hd(ctxt),NIL);
+ for (; nonNull(us) && cellIsMember(hd(us),vs); us=tl(us)) {
+ }
+ if (isNull(us)) {
+ ps = cons(hd(ctxt),ps);
+ }
+ }
+ return rev(ps);
+ }
+}
+
+static Void local checkSynonyms(ts) /* Check for mutually recursive */
+List ts; { /* synonyms */
+ List syns = NIL;
+ for (; nonNull(ts); ts=tl(ts)) { /* build list of all synonyms */
+ Tycon t = hd(ts);
+ switch (whatIs(tycon(t).what)) {
+ case SYNONYM :
+ case RESTRICTSYN : syns = cons(t,syns);
+ break;
+ }
+ }
+ while (nonNull(syns)) { /* then visit each synonym */
+ syns = visitSyn(NIL,hd(syns),syns);
+ }
+}
+
+static List local visitSyn(path,t,syns) /* visit synonym definition to look*/
+List path; /* for cycles */
+Tycon t;
+List syns; {
+ if (cellIsMember(t,path)) { /* every elt in path depends on t */
+ ERRMSG(tycon(t).line)
+ "Type synonyms \"%s\" and \"%s\" are mutually recursive",
+ textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
+ EEND;
+ } else {
+ List ds = tycon(t).kind;
+ List path1 = NIL;
+ for (; nonNull(ds); ds=tl(ds)) {
+ if (cellIsMember(hd(ds),syns)) {
+ if (isNull(path1))
+ path1 = cons(t,path);
+ syns = visitSyn(path1,hd(ds),syns);
+ }
+ }
+ }
+ tycon(t).defn = fullExpand(tycon(t).defn);
+ return removeCell(t,syns);
+}
+
+/* --------------------------------------------------------------------------
+ * The following code is used in calculating contexts for the automatically
+ * derived Eval instances for newtype and restricted type synonyms. This is
+ * ugly code, resulting from an ugly feature in the language, and I hope that
+ * the feature, and hence the code, will be removed in the not too distant
+ * future.
+ * ------------------------------------------------------------------------*/
+
+#if EVAL_INSTANCES
+static Void local deriveEval(tcs) /* Derive instances of Eval */
+List tcs; {
+ List ts1 = tcs;
+ List ts = NIL;
+ for (; nonNull(ts1); ts1=tl(ts1)) { /* Build list of rsyns and newtypes*/
+ Tycon t = hd(ts1); /* and derive instances for data */
+ switch (whatIs(tycon(t).what)) {
+ case DATATYPE : addEvalInst(tycon(t).line,t,tycon(t).arity,NIL);
+ break;
+ case NEWTYPE :
+ case RESTRICTSYN : ts = cons(t,ts);
+ break;
+ }
+ }
+ emptySubstitution(); /* then derive other instances */
+ while (nonNull(ts)) {
+ ts = calcEvalContexts(hd(ts),tl(ts),NIL);
+ }
+ emptySubstitution();
+
+ for (; nonNull(tcs); tcs=tl(tcs)) { /* Check any banged components */
+ Tycon t = hd(tcs);
+ if (whatIs(tycon(t).what)==DATATYPE) {
+ List cs = tycon(t).defn;
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ if (isPair(name(c).defn)) {
+ Type t = name(c).type;
+ List scs = fst(name(c).defn);
+ Kinds ks = NIL;
+ List ctxt = NIL;
+ Int n = 1;
+ if (isPolyType(t)) {
+ ks = polySigOf(t);
+ t = monotypeOf(t);
+ }
+ if (whatIs(t)==QUAL) {
+ ctxt = fst(snd(t));
+ t = snd(snd(t));
+ }
+ for (; nonNull(scs); scs=tl(scs)) {
+ Int i = intOf(hd(scs));
+ for (; n<i; n++) {
+ t = arg(t);
+ }
+ checkBanged(c,ks,ctxt,arg(fun(t)));
+ }
+ }
+ }
+ }
+ }
+}
+
+static List local calcEvalContexts(tc,ts,ps)
+Tycon tc; /* Worker code for deriveEval */
+List ts; /* ts = not visited, ps = visiting */
+List ps; {
+ Cell ctxt = NIL;
+ Int o = newKindedVars(tycon(tc).kind);
+ Type t = tycon(tc).defn;
+ Int i;
+
+ if (whatIs(tycon(tc).what)==NEWTYPE) {
+ t = name(hd(t)).type;
+ if (isPolyType(t)) {
+ t = monotypeOf(t);
+ }
+ if (whatIs(t)==QUAL) {
+ t = snd(snd(t));
+ }
+ if (whatIs(t)==EXIST) { /* No instance if existentials used*/
+ return ts;
+ }
+ if (whatIs(t)==RANK2) { /* No instance if arg is poly/qual */
+ return ts;
+ }
+ t = arg(fun(t));
+ }
+
+ clearMarks(); /* Make sure generics are marked */
+ for (i=0; i<tycon(tc).arity; i++) { /* in the correct order. */
+ copyTyvar(o+i);
+ }
+
+ for (;;) {
+ Type h = getDerefHead(t,o);
+ if (isSynonym(h) && argCount>=tycon(h).arity) {
+ expandSyn(h,argCount,&t,&o);
+ } else if (isOffset(h)) { /* Stop if var at head */
+ ctxt = singleton(ap(classEval,copyType(t,o)));
+ break;
+ } else if (isTuple(h) /* Check for tuples ... */
+ || h==tc /* ... direct recursion */
+ || cellIsMember(h,ps) /* ... mutual recursion */
+ || tycon(h).what==DATATYPE) { /* ... or datatype. */
+ break; /* => empty context */
+ } else {
+ Cell pi = ap(classEval,t);
+ Inst in;
+
+ if (cellIsMember(h,ts)) { /* Not yet visited? */
+ ts = calcEvalContexts(h,removeCell(h,ts),cons(h,ts));
+ }
+ if (nonNull(in=findInstFor(pi,o))) {/* Look for Eval instance */
+ List qs = inst(in).specifics;
+ Int o1 = typeOff;
+ if (isNull(qs)) { /* No context there */
+ break; /* => empty context here */
+ }
+ if (isNull(tl(qs)) && classEval==fun(hd(qs))) {
+ t = arg(hd(qs));
+ o = o1;
+ continue;
+ }
+ }
+ return ts; /* No instance, so give up */
+ }
+ }
+ addEvalInst(tycon(tc).line,tc,tycon(tc).arity,ctxt);
+ return ts;
+}
+
+static Void local checkBanged(c,ks,ps,ty)
+Name c; /* Check that banged component of c*/
+Kinds ks; /* with type ty is an instance of */
+List ps; /* Eval under the predicates in ps.*/
+Type ty; { /* (All types using ks) */
+ Cell pi = ap(classEval,ty);
+ if (isNull(provePred(ks,ps,pi))) {
+ ERRMSG(name(c).line) "Illegal datatype strictness annotation:" ETHEN
+ ERRTEXT "\n*** Constructor : " ETHEN ERREXPR(c);
+ ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps);
+ ERRTEXT "\n*** Required : " ETHEN ERRPRED(pi);
+ ERRTEXT "\n"
+ EEND;
+ }
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Expanding out all type synonyms in a type expression:
+ * ------------------------------------------------------------------------*/
+
+Type fullExpand(t) /* find full expansion of type exp */
+Type t; { /* assuming that all relevant */
+ Cell h = t; /* synonym defns of lower rank have*/
+ Int n = 0; /* already been fully expanded */
+ List args;
+ for (args=NIL; isAp(h); h=fun(h), n++) {
+ args = cons(fullExpand(arg(h)),args);
+ }
+ t = applyToArgs(h,args);
+ if (isSynonym(h) && n>=tycon(h).arity) {
+ if (n==tycon(h).arity) {
+ t = instantiateSyn(tycon(h).defn,t);
+ } else {
+ Type p = t;
+ while (--n > tycon(h).arity) {
+ p = fun(p);
+ }
+ fun(p) = instantiateSyn(tycon(h).defn,fun(p));
+ }
+ }
+ return t;
+}
+
+static Type local instantiateSyn(t,env) /* instantiate type according using*/
+Type t; /* env to determine appropriate */
+Type env; { /* values for OFFSET type vars */
+ switch (whatIs(t)) {
+ case AP : return ap(instantiateSyn(fun(t),env),
+ instantiateSyn(arg(t),env));
+
+ case OFFSET : return nthArg(offsetOf(t),env);
+
+ default : return t;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Static analysis of class declarations:
+ *
+ * Performed in a similar manner to that used for type declarations.
+ *
+ * The first part of the static analysis is performed as the declarations
+ * are read during parsing. The parser ensures that:
+ * - the class header and all superclass predicates are of the form
+ * ``Class var''
+ *
+ * The classDefn() function:
+ * - ensures that there is no previous definition for class
+ * - checks that class name has not previously been used as a type constr.
+ * - make new entry in class table
+ * - record line number of declaration
+ * - build list of classes defined in current script for use in later
+ * stages of static analysis.
+ * ------------------------------------------------------------------------*/
+
+Void classDefn(line,head,ms) /* process new class definition */
+Int line; /* definition line number */
+Cell head; /* class header :: ([Supers],Class)*/
+List ms; { /* class definition body */
+ Text ct = textOf(getHead(snd(head)));
+ Int arity = argCount;
+
+ if (nonNull(findClass(ct))) {
+ ERRMSG(line) "Repeated definition of class \"%s\"",
+ textToStr(ct)
+ EEND;
+ } else if (nonNull(findTycon(ct))) {
+ ERRMSG(line) "\"%s\" used as both class and type constructor",
+ textToStr(ct)
+ EEND;
+ } else {
+ Class nw = newClass(ct);
+ cclass(nw).line = line;
+ cclass(nw).arity = arity;
+ cclass(nw).head = snd(head);
+ cclass(nw).supers = fst(head);
+ cclass(nw).members = ms;
+ cclass(nw).level = 0;
+ classDefns = cons(nw,classDefns);
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Further analysis of class declarations:
+ *
+ * Full static analysis of class definitions must be postponed until the
+ * complete script has been read and all static analysis on type definitions
+ * has been completed.
+ *
+ * Once this has been achieved, we carry out the following checks on each
+ * class definition:
+ * - check that variables in header are distinct
+ * - replace head by skeleton
+ * - check superclass declarations, replace by skeltons
+ * - split body of class into members and declarations
+ * - make new name entry for each member function
+ * - record member function number (eventually an offset into dictionary!)
+ * - no member function has a previous definition ...
+ * - no member function is mentioned more than once in the list of members
+ * - each member function type is valid, replace vars by offsets
+ * - qualify each member function type by class header
+ * - only bindings for members appear in defaults
+ * - only function bindings appear in defaults
+ * - check that extended class hierarchy does not contain any cycles
+ * ------------------------------------------------------------------------*/
+
+static Void local checkClassDefn(c) /* validate class definition */
+Class c; {
+ List tyvars = NIL;
+ Int args = cclass(c).arity - 1;
+ Cell temp = cclass(c).head;
+
+ for (; isAp(temp); temp=fun(temp)) {
+ if (!isVar(arg(temp))) {
+ ERRMSG(cclass(c).line) "Type variable required in class head"
+ EEND;
+ }
+ if (nonNull(varIsMember(textOf(arg(temp)),tyvars))) {
+ ERRMSG(cclass(c).line)
+ "Repeated type variable \"%s\" in class head",
+ textToStr(textOf(arg(temp)))
+ EEND;
+ }
+ tyvars = cons(arg(temp),tyvars);
+ }
+
+ for (temp=cclass(c).head; args>0; temp=fun(temp), args--) {
+ arg(temp) = mkOffset(args);
+ }
+ arg(temp) = mkOffset(0);
+ fun(temp) = c;
+
+ tcDeps = NIL; /* find dependents */
+ map2Proc(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
+ cclass(c).numSupers = length(cclass(c).supers);
+ cclass(c).defaults = extractBindings(cclass(c).members); /* defaults*/
+ cclass(c).members = extractSigdecls(cclass(c).members);
+ map2Proc(checkMems,c,tyvars,cclass(c).members);
+ cclass(c).kinds = tcDeps;
+ tcDeps = NIL;
+}
+
+static Void local depPredExp(line,tyvars,pred)
+Int line;
+List tyvars;
+Cell pred; {
+ Int args = 1; /* parser guarantees >=1 args */
+ Cell h = fun(pred);
+ for (; isAp(h); args++) {
+ arg(pred) = depTypeExp(line,tyvars,arg(pred));
+ pred = h;
+ h = fun(pred);
+ }
+ arg(pred) = depTypeExp(line,tyvars,arg(pred));
+
+ if (isQCon(h)) { /* standard class constraint */
+ Class c = findQualClass(h);
+ if (isNull(c)) {
+ ERRMSG(line) "Undefined class \"%s\"", identToStr(h)
+ EEND;
+ }
+ fun(pred) = c;
+ if (args!=cclass(c).arity) {
+ ERRMSG(line) "Wrong number of arguments for class \"%s\"",
+ textToStr(cclass(c).text)
+ EEND;
+ }
+ if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps))
+ tcDeps = cons(c,tcDeps);
+ }
+#if TREX
+ else if (isExt(h)) { /* Lacks predicate */
+ if (args!=1) { /* parser shouldn't let this happen*/
+ ERRMSG(line) "Wrong number of arguments for lacks predicate"
+ EEND;
+ }
+ }
+#endif
+ else { /* check for other kinds of pred */
+ internal("depPredExp"); /* ... but there aren't any! */
+ }
+}
+
+static Void local checkMems(c,tyvars,m) /* check member function details */
+Class c;
+List tyvars;
+Cell m; {
+ Int line = intOf(fst3(m));
+ List vs = snd3(m);
+ Type t = thd3(m);
+ List sig = NIL;
+ List tvs = NIL;
+
+ tyvars = typeVarsIn(t,NIL,tyvars);/* Look for extra type vars. */
+
+ if (whatIs(t)==QUAL) { /* Overloaded member signatures? */
+ map2Proc(depPredExp,line,tyvars,fst(snd(t)));
+ } else {
+ t = ap(QUAL,pair(NIL,t));
+ }
+
+ fst(snd(t)) = cons(cclass(c).head,fst(snd(t)));/* Add main predicate */
+ snd(snd(t)) = depTopType(line,tyvars,snd(snd(t)));
+
+ for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)) { /* Quantify */
+ sig = ap(NIL,sig);
+ }
+ t = mkPolyType(sig,t);
+ thd3(m) = t; /* Save type */
+ take(cclass(c).arity,tyvars); /* Delete extra type vars */
+
+ if (isAmbiguous(t)) {
+ ambigError(line,"class declaration",hd(vs),t);
+ }
+}
+
+static Void local addMembers(c) /* Add definitions of member funs */
+Class c; { /* and other parts of class struct.*/
+ List ms = cclass(c).members;
+ List ns = NIL; /* List of names */
+ Int mno; /* Member function number */
+
+ for (mno=0; mno<cclass(c).numSupers; mno++) {
+ ns = cons(newDSel(c,mno),ns);
+ }
+ cclass(c).dsels = rev(ns); /* Save dictionary selectors */
+
+ for (mno=1, ns=NIL; nonNull(ms); ms=tl(ms)) {
+ Int line = intOf(fst3(hd(ms)));
+ List vs = rev(snd3(hd(ms)));
+ Type t = thd3(hd(ms));
+ for (; nonNull(vs); vs=tl(vs)) {
+ ns = cons(newMember(line,mno++,hd(vs),t),ns);
+ }
+ }
+ cclass(c).members = rev(ns); /* Save list of members */
+ cclass(c).numMembers = length(cclass(c).members);
+
+/* Not actually needed just yet; for the time being, dictionary code will
+ not be passed through the type checker.
+
+ cclass(c).dtycon = addPrimTycon(generateText("Dict.%s",c),
+ NIL,
+ cclass(c).arity,
+ DATATYPE,
+ NIL);
+*/
+
+ mno = cclass(c).numSupers + cclass(c).numMembers;
+ cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,0);
+ implementCfun(cclass(c).dcon,NIL); /* ADR addition */
+#if USE_NEWTYPE_FOR_DICTS
+ if (mno==1) { /* Single entry dicts use newtype */
+ name(cclass(c).dcon).defn = nameId;
+ name(hd(cclass(c).members)).number = mfunNo(0);
+ }
+#endif
+ cclass(c).dbuild = newDBuild(c);
+ cclass(c).defaults = classBindings("class",c,cclass(c).defaults);
+}
+
+static Name local newMember(l,no,v,t) /* Make definition for member fn */
+Int l;
+Int no;
+Cell v;
+Type t; {
+ Name m = findName(textOf(v));
+
+ if (isNull(m)) {
+ m = newName(textOf(v));
+ } else if (name(m).defn!=PREDEFINED) {
+ ERRMSG(l) "Repeated definition for member function \"%s\"",
+ textToStr(name(m).text)
+ EEND;
+ }
+
+ name(m).line = l;
+ name(m).arity = 1;
+ name(m).number = mfunNo(no);
+ name(m).type = t;
+ return m;
+}
+
+static Name local newDSel(c,no) /* Make definition for dict selectr*/
+Class c;
+Int no; {
+ Name s;
+ char buf[16];
+
+ sprintf(buf,"sc%d.%s",no,"%s");
+ s = newName(generateText(buf,c));
+ name(s).line = cclass(c).line;
+ name(s).arity = 1;
+ name(s).number = DFUNNAME;
+ return s;
+}
+
+static Name local newDBuild(c) /* Make definition for builder */
+Class c; {
+ Name b = newName(generateText("class.%s",c));
+ name(b).line = cclass(c).line;
+ name(b).arity = cclass(c).numSupers+1;
+ return b;
+}
+
+#define MAX_GEN 128
+
+static Text local generateText(sk,c) /* We need to generate names for */
+String sk; /* certain objects corresponding */
+Class c; { /* to each class. */
+ String cname = textToStr(cclass(c).text);
+ char buffer[MAX_GEN+1];
+
+ if ((strlen(sk)+strlen(cname))>=MAX_GEN) {
+ ERRMSG(0) "Please use a shorter name for class \"%s\"", cname
+ EEND;
+ }
+ sprintf(buffer,sk,cname);
+ return findText(buffer);
+}
+
+static Int local visitClass(c) /* visit class defn to check that */
+Class c; { /* class hierarchy is acyclic */
+#if TREX
+ if (isExt(c)) { /* special case for lacks preds */
+ return 0;
+ }
+#endif
+ if (cclass(c).level < 0) { /* already visiting this class? */
+ ERRMSG(cclass(c).line) "Class hierarchy for \"%s\" is not acyclic",
+ textToStr(cclass(c).text)
+ EEND;
+ } else if (cclass(c).level == 0) { /* visiting class for first time */
+ List scs = cclass(c).supers;
+ Int lev = 0;
+ cclass(c).level = (-1);
+ for (; nonNull(scs); scs=tl(scs)) {
+ Int l = visitClass(getHead(hd(scs)));
+ if (l>lev) lev=l;
+ }
+ cclass(c).level = 1+lev; /* level = 1 + max level of supers */
+ }
+ return cclass(c).level;
+}
+
+/* --------------------------------------------------------------------------
+ * Process class and instance declaration binding groups:
+ * ------------------------------------------------------------------------*/
+
+static List local classBindings(where,c,bs)
+String where; /*check validity of bindings bs for*/
+Class c; /* class c (or an instance of c) */
+List bs; { /* sort into approp. member order */
+ List nbs = NIL;
+
+ for (; nonNull(bs); bs=tl(bs)) {
+ Cell b = hd(bs);
+ Name mnm;
+
+ if (!isVar(fst(b))) { /* only allows function bindings */
+ ERRMSG(rhsLine(snd(snd(snd(b)))))
+ "Pattern binding illegal in %s declaration", where
+ EEND;
+ }
+
+ if (isNull(mnm=memberName(c,textOf(fst(b))))) {
+ ERRMSG(rhsLine(snd(hd(snd(snd(b))))))
+ "No member \"%s\" in class \"%s\"",
+ textToStr(textOf(fst(b))), textToStr(cclass(c).text)
+ EEND;
+ }
+
+ snd(b) = snd(snd(b));
+ nbs = numInsert(mfunOf(mnm)-1,b,nbs);
+ }
+ return nbs;
+}
+
+static Name local memberName(c,t) /* return name of member function */
+Class c; /* with name t in class c */
+Text t; { /* return NIL if not a member */
+ List ms = cclass(c).members;
+ for (; nonNull(ms); ms=tl(ms)) {
+ if (t==name(hd(ms)).text) {
+ return hd(ms);
+ }
+ }
+ return NIL;
+}
+
+static List local numInsert(n,x,xs) /* insert x at nth position in xs, */
+Int n; /* filling gaps with NIL */
+Cell x;
+List xs; {
+ List start = isNull(xs) ? cons(NIL,NIL) : xs;
+
+ for (xs=start; 0<n--; xs=tl(xs)) {
+ if (isNull(tl(xs))) {
+ tl(xs) = cons(NIL,NIL);
+ }
+ }
+ hd(xs) = x;
+ return start;
+}
+
+/* --------------------------------------------------------------------------
+ * Calculate set of variables appearing in a given type expression (possibly
+ * qualified) as a list of distinct values. The order in which variables
+ * appear in the list is the same as the order in which those variables
+ * occur in the type expression when read from left to right.
+ * ------------------------------------------------------------------------*/
+
+static List local typeVarsIn(ty,us,vs) /* Calculate list of type variables*/
+Cell ty; /* used in type expression, reading*/
+List us; /* from left to right ignoring any */
+List vs; { /* listed in us. */
+ switch (whatIs(ty)) {
+ case AP : return typeVarsIn(snd(ty),us,
+ typeVarsIn(fst(ty),us,vs));
+
+ case VARIDCELL :
+ case VAROPCELL : if (nonNull(findBtyvs(textOf(ty)))
+ || varIsMember(textOf(ty),us)) {
+ return vs;
+ } else {
+ return maybeAppendVar(ty,vs);
+ }
+ case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),vs);
+
+ case QUAL : { List qs = fst(snd(ty));
+ for (; nonNull(qs); qs=tl(qs)) {
+ vs = typeVarsIn(hd(qs),us,vs);
+ }
+ return typeVarsIn(snd(snd(ty)),us,vs);
+ }
+
+ case BANG : return typeVarsIn(snd(ty),us,vs);
+
+ case LABC : { List fs = snd(snd(ty));
+ for (; nonNull(fs); fs=tl(fs)) {
+ vs = typeVarsIn(snd(hd(fs)),us,vs);
+ }
+ return vs;
+ }
+ }
+ return vs;
+}
+
+static List local maybeAppendVar(v,vs) /* append variable to list if not */
+Cell v; /* already included */
+List vs; {
+ Text t = textOf(v);
+ List p = NIL;
+ List c = vs;
+
+ while (nonNull(c)) {
+ if (textOf(hd(c))==t) {
+ return vs;
+ }
+ p = c;
+ c = tl(c);
+ }
+
+ if (nonNull(p)) {
+ tl(p) = cons(v,NIL);
+ } else {
+ vs = cons(v,NIL);
+ }
+ return vs;
+}
+
+/* --------------------------------------------------------------------------
+ * Static analysis for type expressions is required to:
+ * - ensure that each type constructor or class used has been defined.
+ * - replace type variables by offsets, constructor names by Tycons.
+ * - ensure that the type is well-kinded.
+ * ------------------------------------------------------------------------*/
+
+static Type local checkSigType(line,where,e,type)
+Int line; /* Check validity of type expr in */
+String where; /* explicit type signature */
+Cell e;
+Type type; {
+ List tvs = typeVarsIn(type,NIL,NIL);
+ Int n = length(tvs);
+ List sunk = unkindTypes;
+
+ if (whatIs(type)==QUAL) {
+ map2Proc(depPredExp,line,tvs,fst(snd(type)));
+ snd(snd(type)) = depTopType(line,tvs,snd(snd(type)));
+
+ if (isAmbiguous(type)) {
+ ambigError(line,where,e,type);
+ }
+ } else {
+ type = depTopType(line,tvs,type);
+ }
+ if (n>0) {
+ if (n>=NUM_OFFSETS) {
+ ERRMSG(line) "Too many type variables in %s\n", where
+ EEND;
+ } else {
+ List ts = tvs;
+ for (; nonNull(ts); ts=tl(ts)) {
+ hd(ts) = NIL;
+ }
+ type = mkPolyType(tvs,type);
+ }
+ }
+
+ unkindTypes = NIL;
+ kindType(line,"type expression",type);
+ fixKinds();
+ unkindTypes = sunk;
+ return type;
+}
+
+static Type local depTopType(l,tvs,t) /* Check top-level of type sig */
+Int l;
+List tvs;
+Type t; {
+ Type prev = NIL;
+ Type t1 = t;
+ Int nr2 = 0;
+ Int i = 1;
+ for (; getHead(t1)==typeArrow; ++i) {
+ arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1)));
+ if (isPolyType(arg(fun(t1)))) {
+ nr2 = i;
+ }
+ prev = t1;
+ t1 = arg(t1);
+ }
+ if (nonNull(prev)) {
+ arg(prev) = depTypeExp(l,tvs,t1);
+ } else {
+ t = depTypeExp(l,tvs,t1);
+ }
+ if (nr2>0) {
+ t = ap(RANK2,pair(mkInt(nr2),t));
+ }
+ return t;
+}
+
+static Type local depCompType(l,tvs,t) /* Check component type for constr */
+Int l;
+List tvs;
+Type t; {
+ if (isPolyType(t)) {
+ Int ntvs = length(tvs);
+ List nfr = NIL;
+ if (isPolyType(t)) {
+ List vs = fst(snd(t));
+ List bvs = typeVarsIn(monotypeOf(t),NIL,NIL);
+ List us = vs;
+ for (; nonNull(us); us=tl(us)) {
+ Text u = textOf(hd(us));
+ if (varIsMember(u,tl(us))) {
+ ERRMSG(l) "Duplicated quantified variable %s",
+ textToStr(u)
+ EEND;
+ }
+ if (varIsMember(u,tvs)) {
+ ERRMSG(l) "Local quantifier for %s hides an outer use",
+ textToStr(u)
+ EEND;
+ }
+ if (!varIsMember(u,bvs)) {
+ ERRMSG(l) "Locally quantified variable %s is not used",
+ textToStr(u)
+ EEND;
+ }
+ }
+ nfr = replicate(length(vs),NIL);
+ tvs = appendOnto(tvs,vs);
+ t = monotypeOf(t);
+ }
+ if (whatIs(t)==QUAL) {
+ map2Proc(depPredExp,l,tvs,fst(snd(t)));
+ snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
+ if (isAmbiguous(t))
+ ambigError(l,"type component",NIL,t);
+ } else {
+ t = depTypeExp(l,tvs,t);
+ }
+ if (isNull(nfr)) {
+ return t;
+ }
+ take(ntvs,tvs);
+ return mkPolyType(nfr,t);
+ } else {
+ return depTypeExp(l,tvs,t);
+ }
+}
+
+static Type local depTypeExp(line,tyvars,type)
+Int line;
+List tyvars;
+Type type; {
+ switch (whatIs(type)) {
+ case AP : fst(type) = depTypeExp(line,tyvars,fst(type));
+ snd(type) = depTypeExp(line,tyvars,snd(type));
+ break;
+
+ case VARIDCELL : return depTypeVar(line,tyvars,textOf(type));
+
+ case QUALIDENT : if (isQVar(type)) {
+ ERRMSG(line) "Qualified type variables not allowed"
+ EEND;
+ }
+ /* deliberate fall through */
+ case CONIDCELL : { Tycon tc = findQualTycon(type);
+ if (isNull(tc)) {
+ ERRMSG(line)
+ "Undefined type constructor \"%s\"",
+ identToStr(type)
+ EEND;
+ }
+ if (cellIsMember(tc,tyconDefns) &&
+ !cellIsMember(tc,tcDeps)) {
+ tcDeps = cons(tc,tcDeps);
+ }
+ return tc;
+ }
+
+#if TREX
+ case EXT :
+#endif
+ case TYCON :
+ case TUPLE : break;
+
+ default : internal("depTypeExp");
+ }
+ return type;
+}
+
+static Type local depTypeVar(line,tyvars,tv)
+Int line;
+List tyvars;
+Text tv; {
+ Int offset = 0;
+ Cell vt = findBtyvs(tv);
+
+ if (nonNull(vt)) {
+ return fst(vt);
+ }
+ for (; nonNull(tyvars) && tv!=textOf(hd(tyvars)); offset++) {
+ tyvars = tl(tyvars);
+ }
+ if (isNull(tyvars)) {
+ ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
+ EEND;
+ }
+ return mkOffset(offset);
+}
+
+/* --------------------------------------------------------------------------
+ * Check for ambiguous types:
+ * A type Preds => type is ambiguous if not (TV(P) `subset` TV(type))
+ * ------------------------------------------------------------------------*/
+
+Bool isAmbiguous(type) /* Determine whether type is */
+Type type; { /* ambiguous */
+ if (isPolyType(type)) {
+ type = monotypeOf(type);
+ }
+ if (whatIs(type)==QUAL) { /* only qualified types can be */
+ List tvps = offsetTyvarsIn(fst(snd(type)),NIL); /* ambiguous */
+ List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
+ while (nonNull(tvps) && cellIsMember(hd(tvps),tvts)) {
+ tvps = tl(tvps);
+ }
+ return nonNull(tvps);
+ }
+ return FALSE;
+}
+
+Void ambigError(line,where,e,type) /* produce error message for */
+Int line; /* ambiguity */
+String where;
+Cell e;
+Type type; {
+ ERRMSG(line) "Ambiguous type signature in %s", where ETHEN
+ ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
+ if (nonNull(e)) {
+ ERRTEXT "\n*** assigned to : " ETHEN ERREXPR(e);
+ }
+ ERRTEXT "\n"
+ EEND;
+}
+
+/* --------------------------------------------------------------------------
+ * Kind inference for simple types:
+ * ------------------------------------------------------------------------*/
+
+static Void local kindConstr(line,alpha,m,c)
+Int line; /* Determine kind of constructor */
+Int alpha;
+Int m;
+Cell c; {
+ Cell h = getHead(c);
+ Int n = argCount;
+
+#ifdef DEBUG_KINDS
+ printf("kindConstr: alpha=%d, m=%d, c=",alpha,m);
+ printType(stdout,c);
+ printf("\n");
+#endif
+
+ switch (whatIs(h)) {
+ case POLYTYPE : if (n!=0) {
+ internal("kindConstr1");
+ } else {
+ static String pt = "polymorphic type";
+ Type t = dropRank1(c,alpha,m);
+ Kinds ks = polySigOf(t);
+ Int m1 = 0;
+ Int beta;
+ for (; isAp(ks); ks=tl(ks))
+ m1++;
+ beta = newKindvars(m1);
+ unkindTypes = cons(pair(mkInt(beta),t),unkindTypes);
+ checkKind(line,beta,m1,monotypeOf(t),NIL,pt,STAR,0);
+ }
+ return;
+
+ case QUAL : if (n!=0) {
+ internal("kindConstr2");
+ }
+ map3Proc(kindPred,line,alpha,m,fst(snd(c)));
+ kindConstr(line,alpha,m,snd(snd(c)));
+ return;
+
+ case EXIST :
+ case RANK2 : kindConstr(line,alpha,m,snd(snd(c)));
+ return;
+
+#if TREX
+ case EXT : if (n!=2) {
+ ERRMSG(line)
+ "Illegal use of row in " ETHEN ERRTYPE(c);
+ ERRTEXT "\n"
+ EEND;
+ }
+ break;
+#endif
+
+ case TYCON : if (isSynonym(h) && n<tycon(h).arity) {
+ ERRMSG(line)
+ "Not enough arguments for type synonym \"%s\"",
+ textToStr(tycon(h).text)
+ EEND;
+ }
+ break;
+ }
+
+ if (n==0) { /* trivial case, no arguments */
+ typeIs = kindAtom(alpha,c);
+ } else { /* non-trivial application */
+ static String app = "constructor application";
+ Cell a = c;
+ Int i;
+ Kind k;
+ Int beta;
+
+ varKind(n);
+ beta = typeOff;
+ k = typeIs;
+
+ typeIs = kindAtom(alpha,h); /* h :: v1 -> ... -> vn -> w */
+ shouldKind(line,h,c,app,k,beta);
+
+ for (i=n; i>0; --i) { /* ci :: vi for each 1 <- 1..n */
+ checkKind(line,alpha,m,arg(a),c,app,aVar,beta+i-1);
+ a = fun(a);
+ }
+ tyvarType(beta+n); /* inferred kind is w */
+ }
+}
+
+static Kind local kindAtom(alpha,c) /* Find kind of atomic constructor */
+Int alpha;
+Cell c; {
+ switch (whatIs(c)) {
+ case TUPLE : return simpleKind(tupleOf(c)); /*(,)::* -> * -> * */
+ case OFFSET : return mkInt(alpha+offsetOf(c));
+ case TYCON : return tycon(c).kind;
+ case INTCELL : return c;
+ case VARIDCELL :
+ case VAROPCELL : { Cell vt = findBtyvs(textOf(c));
+ if (nonNull(vt)) {
+ return snd(vt);
+ }
+ }
+#if TREX
+ case EXT : return extKind;
+#endif
+ }
+#if DEBUG_KINDS
+ printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c));
+ printType(stdout,c);
+ printf("\n");
+#endif
+ internal("kindAtom");
+ return STAR;/* not reached */
+}
+
+static Void local kindPred(l,alpha,m,pi)/* Check kinds of arguments in pred*/
+Int l;
+Int alpha;
+Int m;
+Cell pi; {
+#if TREX
+ if (isExt(fun(pi))) {
+ static String lackspred = "lacks predicate";
+ checkKind(l,alpha,m,arg(pi),NIL,lackspred,ROW,0);
+ return;
+ }
+#endif
+ { static String predicate = "class constraint";
+ Class c = getHead(pi);
+ List as = getArgs(pi);
+ Kinds ks = cclass(c).kinds;
+
+ while (nonNull(ks)) {
+ checkKind(l,alpha,m,hd(as),NIL,predicate,hd(ks),0);
+ ks = tl(ks);
+ as = tl(as);
+ }
+ }
+}
+
+static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
+Int line; /* is well-kinded */
+String wh;
+Type type; {
+ checkKind(line,0,0,type,NIL,wh,STAR,0);
+}
+
+static Void local fixKinds() { /* add kind annotations to types */
+ for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
+ Pair pr = hd(unkindTypes);
+ Int beta = intOf(fst(pr));
+ Cell qts = polySigOf(snd(pr));
+ for (;;) {
+ if (isNull(hd(qts))) {
+ hd(qts) = copyKindvar(beta++);
+ } else {
+ internal("fixKinds");
+ }
+ if (nonNull(tl(qts))) {
+ qts = tl(qts);
+ } else {
+ tl(qts) = STAR;
+ break;
+ }
+ }
+#ifdef DEBUG_KINDS
+ printf("Type expression: ");
+ printType(stdout,snd(pr));
+ printf(" :: ");
+ printKind(stdout,polySigOf(snd(pr)));
+ printf("\n");
+#endif
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Kind checking of groups of type constructors and classes:
+ * ------------------------------------------------------------------------*/
+
+static Void local kindTCGroup(tcs) /* find kinds for mutually rec. gp */
+List tcs; { /* of tycons and classes */
+ emptySubstitution();
+ unkindTypes = NIL;
+ mapProc(initTCKind,tcs);
+ mapProc(kindTC,tcs);
+ mapProc(genTC,tcs);
+ fixKinds();
+ emptySubstitution();
+}
+
+static Void local initTCKind(c) /* build initial kind/arity for c */
+Cell c; {
+ if (isTycon(c)) { /* Initial kind of tycon is: */
+ Int beta = newKindvars(1); /* v1 -> ... -> vn -> vn+1 */
+ varKind(tycon(c).arity); /* where n is the arity of c. */
+ bindTv(beta,typeIs,typeOff); /* For data definitions, vn+1 == * */
+ switch (whatIs(tycon(c).what)) {
+ case NEWTYPE :
+ case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
+ }
+ tycon(c).kind = mkInt(beta);
+ } else {
+ Int n = cclass(c).arity;
+ Int beta = newKindvars(n);
+ cclass(c).kinds = NIL;
+ do {
+ n--;
+ cclass(c).kinds = pair(mkInt(beta+n),cclass(c).kinds);
+ } while (n>0);
+ }
+}
+
+static Void local kindTC(c) /* check each part of a tycon/class*/
+Cell c; { /* is well-kinded */
+ if (isTycon(c)) {
+ static String cfun = "constructor function";
+ static String tsyn = "synonym definition";
+ Int line = tycon(c).line;
+ Int beta = tyvar(intOf(tycon(c).kind))->offs;
+ Int m = tycon(c).arity;
+ switch (whatIs(tycon(c).what)) {
+ case NEWTYPE :
+ case DATATYPE : { List cs = tycon(c).defn;
+ if (whatIs(cs)==QUAL) {
+ map3Proc(kindPred,line,beta,m,
+ fst(snd(cs)));
+ tycon(c).defn = cs = snd(snd(cs));
+ }
+ for (; hasCfun(cs); cs=tl(cs)) {
+ kindType(line,cfun,name(hd(cs)).type);
+ }
+ break;
+ }
+
+ default : checkKind(line,beta,m,tycon(c).defn,NIL,
+ tsyn,aVar,beta+m);
+ }
+ }
+ else { /* scan type exprs in class defn to*/
+ List ms = cclass(c).members; /* determine the class signature */
+ Int m = cclass(c).arity;
+ Int beta = newKindvars(m);
+ kindPred(cclass(c).line,beta,m,cclass(c).head);
+ map3Proc(kindPred,cclass(c).line,beta,m,cclass(c).supers);
+ for (; nonNull(ms); ms=tl(ms)) {
+ Int line = intOf(fst3(hd(ms)));
+ Type type = thd3(hd(ms));
+ kindType(line,"member function type signature",type);
+ }
+ }
+}
+
+static Void local genTC(c) /* generalise kind inferred for */
+Cell c; { /* given tycon/class */
+ if (isTycon(c)) {
+ tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
+#ifdef DEBUG_KINDS
+ printf("%s :: ",textToStr(tycon(c).text));
+ printKind(stdout,tycon(c).kind);
+ putchar('\n');
+#endif
+ } else {
+ Kinds ks = cclass(c).kinds;
+ for (; nonNull(ks); ks=tl(ks)) {
+ hd(ks) = copyKindvar(intOf(hd(ks)));
+ }
+#ifdef DEBUG_KINDS
+ printf("%s :: ",textToStr(cclass(c).text));
+ printKinds(stdout,cclass(c).kinds);
+ putchar('\n');
+#endif
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Static analysis of instance declarations:
+ *
+ * The first part of the static analysis is performed as the declarations
+ * are read during parsing:
+ * - make new entry in instance table
+ * - record line number of declaration
+ * - build list of instances defined in current script for use in later
+ * stages of static analysis.
+ * ------------------------------------------------------------------------*/
+
+Void instDefn(line,head,ms) /* process new instance definition */
+Int line; /* definition line number */
+Cell head; /* inst header :: (context,Class) */
+List ms; { /* instance members */
+ Inst nw = newInst();
+ inst(nw).line = line;
+ inst(nw).specifics = fst(head);
+ inst(nw).head = snd(head);
+ inst(nw).implements = ms;
+ instDefns = cons(nw,instDefns);
+}
+
+/* --------------------------------------------------------------------------
+ * Further static analysis of instance declarations:
+ *
+ * Makes the following checks:
+ * - Class part of header has form C (T a1 ... an) where C is a known
+ * class, and T is a known datatype constructor (or restricted synonym),
+ * and there is no previous C-T instance, and (T a1 ... an) has a kind
+ * appropriate for the class C.
+ * - Each element of context is a valid class expression, with type vars
+ * drawn from a1, ..., an.
+ * - All bindings are function bindings
+ * - All bindings define member functions for class C
+ * - Arrange bindings into appropriate order for member list
+ * - No top level type signature declarations
+ * ------------------------------------------------------------------------*/
+
+Bool allowOverlap = FALSE; /* TRUE => allow overlapping insts */
+
+static Void local checkInstDefn(in) /* Validate instance declaration */
+Inst in; {
+ Int line = inst(in).line;
+ List tyvars = typeVarsIn(inst(in).head,NIL,NIL);
+
+ depPredExp(line,tyvars,inst(in).head);
+ map2Proc(depPredExp,line,tyvars,inst(in).specifics);
+ inst(in).numSpecifics = length(inst(in).specifics);
+ inst(in).c = getHead(inst(in).head);
+ if (!isClass(inst(in).c)) {
+ ERRMSG(line) "Illegal predicate in instance declaration"
+ EEND;
+ }
+#if EVAL_INSTANCES
+ if (inst(in).c==classEval) {
+ ERRMSG(line) "Instances of class \"%s\" are generated automatically",
+ textToStr(cclass(inst(in).c).text)
+ EEND;
+ }
+#endif
+ kindInst(in,length(tyvars));
+ insertInst(in);
+
+ if (nonNull(extractSigdecls(inst(in).implements))) {
+ ERRMSG(line) "Type signature decls not permitted in instance decl"
+ EEND;
+ }
+ inst(in).implements = classBindings("instance",
+ inst(in).c,
+ extractBindings(inst(in).implements));
+ inst(in).builder = newInstImp(in);
+}
+
+static Void local insertInst(in) /* Insert instance into class */
+Inst in; {
+ Class c = inst(in).c;
+ List ins = cclass(c).instances;
+ List prev = NIL;
+
+ substitution(RESET);
+ while (nonNull(ins)) { /* Look for overlap w/ other insts */
+ Int alpha = newKindedVars(inst(in).kinds);
+ Int beta = newKindedVars(inst(hd(ins)).kinds);
+ if (unifyPred(inst(in).head,alpha,inst(hd(ins)).head,beta)) {
+ Cell pi = copyPred(inst(in).head,alpha);
+ if (allowOverlap) { /* So long as one is more specific */
+ Bool bef = instCompare(in,hd(ins));
+ Bool aft = instCompare(hd(ins),in);
+ if (bef && !aft) { /* in comes strictly before hd(ins)*/
+ break;
+ }
+ if (aft && !bef) { /* in comes strictly after hd(ins) */
+ prev = ins;
+ ins = tl(ins);
+ continue;
+ }
+ }
+ ERRMSG(inst(in).line) "Overlapping instances for class \"%s\"",
+ textToStr(cclass(c).text)
+ ETHEN
+ ERRTEXT "\n*** This instance : " ETHEN ERRPRED(inst(in).head);
+ ERRTEXT "\n*** Overlaps with : " ETHEN
+ ERRPRED(inst(hd(ins)).head);
+ ERRTEXT "\n*** Common instance : " ETHEN
+ ERRPRED(pi);
+ ERRTEXT "\n"
+ EEND;
+ }
+ prev = ins; /* No overlap detected, so move on */
+ ins = tl(ins); /* to next instance */
+ }
+ substitution(RESET);
+
+ if (nonNull(prev)) { /* Insert instance at this point */
+ tl(prev) = cons(in,ins);
+ } else {
+ cclass(c).instances = cons(in,ins);
+ }
+}
+
+static Bool local instCompare(ia,ib) /* See if ia is an instance of ib */
+Inst ia, ib;{
+ Int alpha = newKindedVars(inst(ia).kinds);
+ Int beta = newKindedVars(inst(ib).kinds);
+ return matchPred(inst(ia).head,alpha,inst(ib).head,beta);
+}
+
+static Name local newInstImp(in) /* Make definition for inst builder*/
+Inst in; {
+ Name b = newName(inventText());
+ name(b).line = inst(in).line;
+ name(b).arity = inst(in).numSpecifics;
+ name(b).number = DFUNNAME;
+ return b;
+}
+
+/* --------------------------------------------------------------------------
+ * Kind checking of instance declaration headers:
+ * ------------------------------------------------------------------------*/
+
+static Void local kindInst(in,freedom) /* check predicates in instance */
+Inst in;
+Int freedom; {
+ Int beta;
+
+ emptySubstitution();
+ beta = newKindvars(freedom);
+ kindPred(inst(in).line,beta,freedom,inst(in).head);
+ if (whatIs(inst(in).specifics)!=DERIVE) {
+ map3Proc(kindPred,inst(in).line,beta,freedom,inst(in).specifics);
+ }
+ for (inst(in).kinds = NIL; 0<freedom--; ) {
+ inst(in).kinds = cons(copyKindvar(beta+freedom),inst(in).kinds);
+ }
+#ifdef DEBUG_KINDS
+ printf("instance ");
+ printPred(stdout,inst(in).head);
+ printf(" :: ");
+ printKinds(stdout,inst(in).kinds);
+ putchar('\n');
+#endif
+ emptySubstitution();
+}
+
+/* --------------------------------------------------------------------------
+ * Process derived instance requests:
+ * ------------------------------------------------------------------------*/
+
+static List derivedInsts; /* list of derived instances */
+
+static Void local checkDerive(t,p,ts,ct)/* verify derived instance request */
+Tycon t; /* for tycon t, with explicit */
+List p; /* context p, component types ts */
+List ts; /* and named class ct */
+Cell ct; {
+ Int line = tycon(t).line;
+ Class c = findClass(textOf(ct));
+ if (isNull(c)) {
+ ERRMSG(line) "Unknown class \"%s\" in derived instance",
+ textToStr(textOf(ct))
+ EEND;
+ }
+ addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
+}
+
+static Void local addDerInst(line,c,p,cts,t,a) /* Add a derived instance */
+Int line;
+Class c;
+List p, cts;
+Type t;
+Int a; {
+ Inst in;
+ Cell head = t; /* Build instance head */
+ Int i = 0;
+
+ for (; i<a; i++) {
+ head = ap(head,mkOffset(i));
+ }
+ head = ap(c,head);
+
+ in = newInst();
+ inst(in).c = c;
+ inst(in).line = line;
+ inst(in).head = head;
+ inst(in).specifics = ap(DERIVE,pair(dupList(p),cts));
+ inst(in).implements = NIL;
+ inst(in).kinds = mkInt(a);
+ derivedInsts = cons(in,derivedInsts);
+}
+
+Void addTupInst(c,n) /* Request derived instance of c */
+Class c; /* for mkTuple(n) constructor */
+Int n; {
+ Int m = n;
+ List cts = NIL;
+ while (0<m--) {
+ cts = cons(mkOffset(m),cts);
+ }
+ cts = rev(cts);
+ addDerInst(0,c,NIL,cts,mkTuple(n),n);
+}
+
+#if EVAL_INSTANCES
+/* ADR addition */
+static List evalInsts = NIL;
+
+Void addEvalInst(line,t,arity,ctxt) /* Add dummy instance for Eval */
+Int line;
+Cell t;
+Int arity;
+List ctxt; {
+ Inst in = newInst();
+ Cell head = t;
+ Int i;
+ for (i=0; i<arity; i++) {
+ head = ap(head,mkOffset(i));
+ }
+ inst(in).line = line;
+ inst(in).c = classEval;
+ inst(in).head = ap(classEval,head);
+ inst(in).specifics = ctxt;
+ inst(in).builder = newInstImp(in);
+ inst(in).numSpecifics = length(ctxt);
+ kindInst(in,arity);
+ cclass(classEval).instances
+ = appendOnto(cclass(classEval).instances,singleton(in));
+ /* ADR addition */
+ evalInsts = cons(in,evalInsts);
+}
+#endif
+
+#if TREX
+Inst addRecShowInst(c,e) /* Generate instance for ShowRecRow*/
+Class c; /* c *must* be ShowRecRow */
+Ext e; {
+ Inst in = newInst();
+ inst(in).c = c;
+ inst(in).head = ap(c,ap2(e,mkOffset(0),mkOffset(1)));
+ inst(in).kinds = extKind;
+ inst(in).specifics = cons(ap(classShow,mkOffset(0)),
+ cons(ap(e,mkOffset(1)),
+ cons(ap(c,mkOffset(1)),NIL)));
+ inst(in).numSpecifics = 3;
+ inst(in).builder = implementRecShw(extText(e));
+ cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
+ return in;
+}
+
+Inst addRecEqInst(c,e) /* Generate instance for EqRecRow */
+Class c; /* c *must* be EqRecRow */
+Ext e; {
+ Inst in = newInst();
+ inst(in).c = c;
+ inst(in).head = ap(c,ap2(e,mkOffset(0),mkOffset(1)));
+ inst(in).kinds = extKind;
+ inst(in).specifics = cons(ap(classEq,mkOffset(0)),
+ cons(ap(e,mkOffset(1)),
+ cons(ap(c,mkOffset(1)),NIL)));
+ inst(in).numSpecifics = 3;
+ inst(in).builder = implementRecEq(extText(e));
+ cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
+ return in;
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Calculation of contexts for derived instances:
+ *
+ * Allowing arbitrary types to appear in contexts makes it rather harder
+ * to decide what the context for a derived instance should be. For
+ * example, given:
+ *
+ * data T a = MkT [a] deriving Show,
+ *
+ * we could have either of the following:
+ *
+ * instance (Show [a]) => Show (T a) where ...
+ * instance (Show a) => Show (T a) where ...
+ *
+ * (assuming, of course, that instance (Show a) => Show [a]). For now, we
+ * choose to reduce contexts in the hope of detecting errors at an earlier
+ * stage---in contrast with value definitions, there is no way for a user
+ * to provide something analogous to a `type signature' by which they might
+ * be able to control this behaviour themselves. We eliminate tautological
+ * predicates, but only allow predicates to appear in the final result if
+ * they have at least one argument with a variable at its head.
+ *
+ * In general, we have to deal with mutually recursive instance declarations.
+ * We find a solution in the obvious way by iterating to find a fixed point.
+ * Of course, without restrictions on the form of instance declarations, we
+ * cannot be sure that this will always terminate!
+ *
+ * For each instance we maintain a pair of the form DERIVE (ctxt,ps).
+ * Ctxt is a list giving the parts of the context that have been produced
+ * so far in the form of predicate skeletons. During the calculation of
+ * derived instances, we attach a dummy NIL value to the end of the list
+ * which acts as a kind of `variable': other parts of the system maintain
+ * pointers to this variable, and use it to detect when the context has
+ * been extended with new elements. Meanwhile, ps is a list containing
+ * predicates (pi,o) together with (delayed) substitutions of the form
+ * (o,xs) where o is an offset and xs is one of the context variables
+ * described above, which may have been partially instantiated.
+ * ------------------------------------------------------------------------*/
+
+static Bool instsChanged;
+
+static Void local deriveContexts(is) /* Calc contexts for derived insts */
+List is; {
+ emptySubstitution();
+ mapProc(initDerInst,is); /* Prepare derived instances */
+
+ do { /* Main calculation of contexts */
+ instsChanged = FALSE;
+ mapProc(calcInstPreds,is);
+ } while (instsChanged);
+
+ mapProc(tidyDerInst,is); /* Tidy up results */
+#if DERIVE_SHOW | DERIVE_READ
+ cfunSfuns = NIL; /* Only needed to derive Read/Show */
+#endif
+}
+
+static Void local initDerInst(in) /* Prepare instance for calculation*/
+Inst in; { /* of derived instance context */
+ Cell spcs = inst(in).specifics;
+ Int beta = newKindedVars(inst(in).kinds);
+ if (whatIs(spcs)!=DERIVE) {
+ internal("initDerInst");
+ }
+ fst(snd(spcs)) = appendOnto(fst(snd(spcs)),singleton(NIL));
+ for (spcs=snd(snd(spcs)); nonNull(spcs); spcs=tl(spcs)) {
+ hd(spcs) = ap2(inst(in).c,hd(spcs),mkInt(beta));
+ }
+ inst(in).numSpecifics = beta;
+
+#ifdef DEBUG_DERIVING
+ printf("initDerInst: ");
+ printPred(stdout,inst(in).head);
+ printf("\n");
+ printContext(stdout,snd(snd(inst(in).specifics)));
+ printf("\n");
+#endif
+}
+
+static Void local calcInstPreds(in) /* Calculate next approximation */
+Inst in; { /* of the context for a derived */
+ List retain = NIL; /* instance */
+ List ps = snd(snd(inst(in).specifics));
+ List spcs = fst(snd(inst(in).specifics));
+ Int beta = inst(in).numSpecifics;
+
+#ifdef DEBUG_DERIVING
+ printf("calcInstPreds: ");
+ printPred(stdout,inst(in).head);
+ printf("\n");
+#endif
+
+ while (nonNull(ps)) {
+ Cell p = hd(ps);
+ ps = tl(ps);
+ if (isInt(fst(p))) { /* Delayed substitution? */
+ List qs = snd(p);
+ for (; nonNull(hd(qs)); qs=tl(qs)) {
+ ps = cons(pair(hd(qs),fst(p)),ps);
+ }
+ retain = cons(pair(fst(p),qs),retain);
+ }
+#if TREX
+ else if (isExt(fun(fst(p)))) { /* Lacks predicate */
+ Text l = extText(fun(fst(p)));
+ Type t = arg(fst(p));
+ Int o = intOf(snd(p));
+ Type h;
+ Tyvar *tyv;
+
+ deRef(tyv,t,o);
+ h = getDerefHead(t,o);
+ while (isExt(h) && argCount==2 && l!=extText(h)) {
+ t = arg(t);
+ deRef(tyv,t,o);
+ h = getDerefHead(t,o);
+ }
+ if (argCount==0 && isOffset(h)) {
+ maybeAddPred(ap(fun(fun(p)),h),o,beta,spcs);
+ } else if (argCount!=0 || h!=typeNoRow) {
+ Cell bpi = inst(in).head;
+ Cell pi = copyPred(fun(p),intOf(snd(p)));
+ ERRMSG(inst(in).line) "Cannot derive " ETHEN ERRPRED(bpi);
+ ERRTEXT " because predicate " ETHEN ERRPRED(pi);
+ ERRTEXT " does not hold\n"
+ EEND;
+ }
+ }
+#endif
+ else { /* Class predicate */
+ Cell pi = fst(p);
+ Int o = intOf(snd(p));
+ Inst in1 = findInstFor(pi,o);
+ if (nonNull(in1)) {
+ List qs = inst(in1).specifics;
+ Int off = mkInt(typeOff);
+ if (whatIs(qs)==DERIVE) { /* Still being derived */
+ for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs))
+ ps = cons(pair(hd(qs),off),ps);
+ retain = cons(pair(off,qs),retain);
+ } else { /* Previously def'd inst */
+ for (; nonNull(qs); qs=tl(qs)) {
+ ps = cons(pair(hd(qs),off),ps);
+ }
+ }
+ } else { /* No matching instance */
+ Cell qi = pi;
+ while (isAp(qi) && isOffset(getDerefHead(arg(qi),o))) {
+ qi = fun(qi);
+ }
+ if (isAp(qi)) {
+ Cell bpi = inst(in).head;
+ pi = copyPred(pi,o);
+ ERRMSG(inst(in).line) "An instance of " ETHEN ERRPRED(pi);
+ ERRTEXT " is required to derive " ETHEN ERRPRED(bpi);
+ ERRTEXT "\n"
+ EEND;
+ } else {
+ maybeAddPred(pi,o,beta,spcs);
+ }
+ }
+ }
+ }
+ snd(snd(inst(in).specifics)) = retain;
+}
+
+static Void local maybeAddPred(pi,o,beta,ps)
+Cell pi; /* Add predicate pi to the list ps,*/
+Int o; /* setting the instsChanged flag if*/
+Int beta; /* pi is not already a member and */
+List ps; { /* using beta to adjust vars */
+ Cell c = getHead(pi);
+ for (; nonNull(ps); ps=tl(ps)) {
+ if (isNull(hd(ps))) { /* reached the `dummy' end of list?*/
+ hd(ps) = copyAdj(pi,o,beta);
+ tl(ps) = pair(NIL,NIL);
+ instsChanged = TRUE;
+ return;
+ } else if (c==getHead(hd(ps)) && samePred(pi,o,hd(ps),beta)) {
+ return;
+ }
+ }
+}
+
+static Cell local copyAdj(c,o,beta) /* Copy (c,o), replacing vars with */
+Cell c; /* offsets relative to beta. */
+Int o;
+Int beta; {
+ switch (whatIs(c)) {
+ case AP : { Cell l = copyAdj(fst(c),o,beta);
+ Cell r = copyAdj(snd(c),o,beta);
+ return ap(l,r);
+ }
+
+ case OFFSET : { Int vn = o+offsetOf(c);
+ Tyvar *tyv = tyvar(vn);
+ if (isBound(tyv)) {
+ return copyAdj(tyv->bound,tyv->offs,beta);
+ }
+ vn -= beta;
+ if (vn<0 || vn>=NUM_OFFSETS) {
+ internal("copyAdj");
+ }
+ return mkOffset(vn);
+ }
+ }
+ return c;
+}
+
+static Void local tidyDerInst(in) /* Tidy up results of derived inst */
+Inst in; { /* calculations */
+ Int o = inst(in).numSpecifics;
+ List ps = tl(rev(fst(snd(inst(in).specifics))));
+ clearMarks();
+ copyPred(inst(in).head,o);
+ inst(in).specifics = simpleContext(ps,o);
+ inst(in).numSpecifics = length(inst(in).specifics);
+
+#ifdef DEBUG_DERIVING
+ printf("Derived instance: ");
+ printContext(stdout,inst(in).specifics);
+ printf(" ||- ");
+ printPred(stdout,inst(in).head);
+ printf("\n");
+#endif
+}
+
+/* --------------------------------------------------------------------------
+ * Generate code for derived instances:
+ * ------------------------------------------------------------------------*/
+
+static Void local addDerivImp(in)
+Inst in; {
+ List imp = NIL;
+ Type t = getHead(arg(inst(in).head));
+ Class c = inst(in).c;
+#if DERIVE_EQ
+ if (c==classEq)
+ imp = deriveEq(t);
+ else
+#endif
+#if DERIVE_ORD
+ if (c==classOrd)
+ imp = deriveOrd(t);
+ else
+#endif
+#if DERIVE_ENUM
+ if (c==classEnum)
+ imp = deriveEnum(t);
+ else
+#endif
+#if DERIVE_IX
+ if (c==classIx)
+ imp = deriveIx(t);
+ else
+#endif
+#if DERIVE_SHOW
+ if (c==classShow)
+ imp = deriveShow(t);
+ else
+#endif
+#if DERIVE_READ
+ if (c==classRead)
+ imp = deriveRead(t);
+ else
+#endif
+#if DERIVE_BOUNDED
+ if (c==classBounded)
+ imp = deriveBounded(t);
+ else
+#endif
+ {
+ ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"",
+ textToStr(cclass(inst(in).c).text)
+ EEND;
+ }
+
+ kindInst(in,intOf(inst(in).kinds));
+ insertInst(in);
+ inst(in).builder = newInstImp(in);
+ inst(in).implements = classBindings("derived instance",
+ inst(in).c,
+ imp);
+}
+
+/* --------------------------------------------------------------------------
+ * Default definitions; only one default definition is permitted in a
+ * given script file. If no default is supplied, then a standard system
+ * default will be used where necessary.
+ * ------------------------------------------------------------------------*/
+
+Void defaultDefn(line,defs) /* Handle default types definition */
+Int line;
+List defs; {
+ if (defaultLine!=0) {
+ ERRMSG(line) "Multiple default declarations are not permitted in" ETHEN
+ ERRTEXT "a single script file.\n"
+ EEND;
+ }
+ defaultDefns = defs;
+ defaultLine = line;
+}
+
+static Void local checkDefaultDefns() { /* check that default types are */
+ List ds = NIL; /* well-kinded instances of Num */
+
+ if (defaultLine!=0) {
+ map2Over(depTypeExp,defaultLine,NIL,defaultDefns);
+ emptySubstitution();
+ unkindTypes = NIL;
+ map2Proc(kindType,defaultLine,"default type",defaultDefns);
+ fixKinds();
+ emptySubstitution();
+ mapOver(fullExpand,defaultDefns);
+ } else {
+ defaultDefns = stdDefaults;
+ }
+ for (ds=defaultDefns; nonNull(ds); ds=tl(ds)) {
+ if (isNull(provePred(NIL,NIL,ap(classNum,hd(ds))))) {
+ ERRMSG(defaultLine)
+ "Default types must be instances of the Num class"
+ EEND;
+ }
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
+ * They are used to "import" C functions into a module.
+ * They are usually not written by hand but, rather, generated automatically
+ * by GreenCard, IDL compilers or whatever.
+ *
+ * Foreign export declarations generate C wrappers for Hugs functions.
+ * Hugs only provides "foreign export dynamic" because it's not obvious
+ * what "foreign export static" would mean in an interactive setting.
+ * ------------------------------------------------------------------------*/
+
+Void foreignImport(line,extName,intName,type) /* Handle foreign imports */
+Cell line;
+Pair extName;
+Cell intName;
+Cell type; {
+ Text t = textOf(intName);
+ Name n = findName(t);
+ Int l = intOf(line);
+
+ if (isNull(n)) {
+ n = newName(t);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
+ EEND;
+ }
+ name(n).line = l;
+ name(n).defn = extName;
+ name(n).type = type;
+ foreignImports = cons(n,foreignImports);
+}
+
+static Void local checkForeignImport(p) /* Check foreign import */
+Name p; {
+ emptySubstitution();
+ name(p).type = checkSigType(name(p).line,
+ "foreign import declaration",
+ p,
+ name(p).type);
+ /* We don't expand synonyms here because we don't want the IO
+ * part to be expanded.
+ * name(p).type = fullExpand(name(p).type);
+ */
+ implementForeignImport(p);
+}
+
+Void foreignExport(line,extName,intName,type)/* Handle foreign exports */
+Cell line;
+Cell extName;
+Cell intName;
+Cell type; {
+ Text t = textOf(intName);
+ Name n = findName(t);
+ Int l = intOf(line);
+
+ if (isNull(n)) {
+ n = newName(t);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
+ EEND;
+ }
+ name(n).line = l;
+ name(n).defn = NIL; /* nothing to say */
+ name(n).type = type;
+ foreignExports = cons(n,foreignExports);
+}
+
+static Void local checkForeignExport(p) /* Check foreign export */
+Name p; {
+ emptySubstitution();
+ name(p).type = checkSigType(name(p).line,
+ "foreign export declaration",
+ p,
+ name(p).type);
+ implementForeignExport(p);
+}
+
+/* --------------------------------------------------------------------------
+ * Static analysis of patterns:
+ *
+ * Patterns are parsed as ordinary (atomic) expressions. Static analysis
+ * makes the following checks:
+ * - Patterns are well formed (according to pattern syntax), including the
+ * special case of (n+k) patterns.
+ * - All constructor functions have been defined and are used with the
+ * correct number of arguments.
+ * - No variable name is used more than once in a pattern.
+ *
+ * The list of pattern variables occuring in each pattern is accumulated in
+ * a global list `patVars', which must be initialised to NIL at appropriate
+ * points before using these routines to check for valid patterns. This
+ * mechanism enables the pattern checking routine to be mapped over a list
+ * of patterns, ensuring that no variable occurs more than once in the
+ * complete pattern list (as is required on the lhs of a function defn).
+ * ------------------------------------------------------------------------*/
+
+static List patVars; /* List of vars bound in pattern */
+
+static Cell local checkPat(line,p) /* Check valid pattern syntax */
+Int line;
+Cell p; {
+ switch (whatIs(p)) {
+ case VARIDCELL :
+ case VAROPCELL : addPatVar(line,p);
+ break;
+
+ case AP : return checkMaybeCnkPat(line,p);
+
+ case NAME :
+ case QUALIDENT :
+ case CONIDCELL :
+ case CONOPCELL : return checkApPat(line,0,p);
+
+ case WILDCARD :
+ case STRCELL :
+ case CHARCELL :
+ case INTCELL :
+ case BIGCELL :
+ case FLOATCELL : break;
+
+ case ASPAT : addPatVar(line,fst(snd(p)));
+ snd(snd(p)) = checkPat(line,snd(snd(p)));
+ break;
+
+ case LAZYPAT : snd(p) = checkPat(line,snd(p));
+ break;
+
+ case FINLIST : map1Over(checkPat,line,snd(p));
+ break;
+
+ case CONFLDS : depConFlds(line,p,TRUE);
+ break;
+
+ case ESIGN : { Type t = snd(snd(p));
+ List tvs = typeVarsIn(t,NIL,NIL);
+ for (; nonNull(tvs); tvs=tl(tvs)) {
+ Int beta = newKindvars(1);
+ hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)),
+ hd(btyvars));
+ }
+ t = checkSigType(line,
+ "pattern type",
+ fst(snd(p)),
+ t);
+ if (isPolyType(t)
+ || whatIs(t)==QUAL
+ || whatIs(t)==RANK2) {
+ ERRMSG(line)
+ "Illegal type in pattern annotation"
+ EEND;
+ }
+ snd(snd(p)) = t;
+ fst(snd(p)) = checkPat(line,fst(snd(p)));
+ }
+ break;
+
+ default : ERRMSG(line) "Illegal pattern syntax"
+ EEND;
+ }
+ return p;
+}
+
+static Cell local checkMaybeCnkPat(l,p) /* Check applicative pattern with */
+Int l; /* the possibility of n+k pattern */
+Cell p; {
+#if NPLUSK
+ Cell h = getHead(p);
+
+ if (argCount==2 && isVar(h) && textOf(h)==textPlus) { /* n+k */
+ Cell v = arg(fun(p));
+ if (!isInt(arg(p)) && !isBignum(arg(p))) {
+ ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
+ EEND;
+ }
+#if 0 /* can't call intOf - it might be a bignum */
+ if (intOf(arg(p))<=0) {
+ ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
+ EEND;
+ }
+#endif
+ overwrite2(fun(p),ADDPAT,arg(p));
+ arg(p) = checkPat(l,v);
+ return p;
+ }
+#endif
+ return checkApPat(l,0,p);
+}
+
+static Cell local checkApPat(line,args,p)
+Int line; /* check validity of application */
+Int args; /* of constructor to arguments */
+Cell p; {
+ switch (whatIs(p)) {
+ case AP : fun(p) = checkApPat(line,args+1,fun(p));
+ arg(p) = checkPat(line,arg(p));
+ break;
+
+ case TUPLE : if (tupleOf(p)!=args) {
+ ERRMSG(line) "Illegal tuple pattern"
+ EEND;
+ }
+ break;
+
+#if TREX
+ case EXT : if (args!=2) {
+ ERRMSG(line) "Illegal record pattern"
+ EEND;
+ }
+ break;
+#endif
+
+ case QUALIDENT :
+ if (!isQCon(p)) {
+ ERRMSG(line) "Illegal use of qualified variable in pattern"
+ EEND;
+ }
+ /* deliberate fall through */
+ case CONIDCELL :
+ case CONOPCELL : p = conDefined(line,p);
+ checkCfunArgs(line,p,args);
+ break;
+
+ case NAME : checkIsCfun(line,p);
+ checkCfunArgs(line,p,args);
+ break;
+
+ default : ERRMSG(line) "Illegal pattern syntax"
+ EEND;
+ }
+ return p;
+}
+
+static Void local addPatVar(line,v) /* add variable v to list of vars */
+Int line; /* in current pattern, checking for*/
+Cell v; { /* repeated variables. */
+ Text t = textOf(v);
+ List p = NIL;
+ List n = patVars;
+
+ for (; nonNull(n); p=n, n=tl(n)) {
+ if (textOf(hd(n))==t) {
+ ERRMSG(line) "Repeated variable \"%s\" in pattern",
+ textToStr(t)
+ EEND;
+ }
+ }
+ if (isNull(p)) {
+ patVars = cons(v,NIL);
+ } else {
+ tl(p) = cons(v,NIL);
+ }
+}
+
+static Name local conDefined(line,nm) /* check that nm is the name of a */
+Int line; /* previously defined constructor */
+Cell nm; { /* function. */
+ Cell c=findQualName(line,nm);
+ if (isNull(c)) {
+ ERRMSG(line) "Undefined constructor function \"%s\"", identToStr(nm)
+ EEND;
+ }
+ checkIsCfun(line,c);
+ return c;
+}
+
+static Void local checkIsCfun(line,c) /* Check that c is a constructor fn*/
+Int line;
+Name c; {
+ if (!isCfun(c)) {
+ ERRMSG(line) "\"%s\" is not a constructor function",
+ textToStr(name(c).text)
+ EEND;
+ }
+}
+
+static Void local checkCfunArgs(line,c,args)
+Int line; /* Check constructor applied with */
+Cell c; /* correct number of arguments */
+Int args; {
+ if (name(c).arity!=args) {
+ ERRMSG(line) "Constructor function \"%s\" needs %d args in pattern",
+ textToStr(name(c).text), name(c).arity
+ EEND;
+ }
+}
+
+static Cell local applyBtyvs(pat) /* Record bound type vars in pat */
+Cell pat; {
+ List bts = hd(btyvars);
+ btyvars = tl(btyvars);
+ if (nonNull(bts)) {
+ pat = ap(BIGLAM,pair(bts,pat));
+ for (; nonNull(bts); bts=tl(bts)) {
+ snd(hd(bts)) = copyKindvar(intOf(snd(hd(bts))));
+ }
+ }
+ return pat;
+}
+
+/* --------------------------------------------------------------------------
+ * Maintaining lists of bound variables and local definitions, for
+ * dependency and scope analysis.
+ * ------------------------------------------------------------------------*/
+
+static List bounds; /* list of lists of bound vars */
+static List bindings; /* list of lists of binds in scope */
+static List depends; /* list of lists of dependents */
+
+#define saveBvars() hd(bounds) /* list of bvars in current scope */
+#define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables */
+
+static Cell local bindPat(line,p) /* add new bound vars for pattern */
+Int line;
+Cell p; {
+ patVars = NIL;
+ p = checkPat(line,p);
+ hd(bounds) = revOnto(patVars,hd(bounds));
+ return p;
+}
+
+static Void local bindPats(line,ps) /* add new bound vars for patterns */
+Int line;
+List ps; {
+ patVars = NIL;
+ map1Over(checkPat,line,ps);
+ hd(bounds) = revOnto(patVars,hd(bounds));
+}
+
+/* --------------------------------------------------------------------------
+ * Before processing value and type signature declarations, all data and
+ * type definitions have been processed so that:
+ * - all valid type constructors (with their arities) are known.
+ * - all valid constructor functions (with their arities and types) are
+ * known.
+ *
+ * The result of parsing a list of value declarations is a list of Eqns:
+ * Eqn ::= (SIGDECL,(Line,[Var],type)) | (Expr,Rhs)
+ * The ordering of the equations in this list is the reverse of the original
+ * ordering in the script parsed. This is a consequence of the structure of
+ * the parser ... but also turns out to be most convenient for the static
+ * analysis.
+ *
+ * As the first stage of the static analysis of value declarations, each
+ * list of Eqns is converted to a list of Bindings. As part of this
+ * process:
+ * - The ordering of the list of Bindings produced is the same as in the
+ * original script.
+ * - When a variable (function) is defined over a number of lines, all
+ * of the definitions should appear together and each should give the
+ * same arity to the variable being defined.
+ * - No variable can have more than one definition.
+ * - For pattern bindings:
+ * - Each lhs is a valid pattern/function lhs, all constructor functions
+ * have been defined and are used with the correct number of arguments.
+ * - Each lhs contains no repeated pattern variables.
+ * - Each equation defines at least one variable (e.g. True = False is
+ * not allowed).
+ * - Types appearing in type signatures are well formed:
+ * - Type constructors used are defined and used with correct number
+ * of arguments.
+ * - type variables are replaced by offsets, type constructor names
+ * by Tycons.
+ * - Every variable named in a type signature declaration is defined by
+ * one or more equations elsewhere in the script.
+ * - No variable has more than one type declaration.
+ *
+ * ------------------------------------------------------------------------*/
+
+#define bindingType(b) fst(snd(b)) /* type (or types) for binding */
+#define fbindAlts(b) snd(snd(b)) /*alternatives for function binding*/
+
+static List local extractSigdecls(es) /* extract the SIGDECLS from list */
+List es; { /* of equations */
+ List sigDecls = NIL; /* :: [(Line,[Var],Type)] */
+
+ for(; nonNull(es); es=tl(es)) {
+ if (fst(hd(es))==SIGDECL) { /* type-declaration? */
+ Pair sig = snd(hd(es));
+ Int line = intOf(fst3(sig));
+ List vs = snd3(sig);
+ for(; nonNull(vs); vs=tl(vs)) {
+ if (isQualIdent(hd(vs))) {
+ ERRMSG(line) "Type signature for qualified variable \"%s\" is not allowed",
+ identToStr(hd(vs))
+ EEND;
+ }
+ }
+ sigDecls = cons(sig,sigDecls); /* discard SIGDECL tag */
+ }
+ }
+ return sigDecls;
+}
+
+static List local extractBindings(es) /* extract untyped bindings from */
+List es; { /* given list of equations */
+ Cell lastVar = NIL; /* = var def'd in last eqn (if any)*/
+ Int lastArity = 0; /* = number of args in last defn */
+ List bs = NIL; /* :: [Binding] */
+
+ for(; nonNull(es); es=tl(es)) {
+ Cell e = hd(es);
+
+ if (fst(e)!=SIGDECL) {
+ Int line = rhsLine(snd(e));
+ Cell lhsHead = getHead(fst(e));
+
+ switch (whatIs(lhsHead)) {
+ case VARIDCELL :
+ case VAROPCELL : { /* function-binding? */
+ Cell newAlt = pair(getArgs(fst(e)), snd(e));
+ if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
+ if (argCount!=lastArity) {
+ ERRMSG(line)
+ "Equations give different arities for \"%s\"",
+ textToStr(textOf(lhsHead))
+ EEND;
+ }
+ fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
+ }
+ else {
+ lastVar = lhsHead;
+ lastArity = argCount;
+ notDefined(line,bs,lhsHead);
+ bs = cons(pair(lhsHead,
+ pair(NIL,
+ singleton(newAlt))),
+ bs);
+ }
+ }
+ break;
+
+ case QUALIDENT: if (isQVar(lhsHead)) {
+ ERRMSG(line) "Binding for qualified variable \"%s\" not allowed",
+ identToStr(lhsHead)
+ EEND;
+ }
+ break;
+ /* deliberate fall through */
+#if TREX
+ case EXT :
+#endif
+ case CONFLDS :
+ case CONOPCELL :
+ case CONIDCELL :
+ case FINLIST :
+ case TUPLE :
+ case NAME :
+ case LAZYPAT :
+ case ASPAT : lastVar = NIL; /* pattern-binding? */
+ patVars = NIL;
+ enterBtyvs();
+ fst(e) = checkPat(line,fst(e));
+ if (isNull(patVars)) {
+ ERRMSG(line)
+ "No variables defined in lhs pattern"
+ EEND;
+ }
+ map2Proc(notDefined,line,bs,patVars);
+ bs = cons(pair(patVars,pair(NIL,e)),bs);
+ if (nonNull(hd(btyvars))) {
+ ERRMSG(line)
+ "Sorry, no type variables are allowed in pattern binding type annotations"
+ EEND;
+ }
+ leaveBtyvs();
+ break;
+
+ default : ERRMSG(line) "Improper left hand side"
+ EEND;
+ }
+ }
+ }
+ return bs;
+}
+
+static List local eqnsToBindings(es) /*Convert list of equations to list*/
+List es; { /*of typed bindings */
+ List bs = extractBindings(es);
+ map1Proc(addSigDecl,bs,extractSigdecls(es));
+ return bs;
+}
+
+static Void local notDefined(line,bs,v) /* check if name already defined in*/
+Int line; /* list of bindings */
+List bs;
+Cell v; {
+ if (nonNull(findBinding(textOf(v),bs))) {
+ ERRMSG(line) "\"%s\" multiply defined", textToStr(textOf(v))
+ EEND;
+ }
+}
+
+static Cell local findBinding(t,bs) /* look for binding for variable t */
+Text t; /* in list of bindings bs */
+List bs; {
+ for (; nonNull(bs); bs=tl(bs)) {
+ if (isVar(fst(hd(bs)))) { /* function-binding? */
+ if (textOf(fst(hd(bs)))==t) {
+ return hd(bs);
+ }
+ } else if (nonNull(varIsMember(t,fst(hd(bs))))) { /* pattern-binding? */
+ return hd(bs);
+ }
+ }
+ return NIL;
+}
+
+static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
+List bs; /* :: [Binding] */
+Cell sigDecl; { /* :: (Line,[Var],Type) */
+ Int line = intOf(fst3(sigDecl));
+ Cell vs = snd3(sigDecl);
+ Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));
+
+ map3Proc(setType,line,type,bs,vs);
+}
+
+static Void local setType(line,type,bs,v)
+Int line; /* Set type of variable */
+Cell type;
+Cell v;
+List bs; {
+ Text t = textOf(v);
+ Cell b = findBinding(t,bs);
+
+ if (isNull(b)) {
+ ERRMSG(line) "Type declaration for variable \"%s\" with no body",
+ textToStr(t)
+ EEND;
+ }
+
+ if (isVar(fst(b))) { /* function-binding? */
+ if (isNull(bindingType(b))) {
+ bindingType(b) = type;
+ return;
+ }
+ } else { /* pattern-binding? */
+ List vs = fst(b);
+ List ts = bindingType(b);
+
+ if (isNull(ts)) {
+ bindingType(b) = ts = replicate(length(vs),NIL);
+ }
+ while (nonNull(vs) && t!=textOf(hd(vs))) {
+ vs = tl(vs);
+ ts = tl(ts);
+ }
+
+ if (nonNull(vs) && isNull(hd(ts))) {
+ hd(ts) = type;
+ return;
+ }
+ }
+
+ ERRMSG(line) "Repeated type declaration for \"%s\"", textToStr(t)
+ EEND;
+}
+
+/* --------------------------------------------------------------------------
+ * To facilitate dependency analysis, lists of bindings are temporarily
+ * augmented with an additional field, which is used in two ways:
+ * - to build the `adjacency lists' for the dependency graph. Represented by
+ * a list of pointers to other bindings in the same list of bindings.
+ * - to hold strictly positive integer values (depth first search numbers) of
+ * elements `on the stack' during the strongly connected components search
+ * algorithm, or a special value mkInt(0), once the binding has been added
+ * to a particular strongly connected component.
+ *
+ * Using this extra field, the type of each list of declarations during
+ * dependency analysis is [Binding'] where:
+ *
+ * Binding' ::= (Var, (Dep, (Type, [Alt]))) -- function binding
+ * | ([Var], (Dep, ([Type], (Pat,Rhs)))) -- pattern binding
+ *
+ * ------------------------------------------------------------------------*/
+
+#define depVal(d) (fst(snd(d))) /* Access to dependency information*/
+
+static List local dependencyAnal(bs) /* Separate lists of bindings into */
+List bs; { /* mutually recursive groups in */
+ /* order of dependency */
+
+ mapProc(addDepField,bs); /* add extra field for dependents */
+ mapProc(depBinding,bs); /* find dependents of each binding */
+ bs = bscc(bs); /* sort to strongly connected comps*/
+ mapProc(remDepField,bs); /* remove dependency info field */
+ return bs;
+}
+
+static List local topDependAnal(bs) /* Like dependencyAnal(), but at */
+List bs; { /* top level, reporting on progress*/
+ List xs;
+ Int i = 0;
+
+ setGoal("Dependency analysis",(Target)(length(bs)));
+ mapProc(addDepField,bs); /* add extra field for dependents */
+ for (xs=bs; nonNull(xs); xs=tl(xs)) {
+ emptySubstitution();
+ depBinding(hd(xs));
+ soFar((Target)(i++));
+ }
+ bs = bscc(bs); /* sort to strongly connected comps*/
+ mapProc(remDepField,bs); /* remove dependency info field */
+ done();
+ return bs;
+}
+
+static Void local addDepField(b) /* add extra field to binding to */
+Cell b; { /* hold list of dependents */
+ snd(b) = pair(NIL,snd(b));
+}
+
+static Void local remDepField(bs) /* remove dependency field from */
+List bs; { /* list of bindings */
+ mapProc(remDepField1,bs);
+}
+
+static Void local remDepField1(b) /* remove dependency field from */
+Cell b; { /* single binding */
+ snd(b) = snd(snd(b));
+}
+
+static Void local clearScope() { /* initialise dependency scoping */
+ bounds = NIL;
+ bindings = NIL;
+ depends = NIL;
+}
+
+static Void local withinScope(bs) /* enter scope of bindings bs */
+List bs; {
+ bounds = cons(NIL,bounds);
+ bindings = cons(bs,bindings);
+ depends = cons(NIL,depends);
+}
+
+static Void local leaveScope() { /* leave scope of last withinScope */
+ bounds = tl(bounds);
+ bindings = tl(bindings);
+ depends = tl(depends);
+}
+
+/* --------------------------------------------------------------------------
+ * As a side effect of the dependency analysis we also make the following
+ * checks:
+ * - Each lhs is a valid pattern/function lhs, all constructor functions
+ * have been defined and are used with the correct number of arguments.
+ * - No lhs contains repeated pattern variables.
+ * - Expressions used on the rhs of an eqn should be well formed. This
+ * includes:
+ * - Checking for valid patterns (including repeated vars) in lambda,
+ * case, and list comprehension expressions.
+ * - Recursively checking local lists of equations.
+ * - No free (i.e. unbound) variables are used in the declaration list.
+ * ------------------------------------------------------------------------*/
+
+static Void local depBinding(b) /* find dependents of binding */
+Cell b; {
+ Cell defpart = snd(snd(snd(b))); /* definition part of binding */
+
+ hd(depends) = NIL;
+
+ if (isVar(fst(b))) { /* function-binding? */
+ mapProc(depAlt,defpart);
+ if (isNull(fst(snd(snd(b))))) { /* Save dep info for implicitly */
+ fst(snd(snd(b))) = ap(IMPDEPS,hd(depends)); /* typed var binds */
+ }
+ } else { /* pattern-binding? */
+ depRhs(snd(defpart));
+ }
+ depVal(b) = hd(depends);
+}
+
+static Void local depDefaults(c) /* dependency analysis on defaults */
+Class c; { /* from class definition */
+ depClassBindings(cclass(c).defaults);
+}
+
+static Void local depInsts(in) /* dependency analysis on instance */
+Inst in; { /* bindings */
+ depClassBindings(inst(in).implements);
+}
+
+static Void local depClassBindings(bs) /* dependency analysis on list of */
+List bs; { /* bindings, possibly containing */
+ for (; nonNull(bs); bs=tl(bs)) { /* NIL bindings ... */
+ if (nonNull(hd(bs))) { /* No need to add extra field for */
+ mapProc(depAlt,snd(hd(bs))); /* dependency information ... */
+ }
+ }
+}
+
+static Void local depAlt(a) /* Find dependents of alternative */
+Cell a; {
+ List obvs = saveBvars(); /* Save list of bound variables */
+ enterBtyvs();
+ bindPats(rhsLine(snd(a)),fst(a)); /* add new bound vars for patterns */
+ depRhs(snd(a)); /* find dependents of rhs */
+ fst(a) = applyBtyvs(fst(a));
+ restoreBvars(obvs); /* restore original list of bvars */
+}
+
+static Void local depRhs(r) /* Find dependents of rhs */
+Cell r; {
+ switch (whatIs(r)) {
+ case GUARDED : mapProc(depGuard,snd(r));
+ break;
+
+ case LETREC : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
+ withinScope(fst(snd(r)));
+ fst(snd(r)) = dependencyAnal(fst(snd(r)));
+ hd(depends) = fst(snd(r));
+ depRhs(snd(snd(r)));
+ leaveScope();
+ break;
+
+ default : snd(r) = depExpr(intOf(fst(r)),snd(r));
+ break;
+ }
+}
+
+static Void local depGuard(g) /*find dependents of single guarded*/
+Cell g; { /* expression */
+ depPair(intOf(fst(g)),snd(g));
+}
+
+static Cell local depExpr(line,e) /* find dependents of expression */
+Int line;
+Cell e; {
+ switch (whatIs(e)) {
+
+ case VARIDCELL :
+ case VAROPCELL : return depVar(line,e);
+
+ case CONIDCELL :
+ case CONOPCELL : return conDefined(line,e);
+
+ case QUALIDENT : if (isQVar(e)) {
+ return depQVar(line,e);
+ } else { /* QConOrConOp */
+ return conDefined(line,e);
+ }
+
+#if TREX
+ case RECSEL : break;
+
+ case AP : if (isAp(e) && isAp(fun(e)) && isExt(fun(fun(e)))) {
+ return depRecord(line,e);
+ } else {
+ Cell nx = e;
+ Cell a;
+ do {
+ a = nx;
+ arg(a) = depExpr(line,arg(a));
+ nx = fun(a);
+ } while (isAp(nx));
+ fun(a) = depExpr(line,fun(a));
+ }
+ break;
+#else
+ case AP : depPair(line,e);
+ break;
+#endif
+
+ case NAME :
+ case TUPLE :
+ case STRCELL :
+ case CHARCELL :
+ case INTCELL :
+ case BIGCELL :
+ case FLOATCELL : break;
+
+ case COND : depTriple(line,snd(e));
+ break;
+
+ case FINLIST : map1Over(depExpr,line,snd(e));
+ break;
+
+ case LETREC : fst(snd(e)) = eqnsToBindings(fst(snd(e)));
+ withinScope(fst(snd(e)));
+ fst(snd(e)) = dependencyAnal(fst(snd(e)));
+ hd(depends) = fst(snd(e));
+ snd(snd(e)) = depExpr(line,snd(snd(e)));
+ leaveScope();
+ break;
+
+ case LAMBDA : depAlt(snd(e));
+ break;
+
+ case DOCOMP : /* fall-thru */
+ case COMP : depComp(line,snd(e),snd(snd(e)));
+ break;
+
+ case ESIGN : fst(snd(e)) = depExpr(line,fst(snd(e)));
+ snd(snd(e)) = checkSigType(line,
+ "expression",
+ fst(snd(e)),
+ snd(snd(e)));
+ break;
+
+ case CASE : fst(snd(e)) = depExpr(line,fst(snd(e)));
+ map1Proc(depCaseAlt,line,snd(snd(e)));
+ break;
+
+ case CONFLDS : depConFlds(line,e,FALSE);
+ break;
+
+ case UPDFLDS : depUpdFlds(line,e);
+ break;
+
+ case ASPAT : ERRMSG(line) "Illegal `@' in expression"
+ EEND;
+
+ case LAZYPAT : ERRMSG(line) "Illegal `~' in expression"
+ EEND;
+
+ case WILDCARD : ERRMSG(line) "Illegal `_' in expression"
+ EEND;
+
+#if TREX
+ case EXT : ERRMSG(line) "Illegal application of record"
+ EEND;
+#endif
+
+ default : internal("in depExpr");
+ }
+ return e;
+}
+
+static Void local depPair(line,e) /* find dependents of pair of exprs*/
+Int line;
+Cell e; {
+ fst(e) = depExpr(line,fst(e));
+ snd(e) = depExpr(line,snd(e));
+}
+
+static Void local depTriple(line,e) /* find dependents of triple exprs */
+Int line;
+Cell e; {
+ fst3(e) = depExpr(line,fst3(e));
+ snd3(e) = depExpr(line,snd3(e));
+ thd3(e) = depExpr(line,thd3(e));
+}
+
+static Void local depComp(l,e,qs) /* find dependents of comprehension*/
+Int l;
+Cell e;
+List qs; {
+ if (isNull(qs))
+ fst(e) = depExpr(l,fst(e));
+ else {
+ Cell q = hd(qs);
+ List qs1 = tl(qs);
+ switch (whatIs(q)) {
+ case FROMQUAL : { List obvs = saveBvars();
+ snd(snd(q)) = depExpr(l,snd(snd(q)));
+ enterBtyvs();
+ fst(snd(q)) = bindPat(l,fst(snd(q)));
+ depComp(l,e,qs1);
+ fst(snd(q)) = applyBtyvs(fst(snd(q)));
+ restoreBvars(obvs);
+ }
+ break;
+
+ case QWHERE : snd(q) = eqnsToBindings(snd(q));
+ withinScope(snd(q));
+ snd(q) = dependencyAnal(snd(q));
+ hd(depends) = snd(q);
+ depComp(l,e,qs1);
+ leaveScope();
+ break;
+
+ case DOQUAL : /* fall-thru */
+ case BOOLQUAL : snd(q) = depExpr(l,snd(q));
+ depComp(l,e,qs1);
+ break;
+ }
+ }
+}
+
+static Void local depCaseAlt(line,a) /* Find dependents of case altern. */
+Int line;
+Cell a; {
+ List obvs = saveBvars(); /* Save list of bound variables */
+ enterBtyvs();
+ fst(a) = bindPat(line,fst(a)); /* Add new bound vars for pats */
+ depRhs(snd(a)); /* Find dependents of rhs */
+ fst(a) = applyBtyvs(fst(a));
+ restoreBvars(obvs); /* Restore original list of bvars */
+}
+
+static Cell local depVar(line,e) /* Register occurrence of variable */
+Int line;
+Cell e; {
+ List bounds1 = bounds;
+ List bindings1 = bindings;
+ List depends1 = depends;
+ Text t = textOf(e);
+ Cell n;
+
+ while (nonNull(bindings1)) {
+ n = varIsMember(t,hd(bounds1)); /* look for t in bound variables */
+ if (nonNull(n)) {
+ return n;
+ }
+ n = findBinding(t,hd(bindings1)); /* look for t in var bindings */
+ if (nonNull(n)) {
+ if (!cellIsMember(n,hd(depends1)))
+ hd(depends1) = cons(n,hd(depends1));
+ return (isVar(fst(n)) ? fst(n) : e);
+ }
+
+ bounds1 = tl(bounds1);
+ bindings1 = tl(bindings1);
+ depends1 = tl(depends1);
+ }
+
+ if (isNull(n=findName(t))) { /* check global definitions */
+ ERRMSG(line) "Undefined variable \"%s\"", textToStr(t)
+ EEND;
+ }
+
+ if (name(n).mod != thisModule) {
+ return n;
+ }
+ /* Later phases of the system cannot cope if we resolve references
+ * to unprocessed objects too early. This is the main reason that
+ * we cannot cope with recursive modules at the moment.
+ */
+ return n;
+}
+
+static Cell local depQVar(line,e)/* register occurrence of qualified variable */
+Int line;
+Cell e; {
+ Cell n = findQualName(line,e);
+ if (isNull(n)) { /* check global definitions */
+ ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
+ EEND;
+ }
+ if (name(n).mod != currentModule) {
+ return n;
+ }
+ if (fst(e) == VARIDCELL) {
+ e = mkVar(qtextOf(e));
+ } else {
+ e = mkVarop(qtextOf(e));
+ }
+ return depVar(line,e);
+}
+
+static Void local depConFlds(line,e,isP)/* check construction using fields */
+Int line;
+Cell e;
+Bool isP; {
+ Name c = conDefined(line,fst(snd(e)));
+ if (isNull(snd(snd(e))) ||
+ nonNull(cellIsMember(c,depFields(line,e,snd(snd(e)),isP)))) {
+ fst(snd(e)) = c;
+ } else {
+ ERRMSG(line) "Constructor \"%s\" does not have selected fields in ",
+ textToStr(name(c).text)
+ ETHEN ERREXPR(e);
+ ERRTEXT "\n"
+ EEND;
+ }
+ if (!isP && isPair(name(c).defn)) { /* Check that banged fields defined*/
+ List scs = fst(name(c).defn); /* List of strict components */
+ Type t = name(c).type;
+ Int a = name(c).arity;
+ List fs = snd(snd(e));
+ List ss;
+ if (isPolyType(t)) { /* Find tycon that c belongs to */
+ t = monotypeOf(t);
+ }
+ if (whatIs(t)==QUAL) {
+ t = snd(snd(t));
+ }
+ while (0<a--) {
+ t = arg(t);
+ }
+ while (isAp(t)) {
+ t = fun(t);
+ }
+ for (ss=tycon(t).defn; hasCfun(ss); ss=tl(ss)) {
+ }
+ /* Now we know the tycon t that c belongs to, and the corresponding
+ * list of selectors for that type, ss. Now we have to check that
+ * each of the fields identified by scs appears in fs, using ss to
+ * cross reference, and convert integers to selector names.
+ */
+ for (; nonNull(scs); scs=tl(scs)) {
+ Int i = intOf(hd(scs));
+ List ss1 = ss;
+ for (; nonNull(ss1); ss1=tl(ss1)) {
+ List cns = name(hd(ss1)).defn;
+ for (; nonNull(cns); cns=tl(cns)) {
+ if (fst(hd(cns))==c) {
+ break;
+ }
+ }
+ if (nonNull(cns) && intOf(snd(hd(cns)))==i) {
+ break;
+ }
+ }
+ if (isNull(ss1)) {
+ internal("depConFlds");
+ } else {
+ Name s = hd(ss1);
+ List fs1 = fs;
+ for (; nonNull(fs1) && s!=fst(hd(fs1)); fs1=tl(fs1)) {
+ }
+ if (isNull(fs1)) {
+ ERRMSG(line) "Construction does not define strict field"
+ ETHEN
+ ERRTEXT "\nExpression : " ETHEN ERREXPR(e);
+ ERRTEXT "\nField : " ETHEN ERREXPR(s);
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+ }
+ }
+}
+
+static Void local depUpdFlds(line,e) /* check update using fields */
+Int line;
+Cell e; {
+ if (isNull(thd3(snd(e)))) {
+ ERRMSG(line) "Empty field list in update"
+ EEND;
+ }
+ fst3(snd(e)) = depExpr(line,fst3(snd(e)));
+ snd3(snd(e)) = depFields(line,e,thd3(snd(e)),FALSE);
+}
+
+static List local depFields(l,e,fs,isP) /* check field binding list */
+Int l;
+Cell e;
+List fs;
+Bool isP; {
+ List cs = NIL;
+ List ss = NIL;
+
+ for (; nonNull(fs); fs=tl(fs)) { /* for each field binding */
+ Cell fb = hd(fs);
+ Name s;
+
+ if (isVar(fb)) { /* expand var to var = var */
+ fb = hd(fs) = pair(fb,fb);
+ }
+ s = findQualName(l,fst(fb)); /* check for selector */
+ if (nonNull(s) && isSfun(s)) {
+ fst(fb) = s;
+ } else {
+ ERRMSG(l) "\"%s\" is not a selector function/field name",
+ textToStr(textOf(fst(fb)))
+ EEND;
+ }
+
+ if (isNull(ss)) { /* for first named selector */
+ List scs = name(s).defn; /* calculate list of constructors */
+ for (; nonNull(scs); scs=tl(scs))
+ cs = cons(fst(hd(scs)),cs);
+ ss = singleton(s); /* initialize selector list */
+ } else { /* for subsequent selectors */
+ List ds = cs; /* intersect constructor lists */
+ for (cs=NIL; nonNull(ds); ) {
+ List scs = name(s).defn;
+ while (nonNull(scs) && fst(hd(scs))!=hd(ds)) {
+ scs = tl(scs);
+ }
+ if (isNull(scs)) {
+ ds = tl(ds);
+ } else {
+ List next = tl(ds);
+ tl(ds) = cs;
+ cs = ds;
+ ds = next;
+ }
+ }
+
+ if (cellIsMember(s,ss)) { /* check for repeated uses */
+ ERRMSG(l) "Repeated field name \"%s\" in field list",
+ textToStr(name(s).text)
+ EEND;
+ }
+ ss = cons(s,ss);
+ }
+
+ if (isNull(cs)) { /* Are there any matching constrs? */
+ ERRMSG(l) "No constructor has all of the fields specified in "
+ ETHEN ERREXPR(e);
+ ERRTEXT "\n"
+ EEND;
+ }
+
+ snd(fb) = (isP ? checkPat(l,snd(fb)) : depExpr(l,snd(fb)));
+ }
+ return cs;
+}
+
+#if TREX
+static Cell local depRecord(line,e) /* find dependents of record and */
+Int line; /* sort fields into approp. order */
+Cell e; { /* to make construction and update */
+ List exts = NIL; /* more efficient. */
+ Cell r = e;
+
+ do { /* build up list of extensions */
+ Text t = extText(fun(fun(r)));
+ String s = textToStr(t);
+ List prev = NIL;
+ List nx = exts;
+ while (nonNull(nx) && strcmp(textToStr(extText(fun(fun(nx)))),s)>0) {
+ prev = nx;
+ nx = extRow(nx);
+ }
+ if (nonNull(nx) && t==extText(fun(fun(nx)))) {
+ ERRMSG(line) "Repeated label \"%s\" in record ", s
+ ETHEN ERREXPR(e);
+ ERRTEXT "\n"
+ EEND;
+ }
+ if (isNull(prev)) {
+ exts = cons(fun(r),exts);
+ } else {
+ tl(prev) = cons(fun(r),nx);
+ }
+ extField(r) = depExpr(line,extField(r));
+ r = extRow(r);
+ } while (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r))));
+ r = depExpr(line,r);
+ return revOnto(exts,r);
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Several parts of this program require an algorithm for sorting a list
+ * of values (with some added dependency information) into a list of strongly
+ * connected components in which each value appears before its dependents.
+ *
+ * Each of these algorithms is obtained by parameterising a standard
+ * algorithm in "scc.c" as shown below.
+ * ------------------------------------------------------------------------*/
+
+#define SCC2 tcscc /* make scc algorithm for Tycons */
+#define LOWLINK tclowlink
+#define DEPENDS(c) (isTycon(c) ? tycon(c).kind : cclass(c).kinds)
+#define SETDEPENDS(c,v) if(isTycon(c))tycon(c).kind=v;else cclass(c).kinds=v
+#include "scc.c"
+#undef SETDEPENDS
+#undef DEPENDS
+#undef LOWLINK
+#undef SCC2
+
+#define SCC bscc /* make scc algorithm for Bindings */
+#define LOWLINK blowlink
+#define DEPENDS(t) depVal(t)
+#define SETDEPENDS(c,v) depVal(c)=v
+#include "scc.c"
+#undef SETDEPENDS
+#undef DEPENDS
+#undef LOWLINK
+#undef SCC
+
+/* --------------------------------------------------------------------------
+ * Main static analysis:
+ * ------------------------------------------------------------------------*/
+
+Void checkExp() { /* Top level static check on Expr */
+ staticAnalysis(RESET);
+ clearScope(); /* Analyse expression in the scope */
+ withinScope(NIL); /* of no local bindings */
+ inputExpr = depExpr(0,inputExpr);
+ leaveScope();
+ staticAnalysis(RESET);
+}
+
+Void checkDefns() { /* Top level static analysis */
+ staticAnalysis(RESET);
+ thisModule = lastModule();
+ setCurrModule(thisModule);
+
+ /* Resolve module references */
+ mapProc(checkQualImport, module(thisModule).qualImports);
+ mapProc(checkUnqualImport,unqualImports);
+
+ /* Add implicit import declarations - if Prelude has been loaded */
+ {
+ Module modulePrelude = findModule(findText("Prelude"));
+ if (nonNull(modulePrelude)) {
+ /* Add "import Prelude" if there`s no explicit import */
+ if (thisModule != modulePrelude
+ && isNull(cellAssoc(modulePrelude,unqualImports))
+ && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
+ unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
+ }
+ /* Add "import qualified Prelude" */
+ module(thisModule).qualImports=cons(pair(conPrelude,modulePrelude),
+ module(thisModule).qualImports);
+ }
+ }
+ map1Proc(checkImportList, thisModule, unqualImports);
+
+ linkPreludeTC(); /* Get prelude tycons and classes */
+ setCurrModule(thisModule);
+
+ mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */
+ checkSynonyms(tyconDefns); /* check synonym definitions */
+ mapProc(checkClassDefn,classDefns); /* process class definitions */
+ mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds */
+ mapProc(addMembers,classDefns); /* add definitions for member funs */
+ mapProc(visitClass,classDefns); /* check class hierarchy */
+
+ instDefns = rev(instDefns); /* process instance definitions */
+ mapProc(checkInstDefn,instDefns);
+
+ linkPreludeCM(); /* Get prelude cfuns and mfuns */
+ setCurrModule(thisModule);
+
+ mapProc(addDerivImp,derivedInsts); /* Add impls for derived instances */
+ deriveContexts(derivedInsts); /* Calculate derived inst contexts */
+#if EVAL_INSTANCES
+ deriveEval(tyconDefns); /* Derive instances of Eval */
+#endif
+ tyconDefns = NIL;
+ instDefns = appendOnto(instDefns,derivedInsts);
+#if EVAL_INSTANCES
+ instDefns = appendOnto(evalInsts,instDefns); /* ADR addition */
+#endif
+ checkDefaultDefns(); /* validate default definitions */
+
+ mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
+ valDefns = eqnsToBindings(valDefns);/* translate value equations */
+ map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound */
+ mapProc(allNoPrevDef,valDefns); /* check against previous defns */
+
+ linkPreludeNames(); /* Get prelude names */
+ setCurrModule(thisModule);
+
+ mapProc(checkForeignImport,foreignImports); /* check foreign imports */
+ mapProc(checkForeignExport,foreignExports); /* check foreign exports */
+ foreignImports = NIL;
+ foreignExports = NIL;
+
+ /* Every top-level name has now been created - so we can build the */
+ /* export list. Note that this has to happen before dependency */
+ /* analysis so that references to Prelude.foo will be resolved */
+ /* when compiling the prelude. */
+ /* Note too that this is just a little too late to catch the use of */
+ /* qualified tycons (for the current module) in data declarations */
+ module(thisModule).exports = checkExports(thisModule,module(thisModule).exports);
+
+ mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */
+
+ clearScope();
+ withinScope(valDefns);
+ valDefns = topDependAnal(valDefns); /* top level dependency ordering */
+ mapProc(depDefaults,classDefns); /* dep. analysis on class defaults */
+ mapProc(depInsts,instDefns); /* dep. analysis on inst defns */
+ leaveScope();
+
+ /* ToDo: evalDefaults should match current evaluation module */
+ evalDefaults = defaultDefns; /* Set defaults for evaluator */
+
+ staticAnalysis(RESET);
+}
+
+static Void local addRSsigdecls(pr) /* add sigdecls from TYPE ... IN ..*/
+Pair pr; {
+ List vs = snd(pr); /* get list of variables */
+ for (; nonNull(vs); vs=tl(vs)) {
+ if (fst(hd(vs))==SIGDECL) { /* find a sigdecl */
+ valDefns = cons(hd(vs),valDefns); /* add to valDefns */
+ hd(vs) = hd(snd3(snd(hd(vs)))); /* and replace with var */
+ }
+ }
+}
+
+static Void local opDefined(bs,op) /* check that op bound in bs */
+List bs; /* (or in current module for */
+Cell op; { /* constructor functions etc...) */
+ Name n;
+
+ if (isNull(findBinding(textOf(op),bs))
+ && (isNull(n=findName(textOf(op))) || name(n).mod != thisModule)) {
+ ERRMSG(0) "No top level definition for operator symbol \"%s\"",
+ textToStr(textOf(op))
+ EEND;
+ }
+}
+
+static Void local allNoPrevDef(b) /* ensure no previous bindings for */
+Cell b; { /* variables in new binding */
+ if (isVar(fst(b))) {
+ noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
+ } else {
+ Int line = rhsLine(snd(snd(snd(b))));
+ map1Proc(noPrevDef,line,fst(b));
+ }
+}
+
+static Void local noPrevDef(line,v) /* ensure no previous binding for */
+Int line; /* new variable */
+Cell v; {
+ Name n = findName(textOf(v));
+
+ if (isNull(n)) {
+ n = newName(textOf(v));
+ name(n).defn = PREDEFINED;
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Attempt to redefine variable \"%s\"",
+ textToStr(name(n).text)
+ EEND;
+ }
+ name(n).line = line;
+}
+
+static Void local duplicateError(line,mod,t,kind)/* report duplicate defn */
+Int line;
+Module mod;
+Text t;
+String kind; {
+ if (mod == currentModule) {
+ ERRMSG(line) "Repeated definition for %s \"%s\"", kind,
+ textToStr(t)
+ EEND;
+ } else {
+ ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
+ textToStr(t)
+ EEND;
+ }
+}
+
+static Void local checkTypeIn(cvs) /* Check that vars in restricted */
+Pair cvs; { /* synonym are defined */
+ Tycon c = fst(cvs);
+ List vs = snd(cvs);
+
+ for (; nonNull(vs); vs=tl(vs)) {
+ if (isNull(findName(textOf(hd(vs))))) {
+ ERRMSG(tycon(c).line)
+ "No top level binding of \"%s\" for restricted synonym \"%s\"",
+ textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
+ EEND;
+ }
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Static Analysis control:
+ * ------------------------------------------------------------------------*/
+
+Void staticAnalysis(what)
+Int what; {
+ switch (what) {
+ case RESET : daSccs = NIL;
+ patVars = NIL;
+ bounds = NIL;
+ bindings = NIL;
+ depends = NIL;
+ tcDeps = NIL;
+ derivedInsts = NIL;
+#if EVAL_INSTANCES
+ evalInsts = NIL;
+#endif
+ unkindTypes = NIL;
+ thisModule = 0;
+ break;
+
+ case MARK : mark(daSccs);
+ mark(patVars);
+ mark(bounds);
+ mark(bindings);
+ mark(depends);
+ mark(tcDeps);
+ mark(derivedInsts);
+#if EVAL_INSTANCES
+ mark(evalInsts);
+#endif
+ mark(unkindTypes);
+#if TREX
+ mark(extKind);
+#endif
+ break;
+
+ case INSTALL : staticAnalysis(RESET);
+#if TREX
+ extKind = pair(STAR,pair(ROW,ROW));
+#endif
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+extern List unqualImports; /* unqualified import list */
+
+#if DERIVE_SHOW | DERIVE_READ
+extern List cfunSfuns;
+#endif
+extern Void startModule Args((Cell));
+extern Void setExportList Args((List));
+extern Void setExports Args((List));
+extern Void addQualImport Args((Text,Text));
+extern Void addUnqualImport Args((Text,List));
+extern Void tyconDefn Args((Int,Cell,Cell,Cell));
+extern Void setTypeIns Args((List));
+extern Void clearTypeIns Args((Void));
+extern Type fullExpand Args((Type));
+extern Bool isAmbiguous Args((Type));
+extern Void ambigError Args((Int,String,Cell,Type));
+extern Void classDefn Args((Int,Cell,Cell));
+extern Void instDefn Args((Int,Cell,Cell));
+extern Void addTupInst Args((Class,Int));
+#if TREX
+extern Inst addRecShowInst Args((Class,Ext));
+extern Inst addRecEqInst Args((Class,Ext));
+#endif
+extern Void addEvalInst Args((Int,Cell,Int,List));
+extern Void foreignImport Args((Cell,Pair,Cell,Cell));
+extern Void foreignExport Args((Cell,Cell,Cell,Cell));
+extern Void defaultDefn Args((Int,List));
+extern Void checkExp Args((Void));
+extern Void checkDefns Args((Void));
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * STG syntax
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: stg.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:38 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+#include "link.h" /* for nameTrue/False */
+#include "Assembler.h" /* for AsmRep and primops */
+
+/* --------------------------------------------------------------------------
+ * Utility functions
+ * ------------------------------------------------------------------------*/
+
+int stgConTag( StgDiscr d )
+{
+ switch (whatIs(d)) {
+ case NAME:
+ return cfunOf(d);
+ case TUPLE:
+ return 0;
+ default:
+ internal("stgConTag");
+ }
+}
+
+void* stgConInfo( StgDiscr d )
+{
+ switch (whatIs(d)) {
+ case NAME:
+ return asmMkInfo(cfunOf(d),name(d).arity);
+ case TUPLE:
+ return asmMkInfo(0,tupleOf(d));
+ default:
+ internal("stgConInfo");
+ }
+}
+
+/* ToDo: identical to stgConTag */
+int stgDiscrTag( StgDiscr d )
+{
+ switch (whatIs(d)) {
+ case NAME:
+ return cfunOf(d);
+ case TUPLE:
+ return 0;
+ default:
+ internal("stgDiscrTag");
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Utility functions for manipulating STG syntax trees.
+ * ------------------------------------------------------------------------*/
+
+List makeArgs( Int n )
+{
+ List args = NIL;
+ for(; n>0; --n) {
+ args = cons(mkStgVar(NIL,NIL),args);
+ }
+ return args;
+}
+
+StgExpr makeStgLambda( List args, StgExpr body )
+{
+ if (isNull(args)) {
+ return body;
+ } else {
+ if (whatIs(body) == LAMBDA) {
+ return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
+ stgLambdaBody(body));
+ } else {
+ return mkStgLambda(args,body);
+ }
+ }
+}
+
+StgExpr makeStgApp( StgVar fun, List args )
+{
+ if (isNull(args)) {
+ return fun;
+ } else {
+ return mkStgApp(fun,args);
+ }
+}
+
+StgExpr makeStgLet( List binds, StgExpr body )
+{
+ if (isNull(binds)) {
+ return body;
+ } else {
+ return mkStgLet(binds,body);
+ }
+}
+
+StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
+{
+ if (cond == nameTrue) {
+ return e1;
+ } else if (cond == nameFalse) {
+ return e2;
+ } else {
+ return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
+ mkStgCaseAlt(nameFalse,NIL,e2)));
+ }
+}
+
+Bool isStgVar(e)
+StgRhs e; {
+ switch (whatIs(e)) {
+ case STGVAR:
+ return TRUE;
+ default:
+ return FALSE;
+ }
+}
+
+Bool isAtomic(e)
+StgRhs e; {
+ switch (whatIs(e)) {
+ case STGVAR:
+ case NAME:
+ case CHARCELL:
+ case INTCELL:
+ case BIGCELL:
+ case FLOATCELL:
+ case STRCELL:
+ case PTRCELL:
+ return TRUE;
+ default:
+ return FALSE;
+ }
+}
+
+StgVar mkStgVar( StgRhs rhs, Cell info )
+{
+ return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * STG syntax
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: stg.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:39 $
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * STG Syntax:
+ *
+ * Rhs -> STGCON (Con, [Atom])
+ * | STGAPP (Var, [Atom]) -- delayed application
+ * | Expr
+ *
+ * Expr -> LETREC ([Var],Expr) -- Vars contain their bound value
+ * | LAMBDA ([Var],Expr) -- all vars bound to NIL
+ * | CASE (Expr,[Alt])
+ * | PRIMCASE (Expr,[PrimAlt])
+ * | STGPRIM (Prim,[Atom])
+ * | STGAPP (Var, [Atom]) -- tail call
+ * | Var -- Abbreviation for STGAPP(Var,[])
+ *
+ * Atom -> Var
+ * | CHAR -- unboxed
+ * | INT -- unboxed
+ * | BIGNUM -- unboxed
+ * | FLOAT -- unboxed
+ * | ADDR -- unboxed
+ * | STRING -- boxed
+ *
+ * Var -> STGVAR (Rhs,StgRep,info) -- let, case or lambda bound
+ * | Name -- let-bound (effectively)
+ * -- always unboxed (PTR_REP)
+ *
+ * Alt -> (Pat,Expr)
+ * Pat -> Var -- bound to a constructor, a tuple or unbound
+ * PrimAlt -> ([PrimPat],Expr)
+ * PrimPat -> Var -- bound to int or unbound
+ *
+ * We use pointer equality to distinguish variables.
+ * The info field of a Var is used as follows in various phases:
+ *
+ * Translation: unused (set to NIL on output)
+ * Freevar analysis: list of free vars after
+ * Lambda lifting: freevar list or UNIT on input, discarded after
+ * Code generation: unused
+ * ------------------------------------------------------------------------*/
+
+typedef Cell StgRhs;
+typedef Cell StgExpr;
+typedef Cell StgAtom;
+typedef Cell StgVar; /* Could be a Name or an STGVAR */
+typedef Pair StgCaseAlt;
+typedef StgVar StgPat;
+typedef Cell StgDiscr;
+typedef Pair StgPrimAlt;
+typedef StgVar StgPrimPat;
+typedef Cell StgRep; /* PTR_REP | .. DOUBLE_REP */
+
+#define mkStgLet(binds,body) ap(LETREC,pair(binds,body))
+#define stgLetBinds(e) fst(snd(e))
+#define stgLetBody(e) snd(snd(e))
+
+#define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info))
+#define stgVarBody(e) fst3(snd(e))
+#define stgVarRep(e) snd3(snd(e))
+#define stgVarInfo(e) thd3(snd(e))
+
+#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts))
+#define stgCaseScrut(e) fst(snd(e))
+#define stgCaseAlts(e) snd(snd(e))
+
+#define mkStgCaseAlt(discr,vs,e) pair(mkStgVar(mkStgCon(discr,vs),NIL),e)
+#define stgCaseAltPat(alt) fst(alt)
+#define stgCaseAltBody(alt) snd(alt)
+
+#define stgPatDiscr(pat) stgConCon(stgVarBody(pat))
+#define stgPatVars(pat) stgConArgs(stgVarBody(pat))
+
+#define isDefaultPat(pat) (isNull(stgVarBody(pat)))
+#define isStgDefault(alt) (isDefaultPat(stgCaseAltPat(alt)))
+#define mkStgDefault(v,e) pair(v,e)
+
+#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts))
+#define stgPrimCaseScrut(e) fst(snd(e))
+#define stgPrimCaseAlts(e) snd(snd(e))
+
+#define mkStgPrimAlt(vs,body) pair(vs,body)
+#define stgPrimAltPats(alt) fst(alt)
+#define stgPrimAltBody(alt) snd(alt)
+
+#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args))
+#define stgAppFun(e) fst(snd(e))
+#define stgAppArgs(e) snd(snd(e))
+
+#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args))
+#define stgPrimOp(e) fst(snd(e))
+#define stgPrimArgs(e) snd(snd(e))
+
+#define mkStgCon(con,args) ap(STGCON,pair(con,args))
+#define stgConCon(e) fst(snd(e))
+#define stgConArgs(e) snd(snd(e))
+
+#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body))
+#define stgLambdaArgs(e) fst(snd(e))
+#define stgLambdaBody(e) snd(snd(e))
+
+extern int stgConTag ( StgDiscr d );
+extern void* stgConInfo ( StgDiscr d );
+extern int stgDiscrTag( StgDiscr d );
+
+/* --------------------------------------------------------------------------
+ * Utility functions for manipulating STG syntax trees.
+ * ------------------------------------------------------------------------*/
+
+extern List makeArgs ( Int );
+extern StgExpr makeStgLambda ( List args, StgExpr body );
+extern StgExpr makeStgApp ( StgVar fun, List args );
+extern StgExpr makeStgLet ( List binds, StgExpr body );
+extern StgExpr makeStgIf ( StgExpr cond, StgExpr e1, StgExpr e2 );
+extern Bool isStgVar ( StgRhs rhs );
+extern Bool isAtomic ( StgRhs rhs );
+
+extern StgVar mkStgVar ( StgRhs rhs, Cell info );
+
+#define mkSeq(x,y) mkStgCase(mkStgApp(nameForce,singleton(x)),singleton(mkStgDefault(mkStgVar(NIL,NIL),y)))
+
+
+#define mkStgRep(c) mkChar(c)
+
+/*-------------------------------------------------------------------------*/
+
+
+
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Substitute variables in an expression
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: stgSubst.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:40 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+
+#include "stgSubst.h"
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static StgVar substVar ( List sub, StgVar v );
+static StgAtom substAtom ( List sub, StgAtom a );
+static void substBind ( List sub, StgVar bind );
+static void substAlt ( List sub, StgCaseAlt alt );
+static void substPrimAlt ( List sub, StgPrimAlt alt );
+
+/* --------------------------------------------------------------------------
+ * Substitute variables throughout an expression - updating in place.
+ * ------------------------------------------------------------------------*/
+
+static StgVar substVar( List sub, StgVar v )
+{
+ Pair p = cellAssoc(v,sub);
+ if (nonNull(p)) {
+ return snd(p);
+ } else {
+ return v;
+ }
+}
+
+static StgAtom substAtom ( List sub, StgAtom a )
+{
+ switch (whatIs(a)) {
+ case STGVAR:
+ return substVar(sub,a);
+ default:
+ return a;
+ }
+}
+
+static Void substBind( List sub, StgVar bind )
+{
+ StgRhs rhs = stgVarBody(bind);
+ switch (whatIs(rhs)) {
+ case STGCON:
+ map1Over(substAtom,sub,stgConArgs(rhs));
+ return;
+ default:
+ stgVarBody(bind) = substExpr(sub,rhs);
+ return;
+ }
+}
+
+static Void substAlt( List sub, StgCaseAlt alt )
+{
+ stgCaseAltBody(alt) = substExpr(sub,stgCaseAltBody(alt));
+}
+
+static Void substPrimAlt( List sub, StgPrimAlt alt )
+{
+ stgPrimAltBody(alt) = substExpr(sub,stgPrimAltBody(alt));
+}
+
+StgExpr substExpr( List sub, StgExpr e )
+{
+ switch (whatIs(e)) {
+ case LETREC:
+ map1Proc(substBind,sub,stgLetBinds(e));
+ stgLetBody(e) = substExpr(sub,stgLetBody(e));
+ break;
+ case LAMBDA:
+ stgLambdaBody(e) = substExpr(sub,stgLambdaBody(e));
+ break;
+ case CASE:
+ stgCaseScrut(e) = substExpr(sub,stgCaseScrut(e));
+ map1Proc(substAlt,sub,stgCaseAlts(e));
+ break;
+ case PRIMCASE:
+ stgPrimCaseScrut(e) = substExpr(sub,stgPrimCaseScrut(e));
+ map1Proc(substPrimAlt,sub,stgPrimCaseAlts(e));
+ break;
+ case STGPRIM:
+ map1Over(substAtom,sub,stgPrimArgs(e));
+ break;
+ case STGAPP:
+ stgAppFun(e) = substVar(sub,stgAppFun(e));
+ map1Over(substAtom,sub,stgAppArgs(e));
+ break;
+ case STGVAR:
+ case NAME:
+ return substVar(sub,e);
+ default:
+ internal("substExpr");
+ }
+ return e;
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+extern StgExpr substExpr ( List sub, StgExpr e );
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Primitives for manipulating global data structures
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: storage.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:41 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "charset.h"
+#include "errors.h"
+#include "link.h" /* for nameCons */
+#include <setjmp.h>
+
+#include "machdep.h" /* gc-related functions */
+
+/*#define DEBUG_SHOWUSE*/
+
+/* --------------------------------------------------------------------------
+ * local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Int local hash Args((String));
+static Int local saveText Args((Text));
+static Module local findQualifier Args((Text));
+static Void local hashTycon Args((Tycon));
+static List local insertTycon Args((Tycon,List));
+static Void local hashName Args((Name));
+static List local insertName Args((Name,List));
+static Void local patternError Args((String));
+static Bool local stringMatch Args((String,String));
+static Bool local typeInvolves Args((Type,Type));
+static Cell local markCell Args((Cell));
+static Void local markSnd Args((Cell));
+static Cell local lowLevelLastIn Args((Cell));
+static Cell local lowLevelLastOut Args((Cell));
+static Module local moduleOfScript Args((Script));
+static Script local scriptThisFile Args((Text));
+
+
+/* --------------------------------------------------------------------------
+ * Text storage:
+ *
+ * provides storage for the characters making up identifier and symbol
+ * names, string literals, character constants etc...
+ *
+ * All character strings are stored in a large character array, with textHw
+ * pointing to the next free position. Lookup in the array is improved using
+ * a hash table. Internally, text strings are represented by integer offsets
+ * from the beginning of the array to the string in question.
+ *
+ * Where memory permits, the use of multiple hashtables gives a significant
+ * increase in performance, particularly when large source files are used.
+ *
+ * Each string in the array is terminated by a zero byte. No string is
+ * stored more than once, so that it is safe to test equality of strings by
+ * comparing the corresponding offsets.
+ *
+ * Special text values (beyond the range of the text array table) are used
+ * to generate unique `new variable names' as required.
+ *
+ * The same text storage is also used to hold text values stored in a saved
+ * expression. This grows downwards from the top of the text table (and is
+ * not included in the hash table).
+ * ------------------------------------------------------------------------*/
+
+#define TEXTHSZ 512 /* Size of Text hash table */
+#define NOTEXT ((Text)(~0)) /* Empty bucket in Text hash table */
+static Text textHw; /* Next unused position */
+static Text savedText = NUM_TEXT; /* Start of saved portion of text */
+static Text nextNewText; /* Next new text value */
+static Text nextNewDText; /* Next new dict text value */
+static char DEFTABLE(text,NUM_TEXT);/* Storage of character strings */
+static Text textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage */
+
+String textToStr(t) /* find string corresp to given Text*/
+Text t; {
+ static char newVar[16];
+
+ if (0<=t && t<NUM_TEXT) /* standard char string */
+ return text + t;
+ if (t<0)
+ sprintf(newVar,"d%d",-t); /* dictionary variable */
+ else
+ sprintf(newVar,"v%d",t-NUM_TEXT); /* normal variable */
+ return newVar;
+}
+
+String identToStr(v) /*find string corresp to given ident or qualified name*/
+Cell v; {
+ static char newVar[33];
+
+ assert(isPair(v));
+ switch (fst(v)) {
+ case VARIDCELL :
+ case VAROPCELL :
+ case CONIDCELL :
+ case CONOPCELL : return text+textOf(v);
+
+ case QUALIDENT : sprintf(newVar,"%s.%s",
+ text+qmodOf(v),text+qtextOf(v));
+ return newVar;
+ }
+ internal("identToStr 2");
+}
+
+Syntax identSyntax(v) /* find syntax of ident or qualified ident */
+Cell v; {
+ assert(isPair(v));
+ switch (fst(v)) {
+ case VARIDCELL :
+ case VAROPCELL :
+ case CONIDCELL :
+ case CONOPCELL : return syntaxOf(textOf(v));
+
+ case QUALIDENT : return syntaxOf(qtextOf(v));
+ }
+ internal("identSyntax 2");
+}
+
+Text inventText() { /* return new unused variable name */
+ return nextNewText++;
+}
+
+Text inventDictText() { /* return new unused dictvar name */
+ return nextNewDText--;
+}
+
+Bool inventedText(t) /* Signal TRUE if text has been */
+Text t; { /* generated internally */
+ return (t<0 || t>=NUM_TEXT);
+}
+
+static Int local hash(s) /* Simple hash function on strings */
+String s; {
+ int v, j = 3;
+
+ for (v=((int)(*s))*8; *s; s++)
+ v += ((int)(*s))*(j++);
+ if (v<0)
+ v = (-v);
+ return(v%TEXTHSZ);
+}
+
+Text findText(s) /* Locate string in Text array */
+String s; {
+ int h = hash(s);
+ int hashno = 0;
+ Text textPos = textHash[h][hashno];
+
+#define TryMatch { Text originalTextPos = textPos; \
+ String t; \
+ for (t=s; *t==text[textPos]; textPos++,t++) \
+ if (*t=='\0') \
+ return originalTextPos; \
+ }
+#define Skip while (text[textPos++]) ;
+
+ while (textPos!=NOTEXT) {
+ TryMatch
+ if (++hashno<NUM_TEXTH) /* look in next hashtable entry */
+ textPos = textHash[h][hashno];
+ else {
+ Skip
+ while (textPos < textHw) {
+ TryMatch
+ Skip
+ }
+ break;
+ }
+ }
+
+#undef TryMatch
+#undef Skip
+
+ textPos = textHw; /* if not found, save in array */
+ if (textHw + (Int)strlen(s) + 1 > savedText) {
+ ERRMSG(0) "Character string storage space exhausted"
+ EEND;
+ }
+ while ((text[textHw++] = *s++) != 0) {
+ }
+ if (hashno<NUM_TEXTH) { /* updating hash table as necessary */
+ textHash[h][hashno] = textPos;
+ if (hashno<NUM_TEXTH-1)
+ textHash[h][hashno+1] = NOTEXT;
+ }
+
+ return textPos;
+}
+
+static Int local saveText(t) /* Save text value in buffer */
+Text t; { /* at top of text table */
+ String s = textToStr(t);
+ Int l = strlen(s);
+
+ if (textHw + l + 1 > savedText) {
+ ERRMSG(0) "Character string storage space exhausted"
+ EEND;
+ }
+ savedText -= l+1;
+ strcpy(text+savedText,s);
+ return savedText;
+}
+
+/* --------------------------------------------------------------------------
+ * Syntax storage:
+ *
+ * Operator declarations are stored in a table which associates Text values
+ * with Syntax values.
+ * ------------------------------------------------------------------------*/
+
+static Int syntaxHw; /* next unused syntax table entry */
+static struct strSyntax { /* table of Text <-> Syntax values */
+ Text text;
+ Syntax syntax;
+} DEFTABLE(tabSyntax,NUM_SYNTAX);
+
+Syntax defaultSyntax(t) /* Find default syntax of var named */
+Text t; { /* by t ... */
+ String s = textToStr(t);
+ return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
+}
+
+Syntax syntaxOf(t) /* look up syntax of operator symbol*/
+Text t; {
+ int i;
+
+ for (i=0; i<syntaxHw; ++i)
+ if (tabSyntax[i].text==t)
+ return tabSyntax[i].syntax;
+ return defaultSyntax(t);
+}
+
+Void addSyntax(line,t,sy) /* add (t,sy) to syntax table */
+Int line;
+Text t;
+Syntax sy; {
+ int i;
+
+ for (i=0; i<syntaxHw; ++i)
+ if (tabSyntax[i].text==t) {
+ /* There's no problem with multiple identical fixity declarations.
+ * - but note that it's not allowed by the Haskell report. ADR
+ */
+ if (tabSyntax[i].syntax == sy) return;
+ ERRMSG(line) "Attempt to redefine syntax of operator \"%s\"",
+ textToStr(t)
+ EEND;
+ }
+
+ if (syntaxHw>=NUM_SYNTAX) {
+ ERRMSG(line) "Too many fixity declarations"
+ EEND;
+ }
+
+ tabSyntax[syntaxHw].text = t;
+ tabSyntax[syntaxHw].syntax = sy;
+ syntaxHw++;
+}
+
+/* --------------------------------------------------------------------------
+ * Ext storage:
+ *
+ * Currently, the only attributes that we store for each Ext value is the
+ * corresponding Text label. At some later stage, we may decide to cache
+ * types, predicates, etc. here as a space saving gesture. Given that Text
+ * comparison is cheap, and that this is an experimental implementation, we
+ * will use a straightforward linear search to locate Ext values from their
+ * corresponding Text labels; a hashing scheme can be introduced later if
+ * this turns out to be a problem.
+ * ------------------------------------------------------------------------*/
+
+#if TREX
+Text DEFTABLE(tabExt,NUM_EXT); /* Storage for Ext names */
+Ext extHw;
+
+Ext mkExt(t) /* Allocate or find an Ext value */
+Text t; {
+ Ext e = EXTMIN;
+ for (; e<extHw; e++)
+ if (t==extText(e))
+ return e;
+ if (extHw-EXTMIN >= NUM_EXT) {
+ ERRMSG(0) "Ext storage space exhausted"
+ EEND;
+ }
+ extText(extHw) = t;
+ return extHw++;
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Tycon storage:
+ *
+ * A Tycon represents a user defined type constructor. Tycons are indexed
+ * by Text values ... a very simple hash function is used to improve lookup
+ * times. Tycon entries with the same hash code are chained together, with
+ * the most recent entry at the front of the list.
+ * ------------------------------------------------------------------------*/
+
+#define TYCONHSZ 256 /* Size of Tycon hash table*/
+#define tHash(x) ((x)%TYCONHSZ) /* Tycon hash function */
+static Tycon tyconHw; /* next unused Tycon */
+static Tycon DEFTABLE(tyconHash,TYCONHSZ); /* Hash table storage */
+struct strTycon DEFTABLE(tabTycon,NUM_TYCON); /* Tycon storage */
+
+Tycon newTycon(t) /* add new tycon to tycon table */
+Text t; {
+ Int h = tHash(t);
+
+ if (tyconHw-TYCMIN >= NUM_TYCON) {
+ ERRMSG(0) "Type constructor storage space exhausted"
+ EEND;
+ }
+ tycon(tyconHw).text = t; /* clear new tycon record */
+ tycon(tyconHw).kind = NIL;
+ tycon(tyconHw).defn = NIL;
+ tycon(tyconHw).what = NIL;
+ tycon(tyconHw).conToTag = NIL;
+ tycon(tyconHw).tagToCon = NIL;
+ tycon(tyconHw).mod = currentModule;
+ module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
+ tycon(tyconHw).nextTyconHash = tyconHash[h];
+ tyconHash[h] = tyconHw;
+
+ return tyconHw++;
+}
+
+Tycon findTycon(t) /* locate Tycon in tycon table */
+Text t; {
+ Tycon tc = tyconHash[tHash(t)];
+
+ while (nonNull(tc) && tycon(tc).text!=t)
+ tc = tycon(tc).nextTyconHash;
+ return tc;
+}
+
+Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */
+Tycon tc; {
+ Tycon oldtc = findTycon(tycon(tc).text);
+ if (isNull(oldtc)) {
+ hashTycon(tc);
+ module(currentModule).tycons=cons(tc,module(currentModule).tycons);
+ return tc;
+ } else
+ return oldtc;
+}
+
+static Void local hashTycon(tc) /* Insert Tycon into hash table */
+Tycon tc; {
+ Text t = tycon(tc).text;
+ Int h = tHash(t);
+ tycon(tc).nextTyconHash = tyconHash[h];
+ tyconHash[h] = tc;
+}
+
+Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
+Cell id; {
+ assert(isPair(id));
+ switch (fst(id)) {
+ case CONIDCELL :
+ case CONOPCELL :
+ return findTycon(textOf(id));
+ case QUALIDENT : {
+ Text t = qtextOf(id);
+ Module m = findQualifier(qmodOf(id));
+ List es = NIL;
+ if (isNull(m))
+ return NIL;
+ if (m==currentModule) {
+ /* The Haskell report (rightly) forbids this.
+ * We added it to let the Prelude refer to itself
+ * without having to import itself.
+ */
+ return findTycon(t);
+ }
+ for(es=module(m).exports; nonNull(es); es=tl(es)) {
+ Cell e = hd(es);
+ if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
+ return fst(e);
+ }
+ return NIL;
+ }
+ default : internal("findQualTycon2");
+ }
+}
+
+Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
+Text t;
+Kind kind;
+Int ar;
+Cell what;
+Cell defn; {
+ Tycon tc = newTycon(t);
+ tycon(tc).line = 0;
+ tycon(tc).kind = kind;
+ tycon(tc).what = what;
+ tycon(tc).defn = defn;
+ tycon(tc).arity = ar;
+ return tc;
+}
+
+static List local insertTycon(tc,ts) /* insert tycon tc into sorted list*/
+Tycon tc; /* ts */
+List ts; {
+ Cell prev = NIL;
+ Cell curr = ts;
+ String s = textToStr(tycon(tc).text);
+
+ while (nonNull(curr) && strCompare(s,textToStr(tycon(hd(curr)).text))>=0) {
+ if (hd(curr)==tc) /* just in case we get duplicates! */
+ return ts;
+ prev = curr;
+ curr = tl(curr);
+ }
+ if (nonNull(prev)) {
+ tl(prev) = cons(tc,curr);
+ return ts;
+ }
+ else
+ return cons(tc,curr);
+}
+
+List addTyconsMatching(pat,ts) /* Add tycons matching pattern pat */
+String pat; /* to list of Tycons ts */
+List ts; { /* Null pattern matches every tycon*/
+ Tycon tc; /* (Tycons with NIL kind excluded) */
+ for (tc=TYCMIN; tc<tyconHw; ++tc)
+ if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
+ if (nonNull(tycon(tc).kind))
+ ts = insertTycon(tc,ts);
+ return ts;
+}
+
+/* --------------------------------------------------------------------------
+ * Name storage:
+ *
+ * A Name represents a top level binding of a value to an identifier.
+ * Such values may be a constructor function, a member function in a
+ * class, a user-defined or primitive value/function.
+ *
+ * Names are indexed by Text values ... a very simple hash functions speeds
+ * access to the table of Names and Name entries with the same hash value
+ * are chained together, with the most recent entry at the front of the
+ * list.
+ * ------------------------------------------------------------------------*/
+
+#define NAMEHSZ 256 /* Size of Name hash table */
+#define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */
+/*static*/Name nameHw; /* next unused name */
+static Name DEFTABLE(nameHash,NAMEHSZ); /* Hash table storage */
+struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */
+
+Name newName(t) /* add new name to name table */
+Text t; {
+ if (nameHw-NAMEMIN >= NUM_NAME) {
+ ERRMSG(0) "Name storage space exhausted"
+ EEND;
+ }
+ name(nameHw).text = t; /* clear new name record */
+ name(nameHw).line = 0;
+ name(nameHw).arity = 0;
+ name(nameHw).number = EXECNAME;
+ name(nameHw).defn = NIL;
+ name(nameHw).stgVar = NIL;
+ name(nameHw).type = NIL;
+ name(nameHw).primop = 0;
+ name(nameHw).mod = currentModule;
+ hashName(nameHw);
+ module(currentModule).names=cons(nameHw,module(currentModule).names);
+ return nameHw++;
+}
+
+Name findName(t) /* locate name in name table */
+Text t; {
+ Name n = nameHash[nHash(t)];
+
+ while (nonNull(n) && name(n).text!=t) {
+ n = name(n).nextNameHash;
+ }
+ assert(isNull(n) || (isName(n) && n < nameHw));
+ return n;
+}
+
+Name addName(nm) /* Insert Name in name table - if no clash is caused */
+Name nm; {
+ Name oldnm = findName(name(nm).text);
+ if (isNull(oldnm)) {
+ hashName(nm);
+ module(currentModule).names=cons(nm,module(currentModule).names);
+ return nm;
+ } else {
+ return oldnm;
+ }
+}
+
+static Void local hashName(nm) /* Insert Name into hash table */
+Name nm; {
+ Text t = name(nm).text;
+ Int h = nHash(t);
+ name(nm).nextNameHash = nameHash[h];
+ nameHash[h] = nm;
+}
+
+Name findQualName(line,id) /* locate (possibly qualified) name in name table */
+Int line;
+Cell id; {
+ assert(isPair(id));
+ switch (fst(id)) {
+ case VARIDCELL :
+ case VAROPCELL :
+ case CONIDCELL :
+ case CONOPCELL :
+ return findName(textOf(id));
+ case QUALIDENT : {
+ Text t = qtextOf(id);
+ Module m = findQualifier(qmodOf(id));
+ List es = NIL;
+ if (isNull(m)) return NIL;
+ if (m==currentModule) {
+ /* The Haskell report (rightly) forbids this.
+ * We added it to let the Prelude refer to itself
+ * without having to import itself.
+ */
+ return findName(t);
+ }
+ for(es=module(m).exports; nonNull(es); es=tl(es)) {
+ Cell e = hd(es);
+ if (isName(e) && name(e).text==t)
+ return e;
+ else if (isPair(e) && DOTDOT==snd(e)) {
+ List subentities = NIL;
+ Cell c = fst(e);
+ if (isTycon(c)
+ && (tycon(c).what == DATATYPE
+ || tycon(c).what == NEWTYPE))
+ subentities = tycon(c).defn;
+ else if (isClass(c))
+ subentities = cclass(c).members;
+ for(; nonNull(subentities); subentities=tl(subentities)) {
+ assert(isName(hd(subentities)));
+ if (name(hd(subentities)).text == t)
+ return hd(subentities);
+ }
+ }
+ }
+ return NIL;
+ }
+ default : internal("findQualName2");
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Primitive functions:
+ * ------------------------------------------------------------------------*/
+
+Name addPrimCfun(t,arity,no,rep) /* add primitive constructor func */
+Text t;
+Int arity;
+Int no;
+Int rep; { /* Really AsmRep */
+ Name n = newName(t);
+ name(n).arity = arity;
+ name(n).number = cfunNo(no);
+ name(n).type = NIL;
+ name(n).primop = (void*)rep;
+ return n;
+}
+
+Int sfunPos(s,c) /* Find position of field with */
+Name s; /* selector s in constructor c. */
+Name c; {
+ List cns;
+ cns = name(s).defn;
+ for (; nonNull(cns); cns=tl(cns)) {
+ if (fst(hd(cns))==c)
+ return intOf(snd(hd(cns)));
+ }
+ internal("sfunPos");
+ return 0;/*NOTREACHED*/
+}
+
+static List local insertName(nm,ns) /* insert name nm into sorted list */
+Name nm; /* ns */
+List ns; {
+ Cell prev = NIL;
+ Cell curr = ns;
+ String s = textToStr(name(nm).text);
+
+ while (nonNull(curr) && strCompare(s,textToStr(name(hd(curr)).text))>=0) {
+ if (hd(curr)==nm) /* just in case we get duplicates! */
+ return ns;
+ prev = curr;
+ curr = tl(curr);
+ }
+ if (nonNull(prev)) {
+ tl(prev) = cons(nm,curr);
+ return ns;
+ }
+ else
+ return cons(nm,curr);
+}
+
+List addNamesMatching(pat,ns) /* Add names matching pattern pat */
+String pat; /* to list of names ns */
+List ns; { /* Null pattern matches every name */
+ Name nm; /* (Names with NIL type, or hidden */
+ for (nm=NAMEMIN; nm<nameHw; ++nm) /* or invented names are excluded) */
+ if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
+ String str = textToStr(name(nm).text);
+ if (str[0]!='_' && (!pat || stringMatch(pat,str)))
+ ns = insertName(nm,ns);
+ }
+ return ns;
+}
+
+/* --------------------------------------------------------------------------
+ * A simple string matching routine
+ * `*' matches any sequence of zero or more characters
+ * `?' matches any single character exactly
+ * `@str' matches the string str exactly (ignoring any special chars)
+ * `\c' matches the character c only (ignoring special chars)
+ * c matches the character c only
+ * ------------------------------------------------------------------------*/
+
+static Void local patternError(s) /* report error in pattern */
+String s; {
+ ERRMSG(0) "%s in pattern", s
+ EEND;
+}
+
+static Bool local stringMatch(pat,str) /* match string against pattern */
+String pat;
+String str; {
+
+ for (;;)
+ switch (*pat) {
+ case '\0' : return (*str=='\0');
+
+ case '*' : do {
+ if (stringMatch(pat+1,str))
+ return TRUE;
+ } while (*str++);
+ return FALSE;
+
+ case '?' : if (*str++=='\0')
+ return FALSE;
+ pat++;
+ break;
+
+ case '[' : { Bool found = FALSE;
+ while (*++pat!='\0' && *pat!=']')
+ if (!found && ( pat[0] == *str ||
+ (pat[1] == '-' &&
+ pat[2] != ']' &&
+ pat[2] != '\0' &&
+ pat[0] <= *str &&
+ pat[2] >= *str)))
+
+ found = TRUE;
+ if (*pat != ']')
+ patternError("missing `]'");
+ if (!found)
+ return FALSE;
+ pat++;
+ str++;
+ }
+ break;
+
+ case '\\' : if (*++pat == '\0')
+ patternError("extra trailing `\\'");
+ /*fallthru!*/
+ default : if (*pat++ != *str++)
+ return FALSE;
+ break;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Storage of type classes, instances etc...:
+ * ------------------------------------------------------------------------*/
+
+static Class classHw; /* next unused class */
+static List classes; /* list of classes in current scope */
+static Inst instHw; /* next unused instance record */
+#if USE_DICTHW
+static Int dictHw; /* next unused dictionary number */
+#endif
+
+struct strClass DEFTABLE(tabClass,NUM_CLASSES); /* table of class records */
+struct strInst far *tabInst; /* (pointer to) table of instances */
+
+Class newClass(t) /* add new class to class table */
+Text t; {
+ if (classHw-CLASSMIN >= NUM_CLASSES) {
+ ERRMSG(0) "Class storage space exhausted"
+ EEND;
+ }
+ cclass(classHw).text = t;
+ cclass(classHw).arity = 0;
+ cclass(classHw).kinds = NIL;
+ cclass(classHw).head = NIL;
+ cclass(classHw).dcon = NIL;
+ cclass(classHw).supers = NIL;
+ cclass(classHw).dsels = NIL;
+ cclass(classHw).members = NIL;
+ cclass(classHw).dbuild = NIL;
+ cclass(classHw).defaults = NIL;
+ cclass(classHw).instances = NIL;
+ classes=cons(classHw,classes);
+ cclass(classHw).mod = currentModule;
+ module(currentModule).classes=cons(classHw,module(currentModule).classes);
+ return classHw++;
+}
+
+Class classMax() { /* Return max Class in use ... */
+ return classHw; /* This is a bit ugly, but it's not*/
+} /* worth a lot of effort right now */
+
+Class findClass(t) /* look for named class in table */
+Text t; {
+ Class cl;
+ List cs;
+ for (cs=classes; nonNull(cs); cs=tl(cs)) {
+ cl=hd(cs);
+ if (cclass(cl).text==t)
+ return cl;
+ }
+ return NIL;
+}
+
+Class addClass(c) /* Insert Class in class list - if no clash caused */
+Class c; {
+ Class oldc = findClass(cclass(c).text);
+ if (isNull(oldc)) {
+ classes=cons(c,classes);
+ module(currentModule).classes=cons(c,module(currentModule).classes);
+ return c;
+ } else
+ return oldc;
+}
+
+Class findQualClass(c) /* look for (possibly qualified) class in class list */
+Cell c; {
+ if (!isQualIdent(c)) {
+ return findClass(textOf(c));
+ } else {
+ Text t = qtextOf(c);
+ Module m = findQualifier(qmodOf(c));
+ List es = NIL;
+ if (isNull(m)) return NIL;
+ for(es=module(m).exports; nonNull(es); es=tl(es)) {
+ Cell e = hd(es);
+ if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
+ return fst(e);
+ }
+ }
+ return NIL;
+}
+
+Inst newInst() { /* add new instance to table */
+ if (instHw-INSTMIN >= NUM_INSTS) {
+ ERRMSG(0) "Instance storage space exhausted"
+ EEND;
+ }
+ inst(instHw).kinds = NIL;
+ inst(instHw).head = NIL;
+ inst(instHw).specifics = NIL;
+ inst(instHw).implements = NIL;
+ inst(instHw).builder = NIL;
+ inst(instHw).mod = currentModule;
+
+ return instHw++;
+}
+
+Inst findFirstInst(tc) /* look for 1st instance involving */
+Tycon tc; { /* the type constructor tc */
+ return findNextInst(tc,INSTMIN-1);
+}
+
+Inst findNextInst(tc,in) /* look for next instance involving*/
+Tycon tc; /* the type constructor tc */
+Inst in; { /* starting after instance in */
+ while (++in < instHw) {
+ Cell pi = inst(in).head;
+ for (; isAp(pi); pi=fun(pi))
+ if (typeInvolves(arg(pi),tc))
+ return in;
+ }
+ return NIL;
+}
+
+static Bool local typeInvolves(ty,tc) /* Test to see if type ty involves */
+Type ty; /* type constructor/tuple tc. */
+Type tc; {
+ return (ty==tc)
+ || (isAp(ty) && (typeInvolves(fun(ty),tc)
+ || typeInvolves(arg(ty),tc)));
+}
+
+/* --------------------------------------------------------------------------
+ * Control stack:
+ *
+ * Various parts of the system use a stack of cells. Most of the stack
+ * operations are defined as macros, expanded inline.
+ * ------------------------------------------------------------------------*/
+
+Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack */
+StackPtr sp; /* stack pointer */
+
+Void hugsStackOverflow() { /* Report stack overflow */
+ ERRMSG(0) "Control stack overflow"
+ EEND;
+}
+
+/* --------------------------------------------------------------------------
+ * Module storage:
+ *
+ * A Module represents a user defined module.
+ *
+ * Note: there are now two lookup mechanisms in the system:
+ *
+ * 1) The exports from a module are stored in a big list.
+ * We resolve qualified names, and import lists by linearly scanning
+ * through this list.
+ *
+ * 2) Unqualified imports and local definitions for the current module
+ * are stored in hash tables (tyconHash and nameHash) or linear lists
+ * (classes).
+ *
+ * ------------------------------------------------------------------------*/
+
+static Module moduleHw; /* next unused Module */
+struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */
+Module currentModule; /* Module currently being processed*/
+
+Bool isValidModule(m) /* is m a legitimate module id? */
+Module m; {
+ return (MODMIN <= m && m < moduleHw);
+}
+
+Module newModule(t) /* add new module to module table */
+Text t; {
+ if (moduleHw-MODMIN >= NUM_MODULE) {
+ ERRMSG(0) "Module storage space exhausted"
+ EEND;
+ }
+ module(moduleHw).text = t; /* clear new module record */
+ module(moduleHw).qualImports = NIL;
+ module(moduleHw).exports = NIL;
+ module(moduleHw).tycons = NIL;
+ module(moduleHw).names = NIL;
+ module(moduleHw).classes = NIL;
+ module(moduleHw).objectFile = 0;
+ return moduleHw++;
+}
+
+Module findModule(t) /* locate Module in module table */
+Text t; {
+ Module m;
+ for(m=MODMIN; m<moduleHw; ++m) {
+ if (module(m).text==t) {
+ return m;
+ }
+ }
+ return NIL;
+}
+
+Module findModid(c) /* Find module by name or filename */
+Cell c; {
+ switch (whatIs(c)) {
+ case STRCELL : { Script s = scriptThisFile(snd(c));
+ return (s==-1) ? NIL : moduleOfScript(s);
+ }
+ case CONIDCELL : return findModule(textOf(c));
+ default : internal("findModid");
+ }
+}
+
+static local Module findQualifier(t) /* locate Module in import list */
+Text t; {
+ Module ms;
+ if (t==module(modulePreludeHugs).text) {
+ /* The Haskell report (rightly) forbids this.
+ * We added it to let the Prelude refer to itself
+ * without having to import itself.
+ */
+ return modulePreludeHugs;
+ }
+ for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
+ if (textOf(fst(hd(ms)))==t) {
+ return snd(hd(ms));
+ }
+ }
+ return NIL;
+}
+
+Void setCurrModule(m) /* set lookup tables for current module */
+Module m; {
+ Int i;
+ if (m!=currentModule) {
+ currentModule = m; /* This is the only assignment to currentModule */
+ for (i=0; i<TYCONHSZ; ++i) {
+ tyconHash[i] = NIL;
+ }
+ mapProc(hashTycon,module(m).tycons);
+ for (i=0; i<NAMEHSZ; ++i) {
+ nameHash[i] = NIL;
+ }
+ mapProc(hashName,module(m).names);
+ classes = module(m).classes;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Script file storage:
+ *
+ * script files are read into the system one after another. The state of
+ * the stored data structures (except the garbage-collected heap) is recorded
+ * before reading a new script. In the event of being unable to read the
+ * script, or if otherwise requested, the system can be restored to its
+ * original state immediately before the file was read.
+ * ------------------------------------------------------------------------*/
+
+typedef struct { /* record of storage state prior to */
+ Text file; /* reading script/module */
+ Text textHw;
+ Text nextNewText;
+ Text nextNewDText;
+ Int syntaxHw;
+ Module moduleHw;
+ Tycon tyconHw;
+ Name nameHw;
+ Class classHw;
+ Inst instHw;
+#if USE_DICTHW
+ Int dictHw;
+#endif
+#if TREX
+ Ext extHw;
+#endif
+} script;
+
+#ifdef DEBUG_SHOWUSE
+static Void local showUse(msg,val,mx)
+String msg;
+Int val, mx; {
+ Printf("%6s : %d of %d (%d%%)\n",msg,val,mx,(100*val)/mx);
+}
+#endif
+
+static Script scriptHw; /* next unused script number */
+static script scripts[NUM_SCRIPTS]; /* storage for script records */
+
+Script startNewScript(f) /* start new script, keeping record */
+String f; { /* of status for later restoration */
+ if (scriptHw >= NUM_SCRIPTS) {
+ ERRMSG(0) "Too many script files in use"
+ EEND;
+ }
+#ifdef DEBUG_SHOWUSE
+ showUse("Text", textHw, NUM_TEXT);
+ showUse("Syntax", syntaxHw, NUM_SYNTAX);
+ showUse("Module", moduleHw-MODMIN, NUM_MODULE);
+ showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON);
+ showUse("Name", nameHw-NAMEMIN, NUM_NAME);
+ showUse("Class", classHw-CLASSMIN, NUM_CLASSES);
+ showUse("Inst", instHw-INSTMIN, NUM_INSTS);
+#if TREX
+ showUse("Ext", extHw-EXTMIN, NUM_EXT);
+#endif
+#endif
+
+ scripts[scriptHw].file = findText( f ? f : "<nofile>" );
+ scripts[scriptHw].textHw = textHw;
+ scripts[scriptHw].nextNewText = nextNewText;
+ scripts[scriptHw].nextNewDText = nextNewDText;
+ scripts[scriptHw].syntaxHw = syntaxHw;
+ scripts[scriptHw].moduleHw = moduleHw;
+ scripts[scriptHw].tyconHw = tyconHw;
+ scripts[scriptHw].nameHw = nameHw;
+ scripts[scriptHw].classHw = classHw;
+ scripts[scriptHw].instHw = instHw;
+#if USE_DICTHW
+ scripts[scriptHw].dictHw = dictHw;
+#endif
+#if TREX
+ scripts[scriptHw].extHw = extHw;
+#endif
+ return scriptHw++;
+}
+
+#define scriptThis(nm,t,tag) Script nm(x) \
+ t x; { \
+ Script s=0; \
+ while (s<scriptHw \
+ && x>=scripts[s].tag) \
+ s++; \
+ return s; \
+ }
+scriptThis(scriptThisName,Name,nameHw)
+scriptThis(scriptThisTycon,Tycon,tyconHw)
+scriptThis(scriptThisInst,Inst,instHw)
+scriptThis(scriptThisClass,Class,classHw)
+#undef scriptThis
+
+Module lastModule() { /* Return module in current script file */
+ return (moduleHw-1);
+}
+
+static Module local moduleOfScript(s)
+Script s; {
+ return scripts[s-1].moduleHw;
+}
+
+String fileOfModule(m)
+Module m; {
+ Script s;
+ for(s=0; s<scriptHw; ++s) {
+ if (scripts[s].moduleHw == m) {
+ return textToStr(scripts[s].file);
+ }
+ }
+ return 0;
+}
+
+static Script local scriptThisFile(f)
+Text f; {
+ Script s;
+ for (s=0; s < scriptHw; ++s) {
+ if (scripts[s].file == f) {
+ return s+1;
+ }
+ }
+ return (-1);
+}
+
+Void dropScriptsFrom(sno) /* Restore storage to state prior */
+Script sno; { /* to reading script sno */
+ if (sno<scriptHw) { /* is there anything to restore? */
+ int i;
+ textHw = scripts[sno].textHw;
+ nextNewText = scripts[sno].nextNewText;
+ nextNewDText = scripts[sno].nextNewDText;
+ syntaxHw = scripts[sno].syntaxHw;
+ tyconHw = scripts[sno].tyconHw;
+ nameHw = scripts[sno].nameHw;
+ classHw = scripts[sno].classHw;
+ instHw = scripts[sno].instHw;
+#if USE_DICTHW
+ dictHw = scripts[sno].dictHw;
+#endif
+#if TREX
+ extHw = scripts[sno].extHw;
+#endif
+
+ for (i=moduleHw; i >= scripts[sno].moduleHw; --i) {
+ if (module(i).objectFile) {
+ printf("closing objectFile for module %d\n",i);
+ dlclose(module(i).objectFile);
+ }
+ }
+ moduleHw = scripts[sno].moduleHw;
+
+ for (i=0; i<TEXTHSZ; ++i) {
+ int j = 0;
+ while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
+ && textHash[i][j]<textHw)
+ ++j;
+ if (j<NUM_TEXTH)
+ textHash[i][j] = NOTEXT;
+ }
+
+ currentModule=NIL;
+ for (i=0; i<TYCONHSZ; ++i) {
+ tyconHash[i] = NIL;
+ }
+ for (i=0; i<NAMEHSZ; ++i) {
+ nameHash[i] = NIL;
+ }
+
+ for (i=CLASSMIN; i<classHw; i++) {
+ List ins = cclass(i).instances;
+ List is = NIL;
+
+ while (nonNull(ins)) {
+ List temp = tl(ins);
+ if (hd(ins)<instHw) {
+ tl(ins) = is;
+ is = ins;
+ }
+ ins = temp;
+ }
+ cclass(i).instances = rev(is);
+ }
+
+ scriptHw = sno;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Heap storage:
+ *
+ * Provides a garbage collectable heap for storage of expressions etc.
+ *
+ * Now incorporates a flat resource: A two-space collected extension of
+ * the heap that provides storage for contiguous arrays of Cell storage,
+ * cooperating with the garbage collection mechanisms for the main heap.
+ * ------------------------------------------------------------------------*/
+
+Int heapSize = DEFAULTHEAP; /* number of cells in heap */
+Heap heapFst; /* array of fst component of pairs */
+Heap heapSnd; /* array of snd component of pairs */
+Heap heapTopFst;
+Heap heapTopSnd;
+Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
+ /* C stack; use with extreme care! */
+Int cellsRecovered; /* number of cells recovered */
+
+static Cell freeList; /* free list of unused cells */
+static Cell lsave, rsave; /* save components of pair */
+
+#if GC_STATISTICS
+
+static Int markCount, stackRoots;
+
+#define initStackRoots() stackRoots = 0
+#define recordStackRoot() stackRoots++
+
+#define startGC() \
+ if (gcMessages) { \
+ printf("\n"); \
+ fflush(stdout); \
+ }
+#define endGC() \
+ if (gcMessages) { \
+ printf("\n"); \
+ fflush(stdout); \
+ }
+
+#define start() markCount = 0
+#define end(thing,rs) \
+ if (gcMessages) { \
+ printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
+ fflush(stdout); \
+ }
+#define recordMark() markCount++
+
+#else /* !GC_STATISTICS */
+
+#define startGC()
+#define endGC()
+
+#define initStackRoots()
+#define recordStackRoot()
+
+#define start()
+#define end(thing,root)
+#define recordMark()
+
+#endif /* !GC_STATISTICS */
+
+Cell pair(l,r) /* Allocate pair (l, r) from */
+Cell l, r; { /* heap, garbage collecting first */
+ Cell c = freeList; /* if necessary ... */
+
+ if (isNull(c)) {
+ lsave = l;
+ rsave = r;
+ garbageCollect();
+ l = lsave;
+ lsave = NIL;
+ r = rsave;
+ rsave = NIL;
+ c = freeList;
+ }
+ freeList = snd(freeList);
+ fst(c) = l;
+ snd(c) = r;
+ return c;
+}
+
+Void overwrite(dst,src) /* overwrite dst cell with src cell*/
+Pair dst, src; { /* both *MUST* be pairs */
+ assert(isPair(dst) && isPair(src));
+ fst(dst) = fst(src);
+ snd(dst) = snd(src);
+}
+
+Void overwrite2(dst,src1,src2) /* overwrite dst cell with src cell*/
+Pair dst;
+Cell src1, src2; {
+ assert(isPair(dst));
+ fst(dst) = src1;
+ snd(dst) = src2;
+}
+
+static Int *marks;
+static Int marksSize;
+
+Cell markExpr(c) /* External interface to markCell */
+Cell c; {
+ return isGenPair(c) ? markCell(c) : c;
+}
+
+static Cell local markCell(c) /* Traverse part of graph marking */
+Cell c; { /* cells reachable from given root */
+ /* markCell(c) is only called if c */
+ /* is a pair */
+ { register place = placeInSet(c);
+ register mask = maskInSet(c);
+ if (marks[place]&mask)
+ return c;
+ else {
+ marks[place] |= mask;
+ recordMark();
+ }
+ }
+
+ if (isGenPair(fst(c))) {
+ fst(c) = markCell(fst(c));
+ markSnd(c);
+ }
+ else if (isNull(fst(c)) || fst(c)>=BCSTAG)
+ markSnd(c);
+
+ return c;
+}
+
+static Void local markSnd(c) /* Variant of markCell used to */
+Cell c; { /* update snd component of cell */
+ Cell t; /* using tail recursion */
+
+ma: t = c; /* Keep pointer to original pair */
+ c = snd(c);
+mb: if (!isPair(c))
+ return;
+
+ { register place = placeInSet(c);
+ register mask = maskInSet(c);
+ if (marks[place]&mask)
+ return;
+ else {
+ marks[place] |= mask;
+ recordMark();
+ }
+ }
+
+ if (isGenPair(fst(c))) {
+ fst(c) = markCell(fst(c));
+ goto ma;
+ }
+ else if (isNull(fst(c)) || fst(c)>=BCSTAG)
+ goto ma;
+ return;
+}
+
+Void markWithoutMove(n) /* Garbage collect cell at n, as if*/
+Cell n; { /* it was a cell ref, but don't */
+ /* move cell so we don't have */
+ /* to modify the stored value of n */
+ if (isGenPair(n)) {
+ recordStackRoot();
+ markCell(n);
+ }
+}
+
+Void garbageCollect() { /* Run garbage collector ... */
+ Bool breakStat = breakOn(FALSE); /* disable break checking */
+ Int i,j;
+ register Int mask;
+ register Int place;
+ Int recovered;
+ jmp_buf regs; /* save registers on stack */
+ setjmp(regs);
+
+ gcStarted();
+ for (i=0; i<marksSize; ++i) /* initialise mark set to empty */
+ marks[i] = 0;
+
+ everybody(MARK); /* Mark all components of system */
+
+ gcScanning(); /* scan mark set */
+ mask = 1;
+ place = 0;
+ recovered = 0;
+ j = 0;
+ freeList = NIL;
+ for (i=1; i<=heapSize; i++) {
+ if ((marks[place] & mask) == 0) {
+ snd(-i) = freeList;
+ fst(-i) = FREECELL;
+ freeList = -i;
+ recovered++;
+ }
+ mask <<= 1;
+ if (++j == bitsPerWord) {
+ place++;
+ mask = 1;
+ j = 0;
+ }
+ }
+
+ gcRecovered(recovered);
+ breakOn(breakStat); /* restore break trapping if nec. */
+
+ /* can only return if freeList is nonempty on return. */
+ if (recovered<minRecovery || isNull(freeList)) {
+ ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
+ EEND;
+ }
+ cellsRecovered = recovered;
+}
+
+/* --------------------------------------------------------------------------
+ * Code for saving last expression entered:
+ *
+ * This is a little tricky because some text values (e.g. strings or variable
+ * names) may not be defined or have the same value when the expression is
+ * recalled. These text values are therefore saved in the top portion of
+ * the text table.
+ * ------------------------------------------------------------------------*/
+
+static Cell lastExprSaved; /* last expression to be saved */
+
+Void setLastExpr(e) /* save expression for later recall*/
+Cell e; {
+ lastExprSaved = NIL; /* in case attempt to save fails */
+ savedText = NUM_TEXT;
+ lastExprSaved = lowLevelLastIn(e);
+}
+
+static Cell local lowLevelLastIn(c) /* Duplicate expression tree (i.e. */
+Cell c; { /* acyclic graph) for later recall */
+ if (isPair(c)) /* Duplicating any text strings */
+ if (isBoxTag(fst(c))) /* in case these are lost at some */
+ switch (fst(c)) { /* point before the expr is reused */
+ case VARIDCELL :
+ case VAROPCELL :
+ case DICTVAR :
+ case CONIDCELL :
+ case CONOPCELL :
+ case STRCELL : return pair(fst(c),saveText(textOf(c)));
+ default : return pair(fst(c),snd(c));
+ }
+ else
+ return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
+#if TREX
+ else if (isExt(c))
+ return pair(EXTCOPY,saveText(extText(c)));
+#endif
+ else
+ return c;
+}
+
+Cell getLastExpr() { /* recover previously saved expr */
+ return lowLevelLastOut(lastExprSaved);
+}
+
+static Cell local lowLevelLastOut(c) /* As with lowLevelLastIn() above */
+Cell c; { /* except that Cells refering to */
+ if (isPair(c)) /* Text values are restored to */
+ if (isBoxTag(fst(c))) /* appropriate values */
+ switch (fst(c)) {
+ case VARIDCELL :
+ case VAROPCELL :
+ case DICTVAR :
+ case CONIDCELL :
+ case CONOPCELL :
+ case STRCELL : return pair(fst(c),
+ findText(text+intValOf(c)));
+#if TREX
+ case EXTCOPY : return mkExt(findText(text+intValOf(c)));
+#endif
+ default : return pair(fst(c),snd(c));
+ }
+ else
+ return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
+ else
+ return c;
+}
+
+/* --------------------------------------------------------------------------
+ * Miscellaneous operations on heap cells:
+ * ------------------------------------------------------------------------*/
+
+/* profiling suggests that the number of calls to whatIs() is typically */
+/* rather high. The recoded version below attempts to improve the average */
+/* performance for whatIs() using a binary search for part of the analysis */
+
+Cell whatIs(c) /* identify type of cell */
+register Cell c; {
+ if (isPair(c)) {
+ register Cell fstc = fst(c);
+ return isTag(fstc) ? fstc : AP;
+ }
+ if (c<TUPMIN) return c;
+ if (c>=INTMIN) return INTCELL;
+
+ if (c>=NAMEMIN) if (c>=CLASSMIN) if (c>=CHARMIN) return CHARCELL;
+ else return CLASS;
+ else if (c>=INSTMIN) return INSTANCE;
+ else return NAME;
+ else if (c>=MODMIN) if (c>=TYCMIN) return TYCON;
+ else return MODULE;
+ else if (c>=OFFMIN) return OFFSET;
+#if TREX
+ else if (c>=EXTMIN) return EXT;
+#endif
+ else return TUPLE;
+
+/* if (isPair(c)) {
+ register Cell fstc = fst(c);
+ return isTag(fstc) ? fstc : AP;
+ }
+ if (c>=CHARMIN) return CHARCELL;
+ if (c>=CLASSMIN) return CLASS;
+ if (c>=INSTMIN) return INSTANCE;
+ if (c>=NAMEMIN) return NAME;
+ if (c>=TYCMIN) return TYCON;
+ if (c>=MODMIN) return MODULE;
+ if (c>=OFFMIN) return OFFSET;
+#if TREX
+ if (c>=EXTMIN) return EXT;
+#endif
+ if (c>=TUPMIN) return TUPLE;
+ return c;*/
+}
+
+#if DEBUG_PRINTER
+/* A very, very simple printer.
+ * Output is uglier than from printExp - but the printer is more
+ * robust and can be used on any data structure irrespective of
+ * its type.
+ */
+Void print Args((Cell, Int));
+Void print(c, depth)
+Cell c;
+Int depth; {
+ if (0 == depth) {
+ Printf("...");
+ } else {
+ Int tag = whatIs(c);
+ switch (tag) {
+ case AP:
+ Putchar('(');
+ print(fst(c), depth-1);
+ Putchar(',');
+ print(snd(c), depth-1);
+ Putchar(')');
+ break;
+ case FREECELL:
+ Printf("free(%d)", c);
+ break;
+ case INTCELL:
+ Printf("int(%d)", intOf(c));
+ break;
+ case BIGCELL:
+ Printf("bignum(%s)", bignumToString(c));
+ break;
+ case CHARCELL:
+ Printf("char('%c')", charOf(c));
+ break;
+ case PTRCELL:
+ Printf("ptr(%p)",ptrOf(c));
+ break;
+ case CLASS:
+ Printf("class(%d)", c-CLASSMIN);
+ if (CLASSMIN <= c && c < classHw) {
+ Printf("=\"%s\"", textToStr(cclass(c).text));
+ }
+ break;
+ case INSTANCE:
+ Printf("instance(%d)", c - INSTMIN);
+ break;
+ case NAME:
+ Printf("name(%d)", c-NAMEMIN);
+ if (NAMEMIN <= c && c < nameHw) {
+ Printf("=\"%s\"", textToStr(name(c).text));
+ }
+ break;
+ case TYCON:
+ Printf("tycon(%d)", c-TYCMIN);
+ if (TYCMIN <= c && c < tyconHw)
+ Printf("=\"%s\"", textToStr(tycon(c).text));
+ break;
+ case MODULE:
+ Printf("module(%d)", c - MODMIN);
+ break;
+ case OFFSET:
+ Printf("Offset %d", offsetOf(c));
+ break;
+ case TUPLE:
+ Printf("Tuple %d", tupleOf(c));
+ break;
+ case POLYTYPE:
+ Printf("Polytype");
+ print(snd(c),depth-1);
+ break;
+ case RANK2:
+ Printf("Rank2(");
+ if (isPair(snd(c)) && isInt(fst(snd(c)))) {
+ Printf("%d ", intOf(fst(snd(c))));
+ print(snd(snd(c)),depth-1);
+ } else {
+ print(snd(c),depth-1);
+ }
+ Printf(")");
+ break;
+ case NIL:
+ Printf("NIL");
+ break;
+ case WILDCARD:
+ Printf("_");
+ break;
+ case STAR:
+ Printf("STAR");
+ break;
+ case DOTDOT:
+ Printf("DOTDOT");
+ break;
+ case DICTVAR:
+ Printf("{dict %d}",textOf(c));
+ break;
+ case VARIDCELL:
+ case VAROPCELL:
+ case CONIDCELL:
+ case CONOPCELL:
+ Printf("{id %s}",textToStr(textOf(c)));
+ break;
+ case QUALIDENT:
+ Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
+ break;
+ case LETREC:
+ Printf("LetRec(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ case LAMBDA:
+ Printf("Lambda(");
+ print(snd(c),depth-1);
+ Putchar(')');
+ break;
+ case FINLIST:
+ Printf("FinList(");
+ print(snd(c),depth-1);
+ Putchar(')');
+ break;
+ case COMP:
+ Printf("Comp(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ case ASPAT:
+ Printf("AsPat(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ case FROMQUAL:
+ Printf("FromQual(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ case STGVAR:
+ Printf("StgVar%d=",-c);
+ print(snd(c), depth-1);
+ break;
+ case STGAPP:
+ Printf("StgApp(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ case STGPRIM:
+ Printf("StgPrim(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ case STGCON:
+ Printf("StgCon(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ case PRIMCASE:
+ Printf("PrimCase(");
+ print(fst(snd(c)),depth-1);
+ Putchar(',');
+ print(snd(snd(c)),depth-1);
+ Putchar(')');
+ break;
+ default:
+ if (isBoxTag(tag)) {
+ Printf("Tag(%d)=%d", c, tag);
+ } else if (isConTag(tag)) {
+ Printf("%d@(%d,",c,tag);
+ print(snd(c), depth-1);
+ Putchar(')');
+ break;
+ } else if (c == tag) {
+ Printf("Tag(%d)", c);
+ } else {
+ Printf("Tag(%d)=%d", c, tag);
+ }
+ break;
+ }
+ }
+ FlushStdout();
+}
+#endif
+
+Bool isVar(c) /* is cell a VARIDCELL/VAROPCELL ? */
+Cell c; { /* also recognises DICTVAR cells */
+ return isPair(c) &&
+ (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
+}
+
+Bool isCon(c) /* is cell a CONIDCELL/CONOPCELL ? */
+Cell c; {
+ return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
+}
+
+Bool isQVar(c) /* is cell a [un]qualified varop/id? */
+Cell c; {
+ if (!isPair(c)) return FALSE;
+ switch (fst(c)) {
+ case VARIDCELL :
+ case VAROPCELL : return TRUE;
+
+ case QUALIDENT : return isVar(snd(snd(c)));
+
+ default : return FALSE;
+ }
+}
+
+Bool isQCon(c) /*is cell a [un]qualified conop/id? */
+Cell c; {
+ if (!isPair(c)) return FALSE;
+ switch (fst(c)) {
+ case CONIDCELL :
+ case CONOPCELL : return TRUE;
+
+ case QUALIDENT : return isCon(snd(snd(c)));
+
+ default : return FALSE;
+ }
+}
+
+Bool isQualIdent(c) /* is cell a qualified identifier? */
+Cell c; {
+ return isPair(c) && (fst(c)==QUALIDENT);
+}
+
+Bool isIdent(c) /* is cell an identifier? */
+Cell c; {
+ if (!isPair(c)) return FALSE;
+ switch (fst(c)) {
+ case VARIDCELL :
+ case VAROPCELL :
+ case CONIDCELL :
+ case CONOPCELL : return TRUE;
+
+ case QUALIDENT : return TRUE;
+
+ default : return FALSE;
+ }
+}
+
+Bool isInt(c) /* cell holds integer value? */
+Cell c; {
+ return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
+}
+
+Int intOf(c) /* find integer value of cell? */
+Cell c; {
+ assert(isInt(c));
+ return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
+}
+
+Cell mkInt(n) /* make cell representing integer */
+Int n; {
+ return isSmall(INTZERO+n) ? INTZERO+n : pair(INTCELL,n);
+}
+
+#if PTR_ON_HEAP
+#if SIZEOF_INTP == SIZEOF_INT
+typedef union {Int i; Ptr p;} IntOrPtr;
+Cell mkPtr(p)
+Ptr p;
+{
+ IntOrPtr x;
+ x.p = p;
+ return pair(PTRCELL,x.i);
+}
+
+Ptr ptrOf(c)
+Cell c;
+{
+ IntOrPtr x;
+ assert(isPtr(c));
+ x.i = snd(c);
+ return x.p;
+}
+#else
+/* For 8 byte addresses (used on the Alpha), we'll have to work harder */
+#error "PTR_ON_HEAP not supported on this architecture"
+#endif
+#endif
+
+String stringNegate( s )
+String s;
+{
+ if (s[0] == '-') {
+ return &s[1];
+ } else {
+ static char t[100];
+ t[0] = '-';
+ strcpy(&t[1],s); /* ToDo: use strncpy instead */
+ return t;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * List operations:
+ * ------------------------------------------------------------------------*/
+
+Int length(xs) /* calculate length of list xs */
+List xs; {
+ Int n = 0;
+ for (n=0; nonNull(xs); ++n)
+ xs = tl(xs);
+ return n;
+}
+
+List appendOnto(xs,ys) /* Destructively prepend xs onto */
+List xs, ys; { /* ys by modifying xs ... */
+ if (isNull(xs))
+ return ys;
+ else {
+ List zs = xs;
+ while (nonNull(tl(zs)))
+ zs = tl(zs);
+ tl(zs) = ys;
+ return xs;
+ }
+}
+
+List revDupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
+List xs;
+List ys; {
+ for( ; nonNull(xs); xs=tl(xs)) {
+ ys = cons(hd(xs),ys);
+ }
+ return ys;
+}
+
+List dupListOnto(xs,ys) /* Duplicate spine of list xs onto ys */
+List xs;
+List ys; {
+ return revOnto(revDupOnto(xs,NIL),ys);
+}
+
+List revOnto(xs,ys) /* Destructively reverse elements of*/
+List xs, ys; { /* list xs onto list ys... */
+ Cell zs;
+
+ while (nonNull(xs)) {
+ zs = tl(xs);
+ tl(xs) = ys;
+ ys = xs;
+ xs = zs;
+ }
+ return ys;
+}
+
+Bool eqList(as,bs)
+List as;
+List bs; {
+ while (nonNull(as) && nonNull(bs) && hd(as)==hd(bs)) {
+ as=tl(as);
+ bs=tl(bs);
+ }
+ return (isNull(as) && isNull(bs));
+}
+
+Cell varIsMember(t,xs) /* Test if variable is a member of */
+Text t; /* given list of variables */
+List xs; {
+ for (; nonNull(xs); xs=tl(xs))
+ if (t==textOf(hd(xs)))
+ return hd(xs);
+ return NIL;
+}
+
+Cell intIsMember(n,xs) /* Test if integer n is member of */
+Int n; /* given list of integers */
+List xs; {
+ for (; nonNull(xs); xs=tl(xs))
+ if (n==intOf(hd(xs)))
+ return hd(xs);
+ return NIL;
+}
+
+Cell cellIsMember(x,xs) /* Test for membership of specific */
+Cell x; /* cell x in list xs */
+List xs; {
+ for (; nonNull(xs); xs=tl(xs))
+ if (x==hd(xs))
+ return hd(xs);
+ return NIL;
+}
+
+Cell cellAssoc(c,xs) /* Lookup cell in association list */
+Cell c;
+List xs; {
+ for (; nonNull(xs); xs=tl(xs))
+ if (c==fst(hd(xs)))
+ return hd(xs);
+ return NIL;
+}
+
+Cell cellRevAssoc(c,xs) /* Lookup cell in range of */
+Cell c; /* association lists */
+List xs; {
+ for (; nonNull(xs); xs=tl(xs))
+ if (c==snd(hd(xs)))
+ return hd(xs);
+ return NIL;
+}
+
+List replicate(n,x) /* create list of n copies of x */
+Int n;
+Cell x; {
+ List xs=NIL;
+ assert(n>=0);
+ while (0<n--) {
+ xs = cons(x,xs);
+ }
+ return xs;
+}
+
+List diffList(xs,ys) /* list difference: xs\ys */
+List xs, ys; { /* result contains all elements of */
+ List result = NIL; /* `xs' not appearing in `ys' */
+ while (nonNull(xs)) {
+ List next = tl(xs);
+ if (!cellIsMember(hd(xs),ys)) {
+ tl(xs) = result;
+ result = xs;
+ }
+ xs = next;
+ }
+ return rev(result);
+}
+
+List deleteCell(xs, y) /* copy xs deleting pointers to y */
+List xs;
+Cell y; {
+ List result = NIL;
+ for(;nonNull(xs);xs=tl(xs)) {
+ Cell x = hd(xs);
+ if (x != y) {
+ result=cons(x,result);
+ }
+ }
+ return rev(result);
+}
+
+List take(n,xs) /* destructively truncate list to */
+Int n; /* specified length */
+List xs; {
+ List ys = xs;
+
+ assert(n>=0);
+ if (n==0)
+ return NIL;
+ while (1<n-- && nonNull(xs))
+ xs = tl(xs);
+ if (nonNull(xs))
+ tl(xs) = NIL;
+ return ys;
+}
+
+List splitAt(n,xs) /* drop n things from front of list */
+Int n;
+List xs; {
+ assert(n>=0);
+ for(; n>0; --n) {
+ xs = tl(xs);
+ }
+ return xs;
+}
+
+Cell nth(n,xs) /* extract n'th element of list */
+Int n;
+List xs; {
+ assert(n>=0);
+ for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
+ }
+ assert(nonNull(xs));
+ return hd(xs);
+}
+
+List removeCell(x,xs) /* destructively remove cell from */
+Cell x; /* list */
+List xs; {
+ if (nonNull(xs)) {
+ if (hd(xs)==x)
+ return tl(xs); /* element at front of list */
+ else {
+ List prev = xs;
+ List curr = tl(xs);
+ for (; nonNull(curr); prev=curr, curr=tl(prev))
+ if (hd(curr)==x) {
+ tl(prev) = tl(curr);
+ return xs; /* element in middle of list */
+ }
+ }
+ }
+ return xs; /* here if element not found */
+}
+
+/* --------------------------------------------------------------------------
+ * Operations on applications:
+ * ------------------------------------------------------------------------*/
+
+Int argCount; /* number of args in application */
+
+Cell getHead(e) /* get head cell of application */
+Cell e; { /* set number of args in argCount */
+ for (argCount=0; isAp(e); e=fun(e))
+ argCount++;
+ return e;
+}
+
+List getArgs(e) /* get list of arguments in function*/
+Cell e; { /* application: */
+ List as; /* getArgs(f e1 .. en) = [e1,..,en] */
+
+ for (as=NIL; isAp(e); e=fun(e))
+ as = cons(arg(e),as);
+ return as;
+}
+
+Cell nthArg(n,e) /* return nth arg in application */
+Int n; /* of function to m args (m>=n) */
+Cell e; { /* nthArg n (f x0 x1 ... xm) = xn */
+ assert(n>=0);
+ for (n=numArgs(e)-n-1; n>0; n--)
+ e = fun(e);
+ return arg(e);
+}
+
+Int numArgs(e) /* find number of arguments to expr */
+Cell e; {
+ Int n;
+ for (n=0; isAp(e); e=fun(e))
+ n++;
+ return n;
+}
+
+Cell applyToArgs(f,args) /* destructively apply list of args */
+Cell f; /* to function f */
+List args; {
+ while (nonNull(args)) {
+ Cell temp = tl(args);
+ tl(args) = hd(args);
+ hd(args) = f;
+ f = args;
+ args = temp;
+ }
+ return f;
+}
+
+/* --------------------------------------------------------------------------
+ * storage control:
+ * ------------------------------------------------------------------------*/
+
+#if DYN_TABLES
+static void far* safeFarCalloc Args((Int,Int));
+static void far* safeFarCalloc(n,s) /* allocate table storage and check*/
+Int n, s; { /* for non-null return */
+ void far* tab = farCalloc(n,s);
+ if (tab==0) {
+ ERRMSG(0) "Cannot allocate run-time tables"
+ EEND;
+ }
+ return tab;
+}
+#define TABALLOC(v,t,n) v=(t far*)safeFarCalloc(n,sizeof(t));
+#else
+#define TABALLOC(v,t,n)
+#endif
+
+Void storage(what)
+Int what; {
+ Int i;
+
+ switch (what) {
+ case RESET : clearStack();
+
+ consGC = TRUE;
+ lsave = NIL;
+ rsave = NIL;
+ if (isNull(lastExprSaved))
+ savedText = NUM_TEXT;
+ break;
+
+ case MARK :
+ start();
+ for (i=NAMEMIN; i<nameHw; ++i) {
+ mark(name(i).defn);
+ mark(name(i).stgVar);
+ mark(name(i).type);
+ }
+ end("Names", nameHw-NAMEMIN);
+
+ start();
+ for (i=MODMIN; i<moduleHw; ++i) {
+ mark(module(i).tycons);
+ mark(module(i).names);
+ mark(module(i).classes);
+ mark(module(i).exports);
+ mark(module(i).qualImports);
+ }
+ end("Modules", moduleHw-MODMIN);
+
+ start();
+ for (i=TYCMIN; i<tyconHw; ++i) {
+ mark(tycon(i).defn);
+ mark(tycon(i).kind);
+ mark(tycon(i).what);
+ }
+ end("Type constructors", tyconHw-TYCMIN);
+
+ start();
+ for (i=CLASSMIN; i<classHw; ++i) {
+ mark(cclass(i).head);
+ mark(cclass(i).kinds);
+ mark(cclass(i).dsels);
+ mark(cclass(i).supers);
+ mark(cclass(i).members);
+ mark(cclass(i).defaults);
+ mark(cclass(i).instances);
+ }
+ mark(classes);
+ end("Classes", classHw-CLASSMIN);
+
+ start();
+ for (i=INSTMIN; i<instHw; ++i) {
+ mark(inst(i).kinds);
+ mark(inst(i).head);
+ mark(inst(i).specifics);
+ mark(inst(i).implements);
+ }
+ end("Instances", instHw-INSTMIN);
+
+ start();
+ for (i=0; i<=sp; ++i)
+ mark(stack(i));
+ end("Stack", sp+1);
+
+ start();
+ mark(lastExprSaved);
+ mark(lsave);
+ mark(rsave);
+ end("Last expression", 3);
+
+ if (consGC) {
+ start();
+ gcCStack();
+ end("C stack", stackRoots);
+ }
+
+ break;
+
+ case INSTALL : heapFst = heapAlloc(heapSize);
+ heapSnd = heapAlloc(heapSize);
+
+ if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
+ ERRMSG(0) "Cannot allocate heap storage (%d cells)",
+ heapSize
+ EEND;
+ }
+
+ heapTopFst = heapFst + heapSize;
+ heapTopSnd = heapSnd + heapSize;
+ for (i=1; i<heapSize; ++i) {
+ fst(-i) = FREECELL;
+ snd(-i) = -(i+1);
+ }
+ snd(-heapSize) = NIL;
+ freeList = -1;
+ consGC = TRUE;
+ lsave = NIL;
+ rsave = NIL;
+
+ marksSize = bitArraySize(heapSize);
+ if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
+ ERRMSG(0) "Unable to allocate gc markspace"
+ EEND;
+ }
+
+ TABALLOC(text, char, NUM_TEXT)
+ TABALLOC(tabSyntax, struct strSyntax, NUM_SYNTAX)
+ TABALLOC(tyconHash, Tycon, TYCONHSZ)
+ TABALLOC(tabTycon, struct strTycon, NUM_TYCON)
+ TABALLOC(nameHash, Name, NAMEHSZ)
+ TABALLOC(tabName, struct strName, NUM_NAME)
+ TABALLOC(tabClass, struct strClass, NUM_CLASSES)
+ TABALLOC(cellStack, Cell, NUM_STACK)
+ TABALLOC(tabModule, struct Module, NUM_SCRIPTS)
+#if TREX
+ TABALLOC(tabExt, Text, NUM_EXT)
+#endif
+ clearStack();
+
+ textHw = 0;
+ nextNewText = NUM_TEXT;
+ nextNewDText = (-1);
+ lastExprSaved = NIL;
+ savedText = NUM_TEXT;
+ for (i=0; i<TEXTHSZ; ++i)
+ textHash[i][0] = NOTEXT;
+
+ syntaxHw = 0;
+
+ moduleHw = MODMIN;
+
+ tyconHw = TYCMIN;
+ for (i=0; i<TYCONHSZ; ++i)
+ tyconHash[i] = NIL;
+
+#if TREX
+ extHw = EXTMIN;
+#endif
+
+ nameHw = NAMEMIN;
+ for (i=0; i<NAMEHSZ; ++i)
+ nameHash[i] = NIL;
+
+ classHw = CLASSMIN;
+
+ instHw = INSTMIN;
+
+#if USE_DICTHW
+ dictHw = 0;
+#endif
+
+ tabInst = (struct strInst far *)
+ farCalloc(NUM_INSTS,sizeof(struct strInst));
+
+ if (tabInst==0) {
+ ERRMSG(0) "Cannot allocate instance tables"
+ EEND;
+ }
+
+ scriptHw = 0;
+
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair,
+ * Triple, ...
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: storage.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:43 $
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Typedefs for main data types:
+ * Many of these type names are used to indicate the intended us of a data
+ * item, rather than for type checking purposes. Sadly (although sometimes,
+ * fortunately), the C compiler cannot distinguish between the use of two
+ * different names defined to be synonyms for the same types.
+ * ------------------------------------------------------------------------*/
+
+typedef Int Text; /* text string */
+typedef Word Syntax; /* syntax (assoc,preced) */
+typedef Int Cell; /* general cell value */
+typedef Cell far *Heap; /* storage of heap */
+typedef Cell Pair; /* pair cell */
+typedef Int StackPtr; /* stack pointer */
+typedef Cell Offset; /* offset/generic variable*/
+typedef Int Script; /* script file number */
+typedef Int Module; /* module */
+typedef Cell Tycon; /* type constructor */
+typedef Cell Type; /* type expression */
+typedef Cell Kind; /* kind expression */
+typedef Cell Kinds; /* list of kinds */
+typedef Cell Constr; /* constructor expression */
+typedef Cell Name; /* named value */
+typedef Cell Class; /* type class */
+typedef Cell Inst; /* instance of type class */
+typedef Cell Triple; /* triple of cell values */
+typedef Cell List; /* list of cells */
+typedef Cell Bignum; /* integer literal */
+typedef Cell Float; /* floating pt literal */
+#if TREX
+typedef Cell Ext; /* extension label */
+#endif
+
+/* --------------------------------------------------------------------------
+ * Text storage:
+ * provides storage for the characters making up identifier and symbol
+ * names, string literals, character constants etc...
+ * ------------------------------------------------------------------------*/
+
+extern String textToStr Args((Text));
+extern Text findText Args((String));
+extern Text inventText Args((Void));
+extern Text inventDictText Args((Void));
+extern Bool inventedText Args((Text));
+
+/* Variants of textToStr and syntaxOf which work for idents, ops whether
+ * qualified or unqualified.
+ */
+extern String identToStr Args((Cell));
+extern Syntax identSyntax Args((Cell));
+extern Syntax defaultSyntax Args((Text));
+
+/* --------------------------------------------------------------------------
+ * Specification of syntax (i.e. default written form of application)
+ * ------------------------------------------------------------------------*/
+
+#define MIN_PREC 0 /* weakest binding operator */
+#define MAX_PREC 9 /* strongest binding operator */
+#define FUN_PREC (MAX_PREC+2) /* binding of function symbols */
+#define DEF_PREC MAX_PREC
+#define APPLIC 00000 /* written applicatively */
+#define LEFT_ASS 02000 /* left associative infix */
+#define RIGHT_ASS 04000 /* right associative infix */
+#define NON_ASS 06000 /* non associative infix */
+#define DEF_ASS NON_ASS
+
+#define assocOf(x) ((x)&NON_ASS)
+#define precOf(x) ((x)&(~NON_ASS))
+#define mkSyntax(a,p) ((a)|(p))
+#define DEF_OPSYNTAX mkSyntax(DEF_ASS,DEF_PREC)
+
+extern Void addSyntax Args((Int,Text,Syntax));
+extern Syntax syntaxOf Args((Text));
+
+/* --------------------------------------------------------------------------
+ * Heap storage:
+ * Provides a garbage collectable heap for storage of expressions etc.
+ * ------------------------------------------------------------------------*/
+
+#define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell)))
+#define heapBuilt() (heapFst)
+extern Int heapSize;
+extern Heap heapFst, heapSnd;
+extern Heap heapTopFst;
+extern Heap heapTopSnd;
+extern Bool consGC; /* Set to FALSE to turn off gc from*/
+ /* C stack; use with extreme care! */
+extern Int cellsRecovered; /* cells recovered by last gc */
+
+#define fst(c) heapTopFst[c]
+#define snd(c) heapTopSnd[c]
+
+extern Pair pair Args((Cell,Cell));
+extern Void garbageCollect Args((Void));
+
+extern Void overwrite Args((Pair,Pair));
+extern Void overwrite2 Args((Pair,Cell,Cell));
+extern Cell markExpr Args((Cell));
+extern Void markWithoutMove Args((Cell));
+
+#define mark(v) v=markExpr(v)
+
+#define isPair(c) ((c)<0)
+#define isGenPair(c) ((c)<0 && -heapSize<=(c))
+
+extern Cell whatIs Args((Cell));
+
+/* --------------------------------------------------------------------------
+ * Box cell tags are used as the fst element of a pair to indicate that
+ * the snd element of the pair is to be treated in some special way, other
+ * than as a Cell. Examples include holding integer values, variable name
+ * and string text etc.
+ * ------------------------------------------------------------------------*/
+
+#define TAGMIN 1 /* Box and constructor cell tag values */
+#define BCSTAG 20 /* Box=TAGMIN..BCSTAG-1 */
+#define isTag(c) (TAGMIN<=(c) && (c)<SPECMIN) /* Tag cell values */
+#define isBoxTag(c) (TAGMIN<=(c) && (c)<BCSTAG) /* Box cell tag values */
+#define isConTag(c) (BCSTAG<=(c) && (c)<SPECMIN) /* Constr cell tag values*/
+
+#define FREECELL 3 /* Free list cell: snd :: Cell */
+#define VARIDCELL 4 /* Identifier variable: snd :: Text */
+#define VAROPCELL 5 /* Operator variable: snd :: Text */
+#define DICTVAR 6 /* Dictionary variable: snd :: Text */
+#define CONIDCELL 7 /* Identifier constructor: snd :: Text */
+#define CONOPCELL 8 /* Operator constructor: snd :: Text */
+#define STRCELL 9 /* String literal: snd :: Text */
+#define INTCELL 10 /* Int literal: snd :: Int */
+#define FLOATCELL 15 /* Floating Pt literal: snd :: Text */
+#define BIGCELL 16 /* Integer literal: snd :: Text */
+#if PTR_ON_HEAP
+#define PTRCELL 17 /* C Heap Pointer snd :: Ptr */
+#endif
+#if TREX
+#define EXTCOPY 18 /* Copy of an Ext: snd :: Text */
+#endif
+
+#define textOf(c) ((Text)(snd(c))) /* c :: (VAR|CON)(ID|OP) */
+#define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */
+#define qtextOf(c) (textOf(snd(snd(c)))) /* c :: QUALIDENT */
+#define mkVar(t) ap(VARIDCELL,t)
+#define mkVarop(t) ap(VAROPCELL,t)
+#define mkCon(t) ap(CONIDCELL,t)
+#define mkConop(t) ap(CONOPCELL,t)
+#define mkQVar(m,t) ap(QUALIDENT,pair(mkCon(m),mkVar(t)))
+#define mkQCon(m,t) ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
+#define mkQVarOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
+#define mkQConOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
+#define intValOf(c) (snd(c))
+#define inventVar() mkVar(inventText())
+#define mkDictVar(t) ap(DICTVAR,t)
+#define inventDictVar() mkDictVar(inventDictText())
+#define mkStr(t) ap(STRCELL,t)
+extern Bool isVar Args((Cell));
+extern Bool isCon Args((Cell));
+extern Bool isQVar Args((Cell));
+extern Bool isQCon Args((Cell));
+extern Bool isQualIdent Args((Cell));
+extern Bool isIdent Args((Cell));
+
+extern String stringNegate Args((String));
+
+#define intEq(x,y) (intOf(x) == intOf(y))
+#define intNegate(x) mkInt(-intOf(x))
+
+#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
+#define stringToFloat(s) pair(FLOATCELL,findText(s))
+#define floatToString(f) textToStr(snd(f))
+#define floatEq(f1,f2) (snd(f1) == snd(f2))
+#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
+#define floatOf(f) atof(floatToString(f))
+
+#define isBignum(c) (isPair(c) && fst(c)==BIGCELL)
+#define stringToBignum(s) pair(BIGCELL,findText(s))
+#define bignumToString(b) textToStr(snd(b))
+#define bignumEq(b1,b2) (snd(b1) == snd(b2))
+#define bignumNegate(b) stringToBignum(stringNegate(bignumToString(b)))
+#define bignumOf(b) atoi(bignumToString(b)) /* ToDo: overflow check */
+
+#if PTR_ON_HEAP
+#define isPtr(c) (isPair(c) && fst(c)==PTRCELL)
+extern Cell mkPtr Args((Ptr));
+extern Ptr ptrOf Args((Cell));
+#endif
+
+/* --------------------------------------------------------------------------
+ * Constructor cell tags are used as the fst element of a pair to indicate
+ * a particular syntactic construct described by the snd element of the
+ * pair.
+ * Note that a cell c will not be treated as an application (AP/isAp) node
+ * if its first element is a constructor cell tag, whereas a cell whose fst
+ * element is a special cell will be treated as an application node.
+ * ------------------------------------------------------------------------*/
+
+#define LETREC 20 /* LETREC snd :: ([Decl],Exp) */
+#define COND 21 /* COND snd :: (Exp,Exp,Exp) */
+#define LAMBDA 22 /* LAMBDA snd :: Alt */
+#define FINLIST 23 /* FINLIST snd :: [Exp] */
+#define DOCOMP 24 /* DOCOMP snd :: (Exp,[Qual]) */
+#define BANG 25 /* BANG snd :: Type */
+#define COMP 26 /* COMP snd :: (Exp,[Qual]) */
+#define ASPAT 27 /* ASPAT snd :: (Var,Exp) */
+#define ESIGN 28 /* ESIGN snd :: (Exp,Type) */
+#define CASE 29 /* CASE snd :: (Exp,[Alt]) */
+#define NUMCASE 30 /* NUMCASE snd :: (Exp,Disc,Rhs) */
+#define FATBAR 31 /* FATBAR snd :: (Exp,Exp) */
+#define LAZYPAT 32 /* LAZYPAT snd :: Exp */
+#define DERIVE 35 /* DERIVE snd :: Cell */
+#if NPLUSK
+#define ADDPAT 36 /* (_+k) pattern discr: snd :: Cell */
+#endif
+
+#define BOOLQUAL 39 /* BOOLQUAL snd :: Exp */
+#define QWHERE 40 /* QWHERE snd :: [Decl] */
+#define FROMQUAL 41 /* FROMQUAL snd :: (Exp,Exp) */
+#define DOQUAL 42 /* DOQUAL snd :: Exp */
+
+#define GUARDED 44 /* GUARDED snd :: [guarded exprs] */
+
+#define ARRAY 45 /* Array: snd :: (Bounds,[Values]) */
+#define MUTVAR 46 /* Mutvar: snd :: Cell */
+
+#define POLYTYPE 50 /* POLYTYPE snd :: (Kind,Type) */
+#define QUAL 51 /* QUAL snd :: ([Classes],Type) */
+#define RANK2 52 /* RANK2 snd :: (Int,Type) */
+#define EXIST 53 /* EXIST snd :: (Int,Type) */
+#define POLYREC 54 /* POLYREC: snd :: (Int,Type) */
+#define BIGLAM 55 /* BIGLAM: snd :: (vars,patterns) */
+
+#define LABC 60 /* LABC: snd :: (con,[(Vars,Type)]) */
+#define CONFLDS 61 /* CONFLDS: snd :: (con,[Field]) */
+#define UPDFLDS 62 /* UPDFLDS: snd :: (Exp,[con],[Field]) */
+#if TREX
+#define RECORD 63 /* RECORD: snd :: [Val] */
+#define EXTCASE 64 /* EXTCASE: snd :: (Exp,Disc,Rhs) */
+#define RECSEL 65 /* RECSEL: snd :: Ext */
+#endif
+
+#define QUALIDENT 70 /* Qualified identifier snd :: (Id,Id) */
+#define HIDDEN 71 /* hiding import list snd :: [Entity] */
+#define MODULEENT 72 /* module in export list snd :: con */
+
+#define ONLY 75 /* ONLY: snd :: Exp (used in parser)*/
+#define NEG 76 /* NEG: snd :: Exp (used in parser)*/
+
+#define IMPDEPS 78 /* IMPDEFS: snd :: [Binding] */
+
+#define STGVAR 80 /* STGVAR snd :: (StgRhs,info) */
+#define STGAPP 81 /* STGAPP snd :: (StgVar,[Arg]) */
+#define STGPRIM 82 /* STGPRIM snd :: (PrimOp,[Arg]) */
+#define STGCON 83 /* STGCON snd :: (StgCon,[Arg]) */
+#define PRIMCASE 84 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
+
+/* Used when parsing GHC interface files */
+#define DICTAP 85 /* DICTTYPE snd :: (QClassId,[Type]) */
+
+/* Last constructor tag must be less than SPECMIN */
+
+/* --------------------------------------------------------------------------
+ * Special cell values:
+ * ------------------------------------------------------------------------*/
+
+#define SPECMIN 101
+#define isSpec(c) (SPECMIN<=(c) && (c)<TUPMIN)/* Special cell values */
+
+#define NONE 101 /* Dummy stub */
+#define STAR 102 /* Representing the kind of types */
+#if TREX
+#define ROW 103 /* Representing the kind of rows */
+#endif
+#define WILDCARD 104 /* Wildcard pattern */
+#define SKOLEM 105 /* Skolem constant */
+
+#define DOTDOT 106 /* ".." in import/export list */
+
+#define NAME 110 /* whatIs code for isName */
+#define TYCON 111 /* whatIs code for isTycon */
+#define CLASS 112 /* whatIs code for isClass */
+#define MODULE 113 /* whatIs code for isModule */
+#define INSTANCE 114 /* whatIs code for isInst */
+#define TUPLE 115 /* whatIs code for tuple constructor */
+#define OFFSET 116 /* whatis code for offset */
+#define AP 117 /* whatIs code for application node */
+#define CHARCELL 118 /* whatIs code for isChar */
+#if TREX
+#define EXT 119 /* whatIs code for isExt */
+#endif
+
+#define SIGDECL 120 /* Signature declaration */
+#define PREDEFINED 121 /* predefined name, not yet filled */
+
+#define DATATYPE 130 /* datatype type constructor */
+#define NEWTYPE 131 /* newtype type constructor */
+#define SYNONYM 132 /* synonym type constructor */
+#define RESTRICTSYN 133 /* synonym with restricted scope */
+
+#define NODEPENDS 135 /* stop calculation of deps in type check*/
+
+/* --------------------------------------------------------------------------
+ * Tuple data/type constructors:
+ * ------------------------------------------------------------------------*/
+
+#define TUPMIN 201
+#if TREX
+#define isTuple(c) (TUPMIN<=(c) && (c)<EXTMIN)
+#else
+#define isTuple(c) (TUPMIN<=(c) && (c)<OFFMIN)
+#endif
+#define mkTuple(n) (TUPMIN+(n))
+#define tupleOf(n) ((Int)((n)-TUPMIN))
+
+#if TREX
+#define EXTMIN (TUPMIN+NUM_TUPLES)
+#define isExt(c) (EXTMIN<=(c) && (c)<OFFMIN)
+#define extText(e) tabExt[(e)-EXTMIN]
+#define extField(c) arg(fun(c))
+#define extRow(c) arg(c)
+
+extern Text DECTABLE(tabExt);
+extern Ext mkExt Args((Text));
+#else
+#define mkExt(t) NIL
+#endif
+
+/* --------------------------------------------------------------------------
+ * Offsets: (generic types/stack offsets)
+ * ------------------------------------------------------------------------*/
+
+#if TREX
+#define OFFMIN (EXTMIN+NUM_EXT)
+#else
+#define OFFMIN (TUPMIN+NUM_TUPLES)
+#endif
+#define isOffset(c) (OFFMIN<=(c) && (c)<MODMIN)
+#define offsetOf(c) ((c)-OFFMIN)
+#define mkOffset(o) (OFFMIN+(o))
+
+/* --------------------------------------------------------------------------
+ * Modules:
+ * ------------------------------------------------------------------------*/
+
+#define MODMIN (OFFMIN+NUM_OFFSETS)
+
+#define isModule(c) (MODMIN<=(c) && (c)<TYCMIN)
+#define mkModule(n) (MODMIN+(n))
+#define module(n) tabModule[(n)-MODMIN]
+
+/* Under Haskell 1.3, the list of qualified imports is always a subset
+ * of the list of unqualified imports. For simplicity and flexibility,
+ * we do not attempt to exploit this fact - when a module is imported
+ * unqualified, it is added to both the qualified and unqualified
+ * import lists.
+ * Similarily, Haskell 1.3 does not allow a constructor to be imported
+ * or exported without exporting the type it belongs to but the export
+ * list is just a flat list of Texts (before static analysis) or
+ * Tycons, Names and Classes (after static analysis).
+ */
+struct Module {
+ Text text;
+ /* Lists of top level objects (local defns + imports) */
+ List tycons;
+ List names;
+ List classes;
+ List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
+ /* List of qualified imports. Used both during compilation and when
+ * evaluating an expression in the context of the current module.
+ */
+ List qualImports;
+ ObjectFile objectFile; /* usually unused */
+};
+
+extern Module currentModule; /* Module currently being processed */
+extern struct Module DECTABLE(tabModule);
+
+extern Bool isValidModule Args((Module));
+extern Module newModule Args((Text));
+extern Module findModule Args((Text));
+extern Module findModid Args((Cell));
+extern Void setCurrModule Args((Module));
+
+/* --------------------------------------------------------------------------
+ * Type constructor names:
+ * ------------------------------------------------------------------------*/
+
+#define TYCMIN (MODMIN+NUM_MODULE)
+#define isTycon(c) (TYCMIN<=(c) && (c)<NAMEMIN)
+#define mkTycon(n) (TCMIN+(n))
+#define tycon(n) tabTycon[(n)-TYCMIN]
+
+struct strTycon {
+ Text text;
+ Int line;
+ Module mod; /* module that defines it */
+ Int arity;
+ Kind kind; /* kind (includes arity) of Tycon */
+ Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
+ Cell defn;
+ Name conToTag; /* used in derived code */
+ Name tagToCon;
+ Tycon nextTyconHash;
+};
+
+extern struct strTycon DECTABLE(tabTycon);
+
+extern Tycon newTycon Args((Text));
+extern Tycon findTycon Args((Text));
+extern Tycon addTycon Args((Tycon));
+extern Tycon findQualTycon Args((Cell));
+extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
+
+#define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
+#define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
+#define isPolyType(t) (isPair(t) && fst(t)==POLYTYPE)
+#define polySigOf(t) fst(snd(t))
+#define monotypeOf(t) snd(snd(t))
+
+/* --------------------------------------------------------------------------
+ * Globally defined name values:
+ * ------------------------------------------------------------------------*/
+
+#define NAMEMIN (TYCMIN+NUM_TYCON)
+#define isName(c) (NAMEMIN<=(c) && (c)<INSTMIN)
+#define mkName(n) (NAMEMIN+(n))
+#define name(n) tabName[(n)-NAMEMIN]
+
+struct strName {
+ Text text;
+ Int line;
+ Module mod; /* module that defines it */
+ Int arity;
+ Int number;
+ Cell type;
+ Cell defn;
+ Cell stgVar; /* really StgVar */
+ const void* primop; /* really StgPrim* */
+ Name nextNameHash;
+};
+
+extern int numNames Args(( Void ));
+
+extern struct strName DECTABLE(tabName);
+
+/* The number field in a name is used to distinguish various kinds of name:
+ * mfunNo(i) = code for member function, offset i
+ * members that are sole elements of dict use mfunNo(0)
+ * members of dicts with more than one elem use mfunNo(n), n>=1
+ * EXECNAME = code for executable name (bytecodes or primitive)
+ * SELNAME = code for selector function
+ * DFUNNAME = code for dictionary builder or selector
+ * cfunNo(i) = code for data constructor
+ * datatypes with only one constructor uses cfunNo(0)
+ * datatypes with multiple constructors use cfunNo(n), n>=1
+ */
+
+#define EXECNAME 0
+#define SELNAME 1
+#define DFUNNAME 2
+#define CFUNNAME 3
+
+#define isSfun(n) (name(n).number==SELNAME)
+#define isDfun(n) (name(n).number==DFUNNAME)
+
+#define isCfun(n) (name(n).number>=CFUNNAME)
+#define cfunOf(n) (name(n).number-CFUNNAME)
+#define cfunNo(i) ((i)+CFUNNAME)
+#define hasCfun(cs) (nonNull(cs) && isCfun(hd(cs)))
+
+#define isMfun(n) (name(n).number<0)
+#define mfunOf(n) ((-1)-name(n).number)
+#define mfunNo(i) ((-1)-(i))
+
+extern Name newName Args((Text));
+extern Name findName Args((Text));
+extern Name addName Args((Name));
+extern Name findQualName Args((Int,Cell));
+extern Name addPrimCfun Args((Text,Int,Int,Int));
+extern Int sfunPos Args((Name,Name));
+
+/* --------------------------------------------------------------------------
+ * Type class values:
+ * ------------------------------------------------------------------------*/
+
+#define INSTMIN (NAMEMIN+NUM_NAME) /* instances */
+#define isInst(c) (INSTMIN<=(c) && (c)<CLASSMIN)
+#define mkInst(n) (INSTMIN+(n))
+#define instOf(c) ((Int)((c)-INSTMIN))
+#define inst(in) tabInst[(in)-INSTMIN]
+
+struct strInst {
+ Class c; /* class C */
+ Int line;
+ Module mod; /* module that defines it */
+ Kinds kinds; /* Kinds of variables in head */
+ Cell head; /* :: Pred */
+ List specifics; /* :: [Pred] */
+ Int numSpecifics; /* length(specifics) */
+ List implements;
+ Name builder; /* Dictionary constructor function */
+};
+
+/* a predicate (an element :: Pred) is an application of a Class to one or
+ * more type expressions
+ */
+
+#define CLASSMIN (INSTMIN+NUM_INSTS)
+#define isClass(c) (CLASSMIN<=(c) && (c)<CHARMIN)
+#define mkClass(n) (CLASSMIN+(n))
+#define cclass(n) tabClass[(n)-CLASSMIN]
+
+struct strClass {
+ Text text; /* Name of class */
+ Int line; /* Line where declaration begins */
+ Module mod; /* module that defines it */
+ Int level; /* Level in class hierarchy */
+ Int arity; /* Number of arguments */
+ Kinds kinds; /* Kinds of constructors in class */
+ Cell head; /* Head of class */
+ Name dcon; /* Dictionay constructor function */
+ List supers; /* :: [Pred] */
+ Int numSupers; /* length(supers) */
+ List dsels; /* Superclass dictionary selectors */
+ List members; /* :: [Name] */
+ Int numMembers; /* length(members) */
+ Name dbuild; /* Default dictionary builder */
+ List defaults; /* :: [Name] */
+ List instances; /* :: [Inst] */
+};
+
+extern struct strClass DECTABLE(tabClass);
+extern struct strInst far *tabInst;
+
+extern Class newClass Args((Text));
+extern Class classMax Args((Void));
+extern Class findClass Args((Text));
+extern Class addClass Args((Class));
+extern Class findQualClass Args((Cell));
+extern Inst newInst Args((Void));
+extern Inst findFirstInst Args((Tycon));
+extern Inst findNextInst Args((Tycon,Inst));
+
+/* --------------------------------------------------------------------------
+ * Character values:
+ * ------------------------------------------------------------------------*/
+
+#define CHARMIN (CLASSMIN+NUM_CLASSES)
+#define MAXCHARVAL (NUM_CHARS-1)
+#define isChar(c) (CHARMIN<=(c) && (c)<INTMIN)
+#define charOf(c) ((Char)(c-CHARMIN))
+#define mkChar(c) ((Cell)(CHARMIN+((unsigned)((c)%NUM_CHARS))))
+
+/* --------------------------------------------------------------------------
+ * Small Integer values:
+ * ------------------------------------------------------------------------*/
+
+#define INTMIN (CHARMIN+NUM_CHARS)
+#define INTMAX MAXPOSINT
+#define isSmall(c) (INTMIN<=(c))
+#define INTZERO (INTMIN/2 + INTMAX/2)
+#define mkDigit(c) ((Cell)((c)+INTMIN))
+#define digitOf(c) ((Int)((c)-INTMIN))
+
+extern Bool isInt Args((Cell));
+extern Int intOf Args((Cell));
+extern Cell mkInt Args((Int));
+
+/* --------------------------------------------------------------------------
+ * Implementation of triples:
+ * ------------------------------------------------------------------------*/
+
+#define triple(x,y,z) pair(x,pair(y,z))
+#define fst3(c) fst(c)
+#define snd3(c) fst(snd(c))
+#define thd3(c) snd(snd(c))
+
+/* --------------------------------------------------------------------------
+ * Implementation of lists:
+ * ------------------------------------------------------------------------*/
+
+#define NIL 0
+#define isNull(c) ((c)==NIL)
+#define nonNull(c) (c)
+#define cons(x,xs) pair(x,xs)
+#define singleton(x) cons(x,NIL)
+#define doubleton(x,y) cons(x,cons(y,NIL))
+#define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
+#define hd(c) fst(c)
+#define tl(c) snd(c)
+
+extern Int length Args((List));
+extern List appendOnto Args((List,List)); /* destructive */
+extern List revDupOnto Args((List,List)); /* non-destructive */
+extern List dupListOnto Args((List,List)); /* non-destructive */
+extern List revOnto Args((List,List)); /* destructive */
+#define reverse(xs) revDupOnto((xs),NIL) /* non-destructive */
+#define dupList(xs) dupListOnto((xs),NIL) /* non-destructive */
+#define rev(xs) revOnto((xs),NIL) /* destructive */
+extern Cell cellIsMember Args((Cell,List));
+extern Cell cellAssoc Args((Cell,List));
+extern Cell cellRevAssoc Args((Cell,List));
+extern Bool eqList Args((List,List));
+extern Cell varIsMember Args((Text,List));
+extern Cell intIsMember Args((Int,List));
+extern List replicate Args((Int,Cell));
+extern List diffList Args((List,List)); /* destructive */
+extern List deleteCell Args((List,Cell)); /* non-destructive */
+extern List take Args((Int,List)); /* destructive */
+extern List splitAt Args((Int,List)); /* non-destructive */
+extern Cell nth Args((Int,List));
+extern List removeCell Args((Cell,List)); /* destructive */
+
+/* The following macros provide `inline expansion' of some common ways of
+ * traversing, using and modifying lists:
+ *
+ * N.B. We use the names _f, _a, _xs, Zs, in an attempt to avoid clashes
+ * with identifiers used elsewhere.
+ */
+
+#define mapBasic(_init,_step) {List Zs=(_init);\
+ for(;nonNull(Zs);Zs=tl(Zs)) \
+ _step;}
+#define mapModify(_init,_step) mapBasic(_init,hd(Zs)=_step)
+
+#define mapProc(_f,_xs) mapBasic(_xs,_f(hd(Zs)))
+#define map1Proc(_f,_a,_xs) mapBasic(_xs,_f(_a,hd(Zs)))
+#define map2Proc(_f,_a,_b,_xs) mapBasic(_xs,_f(_a,_b,hd(Zs)))
+#define map3Proc(_f,_a,_b,_c,_xs) mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
+
+#define mapOver(_f,_xs) mapModify(_xs,_f(hd(Zs)))
+#define map1Over(_f,_a,_xs) mapModify(_xs,_f(_a,hd(Zs)))
+#define map2Over(_f,_a,_b,_xs) mapModify(_xs,_f(_a,_b,hd(Zs)))
+#define map3Over(_f,_a,_b,_c,_xs) mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
+
+/* This is just what you want for functions with accumulating parameters */
+#define mapAccum(_f,_acc,_xs) mapBasic(_xs,_acc=_f(_acc,hd(Zs)))
+#define map1Accum(_f,_acc,_a,_xs) mapBasic(_xs,_acc=_f(_acc,_a,hd(Zs)))
+#define map2Accum(_f,_acc,_a,_b,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
+#define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
+
+/* --------------------------------------------------------------------------
+ * Implementation of function application nodes:
+ * ------------------------------------------------------------------------*/
+
+#define ap(f,x) pair(f,x)
+#define ap1(f,x) ap(f,x)
+#define ap2(f,x,y) ap(ap(f,x),y)
+#define ap3(f,x,y,z) ap(ap(ap(f,x),y),z)
+#define fun(c) fst(c)
+#define arg(c) snd(c)
+#define isAp(c) (isPair(c) && !isTag(fst(c)))
+extern Cell getHead Args((Cell));
+extern List getArgs Args((Cell));
+extern Int argCount;
+extern Cell nthArg Args((Int,Cell));
+extern Int numArgs Args((Cell));
+extern Cell applyToArgs Args((Cell,List));
+
+/* --------------------------------------------------------------------------
+ * Stack implementation:
+ *
+ * NB: Use of macros makes order of evaluation hard to predict.
+ * For example, "push(1+pop());" doesn't increment TOS.
+ * ------------------------------------------------------------------------*/
+
+extern Cell DECTABLE(cellStack);
+extern StackPtr sp;
+
+#define clearStack() sp=(-1)
+#define stackEmpty() (sp==(-1))
+#define stack(p) cellStack[p]
+#define chkStack(n) if (sp>=NUM_STACK-(n)) hugsStackOverflow()
+#define push(c) \
+ do { \
+ chkStack(1); \
+ onto(c); \
+ } while (0)
+#define onto(c) stack(++sp)=(c)
+#define pop() stack(sp--)
+#define drop() sp--
+#define top() stack(sp)
+#define pushed(n) stack(sp-(n))
+
+extern Void hugsStackOverflow Args((Void));
+
+/* --------------------------------------------------------------------------
+ * Script file control:
+ * The implementation of script file storage is hidden.
+ * ------------------------------------------------------------------------*/
+
+extern Script startNewScript Args((String));
+extern Module lastModule Args((Void));
+extern Script scriptThisName Args((Name));
+extern Script scriptThisTycon Args((Tycon));
+extern Script scriptThisInst Args((Inst));
+extern Script scriptThisClass Args((Class));
+extern String fileOfModule Args((Module));
+extern Void dropScriptsFrom Args((Script));
+
+/* --------------------------------------------------------------------------
+ * Misc:
+ * ------------------------------------------------------------------------*/
+
+extern Void setLastExpr Args((Cell));
+extern Cell getLastExpr Args((Void));
+extern List addTyconsMatching Args((String,List));
+extern List addNamesMatching Args((String,List));
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * subst.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
+ * See NOTICE for details and conditions of use etc...
+ * Hugs version 1.3c, March 1998
+ *
+ * Provides an implementation for the `current substitution' used during
+ * type and kind inference in both static analysis and type checking.
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "link.h"
+#include "subst.h"
+
+/*#define DEBUG_TYPES*/
+
+static Int numTyvars; /* no. type vars currently in use */
+static Int maxTyvars = 0;
+static Int nextGeneric; /* number of generics found so far */
+
+#if FIXED_SUBST
+Tyvar tyvars[NUM_TYVARS]; /* storage for type variables */
+#else
+Tyvar *tyvars = 0; /* storage for type variables */
+#endif
+Int typeOff; /* offset of result type */
+Type typeIs; /* skeleton of result type */
+Int typeFree; /* freedom in instantiated type */
+List predsAre; /* list of predicates in type */
+List genericVars; /* list of generic vars */
+List btyvars = NIL; /* explicitly scoped type vars */
+
+/* --------------------------------------------------------------------------
+ * local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Void local expandSubst Args((Int));
+static Int local findBtyvsInt Args((Text));
+static Type local makeTupleType Args((Int));
+static Kind local makeSimpleKind Args((Int));
+static Kind local makeVarKind Args((Int));
+static Void local expandSyn1 Args((Tycon, Type *, Int *));
+static Type local dropRank1Body Args((Type,Int,Int));
+static Type local liftRank1Body Args((Type,Int));
+
+static Bool local varToVarBind Args((Tyvar *,Tyvar *));
+static Bool local varToTypeBind Args((Tyvar *,Type,Int));
+#if TREX
+static Bool local inserter Args((Type,Int,Type,Int));
+static Int local remover Args((Text,Type,Int));
+#endif
+static Bool local kvarToVarBind Args((Tyvar *,Tyvar *));
+static Bool local kvarToTypeBind Args((Tyvar *,Type,Int));
+
+/* --------------------------------------------------------------------------
+ * The substitution, types, and kinds:
+ *
+ * In early versions of Gofer, the `substitution' data structure was only
+ * used by the type checker, so it made sense to include support for it in
+ * type.c. This changed when kinds and kind inference where introduced,
+ * which required access to the substitution during static analysis. The
+ * links between type.c and static.c that were intially used to accomplish
+ * this have now been avoided by making the substitution visible as an
+ * independent data structure in storage.c.
+ *
+ * In the same way that values have types, type constructors (and more
+ * generally, expressions built from such constructors) have kinds.
+ * The syntax of kinds in the current implementation is very simple:
+ *
+ * kind ::= STAR -- the kind of types
+ * | kind => kind -- constructors
+ * | variables -- either INTCELL or OFFSET
+ *
+ * For various reasons, this implementation uses structure sharing, instead
+ * of a copying approach. In principal, this is fast and avoids the need to
+ * build new type expressions. Unfortunately, this implementation will not
+ * be able to handle *very* large expressions.
+ *
+ * The substitution is represented by an array of type variables each of
+ * which is a triple:
+ * bound a (skeletal) type expression, or NIL if the variable
+ * is not bound, or SKOLEM for a Skolem constant (i.e., an
+ * uninstantiable variable).
+ * offs offset of skeleton in bound. If isNull(bound), then offs is
+ * used to indicate whether that variable is generic (i.e. free
+ * in the current assumption set) or fixed (i.e. bound in the
+ * current assumption set). Generic variables are assigned
+ * offset numbers whilst copying type expressions (t,o) to
+ * obtain their most general form.
+ * kind kind of value bound to type variable (`type variable' is
+ * rather inaccurate -- `constructor variable' would be better).
+ * ------------------------------------------------------------------------*/
+
+Void emptySubstitution() { /* clear current substitution */
+ numTyvars = 0;
+#if !FIXED_SUBST
+ if (maxTyvars!=NUM_TYVARS) {
+ maxTyvars = 0;
+ if (tyvars) {
+ free(tyvars);
+ tyvars = 0;
+ }
+ }
+#endif
+ nextGeneric = 0;
+ genericVars = NIL;
+ typeIs = NIL;
+ predsAre = NIL;
+ btyvars = NIL;
+}
+
+static Void local expandSubst(n) /* add further n type variables to */
+Int n; { /* current substituion */
+#if FIXED_SUBST
+ if (numTyvars+n>NUM_TYVARS) {
+ ERRMSG(0) "Too many type variables in type checker"
+ EEND;
+ }
+#else
+ if (numTyvars+n>maxTyvars) { /* need to expand substitution */
+ Int newMax = maxTyvars+NUM_TYVARS;
+ Tyvar *newTvs;
+ Int i;
+
+ if (numTyvars+n>newMax) { /* safety precaution */
+ ERRMSG(0) "Substitution expanding too quickly"
+ EEND;
+ }
+
+ /* It would be better to realloc() here, but that isn't portable
+ * enough for calloc()ed arrays. The following code could cause
+ * a space leak if an interrupt occurs while we're copying the
+ * array ... we won't worry about this for the time being because
+ * we don't expect to have to go through this process much (if at
+ * all) in normal use of the type checker.
+ */
+
+ newTvs = (Tyvar *)calloc(newMax,sizeof(Tyvar));
+ if (!newTvs) {
+ ERRMSG(0) "Too many variables (%d) in type checker", newMax
+ EEND;
+ }
+ for (i=0; i<numTyvars;++i) { /* copy substitution */
+ newTvs[i].offs = tyvars[i].offs;
+ newTvs[i].bound = tyvars[i].bound;
+ newTvs[i].kind = tyvars[i].kind;
+ }
+ maxTyvars = 0; /* protection from SIGINT? */
+ if (tyvars) free(tyvars);
+ tyvars = newTvs;
+ maxTyvars = newMax;
+ }
+#endif
+}
+
+Int newTyvars(n) /* allocate new type variables */
+Int n; { /* all of kind STAR */
+ Int beta = numTyvars;
+
+ expandSubst(n);
+ for (numTyvars+=n; n>0; n--) {
+ tyvars[numTyvars-n].offs = UNUSED_GENERIC;
+ tyvars[numTyvars-n].bound = NIL;
+ tyvars[numTyvars-n].kind = STAR;
+#ifdef DEBUG_TYPES
+ printf("new type variable: _%d ::: ",numTyvars-n);
+ printKind(stdout,tyvars[numTyvars-n].kind);
+ putchar('\n');
+#endif
+ }
+ return beta;
+}
+
+Int newKindedVars(k) /* allocate new variables with */
+Kind k; { /* specified kinds */
+ Int beta = numTyvars; /* if k = k0 -> k1 -> ... -> kn */
+ for (; isPair(k); k=snd(k)) { /* then allocate n vars with kinds */
+ expandSubst(1); /* k0, k1, ..., k(n-1) */
+ tyvars[numTyvars].offs = UNUSED_GENERIC;
+ tyvars[numTyvars].bound = NIL;
+ tyvars[numTyvars].kind = fst(k);
+#ifdef DEBUG_TYPES
+ printf("new type variable: _%d ::: ",numTyvars);
+ printKind(stdout,tyvars[numTyvars].kind);
+ putchar('\n');
+#endif
+ numTyvars++;
+ }
+ return beta;
+}
+
+Void instantiate(type) /* instantiate type, if nonNull */
+Type type; {
+ predsAre = NIL;
+ typeIs = type;
+ typeFree = 0;
+
+ if (nonNull(typeIs)) { /* instantiate type expression ? */
+
+ if (isPolyType(typeIs)) { /* Polymorphic type scheme ? */
+ Kinds ks = polySigOf(typeIs);
+ typeOff = newKindedVars(ks);
+ typeIs = monotypeOf(typeIs);
+ for (; isAp(ks); ks=arg(ks))
+ typeFree++;
+ }
+
+ if (whatIs(typeIs)==QUAL) { /* Qualified type? */
+ predsAre = fst(snd(typeIs));
+ typeIs = snd(snd(typeIs));
+ }
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Bound type variables:
+ * ------------------------------------------------------------------------*/
+
+Pair findBtyvs(t) /* Look for bound tyvar */
+Text t; {
+ List bts = btyvars;
+ for (; nonNull(bts); bts=tl(bts)) {
+ List bts1 = hd(bts);
+ for (; nonNull(bts1); bts1=tl(bts1))
+ if (t==textOf(fst(hd(bts1))))
+ return hd(bts1);
+ }
+ return NIL;
+}
+
+static Int local findBtyvsInt(t) /* Look for bound type variable */
+Text t; { /* expecting to find an integer */
+ Pair p = findBtyvs(t);
+ if (isNull(p))
+ internal("findBtyvsInt");
+ return intOf(snd(p));
+}
+
+Void markBtyvs() { /* Mark explicitly scoped vars */
+ List bts = btyvars;
+ for (; nonNull(bts); bts=tl(bts)) {
+ List bts1 = hd(bts);
+ for (; nonNull(bts1); bts1=tl(bts1))
+ markTyvar(intOf(snd(hd(bts1))));
+ }
+}
+
+Type localizeBtyvs(t) /* Localize type to eliminate refs */
+Type t; { /* to explicitly scoped vars */
+ switch (whatIs(t)) {
+ case RANK2 :
+ case POLYTYPE : snd(snd(t)) = localizeBtyvs(snd(snd(t)));
+ break;
+
+ case QUAL : fst(snd(t)) = localizeBtyvs(fst(snd(t)));
+ snd(snd(t)) = localizeBtyvs(snd(snd(t)));
+ break;
+
+ case AP : fst(t) = localizeBtyvs(fst(t));
+ snd(t) = localizeBtyvs(snd(t));
+ break;
+
+ case VARIDCELL:
+ case VAROPCELL: return mkInt(findBtyvsInt(textOf(t)));
+ }
+ return t;
+}
+
+/* --------------------------------------------------------------------------
+ * Dereference or bind types in subsitution:
+ * ------------------------------------------------------------------------*/
+
+Tyvar *getTypeVar(t,o) /* get number of type variable */
+Type t; /* represented by (t,o) [if any]. */
+Int o; {
+ switch (whatIs(t)) {
+ case INTCELL : return tyvar(intOf(t));
+ case OFFSET : return tyvar(o+offsetOf(t));
+ case VARIDCELL :
+ case VAROPCELL : return tyvar(findBtyvsInt(textOf(t)));
+ }
+ return ((Tyvar *)0);
+}
+
+Void tyvarType(vn) /* load type held in type variable */
+Int vn; { /* vn into (typeIs,typeOff) */
+ Tyvar *tyv;
+
+ while ((tyv=tyvar(vn)), isBound(tyv))
+ switch(whatIs(tyv->bound)) {
+ case INTCELL : vn = intOf(tyv->bound);
+ break;
+
+ case OFFSET : vn = offsetOf(tyv->bound)+(tyv->offs);
+ break;
+
+ case VARIDCELL :
+ case VAROPCELL : vn = findBtyvsInt(textOf(tyv->bound));
+ break;
+
+ default : typeIs = tyv->bound;
+ typeOff = tyv->offs;
+ return;
+ }
+ typeIs = aVar;
+ typeOff = vn;
+}
+
+Void bindTv(vn,t,o) /* set type variable vn to (t,o) */
+Int vn;
+Type t;
+Int o; {
+ Tyvar *tyv = tyvar(vn);
+ tyv->bound = t;
+ tyv->offs = o;
+#ifdef DEBUG_TYPES
+ printf("binding type variable: _%d to ",vn);
+ printType(stdout,debugType(t,o));
+ putchar('\n');
+#endif
+}
+
+Cell getDerefHead(t,o) /* get value at head of type exp. */
+Type t;
+Int o; {
+ Tyvar *tyv;
+ argCount = 0;
+ for (;;) {
+ while (isAp(t)) {
+ argCount++;
+ t = fun(t);
+ }
+ if ((tyv=getTypeVar(t,o)) && isBound(tyv)) {
+ t = tyv->bound;
+ o = tyv->offs;
+ }
+ else
+ break;
+ }
+ return t;
+}
+
+/* --------------------------------------------------------------------------
+ * Expand type synonyms:
+ * ------------------------------------------------------------------------*/
+
+Void expandSyn(h,ar,at,ao) /* Expand type synonym with: */
+Tycon h; /* head h */
+Int ar; /* ar args (NB. ar>=tycon(h).arity)*/
+Type *at; /* original expression (*at,*ao) */
+Int *ao; { /* expansion returned in (*at,*ao) */
+ ar -= tycon(h).arity; /* calculate surplus arguments */
+ if (ar==0)
+ expandSyn1(h,at,ao);
+ else { /* if there are more args than the */
+ Type t = *at; /* arity, we have to do a little */
+ Int o = *ao; /* bit of work to isolate args that*/
+ Type args = NIL; /* will not be changed by expansion*/
+ Int i;
+ while (ar-- > 0) { /* find part to expand, and the */
+ Tyvar *tyv; /* unused arguments */
+ args = cons(arg(t),args);
+ t = fun(t);
+ deRef(tyv,t,o);
+ }
+ expandSyn1(h,&t,&o); /* do the expansion */
+ bindTv((i=newTyvars(1)),t,o); /* and embed the results back in */
+ tyvar(i)->kind = getKind(t,o); /* (*at, *ao) as required */
+ *at = applyToArgs(mkInt(i),args);
+ }
+}
+
+static Void local expandSyn1(h,at,ao) /* Expand type synonym with: */
+Tycon h; /* head h, tycon(h).arity args, */
+Type *at; /* original expression (*at,*ao) */
+Int *ao; { /* expansion returned in (*at,*ao) */
+ Int n = tycon(h).arity;
+ Type t = *at;
+ Int o = *ao;
+ Tyvar *tyv;
+
+ *at = tycon(h).defn;
+ *ao = newKindedVars(tycon(h).kind);
+ for (; 0<n--; t=fun(t)) {
+ deRef(tyv,t,o);
+ if (tyv || !isAp(t))
+ internal("expandSyn1");
+ bindTv(*ao+n,arg(t),o);
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Marking fixed variables in type expressions:
+ * ------------------------------------------------------------------------*/
+
+Void clearMarks() { /* set all unbound type vars to */
+ Int i; /* unused generic variables */
+ for (i=0; i<numTyvars; ++i)
+ if (!isBound(tyvar(i)))
+ tyvar(i)->offs = UNUSED_GENERIC;
+ genericVars = NIL;
+ nextGeneric = 0;
+}
+
+Void resetGenerics() { /* Reset all generic vars to unused*/
+ Int i;
+ for (i=0; i<numTyvars; ++i)
+ if (!isBound(tyvar(i)) && tyvar(i)->offs>=GENERIC)
+ tyvar(i)->offs = UNUSED_GENERIC;
+ genericVars = NIL;
+ nextGeneric = 0;
+}
+
+Void markTyvar(vn) /* mark fixed vars in type bound to*/
+Int vn; { /* given type variable */
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv))
+ markType(tyv->bound, tyv->offs);
+ else
+ (tyv->offs) = FIXED_TYVAR;
+}
+
+Void markType(t,o) /* mark fixed vars in type (t,o) */
+Type t;
+Int o; {
+ switch (whatIs(t)) {
+#if TREX
+ case EXT :st
+#endif
+ case TYCON :
+ case TUPLE : return;
+
+ case AP : markType(fst(t),o);
+ markType(snd(t),o);
+ return;
+
+ case OFFSET : markTyvar(o+offsetOf(t));
+ return;
+
+ case INTCELL : markTyvar(intOf(t));
+ return;
+
+ case VARIDCELL :
+ case VAROPCELL : markTyvar(findBtyvsInt(textOf(t)));
+ return;
+
+ case RANK2 : markType(snd(snd(t)),o);
+ return;
+ case POLYTYPE : /* No need to mark generic types */
+ return;
+
+ default : internal("markType");
+ }
+}
+
+Void markPred(pi) /* Marked fixed type vars in pi */
+Cell pi; {
+ Cell cl = fst3(pi);
+ Int o = intOf(snd3(pi));
+
+ for (; isAp(cl); cl=fun(cl))
+ markType(arg(cl),o);
+}
+
+/* --------------------------------------------------------------------------
+ * Copy type expression from substitution to make a single type expression:
+ * ------------------------------------------------------------------------*/
+
+Type copyTyvar(vn) /* calculate most general form of */
+Int vn; { /* type bound to given type var */
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv))
+ return copyType(tyv->bound,tyv->offs);
+
+ switch (tyv->offs) {
+ case FIXED_TYVAR : return mkInt(vn);
+
+ case UNUSED_GENERIC : (tyv->offs) = GENERIC + nextGeneric++;
+ if (nextGeneric>=NUM_OFFSETS) {
+ ERRMSG(0)
+ "Too many quantified type variables"
+ EEND;
+ }
+ genericVars = cons(mkInt(vn),genericVars);
+
+ default : return mkOffset(tyv->offs - GENERIC);
+ }
+}
+
+Type copyType(t,o) /* calculate most general form of */
+Type t; /* type expression (t,o) */
+Int o; {
+ switch (whatIs(t)) {
+ case AP : { Type l = copyType(fst(t),o);/* ensure correct */
+ Type r = copyType(snd(t),o);/* eval. order */
+ return ap(l,r);
+ }
+ case OFFSET : return copyTyvar(o+offsetOf(t));
+ case INTCELL : return copyTyvar(intOf(t));
+ case VARIDCELL :
+ case VAROPCELL : return copyTyvar(findBtyvsInt(textOf(t)));
+ }
+
+ return t;
+}
+
+Cell copyPred(pi,o) /* Copy single predicate (or part */
+Cell pi; /* thereof) ... */
+Int o; {
+ if (isAp(pi)) {
+ Cell temp = copyPred(fun(pi),o);/* to ensure correct order of eval.*/
+ return ap(temp,copyType(arg(pi),o));
+ }
+ else
+ return pi;
+}
+
+#ifdef DEBUG_TYPES
+Type debugTyvar(vn) /* expand type structure in full */
+Int vn; { /* detail */
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv))
+ return debugType(tyv->bound,tyv->offs);
+ return mkInt(vn);
+}
+
+Type debugType(t,o)
+Type t;
+Int o; {
+ switch (whatIs(t)) {
+ case AP : { Type l = debugType(fst(t),o);
+ Type r = debugType(snd(t),o);
+ return ap(l,r);
+ }
+ case OFFSET : return debugTyvar(o+offsetOf(t));
+ case INTCELL : return debugTyvar(intOf(t));
+ case VARIDCELL :
+ case VAROPCELL : return debugTyvar(findBtyvsInt(textOf(t)));
+ }
+
+ return t;
+}
+#endif /*DEBUG_TYPES*/
+
+Kind copyKindvar(vn) /* build kind attatched to variable*/
+Int vn; {
+ Tyvar *tyv = tyvar(vn);
+ if (tyv->bound)
+ return copyKind(tyv->bound,tyv->offs);
+ return STAR; /* any unbound variable defaults to*/
+} /* the kind of all types */
+
+Kind copyKind(k,o) /* build kind expression from */
+Kind k; /* given skeleton */
+Int o; {
+ switch (whatIs(k)) {
+ case AP : { Kind l = copyKind(fst(k),o); /* ensure correct */
+ Kind r = copyKind(snd(k),o); /* eval. order */
+ return ap(l,r);
+ }
+ case OFFSET : return copyKindvar(o+offsetOf(k));
+ case INTCELL : return copyKindvar(intOf(k));
+ }
+ return k;
+}
+
+/* --------------------------------------------------------------------------
+ * Droping and lifting of type schemes that appear in rank 2 position:
+ * ------------------------------------------------------------------------*/
+
+Type dropRank2(t,alpha,n) /* Drop a (potentially) rank2 type */
+Type t;
+Int alpha;
+Int n; {
+ if (whatIs(t)==RANK2) {
+ Cell r = fst(snd(t));
+ Int i = intOf(r);
+ Type as = NIL;
+ for (t=snd(snd(t)); i>0; i--) {
+ Type a = arg(fun(t));
+ if (isPolyType(a))
+ a = dropRank1(a,alpha,n);
+ as = ap2(typeArrow,a,as);
+ t = arg(t);
+ }
+ t = ap(RANK2,pair(r,revOnto(as,t)));
+ }
+ return t;
+}
+
+Type dropRank1(t,alpha,n) /* Copy rank1 argument type t to */
+Type t; /* make a rank1 type scheme */
+Int alpha;
+Int n; {
+ if (n>0 && isPolyType(t))
+ t = mkPolyType(polySigOf(t),dropRank1Body(monotypeOf(t),alpha,n));
+ return t;
+}
+
+static Type local dropRank1Body(t,alpha,n)
+Type t;
+Int alpha;
+Int n; {
+ switch (whatIs(t)) {
+ case OFFSET : { Int m = offsetOf(t);
+ return (m>=n) ? mkOffset(m-n) : mkInt(alpha+m);
+ }
+
+ case POLYTYPE : return mkPolyType(polySigOf(t),
+ dropRank1Body(monotypeOf(t),alpha,n));
+
+ case QUAL : return ap(QUAL,dropRank1Body(snd(t),alpha,n));
+
+ case RANK2 : return ap(RANK2,pair(fst(snd(t)),
+ dropRank1Body(snd(snd(t)),
+ alpha,
+ n)));
+
+ case AP : return ap(dropRank1Body(fun(t),alpha,n),
+ dropRank1Body(arg(t),alpha,n));
+
+ default : return t;
+ }
+}
+
+Void liftRank2Args(as,alpha,m)
+List as;
+Int alpha;
+Int m; {
+ Int i = 0;
+ for (; i<m; i++)
+ copyTyvar(alpha+i);
+ for (m=nextGeneric; nonNull(as); as=tl(as)) {
+ Type ta = arg(fun(as));
+ ta = isPolyType(ta) ? liftRank1Body(ta,m) : copyType(ta,alpha);
+ arg(fun(as))
+ = ta;
+ }
+}
+
+Type liftRank2(t,alpha,m)
+Type t;
+Int alpha;
+Int m; {
+ if (whatIs(t)==RANK2) {
+ Cell r = fst(snd(t));
+ Int i = 0;
+ Type as = NIL;
+ for (; i<m; i++)
+ copyTyvar(alpha+i);
+ m = nextGeneric;
+ t = snd(snd(t));
+ for (i=intOf(r); i>0; i--) {
+ Type a = arg(fun(t));
+ a = isPolyType(a) ? liftRank1Body(a,m) : copyType(a,alpha);
+ as = ap2(typeArrow,a,as);
+ t = arg(t);
+ }
+ t = ap(RANK2,pair(r,revOnto(as,copyType(t,alpha))));
+ }
+ else
+ t = copyType(t,alpha);
+ return t;
+}
+
+Type liftRank1(t,alpha,m)
+Type t;
+Int alpha;
+Int m; {
+ if (m>0 && isPolyType(t)) {
+ Int i = 0;
+ resetGenerics();
+ for (; i<m; i++)
+ copyTyvar(alpha+i);
+ t = liftRank1Body(t,nextGeneric);
+ }
+ return t;
+}
+
+static Type local liftRank1Body(t,n)
+Type t;
+Int n; {
+ switch (whatIs(t)) {
+ case OFFSET : return mkOffset(n+offsetOf(t));
+
+ case INTCELL : return copyTyvar(intOf(t));
+
+ case VARIDCELL :
+ case VAROPCELL : return copyTyvar(findBtyvsInt(textOf(t)));
+
+ case POLYTYPE : return mkPolyType(polySigOf(t),
+ liftRank1Body(monotypeOf(t),n));
+
+ case QUAL : return ap(QUAL,liftRank1Body(snd(t),n));
+
+ case RANK2 : return ap(RANK2,pair(fst(snd(t)),
+ liftRank1Body(snd(snd(t)),n)));
+
+ case AP : return ap(liftRank1Body(fun(t),n),
+ liftRank1Body(arg(t),n));
+
+ default : return t;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Support for `kind preserving substitutions' from unification:
+ * ------------------------------------------------------------------------*/
+
+Bool eqKind(k1,k2) /* check that two (mono)kinds are */
+Kind k1, k2; { /* equal */
+ return k1==k2
+ || (isPair(k1) && isPair(k2)
+ && eqKind(fst(k1),fst(k2))
+ && eqKind(snd(k1),snd(k2)));
+}
+
+Kind getKind(c,o) /* Find kind of constr during type */
+Cell c; /* checking process */
+Int o; {
+ if (isAp(c)) /* application */
+ return snd(getKind(fst(c),o));
+ switch (whatIs(c)) {
+ case TUPLE : return simpleKind(tupleOf(c)); /*(,)::* -> * -> * */
+ case OFFSET : return tyvar(o+offsetOf(c))->kind;
+ case INTCELL : return tyvar(intOf(c))->kind;
+ case VARIDCELL :
+ case VAROPCELL : return tyvar(findBtyvsInt(textOf(c)))->kind;
+ case TYCON : return tycon(c).kind;
+#if TREX
+ case EXT : return extKind;
+#endif
+ }
+#ifdef DEBUG_KINDS
+ printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
+#endif
+ internal("getKind");
+ return STAR;/* not reached */
+}
+
+/* --------------------------------------------------------------------------
+ * Find generic variables in a type:
+ * ------------------------------------------------------------------------*/
+
+Type genvarTyvar(vn,vs) /* calculate list of generic vars */
+Int vn; /* thru variable vn, prepended to */
+List vs; { /* list vs */
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv))
+ return genvarType(tyv->bound,tyv->offs,vs);
+ else if (tyv->offs == UNUSED_GENERIC) {
+ tyv->offs += GENERIC + nextGeneric++;
+ return cons(mkInt(vn),vs);
+ }
+ else if (tyv->offs>=GENERIC && !intIsMember(vn,vs))
+ return cons(mkInt(vn),vs);
+ else
+ return vs;
+}
+
+List genvarType(t,o,vs) /* calculate list of generic vars */
+Type t; /* in type expression (t,o) */
+Int o; /* results are prepended to vs */
+List vs; {
+ switch (whatIs(t)) {
+ case AP : return genvarType(snd(t),o,genvarType(fst(t),o,vs));
+ case OFFSET : return genvarTyvar(o+offsetOf(t),vs);
+ case INTCELL : return genvarTyvar(intOf(t),vs);
+ case VARIDCELL :
+ case VAROPCELL : return genvarTyvar(findBtyvsInt(textOf(t)),vs);
+ }
+ return vs;
+}
+
+/* --------------------------------------------------------------------------
+ * Occurs check:
+ * ------------------------------------------------------------------------*/
+
+Bool doesntOccurIn(lookFor,t,o) /* Return TRUE if var lookFor */
+Tyvar *lookFor; /* isn't referenced in (t,o) */
+Type t;
+Int o; {
+ Tyvar *tyv;
+
+ for (;;) {
+ deRef(tyv,t,o);
+ if (tyv) /* type variable */
+ return tyv!=lookFor;
+ else if (isAp(t)) { /* application */
+ if (doesntOccurIn(lookFor,snd(t),o))
+ t = fst(t);
+ else
+ return FALSE;
+ }
+ else /* no variable found */
+ break;
+ }
+ return TRUE;
+}
+
+/* --------------------------------------------------------------------------
+ * Unification algorithm:
+ * ------------------------------------------------------------------------*/
+
+char *unifyFails = 0; /* Unification error message */
+static Int bindAbove = 0; /* Used to restrict var binding */
+
+#define bindOnlyAbove(beta) bindAbove=beta
+#define noBind() bindAbove=MAXPOSINT
+#define unrestrictBind() bindAbove=0
+
+static Bool local varToVarBind(tyv1,tyv2)/* Make binding tyv1 := tyv2 */
+Tyvar *tyv1, *tyv2; {
+ if (tyv1!=tyv2) { /* If vars are same, nothing to do!*/
+
+ /* Check that either tyv1 or tyv2 is in allowed range for binding */
+ /* and is not a Skolem constant, and swap vars if nec. so we can */
+ /* bind to tyv1. */
+
+ if (tyvNum(tyv1)<bindAbove || tyv1->bound==SKOLEM) {
+ if (tyvNum(tyv2)<bindAbove || tyv2->bound==SKOLEM) {
+ unifyFails = "types do not match";
+ return FALSE;
+ }
+ else {
+ Tyvar *tyv = tyv1;
+ tyv1 = tyv2;
+ tyv2 = tyv;
+ }
+ }
+ if (!eqKind(tyv1->kind,tyv2->kind)) {
+ unifyFails = "constructor variable kinds do not match";
+ return FALSE;
+ }
+ tyv1->bound = aVar;
+ tyv1->offs = tyvNum(tyv2);
+#ifdef DEBUG_TYPES
+ printf("vv binding tyvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
+#endif
+ }
+ return TRUE;
+}
+
+static Bool local varToTypeBind(tyv,t,o)/* Make binding tyv := (t,o) */
+Tyvar *tyv;
+Type t; /* guaranteed not to be a v'ble or */
+Int o; { /* have synonym as outermost constr*/
+ if (tyvNum(tyv)<bindAbove) { /* Check that tyv is in range */
+ unifyFails = "types do not match";
+ return FALSE;
+ }
+ else if (tyv->bound == SKOLEM) { /* Check that it is not Skolemized */
+ unifyFails = "cannot instantiate Skolem constant";
+ return FALSE;
+ }
+ else if (!doesntOccurIn(tyv,t,o)) /* Carry out occurs check */
+ unifyFails = "unification would give infinite type";
+ else if (!eqKind(tyv->kind,getKind(t,o)))
+ unifyFails = "kinds do not match";
+ else {
+ tyv->bound = t;
+ tyv->offs = o;
+#ifdef DEBUG_TYPES
+ printf("vt binding type variable: _%d to ",tyvNum(tyv));
+ printType(stdout,debugType(t,o));
+ putchar('\n');
+#endif
+ return TRUE;
+ }
+ return FALSE;
+}
+
+Bool unify(t1,o1,t2,o2) /* Main unification routine */
+Type t1,t2; /* unify (t1,o1) with (t2,o2) */
+Int o1,o2; {
+ Tyvar *tyv1, *tyv2;
+
+ deRef(tyv1,t1,o1);
+ deRef(tyv2,t2,o2);
+
+un: if (tyv1)
+ if (tyv2)
+ return varToVarBind(tyv1,tyv2); /* t1, t2 variables */
+ else {
+ Cell h2 = getDerefHead(t2,o2); /* t1 variable, t2 not */
+ if (isSynonym(h2) && argCount>=tycon(h2).arity) {
+ expandSyn(h2,argCount,&t2,&o2);
+ deRef(tyv2,t2,o2);
+ goto un;
+ }
+ return varToTypeBind(tyv1,t2,o2);
+ }
+ else
+ if (tyv2) {
+ Cell h1 = getDerefHead(t1,o1); /* t2 variable, t1 not */
+ if (isSynonym(h1) && argCount>=tycon(h1).arity) {
+ expandSyn(h1,argCount,&t1,&o1);
+ deRef(tyv1,t1,o1);
+ goto un;
+ }
+ return varToTypeBind(tyv2,t1,o1);
+ }
+ else { /* t1, t2 not vars */
+ Type h1 = getDerefHead(t1,o1);
+ Int a1 = argCount;
+ Type h2 = getDerefHead(t2,o2);
+ Int a2 = argCount;
+
+#ifdef DEBUG_TYPES
+ printf("tt unifying types: ");
+ printType(stdout,debugType(t1,o1));
+ printf(" with ");
+ printType(stdout,debugType(t2,o2));
+ putchar('\n');
+#endif
+
+ if (isOffset(h1) || isInt(h1)) h1=NIL; /* represent var by NIL*/
+ if (isOffset(h2) || isInt(h2)) h2=NIL;
+
+#if TREX
+ if (isExt(h1) || isExt(h2)) {
+ if (a1==2 && isExt(h1) && a2==2 && isExt(h2))
+ return inserter(fun(t1),o1,t2,o2) &&
+ unify(arg(t1),o1,aVar,
+ remover(extText(h1),t2,o2));
+ else {
+ unifyFails = "rows are not compatible";
+ return FALSE;
+ }
+ }
+#endif
+ if (nonNull(h1) && h1==h2) {/* Assuming well-formed types, both*/
+ if (a1!=a2) { /* t1, t2 must have same no of args*/
+ unifyFails = "incompatible constructors";
+ return FALSE;
+ }
+ while (isAp(t1)) {
+ if (!unify(arg(t1),o1,arg(t2),o2))
+ return FALSE;
+ t1 = fun(t1);
+ deRef(tyv1,t1,o1);
+ t2 = fun(t2);
+ deRef(tyv2,t2,o2);
+ }
+ unifyFails = 0;
+ return TRUE;
+ }
+
+ /* Types do not match -- look for type synonyms to expand */
+
+ if (isSynonym(h1) && a1>=tycon(h1).arity) {
+ expandSyn(h1,a1,&t1,&o1);
+ deRef(tyv1,t1,o1);
+ goto un;
+ }
+ if (isSynonym(h2) && a2>=tycon(h2).arity) {
+ expandSyn(h2,a2,&t2,&o2);
+ deRef(tyv2,t2,o2);
+ goto un;
+ }
+
+ if ((isNull(h1) && a1<=a2) || /* last attempt -- maybe */
+ (isNull(h2) && a2<=a1)) { /* one head is a variable? */
+ for (;;) {
+ deRef(tyv1,t1,o1);
+ deRef(tyv2,t2,o2);
+
+ if (tyv1) /* unify heads! */
+ if (tyv2)
+ return varToVarBind(tyv1,tyv2);
+ else
+ return varToTypeBind(tyv1,t2,o2);
+ else if (tyv2)
+ return varToTypeBind(tyv2,t1,o1);
+
+ /* at this point, neither t1 nor t2 is a variable. In */
+ /* addition, they must both be APs unless one of the */
+ /* head variables has been bound during unification of */
+ /* the arguments. */
+
+ if (!isAp(t1) || !isAp(t2)) { /* might not be APs*/
+ unifyFails = 0;
+ return t1==t2;
+ }
+ if (!unify(arg(t1),o1,arg(t2),o2)) /* o/w must be APs */
+ return FALSE;
+ t1 = fun(t1);
+ t2 = fun(t2);
+ }
+ }
+ }
+ unifyFails = 0;
+ return FALSE;
+}
+
+#if TREX
+static Bool local inserter(ins,o,r,or) /* Insert field into row (r,or) */
+Type ins; /* inserter (ins,o), where ins is */
+Int o; /* an applic of an EXT to a type. */
+Type r;
+Int or; {
+ Text labt = extText(fun(ins)); /* Find the text of the label */
+ for (;;) {
+ Tyvar *tyv;
+ deRef(tyv,r,or);
+ if (tyv) {
+ Int beta = newTyvars(1); /* Extend row with new field */
+ tyvar(beta)->kind = ROW;
+ return varToTypeBind(tyv,ap(ins,mkInt(beta)),o);
+ }
+ else if (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r)))) {
+ if (labt==extText(fun(fun(r))))/* Compare existing fields */
+ return unify(arg(ins),o,extField(r),or);
+ r = extRow(r); /* Or skip to next field */
+ }
+ else { /* Nothing else will match */
+ unifyFails = "field mismatch";
+ return FALSE;
+ }
+ }
+}
+
+static Int local remover(l,r,o) /* Make a new row by copying (r,o) */
+Text l; /* but removing the l field (which */
+Type r; /* MUST exist) */
+Int o; {
+ Tyvar *tyv;
+ Int beta = newTyvars(1);
+ tyvar(beta)->kind = ROW;
+ deRef(tyv,r,o);
+ if (tyv || !isAp(r) || !isAp(fun(r)) || !isExt(fun(fun(r))))
+ internal("remover");
+ if (l==extText(fun(fun(r))))
+ r = extRow(r);
+ else
+ r = ap(fun(r),mkInt(remover(l,extRow(r),o)));
+ bindTv(beta,r,o);
+ return beta;
+}
+#endif
+
+Bool typeMatches(type,mt) /* test if type matches monotype mt*/
+Type type, mt; {
+ Bool result;
+ if (isPolyType(type) || whatIs(type)==QUAL)
+ return FALSE;
+ emptySubstitution();
+ noBind();
+ result = unify(mt,0,type,0);
+ unrestrictBind();
+ emptySubstitution();
+ return result;
+}
+
+/* --------------------------------------------------------------------------
+ * Matching predicates:
+ *
+ * There are (at least) four situations where we need to match up pairs
+ * of predicates:
+ *
+ * 1) Testing to see if two predicates are the same (ignoring differences
+ * caused by the use of type synonyms, for example).
+ *
+ * 2) Matching a predicate with the head of its class so that we can
+ * find the corresponding superclass predicates. If the predicates
+ * have already been kind-checked, and the classes are known to be
+ * the same, then this should never fail.
+ *
+ * 3) Matching a predicate against the head of an instance to see if
+ * that instance is applicable.
+ *
+ * 4) Matching two instance heads to see if there is an overlap.
+ *
+ * For (1), we need a matching process that does not bind any variables.
+ * For (2) and (3), we need to use one-way matching, only allowing
+ * variables in the class or instance head to be instantiated. For
+ * (4), we need two-way unification.
+ *
+ * Another situation in which both one-way and two-way unification might
+ * be used is in an implementation of improvement. Here, a one-way match
+ * would be used to determine applicability of a rule for improvement
+ * that would then be followed by unification with another predicate.
+ * One possible syntax for this might be:
+ *
+ * instance P => pi [improves pi'] where ...
+ *
+ * The intention here is that any predicate matching pi' can be unified
+ * with pi to get more accurate types. A simple example of this is:
+ *
+ * instance Collection [a] a improves Collection [a] b where ...
+ *
+ * As soon as we know what the collection type is (in this case, a list),
+ * we will also know what the element type is. To ensure that the rule
+ * for improvement is valid, the compilation system will also need to use
+ * a one-way matching process to ensure that pi is a (substitution) instance
+ * of pi'. Another extension would be to allow more than one predicate pi'
+ * in an improving rule. Read the paper on simplification and improvement
+ * for technical background. Watch this space for implementation news!
+ * ------------------------------------------------------------------------*/
+
+Bool samePred(pi1,o1,pi,o) /* Test to see if predicates are */
+Cell pi1; /* the same, with no binding of */
+Int o1; /* the variables in either one. */
+Cell pi; /* Assumes preds are kind correct */
+Int o; { /* with the same class. */
+ Bool result;
+ noBind();
+ result = unifyPred(pi1,o1,pi,o);
+ unrestrictBind();
+ return result;
+}
+
+Bool matchPred(pi1,o1,pi,o) /* One way match predicate (pi1,o1)*/
+Cell pi1; /* against (pi,o), allowing only */
+Int o1; /* vars in 2nd pred to be bound. */
+Cell pi; /* Assumes preds are kind correct */
+Int o; { /* with the same class and that no */
+ Bool result; /* vars have been alloc'd since o. */
+ bindOnlyAbove(o);
+ result = unifyPred(pi1,o1,pi,o);
+ unrestrictBind();
+ return result;
+}
+
+Bool unifyPred(pi1,o1,pi,o) /* Unify two predicates */
+Cell pi1; /* Assumes preds are kind correct */
+Int o1; /* with the same class. */
+Cell pi;
+Int o; {
+ for (; isAp(pi1); pi1=fun(pi1), pi=fun(pi))
+ if (!unify(arg(pi1),o1,arg(pi),o))
+ return FALSE;
+ return pi1==pi;
+}
+
+Inst findInstFor(pi,o) /* Find matching instance for pred */
+Cell pi; /* (pi,o), or otherwise NIL. If a */
+Int o; { /* match is found, then tyvars from*/
+ Class c = getHead(pi); /* typeOff have been initialized to*/
+ List ins; /* allow direct use of specifics. */
+
+ if (!isClass(c))
+ return NIL;
+
+ for (ins=cclass(c).instances; nonNull(ins); ins=tl(ins)) {
+ Inst in = hd(ins);
+ Int beta = newKindedVars(inst(in).kinds);
+ if (matchPred(pi,o,inst(in).head,beta)) {
+ typeOff = beta;
+ return in;
+ }
+ else
+ numTyvars = beta;
+ }
+ unrestrictBind();
+
+#if TREX
+ { Int showRow = strcmp(textToStr(cclass(c).text),"ShowRecRow");
+ Int eqRow = strcmp(textToStr(cclass(c).text),"EqRecRow");
+
+ if (showRow==0 || eqRow==0) { /* Generate instances of */
+ Type t = arg(pi); /* ShowRecRow and EqRecRow */
+ Tyvar *tyv; /* on the fly */
+ Cell e;
+ deRef(tyv,t,o);
+ e = getHead(t);
+ if (isExt(e)) {
+ Inst in = NIL;
+ for (ins=cclass(c).instances; nonNull(ins); ins=tl(ins))
+ if (getHead(arg(inst(hd(ins)).head))==e) {
+ in = hd(ins);
+ break;
+ }
+ if (isNull(in))
+ in = (showRow==0) ? addRecShowInst(c,e)
+ : addRecEqInst(c,e);
+ typeOff = newKindedVars(extKind);
+ bindTv(typeOff,arg(fun(t)),o);
+ bindTv(typeOff+1,arg(t),o);
+ return in;
+ }
+ }
+ }
+#endif
+
+ return NIL;
+}
+
+/* --------------------------------------------------------------------------
+ * Compare type schemes:
+ * ------------------------------------------------------------------------*/
+
+Bool sameSchemes(s,s1) /* Test to see whether two type */
+Type s; /* schemes are the same */
+Type s1; {
+ Int o = 0;
+ Int m = 0;
+ Int nr2 = 0;
+ Bool b = isPolyType(s); /* Check quantifiers are the same */
+ Bool b1 = isPolyType(s1);
+ if (b || b1) {
+ if (b && b1 && eqKind(polySigOf(s),polySigOf(s1))) {
+ Kind k = polySigOf(s);
+ s = monotypeOf(s);
+ s1 = monotypeOf(s1);
+ o = newKindedVars(k);
+ for (; isAp(k); k=arg(k))
+ m++;
+ }
+ else
+ return FALSE;
+ }
+
+ b = (whatIs(s)==QUAL); /* Check that contexts are the same*/
+ b1 = (whatIs(s1)==QUAL);
+ if (b || b1) {
+ if (b && b1) {
+ List ps = fst(snd(s));
+ List ps1 = fst(snd(s1));
+ noBind();
+ while (nonNull(ps) && nonNull(ps1)) {
+ Cell pi = hd(ps);
+ Cell pi1 = hd(ps1);
+ if (getHead(pi)!=getHead(pi1)
+ || !unifyPred(pi,o,pi1,o))
+ break;
+ ps = tl(ps);
+ ps1 = tl(ps1);
+ }
+ unrestrictBind();
+ if (nonNull(ps) || nonNull(ps1))
+ return FALSE;
+ s = snd(snd(s));
+ s1 = snd(snd(s1));
+ }
+ else
+ return FALSE;
+ }
+
+ b = (whatIs(s)==RANK2); /* Check any rank 2 annotations */
+ b1 = (whatIs(s1)==RANK2);
+ if (b || b1) {
+ if (b && b1 && intOf(fst(snd(s)))==intOf(fst(snd(s1)))) {
+ nr2 = intOf(fst(snd(s)));
+ s = snd(snd(s));
+ s1 = snd(snd(s1));
+ }
+ else
+ return FALSE;
+ }
+
+ for (; nr2>0; nr2--) { /* Deal with rank 2 arguments */
+ Type t = arg(fun(s));
+ Type t1 = arg(fun(s1));
+ b = isPolyType(t);
+ b1 = isPolyType(t1);
+ if (b || b1) {
+ if (b && b1) {
+ t = dropRank1(t,o,m);
+ t1 = dropRank1(t1,o,m);
+ if (!sameSchemes(t,t1))
+ return FALSE;
+ }
+ else
+ return FALSE;
+ }
+ else {
+ noBind();
+ b = unify(t,o,t1,o);
+ unrestrictBind();
+ if (!b)
+ return FALSE;
+ }
+ s = arg(s);
+ s1 = arg(s1);
+ }
+
+ noBind(); /* Ensure body types are the same */
+ b = unify(s,o,s1,o);
+ unrestrictBind();
+ return b;
+}
+
+/* --------------------------------------------------------------------------
+ * Unify kind expressions:
+ * ------------------------------------------------------------------------*/
+
+static Bool local kvarToVarBind(tyv1,tyv2)/* Make binding tyv1 := tyv2 */
+Tyvar *tyv1, *tyv2; { /* for kind variable bindings */
+ if (tyv1!=tyv2) {
+ tyv1->bound = aVar;
+ tyv1->offs = tyvNum(tyv2);
+#ifdef DEBUG_KINDS
+ printf("vv binding kvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
+#endif
+ }
+ return TRUE;
+}
+
+static Bool local kvarToTypeBind(tyv,t,o)/* Make binding tyv := (t,o) */
+Tyvar *tyv; /* for kind variable bindings */
+Type t; /* guaranteed not to be a v'ble or */
+Int o; { /* have synonym as outermost constr*/
+ if (doesntOccurIn(tyv,t,o)) {
+ tyv->bound = t;
+ tyv->offs = o;
+#ifdef DEBUG_KINDS
+ printf("vt binding kind variable: _%d to ",tyvNum(tyv));
+ printType(stdout,debugType(t,o));
+ putchar('\n');
+#endif
+ return TRUE;
+ }
+ unifyFails = "unification would give infinite kind";
+ return FALSE;
+}
+
+Bool kunify(k1,o1,k2,o2) /* Unify kind expr (k1,o1) with */
+Kind k1,k2; /* (k2,o2) */
+Int o1,o2; {
+ Tyvar *kyv1, *kyv2;
+
+ deRef(kyv1,k1,o1);
+ deRef(kyv2,k2,o2);
+
+ if (kyv1)
+ if (kyv2)
+ return kvarToVarBind(kyv1,kyv2); /* k1, k2 variables */
+ else
+ return kvarToTypeBind(kyv1,k2,o2); /* k1 variable, k2 not */
+ else
+ if (kyv2)
+ return kvarToTypeBind(kyv2,k1,o1); /* k2 variable, k1 not */
+ else {
+#ifdef DEBUG_KINDS
+ printf("unifying kinds: ");
+ printType(stdout,debugType(k1,o1));
+ printf(" with ");
+ printType(stdout,debugType(k2,o2));
+ putchar('\n');
+#endif
+ if (k1==STAR && k2==STAR) /* k1, k2 not vars */
+ return TRUE;
+#if TREX
+ else if (k1==ROW && k2==ROW)
+ return TRUE;
+#endif
+ else if (isAp(k1) && isAp(k2))
+ return kunify(fst(k1),o1,fst(k2),o2) &&
+ kunify(snd(k1),o1,snd(k2),o2);
+ }
+ unifyFails = 0;
+ return FALSE;
+}
+
+/* --------------------------------------------------------------------------
+ * Tuple type constructors: are generated as necessary. The most common
+ * n-tuple constructors (n<MAXTUPCON) are held in a cache to avoid
+ * repeated generation of the constructor types.
+ * ------------------------------------------------------------------------*/
+
+#define MAXTUPCON 10
+static Type tupleConTypes[MAXTUPCON];
+
+Void typeTuple(e) /* find type for tuple constr, using*/
+Cell e; { /* tupleConTypes to cache previously*/
+ Int n = tupleOf(e); /* calculated tuple constr. types. */
+ typeOff = newTyvars(n);
+ if (n>=MAXTUPCON)
+ typeIs = makeTupleType(n);
+ else if (tupleConTypes[n])
+ typeIs = tupleConTypes[n];
+ else
+ typeIs = tupleConTypes[n] = makeTupleType(n);
+}
+
+static Type local makeTupleType(n) /* construct type for tuple constr. */
+Int n; { /* t1 -> ... -> tn -> (t1,...,tn) */
+ Type h = mkTuple(n);
+ Int i;
+
+ for (i=0; i<n; ++i)
+ h = ap(h,mkOffset(i));
+ while (0<n--)
+ h = fn(mkOffset(n),h);
+ return h;
+}
+
+/* --------------------------------------------------------------------------
+ * Two forms of kind expression are used quite frequently:
+ * * -> * -> ... -> * -> * for kinds of ->, [], ->, (,) etc...
+ * v1 -> v2 -> ... -> vn -> vn+1 skeletons for constructor kinds
+ * Expressions of these forms are produced by the following functions which
+ * use a cache to avoid repeated construction of commonly used values.
+ * A similar approach is used to store the types of tuple constructors in the
+ * main type checker.
+ * ------------------------------------------------------------------------*/
+
+#define MAXKINDFUN 10
+static Kind simpleKindCache[MAXKINDFUN];
+static Kind varKindCache[MAXKINDFUN];
+
+static Kind local makeSimpleKind(n) /* construct * -> ... -> * (n args)*/
+Int n; {
+ Kind k = STAR;
+ while (n-- > 0)
+ k = ap(STAR,k);
+ return k;
+}
+
+Kind simpleKind(n) /* return (possibly cached) simple */
+Int n; { /* function kind */
+ if (n>=MAXKINDFUN)
+ return makeSimpleKind(n);
+ else if (nonNull(simpleKindCache[n]))
+ return simpleKindCache[n];
+ else if (n==0)
+ return simpleKindCache[0] = STAR;
+ else
+ return simpleKindCache[n] = ap(STAR,simpleKind(n-1));
+}
+
+static Kind local makeVarKind(n) /* construct v0 -> .. -> vn */
+Int n; {
+ Kind k = mkOffset(n);
+ while (n-- > 0)
+ k = ap(mkOffset(n),k);
+ return k;
+}
+
+Void varKind(n) /* return (possibly cached) var */
+Int n; { /* function kind */
+ typeOff = newKindvars(n+1);
+ if (n>=MAXKINDFUN)
+ typeIs = makeVarKind(n);
+ else if (nonNull(varKindCache[n]))
+ typeIs = varKindCache[n];
+ else
+ typeIs = varKindCache[n] = makeVarKind(n);
+}
+
+/* --------------------------------------------------------------------------
+ * Substitutution control:
+ * ------------------------------------------------------------------------*/
+
+Void substitution(what)
+Int what; {
+ Int i;
+
+ switch (what) {
+ case RESET : emptySubstitution();
+ unrestrictBind();
+ btyvars = NIL;
+ break;
+
+ case MARK : for (i=0; i<MAXTUPCON; ++i)
+ mark(tupleConTypes[i]);
+ for (i=0; i<MAXKINDFUN; ++i) {
+ mark(simpleKindCache[i]);
+ mark(varKindCache[i]);
+ }
+ for (i=0; i<numTyvars; ++i)
+ mark(tyvars[i].bound);
+ mark(btyvars);
+ mark(typeIs);
+ mark(predsAre);
+ mark(genericVars);
+ break;
+
+ case INSTALL : substitution(RESET);
+ for (i=0; i<MAXTUPCON; ++i)
+ tupleConTypes[i] = NIL;
+ for (i=0; i<MAXKINDFUN; ++i) {
+ simpleKindCache[i] = NIL;
+ varKindCache[i] = NIL;
+ }
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * subst.h: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
+ * See NOTICE for details and conditions of use etc...
+ * Hugs version 1.3c, March 1998
+ *
+ * Definitions for substitution data structure and operations.
+ * ------------------------------------------------------------------------*/
+
+typedef struct { /* Each type variable contains: */
+ Type bound; /* A type skeleton (unbound==NIL) */
+ Int offs; /* Offset for skeleton */
+ Kind kind; /* kind annotation */
+} Tyvar;
+
+#if FIXED_SUBST /* storage for type variables */
+extern Tyvar tyvars[];
+#else
+extern Tyvar *tyvars; /* storage for type variables */
+#endif
+extern Int typeOff; /* offset of result type */
+extern Type typeIs; /* skeleton of result type */
+extern Int typeFree; /* freedom in instantiated type */
+extern List predsAre; /* list of predicates in type */
+extern List genericVars; /* list of generic vars */
+extern List btyvars; /* explicitly scoped type vars */
+
+#define tyvar(n) (tyvars+(n)) /* nth type variable */
+#define tyvNum(t) ((t)-tyvars) /* and the corresp. inverse funct. */
+#define isBound(t) (((t)->bound) && ((t)->bound!=SKOLEM))
+#define aVar mkOffset(0) /* Simple skeleton for type var */
+#define bVar mkOffset(1) /* Simple skeleton for type var */
+#define enterBtyvs() btyvars = cons(NIL,btyvars)
+#define leaveBtyvs() btyvars = tl(btyvars)
+
+#define deRef(tyv,t,o) while ((tyv=getTypeVar(t,o)) && isBound(tyv)) { \
+ t = tyv->bound; \
+ o = tyv->offs; \
+ }
+
+ /* offs values when isNull(bound): */
+#define FIXED_TYVAR 0 /* fixed in current assumption */
+#define UNUSED_GENERIC 1 /* not fixed, not yet encountered */
+#define GENERIC 2 /* GENERIC+n==nth generic var found*/
+
+extern char *unifyFails; /* Unification error message */
+
+extern Void emptySubstitution Args((Void));
+extern Int newTyvars Args((Int));
+#define newKindvars(n) newTyvars(n)
+extern Int newKindedVars Args((Kind));
+extern Void instantiate Args((Type));
+
+extern Pair findBtyvs Args((Text));
+extern Void markBtyvs Args((Void));
+extern Type localizeBtyvs Args((Type));
+
+extern Tyvar *getTypeVar Args((Type,Int));
+extern Void tyvarType Args((Int));
+extern Void bindTv Args((Int,Type,Int));
+extern Cell getDerefHead Args((Type,Int));
+extern Void expandSyn Args((Tycon, Int, Type *, Int *));
+
+extern Void clearMarks Args((Void));
+extern Void resetGenerics Args((Void));
+extern Void markTyvar Args((Int));
+extern Void markType Args((Type,Int));
+extern Void markPred Args((Cell));
+
+extern Type copyTyvar Args((Int));
+extern Type copyType Args((Type,Int));
+extern Cell copyPred Args((Cell,Int));
+extern Type dropRank2 Args((Type,Int,Int));
+extern Type dropRank1 Args((Type,Int,Int));
+extern Void liftRank2Args Args((List,Int,Int));
+extern Type liftRank2 Args((Type,Int,Int));
+extern Type liftRank1 Args((Type,Int,Int));
+#ifdef DEBUG_TYPES
+extern Type debugTyvar Args((Int));
+extern Type debugType Args((Type,Int));
+#endif
+extern Kind copyKindvar Args((Int));
+extern Kind copyKind Args((Kind,Int));
+
+extern Bool eqKind Args((Kind,Kind));
+extern Kind getKind Args((Cell,Int));
+
+extern List genvarTyvar Args((Int,List));
+extern List genvarType Args((Type,Int,List));
+
+extern Bool doesntOccurIn Args((Tyvar*,Type,Int));
+extern Bool unify Args((Type,Int,Type,Int));
+extern Bool kunify Args((Kind,Int,Kind,Int));
+
+extern Void typeTuple Args((Cell));
+extern Kind simpleKind Args((Int));
+extern Void varKind Args((Int));
+
+extern Bool samePred Args((Cell,Int,Cell,Int));
+extern Bool matchPred Args((Cell,Int,Cell,Int));
+extern Bool unifyPred Args((Cell,Int,Cell,Int));
+extern Inst findInstFor Args((Cell,Int));
+
+extern Bool sameSchemes Args((Type,Type));
+
+extern Bool typeMatches Args((Type,Type));
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+#!/usr/bin/perl
+
+die "Usage: before <regexp>" unless $ARGV[0];
+
+$start = $ARGV[0];
+
+# Filter that trims lines before regexp
+
+# skip the initial part
+while (<STDIN>) {
+ last if /$start/;
+}
+# print the good bit
+while (<STDIN>) {
+ print;
+}
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+
+die "Usage: before <regexp>" unless $ARGV[0];
+
+$pat = $ARGV[0];
+
+# Filter that trims lines after regexp
+
+# print the initial part
+while (<STDIN>) {
+ last if /$pat/;
+ print;
+}
+
+exit 0;
--- /dev/null
+look env "f"
+look env "g"
+look env2 "f"
+look env2 "g"
+main
+main2
\ No newline at end of file
--- /dev/null
+--!!! Testing IOExts.fixIO
+
+> module FixIOTest where
+> import Monad
+> import Maybe
+> import IOExts( fixIO )
+
+First a recursively-defined environment in the normal way:
+
+> env = foldl (\env' (s,v) -> enter env' s v)
+> empty
+> [ ("f", (1, fst (fromJust (look env "g")))) ,
+> ("g", (2, fst (fromJust (look env "f")))) ]
+
+> env2 = let vF = (1, fst (fromJust (look env2 "g")))
+> vG = (2, fst (fromJust (look env2 "f")))
+> in enter (enter empty "f" vF) "g" vG
+
+Which yields these correct evaluations:
+ look env' "f" ==> (1,2)
+ look env' "g" ==> (2,1)
+
+Now let's add some IO to each "store action" and use foldM/fixIO to
+tie it all together:
+
+> main =
+> do env <- fixIO (\env -> do
+> foldM (\env' (s,vM) -> do v <- vM
+> return (enter env' s v))
+> empty
+> [ ("f", do putStrLn "storing f"
+> return (1, fst (fromJust (look env "g")))) ,
+> ("g", do putStrLn "storing g"
+> return (2, fst (fromJust (look env "f")))) ] )
+> print (look env "f")
+> print (look env "g")
+> return ()
+
+> main2 =
+> do env <- fixIO (\env -> do
+> let vF = (1,fst (fromJust (look env "g")))
+> vG = (2,fst (fromJust (look env "f")))
+> putStrLn "storing f and g"
+> return $ enter (enter empty "f" vF) "g" vG
+> )
+> putStrLn "Constructed environment"
+> print env
+> print (look env "f")
+> print (look env "g")
+> return ()
+
+But this unfortunately dies a horrible death:
+
+FixIOTest> main
+storing f
+storing g
+Just (1,
+Program error: {_Gc Black Hole}
+
+If I comment out the "print" statements I get:
+
+FixIOTest> main
+storing f
+storing g
+
+and it terminates properly.
+
+----------------------------------------------------------------
+-- Environments
+----------------------------------------------------------------
+
+> empty :: Table a
+> enter :: Table a -> String -> a -> Table a
+> look :: Table a -> String -> Maybe a
+
+----------------------------------------------------------------
+-- A very simple environment implemented as functions:
+----------------------------------------------------------------
+
+> {-
+> type Table a = String -> Maybe a
+> empty s = Nothing
+> enter t s1 x s2 | s1==s2 = Just x
+> | otherwise = look t s2
+> look t s = t s
+> -}
+
+----------------------------------------------------------------
+-- A very simple environment implemented using association lists:
+----------------------------------------------------------------
+
+> type Table a = [(String,a)]
+> empty = []
+> enter t s x = (s,x):t
+> look t s = lookup s t
+
+
--- /dev/null
+Reading file "Monad.hs":
+Reading file "Maybe.hs":
+Reading file "IOExts.lhs":
+Reading file "ST.lhs":
+Reading file "IOExts.lhs":
+Reading file "test/exts/FixIO.lhs":
+Type :? for help
+Hugs:Just (1,2)
+Hugs:Just (2,1)
+Hugs:Just (1,2)
+Hugs:Just (2,1)
+Hugs:storing f
+storing g
+Just (1,2)
+Just (2,1)
+
+Hugs:storing f and g
+Constructed environment
+[("g",(2,1)), ("f",(1,2))]
+Just (1,2)
+Just (2,1)
+
--- /dev/null
+--!!! Testing Int and Word
+module T where
+import Int
+import Word
+import Bits
+import Ix
+
+test = do
+ testIntlike "Int8" (0::Int8)
+ testIntlike "Int16" (0::Int16)
+ testIntlike "Int32" (0::Int32)
+ testIntlike "Word8" (0::Word8)
+ testIntlike "Word16" (0::Word16)
+ testIntlike "Word32" (0::Word32)
+
+testIntlike :: (Bounded a, Integral a, Ix a, Read a, Bits a) => String -> a -> IO ()
+testIntlike name zero = do
+ putStrLn $ "--------------------------------"
+ putStrLn $ "--Testing " ++ name
+ putStrLn $ "--------------------------------"
+ testBounded zero
+ testEnum zero
+ testReadShow zero
+ testEq zero
+ testOrd zero
+ testNum zero
+ testReal zero
+ testIntegral zero
+ testBits zero
+ putStrLn $ "--------------------------------"
+
+-- In all these tests, zero is a dummy element used to get
+-- the overloading to work
+
+testBounded zero = do
+ putStrLn "testBounded"
+ print $ (minBound-1, minBound, minBound+1) `asTypeOf` (zero,zero,zero)
+ print $ (maxBound-1, maxBound, maxBound+1) `asTypeOf` (zero,zero,zero)
+
+testEnum zero = do
+ putStrLn "testEnum"
+ print $ take 10 [zero .. ] -- enumFrom
+ print $ take 10 [zero, toEnum 2 .. ] -- enumFromThen
+ print [zero .. toEnum 20] -- enumFromTo
+ print [zero, toEnum 2 .. toEnum 20] -- enumFromThenTo
+
+samples :: (Num a, Enum a) => a -> ([a], [a])
+samples zero = ([-3 .. -1]++[0 .. 3], [-3 .. -1]++[1 .. 3])
+
+table1 :: (Show a, Show b) => String -> (a -> b) -> [a] -> IO ()
+table1 nm f xs = do
+ sequence [ f' x | x <- xs ]
+ putStrLn "#"
+ where
+ f' x = putStrLn (nm ++ " " ++ show x ++ " = " ++ show (f x))
+
+table2 :: (Show a, Show b, Show c) => String -> (a -> b -> c) -> [a] -> [b] -> IO ()
+table2 nm op xs ys = do
+ sequence [ sequence [ op' x y | y <- ys ] >> putStrLn " "
+ | x <- xs
+ ]
+ putStrLn "#"
+ where
+ op' x y = putStrLn (show x ++ " " ++ nm ++ " " ++ show y
+ ++ " = " ++ show (op x y))
+
+testReadShow zero = do
+ putStrLn "testReadShow"
+ print xs
+ print (map read_show xs)
+ where
+ (xs,zs) = samples zero
+ read_show x = (read (show x) `asTypeOf` zero)
+
+testEq zero = do
+ putStrLn "testEq"
+ table2 "==" (==) xs xs
+ table2 "/=" (/=) xs xs
+ where
+ (xs,ys) = samples zero
+
+testOrd zero = do
+ putStrLn "testOrd"
+ table2 "<=" (<=) xs xs
+ table2 "< " (<) xs xs
+ table2 "> " (>) xs xs
+ table2 ">=" (>=) xs xs
+ table2 "`compare`" compare xs xs
+ where
+ (xs,ys) = samples zero
+
+testNum zero = do
+ putStrLn "testNum"
+ table2 "+" (+) xs xs
+ table2 "-" (-) xs xs
+ table2 "*" (*) xs xs
+ table1 "negate" negate xs
+ where
+ (xs,ys) = samples zero
+
+testReal zero = do
+ putStrLn "testReal"
+ table1 "toRational" toRational xs
+ where
+ (xs,ys) = samples zero
+
+testIntegral zero = do
+ putStrLn "testIntegral"
+ table2 "`divMod` " divMod xs ys
+ table2 "`div` " div xs ys
+ table2 "`mod` " mod xs ys
+ table2 "`quotRem`" quotRem xs ys
+ table2 "`quot` " quot xs ys
+ table2 "`rem` " rem xs ys
+ where
+ (xs,ys) = samples zero
+
+testBits zero = do
+ putStrLn "testBits"
+ table2 ".&. " (.&.) xs ys
+ table2 ".|. " (.|.) xs ys
+ table2 "`xor`" xor xs ys
+ table1 "complement" complement xs
+ table2 "`shift`" shift xs [0..3]
+-- table2 "`rotate`" rotate xs [0..3]
+-- table1 "bit" bit xs
+ table2 "`setBit`" setBit xs [0..3]
+ table2 "`clearBit`" clearBit xs [0..3]
+ table2 "`complementBit`" complementBit xs [0..3]
+ table2 "`testBit`" testBit xs [0..3]
+ table1 "bitSize" bitSize xs
+ table1 "isSigned" isSigned xs
+ where
+ (xs,ys) = samples zero
--- /dev/null
+Reading file "Int.hs":
+Reading file "Bits.lhs":
+Reading file "Int.hs":
+Reading file "Word.hs":
+Reading file "test/exts/intTest.hs":
+Type :? for help
+Hugs:--------------------------------
+--Testing Int8
+--------------------------------
+testBounded
+(127,-128,-127)
+(126,127,-128)
+testEnum
+[0,1,2,3,4,5,6,7,8,9]
+[0,2,4,6,8,10,12,14,16,18]
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
+[0,2,4,6,8,10,12,14,16,18,20]
+testReadShow
+[-3,-2,-1,0,1,2,3]
+[-3,-2,-1,0,1,2,3]
+testEq
+-3 == -3 = True
+-3 == -2 = False
+-3 == -1 = False
+-3 == 0 = False
+-3 == 1 = False
+-3 == 2 = False
+-3 == 3 = False
+
+-2 == -3 = False
+-2 == -2 = True
+-2 == -1 = False
+-2 == 0 = False
+-2 == 1 = False
+-2 == 2 = False
+-2 == 3 = False
+
+-1 == -3 = False
+-1 == -2 = False
+-1 == -1 = True
+-1 == 0 = False
+-1 == 1 = False
+-1 == 2 = False
+-1 == 3 = False
+
+0 == -3 = False
+0 == -2 = False
+0 == -1 = False
+0 == 0 = True
+0 == 1 = False
+0 == 2 = False
+0 == 3 = False
+
+1 == -3 = False
+1 == -2 = False
+1 == -1 = False
+1 == 0 = False
+1 == 1 = True
+1 == 2 = False
+1 == 3 = False
+
+2 == -3 = False
+2 == -2 = False
+2 == -1 = False
+2 == 0 = False
+2 == 1 = False
+2 == 2 = True
+2 == 3 = False
+
+3 == -3 = False
+3 == -2 = False
+3 == -1 = False
+3 == 0 = False
+3 == 1 = False
+3 == 2 = False
+3 == 3 = True
+
+#
+-3 /= -3 = False
+-3 /= -2 = True
+-3 /= -1 = True
+-3 /= 0 = True
+-3 /= 1 = True
+-3 /= 2 = True
+-3 /= 3 = True
+
+-2 /= -3 = True
+-2 /= -2 = False
+-2 /= -1 = True
+-2 /= 0 = True
+-2 /= 1 = True
+-2 /= 2 = True
+-2 /= 3 = True
+
+-1 /= -3 = True
+-1 /= -2 = True
+-1 /= -1 = False
+-1 /= 0 = True
+-1 /= 1 = True
+-1 /= 2 = True
+-1 /= 3 = True
+
+0 /= -3 = True
+0 /= -2 = True
+0 /= -1 = True
+0 /= 0 = False
+0 /= 1 = True
+0 /= 2 = True
+0 /= 3 = True
+
+1 /= -3 = True
+1 /= -2 = True
+1 /= -1 = True
+1 /= 0 = True
+1 /= 1 = False
+1 /= 2 = True
+1 /= 3 = True
+
+2 /= -3 = True
+2 /= -2 = True
+2 /= -1 = True
+2 /= 0 = True
+2 /= 1 = True
+2 /= 2 = False
+2 /= 3 = True
+
+3 /= -3 = True
+3 /= -2 = True
+3 /= -1 = True
+3 /= 0 = True
+3 /= 1 = True
+3 /= 2 = True
+3 /= 3 = False
+
+#
+testOrd
+-3 <= -3 = True
+-3 <= -2 = True
+-3 <= -1 = True
+-3 <= 0 = True
+-3 <= 1 = True
+-3 <= 2 = True
+-3 <= 3 = True
+
+-2 <= -3 = False
+-2 <= -2 = True
+-2 <= -1 = True
+-2 <= 0 = True
+-2 <= 1 = True
+-2 <= 2 = True
+-2 <= 3 = True
+
+-1 <= -3 = False
+-1 <= -2 = False
+-1 <= -1 = True
+-1 <= 0 = True
+-1 <= 1 = True
+-1 <= 2 = True
+-1 <= 3 = True
+
+0 <= -3 = False
+0 <= -2 = False
+0 <= -1 = False
+0 <= 0 = True
+0 <= 1 = True
+0 <= 2 = True
+0 <= 3 = True
+
+1 <= -3 = False
+1 <= -2 = False
+1 <= -1 = False
+1 <= 0 = False
+1 <= 1 = True
+1 <= 2 = True
+1 <= 3 = True
+
+2 <= -3 = False
+2 <= -2 = False
+2 <= -1 = False
+2 <= 0 = False
+2 <= 1 = False
+2 <= 2 = True
+2 <= 3 = True
+
+3 <= -3 = False
+3 <= -2 = False
+3 <= -1 = False
+3 <= 0 = False
+3 <= 1 = False
+3 <= 2 = False
+3 <= 3 = True
+
+#
+-3 < -3 = False
+-3 < -2 = True
+-3 < -1 = True
+-3 < 0 = True
+-3 < 1 = True
+-3 < 2 = True
+-3 < 3 = True
+
+-2 < -3 = False
+-2 < -2 = False
+-2 < -1 = True
+-2 < 0 = True
+-2 < 1 = True
+-2 < 2 = True
+-2 < 3 = True
+
+-1 < -3 = False
+-1 < -2 = False
+-1 < -1 = False
+-1 < 0 = True
+-1 < 1 = True
+-1 < 2 = True
+-1 < 3 = True
+
+0 < -3 = False
+0 < -2 = False
+0 < -1 = False
+0 < 0 = False
+0 < 1 = True
+0 < 2 = True
+0 < 3 = True
+
+1 < -3 = False
+1 < -2 = False
+1 < -1 = False
+1 < 0 = False
+1 < 1 = False
+1 < 2 = True
+1 < 3 = True
+
+2 < -3 = False
+2 < -2 = False
+2 < -1 = False
+2 < 0 = False
+2 < 1 = False
+2 < 2 = False
+2 < 3 = True
+
+3 < -3 = False
+3 < -2 = False
+3 < -1 = False
+3 < 0 = False
+3 < 1 = False
+3 < 2 = False
+3 < 3 = False
+
+#
+-3 > -3 = False
+-3 > -2 = False
+-3 > -1 = False
+-3 > 0 = False
+-3 > 1 = False
+-3 > 2 = False
+-3 > 3 = False
+
+-2 > -3 = True
+-2 > -2 = False
+-2 > -1 = False
+-2 > 0 = False
+-2 > 1 = False
+-2 > 2 = False
+-2 > 3 = False
+
+-1 > -3 = True
+-1 > -2 = True
+-1 > -1 = False
+-1 > 0 = False
+-1 > 1 = False
+-1 > 2 = False
+-1 > 3 = False
+
+0 > -3 = True
+0 > -2 = True
+0 > -1 = True
+0 > 0 = False
+0 > 1 = False
+0 > 2 = False
+0 > 3 = False
+
+1 > -3 = True
+1 > -2 = True
+1 > -1 = True
+1 > 0 = True
+1 > 1 = False
+1 > 2 = False
+1 > 3 = False
+
+2 > -3 = True
+2 > -2 = True
+2 > -1 = True
+2 > 0 = True
+2 > 1 = True
+2 > 2 = False
+2 > 3 = False
+
+3 > -3 = True
+3 > -2 = True
+3 > -1 = True
+3 > 0 = True
+3 > 1 = True
+3 > 2 = True
+3 > 3 = False
+
+#
+-3 >= -3 = True
+-3 >= -2 = False
+-3 >= -1 = False
+-3 >= 0 = False
+-3 >= 1 = False
+-3 >= 2 = False
+-3 >= 3 = False
+
+-2 >= -3 = True
+-2 >= -2 = True
+-2 >= -1 = False
+-2 >= 0 = False
+-2 >= 1 = False
+-2 >= 2 = False
+-2 >= 3 = False
+
+-1 >= -3 = True
+-1 >= -2 = True
+-1 >= -1 = True
+-1 >= 0 = False
+-1 >= 1 = False
+-1 >= 2 = False
+-1 >= 3 = False
+
+0 >= -3 = True
+0 >= -2 = True
+0 >= -1 = True
+0 >= 0 = True
+0 >= 1 = False
+0 >= 2 = False
+0 >= 3 = False
+
+1 >= -3 = True
+1 >= -2 = True
+1 >= -1 = True
+1 >= 0 = True
+1 >= 1 = True
+1 >= 2 = False
+1 >= 3 = False
+
+2 >= -3 = True
+2 >= -2 = True
+2 >= -1 = True
+2 >= 0 = True
+2 >= 1 = True
+2 >= 2 = True
+2 >= 3 = False
+
+3 >= -3 = True
+3 >= -2 = True
+3 >= -1 = True
+3 >= 0 = True
+3 >= 1 = True
+3 >= 2 = True
+3 >= 3 = True
+
+#
+-3 `compare` -3 = EQ
+-3 `compare` -2 = LT
+-3 `compare` -1 = LT
+-3 `compare` 0 = LT
+-3 `compare` 1 = LT
+-3 `compare` 2 = LT
+-3 `compare` 3 = LT
+
+-2 `compare` -3 = GT
+-2 `compare` -2 = EQ
+-2 `compare` -1 = LT
+-2 `compare` 0 = LT
+-2 `compare` 1 = LT
+-2 `compare` 2 = LT
+-2 `compare` 3 = LT
+
+-1 `compare` -3 = GT
+-1 `compare` -2 = GT
+-1 `compare` -1 = EQ
+-1 `compare` 0 = LT
+-1 `compare` 1 = LT
+-1 `compare` 2 = LT
+-1 `compare` 3 = LT
+
+0 `compare` -3 = GT
+0 `compare` -2 = GT
+0 `compare` -1 = GT
+0 `compare` 0 = EQ
+0 `compare` 1 = LT
+0 `compare` 2 = LT
+0 `compare` 3 = LT
+
+1 `compare` -3 = GT
+1 `compare` -2 = GT
+1 `compare` -1 = GT
+1 `compare` 0 = GT
+1 `compare` 1 = EQ
+1 `compare` 2 = LT
+1 `compare` 3 = LT
+
+2 `compare` -3 = GT
+2 `compare` -2 = GT
+2 `compare` -1 = GT
+2 `compare` 0 = GT
+2 `compare` 1 = GT
+2 `compare` 2 = EQ
+2 `compare` 3 = LT
+
+3 `compare` -3 = GT
+3 `compare` -2 = GT
+3 `compare` -1 = GT
+3 `compare` 0 = GT
+3 `compare` 1 = GT
+3 `compare` 2 = GT
+3 `compare` 3 = EQ
+
+#
+testNum
+-3 + -3 = -6
+-3 + -2 = -5
+-3 + -1 = -4
+-3 + 0 = -3
+-3 + 1 = -2
+-3 + 2 = -1
+-3 + 3 = 0
+
+-2 + -3 = -5
+-2 + -2 = -4
+-2 + -1 = -3
+-2 + 0 = -2
+-2 + 1 = -1
+-2 + 2 = 0
+-2 + 3 = 1
+
+-1 + -3 = -4
+-1 + -2 = -3
+-1 + -1 = -2
+-1 + 0 = -1
+-1 + 1 = 0
+-1 + 2 = 1
+-1 + 3 = 2
+
+0 + -3 = -3
+0 + -2 = -2
+0 + -1 = -1
+0 + 0 = 0
+0 + 1 = 1
+0 + 2 = 2
+0 + 3 = 3
+
+1 + -3 = -2
+1 + -2 = -1
+1 + -1 = 0
+1 + 0 = 1
+1 + 1 = 2
+1 + 2 = 3
+1 + 3 = 4
+
+2 + -3 = -1
+2 + -2 = 0
+2 + -1 = 1
+2 + 0 = 2
+2 + 1 = 3
+2 + 2 = 4
+2 + 3 = 5
+
+3 + -3 = 0
+3 + -2 = 1
+3 + -1 = 2
+3 + 0 = 3
+3 + 1 = 4
+3 + 2 = 5
+3 + 3 = 6
+
+#
+-3 - -3 = 0
+-3 - -2 = -1
+-3 - -1 = -2
+-3 - 0 = -3
+-3 - 1 = -4
+-3 - 2 = -5
+-3 - 3 = -6
+
+-2 - -3 = 1
+-2 - -2 = 0
+-2 - -1 = -1
+-2 - 0 = -2
+-2 - 1 = -3
+-2 - 2 = -4
+-2 - 3 = -5
+
+-1 - -3 = 2
+-1 - -2 = 1
+-1 - -1 = 0
+-1 - 0 = -1
+-1 - 1 = -2
+-1 - 2 = -3
+-1 - 3 = -4
+
+0 - -3 = 3
+0 - -2 = 2
+0 - -1 = 1
+0 - 0 = 0
+0 - 1 = -1
+0 - 2 = -2
+0 - 3 = -3
+
+1 - -3 = 4
+1 - -2 = 3
+1 - -1 = 2
+1 - 0 = 1
+1 - 1 = 0
+1 - 2 = -1
+1 - 3 = -2
+
+2 - -3 = 5
+2 - -2 = 4
+2 - -1 = 3
+2 - 0 = 2
+2 - 1 = 1
+2 - 2 = 0
+2 - 3 = -1
+
+3 - -3 = 6
+3 - -2 = 5
+3 - -1 = 4
+3 - 0 = 3
+3 - 1 = 2
+3 - 2 = 1
+3 - 3 = 0
+
+#
+-3 * -3 = 9
+-3 * -2 = 6
+-3 * -1 = 3
+-3 * 0 = 0
+-3 * 1 = -3
+-3 * 2 = -6
+-3 * 3 = -9
+
+-2 * -3 = 6
+-2 * -2 = 4
+-2 * -1 = 2
+-2 * 0 = 0
+-2 * 1 = -2
+-2 * 2 = -4
+-2 * 3 = -6
+
+-1 * -3 = 3
+-1 * -2 = 2
+-1 * -1 = 1
+-1 * 0 = 0
+-1 * 1 = -1
+-1 * 2 = -2
+-1 * 3 = -3
+
+0 * -3 = 0
+0 * -2 = 0
+0 * -1 = 0
+0 * 0 = 0
+0 * 1 = 0
+0 * 2 = 0
+0 * 3 = 0
+
+1 * -3 = -3
+1 * -2 = -2
+1 * -1 = -1
+1 * 0 = 0
+1 * 1 = 1
+1 * 2 = 2
+1 * 3 = 3
+
+2 * -3 = -6
+2 * -2 = -4
+2 * -1 = -2
+2 * 0 = 0
+2 * 1 = 2
+2 * 2 = 4
+2 * 3 = 6
+
+3 * -3 = -9
+3 * -2 = -6
+3 * -1 = -3
+3 * 0 = 0
+3 * 1 = 3
+3 * 2 = 6
+3 * 3 = 9
+
+#
+negate -3 = 3
+negate -2 = 2
+negate -1 = 1
+negate 0 = 0
+negate 1 = -1
+negate 2 = -2
+negate 3 = -3
+#
+testReal
+toRational -3 = -3 % 1
+toRational -2 = -2 % 1
+toRational -1 = -1 % 1
+toRational 0 = 0 % 1
+toRational 1 = 1 % 1
+toRational 2 = 2 % 1
+toRational 3 = 3 % 1
+#
+testIntegral
+-3 `divMod` -3 = (1,0)
+-3 `divMod` -2 = (1,-1)
+-3 `divMod` -1 = (3,0)
+-3 `divMod` 1 = (-3,0)
+-3 `divMod` 2 = (-2,1)
+-3 `divMod` 3 = (-1,0)
+
+-2 `divMod` -3 = (0,-2)
+-2 `divMod` -2 = (1,0)
+-2 `divMod` -1 = (2,0)
+-2 `divMod` 1 = (-2,0)
+-2 `divMod` 2 = (-1,0)
+-2 `divMod` 3 = (-1,1)
+
+-1 `divMod` -3 = (0,-1)
+-1 `divMod` -2 = (0,-1)
+-1 `divMod` -1 = (1,0)
+-1 `divMod` 1 = (-1,0)
+-1 `divMod` 2 = (-1,1)
+-1 `divMod` 3 = (-1,2)
+
+0 `divMod` -3 = (0,0)
+0 `divMod` -2 = (0,0)
+0 `divMod` -1 = (0,0)
+0 `divMod` 1 = (0,0)
+0 `divMod` 2 = (0,0)
+0 `divMod` 3 = (0,0)
+
+1 `divMod` -3 = (-1,-2)
+1 `divMod` -2 = (-1,-1)
+1 `divMod` -1 = (-1,0)
+1 `divMod` 1 = (1,0)
+1 `divMod` 2 = (0,1)
+1 `divMod` 3 = (0,1)
+
+2 `divMod` -3 = (-1,-1)
+2 `divMod` -2 = (-1,0)
+2 `divMod` -1 = (-2,0)
+2 `divMod` 1 = (2,0)
+2 `divMod` 2 = (1,0)
+2 `divMod` 3 = (0,2)
+
+3 `divMod` -3 = (-1,0)
+3 `divMod` -2 = (-2,-1)
+3 `divMod` -1 = (-3,0)
+3 `divMod` 1 = (3,0)
+3 `divMod` 2 = (1,1)
+3 `divMod` 3 = (1,0)
+
+#
+-3 `div` -3 = 1
+-3 `div` -2 = 1
+-3 `div` -1 = 3
+-3 `div` 1 = -3
+-3 `div` 2 = -2
+-3 `div` 3 = -1
+
+-2 `div` -3 = 0
+-2 `div` -2 = 1
+-2 `div` -1 = 2
+-2 `div` 1 = -2
+-2 `div` 2 = -1
+-2 `div` 3 = -1
+
+-1 `div` -3 = 0
+-1 `div` -2 = 0
+-1 `div` -1 = 1
+-1 `div` 1 = -1
+-1 `div` 2 = -1
+-1 `div` 3 = -1
+
+0 `div` -3 = 0
+0 `div` -2 = 0
+0 `div` -1 = 0
+0 `div` 1 = 0
+0 `div` 2 = 0
+0 `div` 3 = 0
+
+1 `div` -3 = -1
+1 `div` -2 = -1
+1 `div` -1 = -1
+1 `div` 1 = 1
+1 `div` 2 = 0
+1 `div` 3 = 0
+
+2 `div` -3 = -1
+2 `div` -2 = -1
+2 `div` -1 = -2
+2 `div` 1 = 2
+2 `div` 2 = 1
+2 `div` 3 = 0
+
+3 `div` -3 = -1
+3 `div` -2 = -2
+3 `div` -1 = -3
+3 `div` 1 = 3
+3 `div` 2 = 1
+3 `div` 3 = 1
+
+#
+-3 `mod` -3 = 0
+-3 `mod` -2 = -1
+-3 `mod` -1 = 0
+-3 `mod` 1 = 0
+-3 `mod` 2 = 1
+-3 `mod` 3 = 0
+
+-2 `mod` -3 = -2
+-2 `mod` -2 = 0
+-2 `mod` -1 = 0
+-2 `mod` 1 = 0
+-2 `mod` 2 = 0
+-2 `mod` 3 = 1
+
+-1 `mod` -3 = -1
+-1 `mod` -2 = -1
+-1 `mod` -1 = 0
+-1 `mod` 1 = 0
+-1 `mod` 2 = 1
+-1 `mod` 3 = 2
+
+0 `mod` -3 = 0
+0 `mod` -2 = 0
+0 `mod` -1 = 0
+0 `mod` 1 = 0
+0 `mod` 2 = 0
+0 `mod` 3 = 0
+
+1 `mod` -3 = -2
+1 `mod` -2 = -1
+1 `mod` -1 = 0
+1 `mod` 1 = 0
+1 `mod` 2 = 1
+1 `mod` 3 = 1
+
+2 `mod` -3 = -1
+2 `mod` -2 = 0
+2 `mod` -1 = 0
+2 `mod` 1 = 0
+2 `mod` 2 = 0
+2 `mod` 3 = 2
+
+3 `mod` -3 = 0
+3 `mod` -2 = -1
+3 `mod` -1 = 0
+3 `mod` 1 = 0
+3 `mod` 2 = 1
+3 `mod` 3 = 0
+
+#
+-3 `quotRem` -3 = (1,0)
+-3 `quotRem` -2 = (1,-1)
+-3 `quotRem` -1 = (3,0)
+-3 `quotRem` 1 = (-3,0)
+-3 `quotRem` 2 = (-1,-1)
+-3 `quotRem` 3 = (-1,0)
+
+-2 `quotRem` -3 = (0,-2)
+-2 `quotRem` -2 = (1,0)
+-2 `quotRem` -1 = (2,0)
+-2 `quotRem` 1 = (-2,0)
+-2 `quotRem` 2 = (-1,0)
+-2 `quotRem` 3 = (0,-2)
+
+-1 `quotRem` -3 = (0,-1)
+-1 `quotRem` -2 = (0,-1)
+-1 `quotRem` -1 = (1,0)
+-1 `quotRem` 1 = (-1,0)
+-1 `quotRem` 2 = (0,-1)
+-1 `quotRem` 3 = (0,-1)
+
+0 `quotRem` -3 = (0,0)
+0 `quotRem` -2 = (0,0)
+0 `quotRem` -1 = (0,0)
+0 `quotRem` 1 = (0,0)
+0 `quotRem` 2 = (0,0)
+0 `quotRem` 3 = (0,0)
+
+1 `quotRem` -3 = (0,1)
+1 `quotRem` -2 = (0,1)
+1 `quotRem` -1 = (-1,0)
+1 `quotRem` 1 = (1,0)
+1 `quotRem` 2 = (0,1)
+1 `quotRem` 3 = (0,1)
+
+2 `quotRem` -3 = (0,2)
+2 `quotRem` -2 = (-1,0)
+2 `quotRem` -1 = (-2,0)
+2 `quotRem` 1 = (2,0)
+2 `quotRem` 2 = (1,0)
+2 `quotRem` 3 = (0,2)
+
+3 `quotRem` -3 = (-1,0)
+3 `quotRem` -2 = (-1,1)
+3 `quotRem` -1 = (-3,0)
+3 `quotRem` 1 = (3,0)
+3 `quotRem` 2 = (1,1)
+3 `quotRem` 3 = (1,0)
+
+#
+-3 `quot` -3 = 1
+-3 `quot` -2 = 1
+-3 `quot` -1 = 3
+-3 `quot` 1 = -3
+-3 `quot` 2 = -1
+-3 `quot` 3 = -1
+
+-2 `quot` -3 = 0
+-2 `quot` -2 = 1
+-2 `quot` -1 = 2
+-2 `quot` 1 = -2
+-2 `quot` 2 = -1
+-2 `quot` 3 = 0
+
+-1 `quot` -3 = 0
+-1 `quot` -2 = 0
+-1 `quot` -1 = 1
+-1 `quot` 1 = -1
+-1 `quot` 2 = 0
+-1 `quot` 3 = 0
+
+0 `quot` -3 = 0
+0 `quot` -2 = 0
+0 `quot` -1 = 0
+0 `quot` 1 = 0
+0 `quot` 2 = 0
+0 `quot` 3 = 0
+
+1 `quot` -3 = 0
+1 `quot` -2 = 0
+1 `quot` -1 = -1
+1 `quot` 1 = 1
+1 `quot` 2 = 0
+1 `quot` 3 = 0
+
+2 `quot` -3 = 0
+2 `quot` -2 = -1
+2 `quot` -1 = -2
+2 `quot` 1 = 2
+2 `quot` 2 = 1
+2 `quot` 3 = 0
+
+3 `quot` -3 = -1
+3 `quot` -2 = -1
+3 `quot` -1 = -3
+3 `quot` 1 = 3
+3 `quot` 2 = 1
+3 `quot` 3 = 1
+
+#
+-3 `rem` -3 = 0
+-3 `rem` -2 = -1
+-3 `rem` -1 = 0
+-3 `rem` 1 = 0
+-3 `rem` 2 = -1
+-3 `rem` 3 = 0
+
+-2 `rem` -3 = -2
+-2 `rem` -2 = 0
+-2 `rem` -1 = 0
+-2 `rem` 1 = 0
+-2 `rem` 2 = 0
+-2 `rem` 3 = -2
+
+-1 `rem` -3 = -1
+-1 `rem` -2 = -1
+-1 `rem` -1 = 0
+-1 `rem` 1 = 0
+-1 `rem` 2 = -1
+-1 `rem` 3 = -1
+
+0 `rem` -3 = 0
+0 `rem` -2 = 0
+0 `rem` -1 = 0
+0 `rem` 1 = 0
+0 `rem` 2 = 0
+0 `rem` 3 = 0
+
+1 `rem` -3 = 1
+1 `rem` -2 = 1
+1 `rem` -1 = 0
+1 `rem` 1 = 0
+1 `rem` 2 = 1
+1 `rem` 3 = 1
+
+2 `rem` -3 = 2
+2 `rem` -2 = 0
+2 `rem` -1 = 0
+2 `rem` 1 = 0
+2 `rem` 2 = 0
+2 `rem` 3 = 2
+
+3 `rem` -3 = 0
+3 `rem` -2 = 1
+3 `rem` -1 = 0
+3 `rem` 1 = 0
+3 `rem` 2 = 1
+3 `rem` 3 = 0
+
+#
+testBits
+-3 .&. -3 = -3
+-3 .&. -2 = -4
+-3 .&. -1 = -3
+-3 .&. 1 = 1
+-3 .&. 2 = 0
+-3 .&. 3 = 1
+
+-2 .&. -3 = -4
+-2 .&. -2 = -2
+-2 .&. -1 = -2
+-2 .&. 1 = 0
+-2 .&. 2 = 2
+-2 .&. 3 = 2
+
+-1 .&. -3 = -3
+-1 .&. -2 = -2
+-1 .&. -1 = -1
+-1 .&. 1 = 1
+-1 .&. 2 = 2
+-1 .&. 3 = 3
+
+0 .&. -3 = 0
+0 .&. -2 = 0
+0 .&. -1 = 0
+0 .&. 1 = 0
+0 .&. 2 = 0
+0 .&. 3 = 0
+
+1 .&. -3 = 1
+1 .&. -2 = 0
+1 .&. -1 = 1
+1 .&. 1 = 1
+1 .&. 2 = 0
+1 .&. 3 = 1
+
+2 .&. -3 = 0
+2 .&. -2 = 2
+2 .&. -1 = 2
+2 .&. 1 = 0
+2 .&. 2 = 2
+2 .&. 3 = 2
+
+3 .&. -3 = 1
+3 .&. -2 = 2
+3 .&. -1 = 3
+3 .&. 1 = 1
+3 .&. 2 = 2
+3 .&. 3 = 3
+
+#
+-3 .|. -3 = -3
+-3 .|. -2 = -1
+-3 .|. -1 = -1
+-3 .|. 1 = -3
+-3 .|. 2 = -1
+-3 .|. 3 = -1
+
+-2 .|. -3 = -1
+-2 .|. -2 = -2
+-2 .|. -1 = -1
+-2 .|. 1 = -1
+-2 .|. 2 = -2
+-2 .|. 3 = -1
+
+-1 .|. -3 = -1
+-1 .|. -2 = -1
+-1 .|. -1 = -1
+-1 .|. 1 = -1
+-1 .|. 2 = -1
+-1 .|. 3 = -1
+
+0 .|. -3 = -3
+0 .|. -2 = -2
+0 .|. -1 = -1
+0 .|. 1 = 1
+0 .|. 2 = 2
+0 .|. 3 = 3
+
+1 .|. -3 = -3
+1 .|. -2 = -1
+1 .|. -1 = -1
+1 .|. 1 = 1
+1 .|. 2 = 3
+1 .|. 3 = 3
+
+2 .|. -3 = -1
+2 .|. -2 = -2
+2 .|. -1 = -1
+2 .|. 1 = 3
+2 .|. 2 = 2
+2 .|. 3 = 3
+
+3 .|. -3 = -1
+3 .|. -2 = -1
+3 .|. -1 = -1
+3 .|. 1 = 3
+3 .|. 2 = 3
+3 .|. 3 = 3
+
+#
+-3 `xor` -3 = 0
+-3 `xor` -2 = 3
+-3 `xor` -1 = 2
+-3 `xor` 1 = -4
+-3 `xor` 2 = -1
+-3 `xor` 3 = -2
+
+-2 `xor` -3 = 3
+-2 `xor` -2 = 0
+-2 `xor` -1 = 1
+-2 `xor` 1 = -1
+-2 `xor` 2 = -4
+-2 `xor` 3 = -3
+
+-1 `xor` -3 = 2
+-1 `xor` -2 = 1
+-1 `xor` -1 = 0
+-1 `xor` 1 = -2
+-1 `xor` 2 = -3
+-1 `xor` 3 = -4
+
+0 `xor` -3 = -3
+0 `xor` -2 = -2
+0 `xor` -1 = -1
+0 `xor` 1 = 1
+0 `xor` 2 = 2
+0 `xor` 3 = 3
+
+1 `xor` -3 = -4
+1 `xor` -2 = -1
+1 `xor` -1 = -2
+1 `xor` 1 = 0
+1 `xor` 2 = 3
+1 `xor` 3 = 2
+
+2 `xor` -3 = -1
+2 `xor` -2 = -4
+2 `xor` -1 = -3
+2 `xor` 1 = 3
+2 `xor` 2 = 0
+2 `xor` 3 = 1
+
+3 `xor` -3 = -2
+3 `xor` -2 = -3
+3 `xor` -1 = -4
+3 `xor` 1 = 2
+3 `xor` 2 = 1
+3 `xor` 3 = 0
+
+#
+complement -3 = 2
+complement -2 = 1
+complement -1 = 0
+complement 0 = -1
+complement 1 = -2
+complement 2 = -3
+complement 3 = -4
+#
+-3 `shift` 0 = -3
+-3 `shift` 1 = -6
+-3 `shift` 2 = -12
+-3 `shift` 3 = -24
+
+-2 `shift` 0 = -2
+-2 `shift` 1 = -4
+-2 `shift` 2 = -8
+-2 `shift` 3 = -16
+
+-1 `shift` 0 = -1
+-1 `shift` 1 = -2
+-1 `shift` 2 = -4
+-1 `shift` 3 = -8
+
+0 `shift` 0 = 0
+0 `shift` 1 = 0
+0 `shift` 2 = 0
+0 `shift` 3 = 0
+
+1 `shift` 0 = 1
+1 `shift` 1 = 2
+1 `shift` 2 = 4
+1 `shift` 3 = 8
+
+2 `shift` 0 = 2
+2 `shift` 1 = 4
+2 `shift` 2 = 8
+2 `shift` 3 = 16
+
+3 `shift` 0 = 3
+3 `shift` 1 = 6
+3 `shift` 2 = 12
+3 `shift` 3 = 24
+
+#
+-3 `setBit` 0 = -3
+-3 `setBit` 1 = -1
+-3 `setBit` 2 = -3
+-3 `setBit` 3 = -3
+
+-2 `setBit` 0 = -1
+-2 `setBit` 1 = -2
+-2 `setBit` 2 = -2
+-2 `setBit` 3 = -2
+
+-1 `setBit` 0 = -1
+-1 `setBit` 1 = -1
+-1 `setBit` 2 = -1
+-1 `setBit` 3 = -1
+
+0 `setBit` 0 = 1
+0 `setBit` 1 = 2
+0 `setBit` 2 = 4
+0 `setBit` 3 = 8
+
+1 `setBit` 0 = 1
+1 `setBit` 1 = 3
+1 `setBit` 2 = 5
+1 `setBit` 3 = 9
+
+2 `setBit` 0 = 3
+2 `setBit` 1 = 2
+2 `setBit` 2 = 6
+2 `setBit` 3 = 10
+
+3 `setBit` 0 = 3
+3 `setBit` 1 = 3
+3 `setBit` 2 = 7
+3 `setBit` 3 = 11
+
+#
+-3 `clearBit` 0 = -4
+-3 `clearBit` 1 = -3
+-3 `clearBit` 2 = -7
+-3 `clearBit` 3 = -11
+
+-2 `clearBit` 0 = -2
+-2 `clearBit` 1 = -4
+-2 `clearBit` 2 = -6
+-2 `clearBit` 3 = -10
+
+-1 `clearBit` 0 = -2
+-1 `clearBit` 1 = -3
+-1 `clearBit` 2 = -5
+-1 `clearBit` 3 = -9
+
+0 `clearBit` 0 = 0
+0 `clearBit` 1 = 0
+0 `clearBit` 2 = 0
+0 `clearBit` 3 = 0
+
+1 `clearBit` 0 = 0
+1 `clearBit` 1 = 1
+1 `clearBit` 2 = 1
+1 `clearBit` 3 = 1
+
+2 `clearBit` 0 = 2
+2 `clearBit` 1 = 0
+2 `clearBit` 2 = 2
+2 `clearBit` 3 = 2
+
+3 `clearBit` 0 = 2
+3 `clearBit` 1 = 1
+3 `clearBit` 2 = 3
+3 `clearBit` 3 = 3
+
+#
+-3 `complementBit` 0 = -4
+-3 `complementBit` 1 = -1
+-3 `complementBit` 2 = -7
+-3 `complementBit` 3 = -11
+
+-2 `complementBit` 0 = -1
+-2 `complementBit` 1 = -4
+-2 `complementBit` 2 = -6
+-2 `complementBit` 3 = -10
+
+-1 `complementBit` 0 = -2
+-1 `complementBit` 1 = -3
+-1 `complementBit` 2 = -5
+-1 `complementBit` 3 = -9
+
+0 `complementBit` 0 = 1
+0 `complementBit` 1 = 2
+0 `complementBit` 2 = 4
+0 `complementBit` 3 = 8
+
+1 `complementBit` 0 = 0
+1 `complementBit` 1 = 3
+1 `complementBit` 2 = 5
+1 `complementBit` 3 = 9
+
+2 `complementBit` 0 = 3
+2 `complementBit` 1 = 0
+2 `complementBit` 2 = 6
+2 `complementBit` 3 = 10
+
+3 `complementBit` 0 = 2
+3 `complementBit` 1 = 1
+3 `complementBit` 2 = 7
+3 `complementBit` 3 = 11
+
+#
+-3 `testBit` 0 = True
+-3 `testBit` 1 = False
+-3 `testBit` 2 = True
+-3 `testBit` 3 = True
+
+-2 `testBit` 0 = False
+-2 `testBit` 1 = True
+-2 `testBit` 2 = True
+-2 `testBit` 3 = True
+
+-1 `testBit` 0 = True
+-1 `testBit` 1 = True
+-1 `testBit` 2 = True
+-1 `testBit` 3 = True
+
+0 `testBit` 0 = False
+0 `testBit` 1 = False
+0 `testBit` 2 = False
+0 `testBit` 3 = False
+
+1 `testBit` 0 = True
+1 `testBit` 1 = False
+1 `testBit` 2 = False
+1 `testBit` 3 = False
+
+2 `testBit` 0 = False
+2 `testBit` 1 = True
+2 `testBit` 2 = False
+2 `testBit` 3 = False
+
+3 `testBit` 0 = True
+3 `testBit` 1 = True
+3 `testBit` 2 = False
+3 `testBit` 3 = False
+
+#
+bitSize -3 = 8
+bitSize -2 = 8
+bitSize -1 = 8
+bitSize 0 = 8
+bitSize 1 = 8
+bitSize 2 = 8
+bitSize 3 = 8
+#
+isSigned -3 = True
+isSigned -2 = True
+isSigned -1 = True
+isSigned 0 = True
+isSigned 1 = True
+isSigned 2 = True
+isSigned 3 = True
+#
+--------------------------------
+--------------------------------
+--Testing Int16
+--------------------------------
+testBounded
+(32767,-32768,-32767)
+(32766,32767,-32768)
+testEnum
+[0,1,2,3,4,5,6,7,8,9]
+[0,2,4,6,8,10,12,14,16,18]
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
+[0,2,4,6,8,10,12,14,16,18,20]
+testReadShow
+[-3,-2,-1,0,1,2,3]
+[-3,-2,-1,0,1,2,3]
+testEq
+-3 == -3 = True
+-3 == -2 = False
+-3 == -1 = False
+-3 == 0 = False
+-3 == 1 = False
+-3 == 2 = False
+-3 == 3 = False
+
+-2 == -3 = False
+-2 == -2 = True
+-2 == -1 = False
+-2 == 0 = False
+-2 == 1 = False
+-2 == 2 = False
+-2 == 3 = False
+
+-1 == -3 = False
+-1 == -2 = False
+-1 == -1 = True
+-1 == 0 = False
+-1 == 1 = False
+-1 == 2 = False
+-1 == 3 = False
+
+0 == -3 = False
+0 == -2 = False
+0 == -1 = False
+0 == 0 = True
+0 == 1 = False
+0 == 2 = False
+0 == 3 = False
+
+1 == -3 = False
+1 == -2 = False
+1 == -1 = False
+1 == 0 = False
+1 == 1 = True
+1 == 2 = False
+1 == 3 = False
+
+2 == -3 = False
+2 == -2 = False
+2 == -1 = False
+2 == 0 = False
+2 == 1 = False
+2 == 2 = True
+2 == 3 = False
+
+3 == -3 = False
+3 == -2 = False
+3 == -1 = False
+3 == 0 = False
+3 == 1 = False
+3 == 2 = False
+3 == 3 = True
+
+#
+-3 /= -3 = False
+-3 /= -2 = True
+-3 /= -1 = True
+-3 /= 0 = True
+-3 /= 1 = True
+-3 /= 2 = True
+-3 /= 3 = True
+
+-2 /= -3 = True
+-2 /= -2 = False
+-2 /= -1 = True
+-2 /= 0 = True
+-2 /= 1 = True
+-2 /= 2 = True
+-2 /= 3 = True
+
+-1 /= -3 = True
+-1 /= -2 = True
+-1 /= -1 = False
+-1 /= 0 = True
+-1 /= 1 = True
+-1 /= 2 = True
+-1 /= 3 = True
+
+0 /= -3 = True
+0 /= -2 = True
+0 /= -1 = True
+0 /= 0 = False
+0 /= 1 = True
+0 /= 2 = True
+0 /= 3 = True
+
+1 /= -3 = True
+1 /= -2 = True
+1 /= -1 = True
+1 /= 0 = True
+1 /= 1 = False
+1 /= 2 = True
+1 /= 3 = True
+
+2 /= -3 = True
+2 /= -2 = True
+2 /= -1 = True
+2 /= 0 = True
+2 /= 1 = True
+2 /= 2 = False
+2 /= 3 = True
+
+3 /= -3 = True
+3 /= -2 = True
+3 /= -1 = True
+3 /= 0 = True
+3 /= 1 = True
+3 /= 2 = True
+3 /= 3 = False
+
+#
+testOrd
+-3 <= -3 = True
+-3 <= -2 = True
+-3 <= -1 = True
+-3 <= 0 = True
+-3 <= 1 = True
+-3 <= 2 = True
+-3 <= 3 = True
+
+-2 <= -3 = False
+-2 <= -2 = True
+-2 <= -1 = True
+-2 <= 0 = True
+-2 <= 1 = True
+-2 <= 2 = True
+-2 <= 3 = True
+
+-1 <= -3 = False
+-1 <= -2 = False
+-1 <= -1 = True
+-1 <= 0 = True
+-1 <= 1 = True
+-1 <= 2 = True
+-1 <= 3 = True
+
+0 <= -3 = False
+0 <= -2 = False
+0 <= -1 = False
+0 <= 0 = True
+0 <= 1 = True
+0 <= 2 = True
+0 <= 3 = True
+
+1 <= -3 = False
+1 <= -2 = False
+1 <= -1 = False
+1 <= 0 = False
+1 <= 1 = True
+1 <= 2 = True
+1 <= 3 = True
+
+2 <= -3 = False
+2 <= -2 = False
+2 <= -1 = False
+2 <= 0 = False
+2 <= 1 = False
+2 <= 2 = True
+2 <= 3 = True
+
+3 <= -3 = False
+3 <= -2 = False
+3 <= -1 = False
+3 <= 0 = False
+3 <= 1 = False
+3 <= 2 = False
+3 <= 3 = True
+
+#
+-3 < -3 = False
+-3 < -2 = True
+-3 < -1 = True
+-3 < 0 = True
+-3 < 1 = True
+-3 < 2 = True
+-3 < 3 = True
+
+-2 < -3 = False
+-2 < -2 = False
+-2 < -1 = True
+-2 < 0 = True
+-2 < 1 = True
+-2 < 2 = True
+-2 < 3 = True
+
+-1 < -3 = False
+-1 < -2 = False
+-1 < -1 = False
+-1 < 0 = True
+-1 < 1 = True
+-1 < 2 = True
+-1 < 3 = True
+
+0 < -3 = False
+0 < -2 = False
+0 < -1 = False
+0 < 0 = False
+0 < 1 = True
+0 < 2 = True
+0 < 3 = True
+
+1 < -3 = False
+1 < -2 = False
+1 < -1 = False
+1 < 0 = False
+1 < 1 = False
+1 < 2 = True
+1 < 3 = True
+
+2 < -3 = False
+2 < -2 = False
+2 < -1 = False
+2 < 0 = False
+2 < 1 = False
+2 < 2 = False
+2 < 3 = True
+
+3 < -3 = False
+3 < -2 = False
+3 < -1 = False
+3 < 0 = False
+3 < 1 = False
+3 < 2 = False
+3 < 3 = False
+
+#
+-3 > -3 = False
+-3 > -2 = False
+-3 > -1 = False
+-3 > 0 = False
+-3 > 1 = False
+-3 > 2 = False
+-3 > 3 = False
+
+-2 > -3 = True
+-2 > -2 = False
+-2 > -1 = False
+-2 > 0 = False
+-2 > 1 = False
+-2 > 2 = False
+-2 > 3 = False
+
+-1 > -3 = True
+-1 > -2 = True
+-1 > -1 = False
+-1 > 0 = False
+-1 > 1 = False
+-1 > 2 = False
+-1 > 3 = False
+
+0 > -3 = True
+0 > -2 = True
+0 > -1 = True
+0 > 0 = False
+0 > 1 = False
+0 > 2 = False
+0 > 3 = False
+
+1 > -3 = True
+1 > -2 = True
+1 > -1 = True
+1 > 0 = True
+1 > 1 = False
+1 > 2 = False
+1 > 3 = False
+
+2 > -3 = True
+2 > -2 = True
+2 > -1 = True
+2 > 0 = True
+2 > 1 = True
+2 > 2 = False
+2 > 3 = False
+
+3 > -3 = True
+3 > -2 = True
+3 > -1 = True
+3 > 0 = True
+3 > 1 = True
+3 > 2 = True
+3 > 3 = False
+
+#
+-3 >= -3 = True
+-3 >= -2 = False
+-3 >= -1 = False
+-3 >= 0 = False
+-3 >= 1 = False
+-3 >= 2 = False
+-3 >= 3 = False
+
+-2 >= -3 = True
+-2 >= -2 = True
+-2 >= -1 = False
+-2 >= 0 = False
+-2 >= 1 = False
+-2 >= 2 = False
+-2 >= 3 = False
+
+-1 >= -3 = True
+-1 >= -2 = True
+-1 >= -1 = True
+-1 >= 0 = False
+-1 >= 1 = False
+-1 >= 2 = False
+-1 >= 3 = False
+
+0 >= -3 = True
+0 >= -2 = True
+0 >= -1 = True
+0 >= 0 = True
+0 >= 1 = False
+0 >= 2 = False
+0 >= 3 = False
+
+1 >= -3 = True
+1 >= -2 = True
+1 >= -1 = True
+1 >= 0 = True
+1 >= 1 = True
+1 >= 2 = False
+1 >= 3 = False
+
+2 >= -3 = True
+2 >= -2 = True
+2 >= -1 = True
+2 >= 0 = True
+2 >= 1 = True
+2 >= 2 = True
+2 >= 3 = False
+
+3 >= -3 = True
+3 >= -2 = True
+3 >= -1 = True
+3 >= 0 = True
+3 >= 1 = True
+3 >= 2 = True
+3 >= 3 = True
+
+#
+-3 `compare` -3 = EQ
+-3 `compare` -2 = LT
+-3 `compare` -1 = LT
+-3 `compare` 0 = LT
+-3 `compare` 1 = LT
+-3 `compare` 2 = LT
+-3 `compare` 3 = LT
+
+-2 `compare` -3 = GT
+-2 `compare` -2 = EQ
+-2 `compare` -1 = LT
+-2 `compare` 0 = LT
+-2 `compare` 1 = LT
+-2 `compare` 2 = LT
+-2 `compare` 3 = LT
+
+-1 `compare` -3 = GT
+-1 `compare` -2 = GT
+-1 `compare` -1 = EQ
+-1 `compare` 0 = LT
+-1 `compare` 1 = LT
+-1 `compare` 2 = LT
+-1 `compare` 3 = LT
+
+0 `compare` -3 = GT
+0 `compare` -2 = GT
+0 `compare` -1 = GT
+0 `compare` 0 = EQ
+0 `compare` 1 = LT
+0 `compare` 2 = LT
+0 `compare` 3 = LT
+
+1 `compare` -3 = GT
+1 `compare` -2 = GT
+1 `compare` -1 = GT
+1 `compare` 0 = GT
+1 `compare` 1 = EQ
+1 `compare` 2 = LT
+1 `compare` 3 = LT
+
+2 `compare` -3 = GT
+2 `compare` -2 = GT
+2 `compare` -1 = GT
+2 `compare` 0 = GT
+2 `compare` 1 = GT
+2 `compare` 2 = EQ
+2 `compare` 3 = LT
+
+3 `compare` -3 = GT
+3 `compare` -2 = GT
+3 `compare` -1 = GT
+3 `compare` 0 = GT
+3 `compare` 1 = GT
+3 `compare` 2 = GT
+3 `compare` 3 = EQ
+
+#
+testNum
+-3 + -3 = -6
+-3 + -2 = -5
+-3 + -1 = -4
+-3 + 0 = -3
+-3 + 1 = -2
+-3 + 2 = -1
+-3 + 3 = 0
+
+-2 + -3 = -5
+-2 + -2 = -4
+-2 + -1 = -3
+-2 + 0 = -2
+-2 + 1 = -1
+-2 + 2 = 0
+-2 + 3 = 1
+
+-1 + -3 = -4
+-1 + -2 = -3
+-1 + -1 = -2
+-1 + 0 = -1
+-1 + 1 = 0
+-1 + 2 = 1
+-1 + 3 = 2
+
+0 + -3 = -3
+0 + -2 = -2
+0 + -1 = -1
+0 + 0 = 0
+0 + 1 = 1
+0 + 2 = 2
+0 + 3 = 3
+
+1 + -3 = -2
+1 + -2 = -1
+1 + -1 = 0
+1 + 0 = 1
+1 + 1 = 2
+1 + 2 = 3
+1 + 3 = 4
+
+2 + -3 = -1
+2 + -2 = 0
+2 + -1 = 1
+2 + 0 = 2
+2 + 1 = 3
+2 + 2 = 4
+2 + 3 = 5
+
+3 + -3 = 0
+3 + -2 = 1
+3 + -1 = 2
+3 + 0 = 3
+3 + 1 = 4
+3 + 2 = 5
+3 + 3 = 6
+
+#
+-3 - -3 = 0
+-3 - -2 = -1
+-3 - -1 = -2
+-3 - 0 = -3
+-3 - 1 = -4
+-3 - 2 = -5
+-3 - 3 = -6
+
+-2 - -3 = 1
+-2 - -2 = 0
+-2 - -1 = -1
+-2 - 0 = -2
+-2 - 1 = -3
+-2 - 2 = -4
+-2 - 3 = -5
+
+-1 - -3 = 2
+-1 - -2 = 1
+-1 - -1 = 0
+-1 - 0 = -1
+-1 - 1 = -2
+-1 - 2 = -3
+-1 - 3 = -4
+
+0 - -3 = 3
+0 - -2 = 2
+0 - -1 = 1
+0 - 0 = 0
+0 - 1 = -1
+0 - 2 = -2
+0 - 3 = -3
+
+1 - -3 = 4
+1 - -2 = 3
+1 - -1 = 2
+1 - 0 = 1
+1 - 1 = 0
+1 - 2 = -1
+1 - 3 = -2
+
+2 - -3 = 5
+2 - -2 = 4
+2 - -1 = 3
+2 - 0 = 2
+2 - 1 = 1
+2 - 2 = 0
+2 - 3 = -1
+
+3 - -3 = 6
+3 - -2 = 5
+3 - -1 = 4
+3 - 0 = 3
+3 - 1 = 2
+3 - 2 = 1
+3 - 3 = 0
+
+#
+-3 * -3 = 9
+-3 * -2 = 6
+-3 * -1 = 3
+-3 * 0 = 0
+-3 * 1 = -3
+-3 * 2 = -6
+-3 * 3 = -9
+
+-2 * -3 = 6
+-2 * -2 = 4
+-2 * -1 = 2
+-2 * 0 = 0
+-2 * 1 = -2
+-2 * 2 = -4
+-2 * 3 = -6
+
+-1 * -3 = 3
+-1 * -2 = 2
+-1 * -1 = 1
+-1 * 0 = 0
+-1 * 1 = -1
+-1 * 2 = -2
+-1 * 3 = -3
+
+0 * -3 = 0
+0 * -2 = 0
+0 * -1 = 0
+0 * 0 = 0
+0 * 1 = 0
+0 * 2 = 0
+0 * 3 = 0
+
+1 * -3 = -3
+1 * -2 = -2
+1 * -1 = -1
+1 * 0 = 0
+1 * 1 = 1
+1 * 2 = 2
+1 * 3 = 3
+
+2 * -3 = -6
+2 * -2 = -4
+2 * -1 = -2
+2 * 0 = 0
+2 * 1 = 2
+2 * 2 = 4
+2 * 3 = 6
+
+3 * -3 = -9
+3 * -2 = -6
+3 * -1 = -3
+3 * 0 = 0
+3 * 1 = 3
+3 * 2 = 6
+3 * 3 = 9
+
+#
+negate -3 = 3
+negate -2 = 2
+negate -1 = 1
+negate 0 = 0
+negate 1 = -1
+negate 2 = -2
+negate 3 = -3
+#
+testReal
+toRational -3 = -3 % 1
+toRational -2 = -2 % 1
+toRational -1 = -1 % 1
+toRational 0 = 0 % 1
+toRational 1 = 1 % 1
+toRational 2 = 2 % 1
+toRational 3 = 3 % 1
+#
+testIntegral
+-3 `divMod` -3 = (1,0)
+-3 `divMod` -2 = (1,-1)
+-3 `divMod` -1 = (3,0)
+-3 `divMod` 1 = (-3,0)
+-3 `divMod` 2 = (-2,1)
+-3 `divMod` 3 = (-1,0)
+
+-2 `divMod` -3 = (0,-2)
+-2 `divMod` -2 = (1,0)
+-2 `divMod` -1 = (2,0)
+-2 `divMod` 1 = (-2,0)
+-2 `divMod` 2 = (-1,0)
+-2 `divMod` 3 = (-1,1)
+
+-1 `divMod` -3 = (0,-1)
+-1 `divMod` -2 = (0,-1)
+-1 `divMod` -1 = (1,0)
+-1 `divMod` 1 = (-1,0)
+-1 `divMod` 2 = (-1,1)
+-1 `divMod` 3 = (-1,2)
+
+0 `divMod` -3 = (0,0)
+0 `divMod` -2 = (0,0)
+0 `divMod` -1 = (0,0)
+0 `divMod` 1 = (0,0)
+0 `divMod` 2 = (0,0)
+0 `divMod` 3 = (0,0)
+
+1 `divMod` -3 = (-1,-2)
+1 `divMod` -2 = (-1,-1)
+1 `divMod` -1 = (-1,0)
+1 `divMod` 1 = (1,0)
+1 `divMod` 2 = (0,1)
+1 `divMod` 3 = (0,1)
+
+2 `divMod` -3 = (-1,-1)
+2 `divMod` -2 = (-1,0)
+2 `divMod` -1 = (-2,0)
+2 `divMod` 1 = (2,0)
+2 `divMod` 2 = (1,0)
+2 `divMod` 3 = (0,2)
+
+3 `divMod` -3 = (-1,0)
+3 `divMod` -2 = (-2,-1)
+3 `divMod` -1 = (-3,0)
+3 `divMod` 1 = (3,0)
+3 `divMod` 2 = (1,1)
+3 `divMod` 3 = (1,0)
+
+#
+-3 `div` -3 = 1
+-3 `div` -2 = 1
+-3 `div` -1 = 3
+-3 `div` 1 = -3
+-3 `div` 2 = -2
+-3 `div` 3 = -1
+
+-2 `div` -3 = 0
+-2 `div` -2 = 1
+-2 `div` -1 = 2
+-2 `div` 1 = -2
+-2 `div` 2 = -1
+-2 `div` 3 = -1
+
+-1 `div` -3 = 0
+-1 `div` -2 = 0
+-1 `div` -1 = 1
+-1 `div` 1 = -1
+-1 `div` 2 = -1
+-1 `div` 3 = -1
+
+0 `div` -3 = 0
+0 `div` -2 = 0
+0 `div` -1 = 0
+0 `div` 1 = 0
+0 `div` 2 = 0
+0 `div` 3 = 0
+
+1 `div` -3 = -1
+1 `div` -2 = -1
+1 `div` -1 = -1
+1 `div` 1 = 1
+1 `div` 2 = 0
+1 `div` 3 = 0
+
+2 `div` -3 = -1
+2 `div` -2 = -1
+2 `div` -1 = -2
+2 `div` 1 = 2
+2 `div` 2 = 1
+2 `div` 3 = 0
+
+3 `div` -3 = -1
+3 `div` -2 = -2
+3 `div` -1 = -3
+3 `div` 1 = 3
+3 `div` 2 = 1
+3 `div` 3 = 1
+
+#
+-3 `mod` -3 = 0
+-3 `mod` -2 = -1
+-3 `mod` -1 = 0
+-3 `mod` 1 = 0
+-3 `mod` 2 = 1
+-3 `mod` 3 = 0
+
+-2 `mod` -3 = -2
+-2 `mod` -2 = 0
+-2 `mod` -1 = 0
+-2 `mod` 1 = 0
+-2 `mod` 2 = 0
+-2 `mod` 3 = 1
+
+-1 `mod` -3 = -1
+-1 `mod` -2 = -1
+-1 `mod` -1 = 0
+-1 `mod` 1 = 0
+-1 `mod` 2 = 1
+-1 `mod` 3 = 2
+
+0 `mod` -3 = 0
+0 `mod` -2 = 0
+0 `mod` -1 = 0
+0 `mod` 1 = 0
+0 `mod` 2 = 0
+0 `mod` 3 = 0
+
+1 `mod` -3 = -2
+1 `mod` -2 = -1
+1 `mod` -1 = 0
+1 `mod` 1 = 0
+1 `mod` 2 = 1
+1 `mod` 3 = 1
+
+2 `mod` -3 = -1
+2 `mod` -2 = 0
+2 `mod` -1 = 0
+2 `mod` 1 = 0
+2 `mod` 2 = 0
+2 `mod` 3 = 2
+
+3 `mod` -3 = 0
+3 `mod` -2 = -1
+3 `mod` -1 = 0
+3 `mod` 1 = 0
+3 `mod` 2 = 1
+3 `mod` 3 = 0
+
+#
+-3 `quotRem` -3 = (1,0)
+-3 `quotRem` -2 = (1,-1)
+-3 `quotRem` -1 = (3,0)
+-3 `quotRem` 1 = (-3,0)
+-3 `quotRem` 2 = (-1,-1)
+-3 `quotRem` 3 = (-1,0)
+
+-2 `quotRem` -3 = (0,-2)
+-2 `quotRem` -2 = (1,0)
+-2 `quotRem` -1 = (2,0)
+-2 `quotRem` 1 = (-2,0)
+-2 `quotRem` 2 = (-1,0)
+-2 `quotRem` 3 = (0,-2)
+
+-1 `quotRem` -3 = (0,-1)
+-1 `quotRem` -2 = (0,-1)
+-1 `quotRem` -1 = (1,0)
+-1 `quotRem` 1 = (-1,0)
+-1 `quotRem` 2 = (0,-1)
+-1 `quotRem` 3 = (0,-1)
+
+0 `quotRem` -3 = (0,0)
+0 `quotRem` -2 = (0,0)
+0 `quotRem` -1 = (0,0)
+0 `quotRem` 1 = (0,0)
+0 `quotRem` 2 = (0,0)
+0 `quotRem` 3 = (0,0)
+
+1 `quotRem` -3 = (0,1)
+1 `quotRem` -2 = (0,1)
+1 `quotRem` -1 = (-1,0)
+1 `quotRem` 1 = (1,0)
+1 `quotRem` 2 = (0,1)
+1 `quotRem` 3 = (0,1)
+
+2 `quotRem` -3 = (0,2)
+2 `quotRem` -2 = (-1,0)
+2 `quotRem` -1 = (-2,0)
+2 `quotRem` 1 = (2,0)
+2 `quotRem` 2 = (1,0)
+2 `quotRem` 3 = (0,2)
+
+3 `quotRem` -3 = (-1,0)
+3 `quotRem` -2 = (-1,1)
+3 `quotRem` -1 = (-3,0)
+3 `quotRem` 1 = (3,0)
+3 `quotRem` 2 = (1,1)
+3 `quotRem` 3 = (1,0)
+
+#
+-3 `quot` -3 = 1
+-3 `quot` -2 = 1
+-3 `quot` -1 = 3
+-3 `quot` 1 = -3
+-3 `quot` 2 = -1
+-3 `quot` 3 = -1
+
+-2 `quot` -3 = 0
+-2 `quot` -2 = 1
+-2 `quot` -1 = 2
+-2 `quot` 1 = -2
+-2 `quot` 2 = -1
+-2 `quot` 3 = 0
+
+-1 `quot` -3 = 0
+-1 `quot` -2 = 0
+-1 `quot` -1 = 1
+-1 `quot` 1 = -1
+-1 `quot` 2 = 0
+-1 `quot` 3 = 0
+
+0 `quot` -3 = 0
+0 `quot` -2 = 0
+0 `quot` -1 = 0
+0 `quot` 1 = 0
+0 `quot` 2 = 0
+0 `quot` 3 = 0
+
+1 `quot` -3 = 0
+1 `quot` -2 = 0
+1 `quot` -1 = -1
+1 `quot` 1 = 1
+1 `quot` 2 = 0
+1 `quot` 3 = 0
+
+2 `quot` -3 = 0
+2 `quot` -2 = -1
+2 `quot` -1 = -2
+2 `quot` 1 = 2
+2 `quot` 2 = 1
+2 `quot` 3 = 0
+
+3 `quot` -3 = -1
+3 `quot` -2 = -1
+3 `quot` -1 = -3
+3 `quot` 1 = 3
+3 `quot` 2 = 1
+3 `quot` 3 = 1
+
+#
+-3 `rem` -3 = 0
+-3 `rem` -2 = -1
+-3 `rem` -1 = 0
+-3 `rem` 1 = 0
+-3 `rem` 2 = -1
+-3 `rem` 3 = 0
+
+-2 `rem` -3 = -2
+-2 `rem` -2 = 0
+-2 `rem` -1 = 0
+-2 `rem` 1 = 0
+-2 `rem` 2 = 0
+-2 `rem` 3 = -2
+
+-1 `rem` -3 = -1
+-1 `rem` -2 = -1
+-1 `rem` -1 = 0
+-1 `rem` 1 = 0
+-1 `rem` 2 = -1
+-1 `rem` 3 = -1
+
+0 `rem` -3 = 0
+0 `rem` -2 = 0
+0 `rem` -1 = 0
+0 `rem` 1 = 0
+0 `rem` 2 = 0
+0 `rem` 3 = 0
+
+1 `rem` -3 = 1
+1 `rem` -2 = 1
+1 `rem` -1 = 0
+1 `rem` 1 = 0
+1 `rem` 2 = 1
+1 `rem` 3 = 1
+
+2 `rem` -3 = 2
+2 `rem` -2 = 0
+2 `rem` -1 = 0
+2 `rem` 1 = 0
+2 `rem` 2 = 0
+2 `rem` 3 = 2
+
+3 `rem` -3 = 0
+3 `rem` -2 = 1
+3 `rem` -1 = 0
+3 `rem` 1 = 0
+3 `rem` 2 = 1
+3 `rem` 3 = 0
+
+#
+testBits
+-3 .&. -3 = -3
+-3 .&. -2 = -4
+-3 .&. -1 = -3
+-3 .&. 1 = 1
+-3 .&. 2 = 0
+-3 .&. 3 = 1
+
+-2 .&. -3 = -4
+-2 .&. -2 = -2
+-2 .&. -1 = -2
+-2 .&. 1 = 0
+-2 .&. 2 = 2
+-2 .&. 3 = 2
+
+-1 .&. -3 = -3
+-1 .&. -2 = -2
+-1 .&. -1 = -1
+-1 .&. 1 = 1
+-1 .&. 2 = 2
+-1 .&. 3 = 3
+
+0 .&. -3 = 0
+0 .&. -2 = 0
+0 .&. -1 = 0
+0 .&. 1 = 0
+0 .&. 2 = 0
+0 .&. 3 = 0
+
+1 .&. -3 = 1
+1 .&. -2 = 0
+1 .&. -1 = 1
+1 .&. 1 = 1
+1 .&. 2 = 0
+1 .&. 3 = 1
+
+2 .&. -3 = 0
+2 .&. -2 = 2
+2 .&. -1 = 2
+2 .&. 1 = 0
+2 .&. 2 = 2
+2 .&. 3 = 2
+
+3 .&. -3 = 1
+3 .&. -2 = 2
+3 .&. -1 = 3
+3 .&. 1 = 1
+3 .&. 2 = 2
+3 .&. 3 = 3
+
+#
+-3 .|. -3 = -3
+-3 .|. -2 = -1
+-3 .|. -1 = -1
+-3 .|. 1 = -3
+-3 .|. 2 = -1
+-3 .|. 3 = -1
+
+-2 .|. -3 = -1
+-2 .|. -2 = -2
+-2 .|. -1 = -1
+-2 .|. 1 = -1
+-2 .|. 2 = -2
+-2 .|. 3 = -1
+
+-1 .|. -3 = -1
+-1 .|. -2 = -1
+-1 .|. -1 = -1
+-1 .|. 1 = -1
+-1 .|. 2 = -1
+-1 .|. 3 = -1
+
+0 .|. -3 = -3
+0 .|. -2 = -2
+0 .|. -1 = -1
+0 .|. 1 = 1
+0 .|. 2 = 2
+0 .|. 3 = 3
+
+1 .|. -3 = -3
+1 .|. -2 = -1
+1 .|. -1 = -1
+1 .|. 1 = 1
+1 .|. 2 = 3
+1 .|. 3 = 3
+
+2 .|. -3 = -1
+2 .|. -2 = -2
+2 .|. -1 = -1
+2 .|. 1 = 3
+2 .|. 2 = 2
+2 .|. 3 = 3
+
+3 .|. -3 = -1
+3 .|. -2 = -1
+3 .|. -1 = -1
+3 .|. 1 = 3
+3 .|. 2 = 3
+3 .|. 3 = 3
+
+#
+-3 `xor` -3 = 0
+-3 `xor` -2 = 3
+-3 `xor` -1 = 2
+-3 `xor` 1 = -4
+-3 `xor` 2 = -1
+-3 `xor` 3 = -2
+
+-2 `xor` -3 = 3
+-2 `xor` -2 = 0
+-2 `xor` -1 = 1
+-2 `xor` 1 = -1
+-2 `xor` 2 = -4
+-2 `xor` 3 = -3
+
+-1 `xor` -3 = 2
+-1 `xor` -2 = 1
+-1 `xor` -1 = 0
+-1 `xor` 1 = -2
+-1 `xor` 2 = -3
+-1 `xor` 3 = -4
+
+0 `xor` -3 = -3
+0 `xor` -2 = -2
+0 `xor` -1 = -1
+0 `xor` 1 = 1
+0 `xor` 2 = 2
+0 `xor` 3 = 3
+
+1 `xor` -3 = -4
+1 `xor` -2 = -1
+1 `xor` -1 = -2
+1 `xor` 1 = 0
+1 `xor` 2 = 3
+1 `xor` 3 = 2
+
+2 `xor` -3 = -1
+2 `xor` -2 = -4
+2 `xor` -1 = -3
+2 `xor` 1 = 3
+2 `xor` 2 = 0
+2 `xor` 3 = 1
+
+3 `xor` -3 = -2
+3 `xor` -2 = -3
+3 `xor` -1 = -4
+3 `xor` 1 = 2
+3 `xor` 2 = 1
+3 `xor` 3 = 0
+
+#
+complement -3 = 2
+complement -2 = 1
+complement -1 = 0
+complement 0 = -1
+complement 1 = -2
+complement 2 = -3
+complement 3 = -4
+#
+-3 `shift` 0 = -3
+-3 `shift` 1 = -6
+-3 `shift` 2 = -12
+-3 `shift` 3 = -24
+
+-2 `shift` 0 = -2
+-2 `shift` 1 = -4
+-2 `shift` 2 = -8
+-2 `shift` 3 = -16
+
+-1 `shift` 0 = -1
+-1 `shift` 1 = -2
+-1 `shift` 2 = -4
+-1 `shift` 3 = -8
+
+0 `shift` 0 = 0
+0 `shift` 1 = 0
+0 `shift` 2 = 0
+0 `shift` 3 = 0
+
+1 `shift` 0 = 1
+1 `shift` 1 = 2
+1 `shift` 2 = 4
+1 `shift` 3 = 8
+
+2 `shift` 0 = 2
+2 `shift` 1 = 4
+2 `shift` 2 = 8
+2 `shift` 3 = 16
+
+3 `shift` 0 = 3
+3 `shift` 1 = 6
+3 `shift` 2 = 12
+3 `shift` 3 = 24
+
+#
+-3 `setBit` 0 = -3
+-3 `setBit` 1 = -1
+-3 `setBit` 2 = -3
+-3 `setBit` 3 = -3
+
+-2 `setBit` 0 = -1
+-2 `setBit` 1 = -2
+-2 `setBit` 2 = -2
+-2 `setBit` 3 = -2
+
+-1 `setBit` 0 = -1
+-1 `setBit` 1 = -1
+-1 `setBit` 2 = -1
+-1 `setBit` 3 = -1
+
+0 `setBit` 0 = 1
+0 `setBit` 1 = 2
+0 `setBit` 2 = 4
+0 `setBit` 3 = 8
+
+1 `setBit` 0 = 1
+1 `setBit` 1 = 3
+1 `setBit` 2 = 5
+1 `setBit` 3 = 9
+
+2 `setBit` 0 = 3
+2 `setBit` 1 = 2
+2 `setBit` 2 = 6
+2 `setBit` 3 = 10
+
+3 `setBit` 0 = 3
+3 `setBit` 1 = 3
+3 `setBit` 2 = 7
+3 `setBit` 3 = 11
+
+#
+-3 `clearBit` 0 = -4
+-3 `clearBit` 1 = -3
+-3 `clearBit` 2 = -7
+-3 `clearBit` 3 = -11
+
+-2 `clearBit` 0 = -2
+-2 `clearBit` 1 = -4
+-2 `clearBit` 2 = -6
+-2 `clearBit` 3 = -10
+
+-1 `clearBit` 0 = -2
+-1 `clearBit` 1 = -3
+-1 `clearBit` 2 = -5
+-1 `clearBit` 3 = -9
+
+0 `clearBit` 0 = 0
+0 `clearBit` 1 = 0
+0 `clearBit` 2 = 0
+0 `clearBit` 3 = 0
+
+1 `clearBit` 0 = 0
+1 `clearBit` 1 = 1
+1 `clearBit` 2 = 1
+1 `clearBit` 3 = 1
+
+2 `clearBit` 0 = 2
+2 `clearBit` 1 = 0
+2 `clearBit` 2 = 2
+2 `clearBit` 3 = 2
+
+3 `clearBit` 0 = 2
+3 `clearBit` 1 = 1
+3 `clearBit` 2 = 3
+3 `clearBit` 3 = 3
+
+#
+-3 `complementBit` 0 = -4
+-3 `complementBit` 1 = -1
+-3 `complementBit` 2 = -7
+-3 `complementBit` 3 = -11
+
+-2 `complementBit` 0 = -1
+-2 `complementBit` 1 = -4
+-2 `complementBit` 2 = -6
+-2 `complementBit` 3 = -10
+
+-1 `complementBit` 0 = -2
+-1 `complementBit` 1 = -3
+-1 `complementBit` 2 = -5
+-1 `complementBit` 3 = -9
+
+0 `complementBit` 0 = 1
+0 `complementBit` 1 = 2
+0 `complementBit` 2 = 4
+0 `complementBit` 3 = 8
+
+1 `complementBit` 0 = 0
+1 `complementBit` 1 = 3
+1 `complementBit` 2 = 5
+1 `complementBit` 3 = 9
+
+2 `complementBit` 0 = 3
+2 `complementBit` 1 = 0
+2 `complementBit` 2 = 6
+2 `complementBit` 3 = 10
+
+3 `complementBit` 0 = 2
+3 `complementBit` 1 = 1
+3 `complementBit` 2 = 7
+3 `complementBit` 3 = 11
+
+#
+-3 `testBit` 0 = True
+-3 `testBit` 1 = False
+-3 `testBit` 2 = True
+-3 `testBit` 3 = True
+
+-2 `testBit` 0 = False
+-2 `testBit` 1 = True
+-2 `testBit` 2 = True
+-2 `testBit` 3 = True
+
+-1 `testBit` 0 = True
+-1 `testBit` 1 = True
+-1 `testBit` 2 = True
+-1 `testBit` 3 = True
+
+0 `testBit` 0 = False
+0 `testBit` 1 = False
+0 `testBit` 2 = False
+0 `testBit` 3 = False
+
+1 `testBit` 0 = True
+1 `testBit` 1 = False
+1 `testBit` 2 = False
+1 `testBit` 3 = False
+
+2 `testBit` 0 = False
+2 `testBit` 1 = True
+2 `testBit` 2 = False
+2 `testBit` 3 = False
+
+3 `testBit` 0 = True
+3 `testBit` 1 = True
+3 `testBit` 2 = False
+3 `testBit` 3 = False
+
+#
+bitSize -3 = 16
+bitSize -2 = 16
+bitSize -1 = 16
+bitSize 0 = 16
+bitSize 1 = 16
+bitSize 2 = 16
+bitSize 3 = 16
+#
+isSigned -3 = True
+isSigned -2 = True
+isSigned -1 = True
+isSigned 0 = True
+isSigned 1 = True
+isSigned 2 = True
+isSigned 3 = True
+#
+--------------------------------
+--------------------------------
+--Testing Int32
+--------------------------------
+testBounded
+(2147483647,-2147483648,-2147483647)
+(2147483646,2147483647,-2147483648)
+testEnum
+[0,1,2,3,4,5,6,7,8,9]
+[0,2,4,6,8,10,12,14,16,18]
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
+[0,2,4,6,8,10,12,14,16,18,20]
+testReadShow
+[-3,-2,-1,0,1,2,3]
+[-3,-2,-1,0,1,2,3]
+testEq
+-3 == -3 = True
+-3 == -2 = False
+-3 == -1 = False
+-3 == 0 = False
+-3 == 1 = False
+-3 == 2 = False
+-3 == 3 = False
+
+-2 == -3 = False
+-2 == -2 = True
+-2 == -1 = False
+-2 == 0 = False
+-2 == 1 = False
+-2 == 2 = False
+-2 == 3 = False
+
+-1 == -3 = False
+-1 == -2 = False
+-1 == -1 = True
+-1 == 0 = False
+-1 == 1 = False
+-1 == 2 = False
+-1 == 3 = False
+
+0 == -3 = False
+0 == -2 = False
+0 == -1 = False
+0 == 0 = True
+0 == 1 = False
+0 == 2 = False
+0 == 3 = False
+
+1 == -3 = False
+1 == -2 = False
+1 == -1 = False
+1 == 0 = False
+1 == 1 = True
+1 == 2 = False
+1 == 3 = False
+
+2 == -3 = False
+2 == -2 = False
+2 == -1 = False
+2 == 0 = False
+2 == 1 = False
+2 == 2 = True
+2 == 3 = False
+
+3 == -3 = False
+3 == -2 = False
+3 == -1 = False
+3 == 0 = False
+3 == 1 = False
+3 == 2 = False
+3 == 3 = True
+
+#
+-3 /= -3 = False
+-3 /= -2 = True
+-3 /= -1 = True
+-3 /= 0 = True
+-3 /= 1 = True
+-3 /= 2 = True
+-3 /= 3 = True
+
+-2 /= -3 = True
+-2 /= -2 = False
+-2 /= -1 = True
+-2 /= 0 = True
+-2 /= 1 = True
+-2 /= 2 = True
+-2 /= 3 = True
+
+-1 /= -3 = True
+-1 /= -2 = True
+-1 /= -1 = False
+-1 /= 0 = True
+-1 /= 1 = True
+-1 /= 2 = True
+-1 /= 3 = True
+
+0 /= -3 = True
+0 /= -2 = True
+0 /= -1 = True
+0 /= 0 = False
+0 /= 1 = True
+0 /= 2 = True
+0 /= 3 = True
+
+1 /= -3 = True
+1 /= -2 = True
+1 /= -1 = True
+1 /= 0 = True
+1 /= 1 = False
+1 /= 2 = True
+1 /= 3 = True
+
+2 /= -3 = True
+2 /= -2 = True
+2 /= -1 = True
+2 /= 0 = True
+2 /= 1 = True
+2 /= 2 = False
+2 /= 3 = True
+
+3 /= -3 = True
+3 /= -2 = True
+3 /= -1 = True
+3 /= 0 = True
+3 /= 1 = True
+3 /= 2 = True
+3 /= 3 = False
+
+#
+testOrd
+-3 <= -3 = True
+-3 <= -2 = True
+-3 <= -1 = True
+-3 <= 0 = True
+-3 <= 1 = True
+-3 <= 2 = True
+-3 <= 3 = True
+
+-2 <= -3 = False
+-2 <= -2 = True
+-2 <= -1 = True
+-2 <= 0 = True
+-2 <= 1 = True
+-2 <= 2 = True
+-2 <= 3 = True
+
+-1 <= -3 = False
+-1 <= -2 = False
+-1 <= -1 = True
+-1 <= 0 = True
+-1 <= 1 = True
+-1 <= 2 = True
+-1 <= 3 = True
+
+0 <= -3 = False
+0 <= -2 = False
+0 <= -1 = False
+0 <= 0 = True
+0 <= 1 = True
+0 <= 2 = True
+0 <= 3 = True
+
+1 <= -3 = False
+1 <= -2 = False
+1 <= -1 = False
+1 <= 0 = False
+1 <= 1 = True
+1 <= 2 = True
+1 <= 3 = True
+
+2 <= -3 = False
+2 <= -2 = False
+2 <= -1 = False
+2 <= 0 = False
+2 <= 1 = False
+2 <= 2 = True
+2 <= 3 = True
+
+3 <= -3 = False
+3 <= -2 = False
+3 <= -1 = False
+3 <= 0 = False
+3 <= 1 = False
+3 <= 2 = False
+3 <= 3 = True
+
+#
+-3 < -3 = False
+-3 < -2 = True
+-3 < -1 = True
+-3 < 0 = True
+-3 < 1 = True
+-3 < 2 = True
+-3 < 3 = True
+
+-2 < -3 = False
+-2 < -2 = False
+-2 < -1 = True
+-2 < 0 = True
+-2 < 1 = True
+-2 < 2 = True
+-2 < 3 = True
+
+-1 < -3 = False
+-1 < -2 = False
+-1 < -1 = False
+-1 < 0 = True
+-1 < 1 = True
+-1 < 2 = True
+-1 < 3 = True
+
+0 < -3 = False
+0 < -2 = False
+0 < -1 = False
+0 < 0 = False
+0 < 1 = True
+0 < 2 = True
+0 < 3 = True
+
+1 < -3 = False
+1 < -2 = False
+1 < -1 = False
+1 < 0 = False
+1 < 1 = False
+1 < 2 = True
+1 < 3 = True
+
+2 < -3 = False
+2 < -2 = False
+2 < -1 = False
+2 < 0 = False
+2 < 1 = False
+2 < 2 = False
+2 < 3 = True
+
+3 < -3 = False
+3 < -2 = False
+3 < -1 = False
+3 < 0 = False
+3 < 1 = False
+3 < 2 = False
+3 < 3 = False
+
+#
+-3 > -3 = False
+-3 > -2 = False
+-3 > -1 = False
+-3 > 0 = False
+-3 > 1 = False
+-3 > 2 = False
+-3 > 3 = False
+
+-2 > -3 = True
+-2 > -2 = False
+-2 > -1 = False
+-2 > 0 = False
+-2 > 1 = False
+-2 > 2 = False
+-2 > 3 = False
+
+-1 > -3 = True
+-1 > -2 = True
+-1 > -1 = False
+-1 > 0 = False
+-1 > 1 = False
+-1 > 2 = False
+-1 > 3 = False
+
+0 > -3 = True
+0 > -2 = True
+0 > -1 = True
+0 > 0 = False
+0 > 1 = False
+0 > 2 = False
+0 > 3 = False
+
+1 > -3 = True
+1 > -2 = True
+1 > -1 = True
+1 > 0 = True
+1 > 1 = False
+1 > 2 = False
+1 > 3 = False
+
+2 > -3 = True
+2 > -2 = True
+2 > -1 = True
+2 > 0 = True
+2 > 1 = True
+2 > 2 = False
+2 > 3 = False
+
+3 > -3 = True
+3 > -2 = True
+3 > -1 = True
+3 > 0 = True
+3 > 1 = True
+3 > 2 = True
+3 > 3 = False
+
+#
+-3 >= -3 = True
+-3 >= -2 = False
+-3 >= -1 = False
+-3 >= 0 = False
+-3 >= 1 = False
+-3 >= 2 = False
+-3 >= 3 = False
+
+-2 >= -3 = True
+-2 >= -2 = True
+-2 >= -1 = False
+-2 >= 0 = False
+-2 >= 1 = False
+-2 >= 2 = False
+-2 >= 3 = False
+
+-1 >= -3 = True
+-1 >= -2 = True
+-1 >= -1 = True
+-1 >= 0 = False
+-1 >= 1 = False
+-1 >= 2 = False
+-1 >= 3 = False
+
+0 >= -3 = True
+0 >= -2 = True
+0 >= -1 = True
+0 >= 0 = True
+0 >= 1 = False
+0 >= 2 = False
+0 >= 3 = False
+
+1 >= -3 = True
+1 >= -2 = True
+1 >= -1 = True
+1 >= 0 = True
+1 >= 1 = True
+1 >= 2 = False
+1 >= 3 = False
+
+2 >= -3 = True
+2 >= -2 = True
+2 >= -1 = True
+2 >= 0 = True
+2 >= 1 = True
+2 >= 2 = True
+2 >= 3 = False
+
+3 >= -3 = True
+3 >= -2 = True
+3 >= -1 = True
+3 >= 0 = True
+3 >= 1 = True
+3 >= 2 = True
+3 >= 3 = True
+
+#
+-3 `compare` -3 = EQ
+-3 `compare` -2 = LT
+-3 `compare` -1 = LT
+-3 `compare` 0 = LT
+-3 `compare` 1 = LT
+-3 `compare` 2 = LT
+-3 `compare` 3 = LT
+
+-2 `compare` -3 = GT
+-2 `compare` -2 = EQ
+-2 `compare` -1 = LT
+-2 `compare` 0 = LT
+-2 `compare` 1 = LT
+-2 `compare` 2 = LT
+-2 `compare` 3 = LT
+
+-1 `compare` -3 = GT
+-1 `compare` -2 = GT
+-1 `compare` -1 = EQ
+-1 `compare` 0 = LT
+-1 `compare` 1 = LT
+-1 `compare` 2 = LT
+-1 `compare` 3 = LT
+
+0 `compare` -3 = GT
+0 `compare` -2 = GT
+0 `compare` -1 = GT
+0 `compare` 0 = EQ
+0 `compare` 1 = LT
+0 `compare` 2 = LT
+0 `compare` 3 = LT
+
+1 `compare` -3 = GT
+1 `compare` -2 = GT
+1 `compare` -1 = GT
+1 `compare` 0 = GT
+1 `compare` 1 = EQ
+1 `compare` 2 = LT
+1 `compare` 3 = LT
+
+2 `compare` -3 = GT
+2 `compare` -2 = GT
+2 `compare` -1 = GT
+2 `compare` 0 = GT
+2 `compare` 1 = GT
+2 `compare` 2 = EQ
+2 `compare` 3 = LT
+
+3 `compare` -3 = GT
+3 `compare` -2 = GT
+3 `compare` -1 = GT
+3 `compare` 0 = GT
+3 `compare` 1 = GT
+3 `compare` 2 = GT
+3 `compare` 3 = EQ
+
+#
+testNum
+-3 + -3 = -6
+-3 + -2 = -5
+-3 + -1 = -4
+-3 + 0 = -3
+-3 + 1 = -2
+-3 + 2 = -1
+-3 + 3 = 0
+
+-2 + -3 = -5
+-2 + -2 = -4
+-2 + -1 = -3
+-2 + 0 = -2
+-2 + 1 = -1
+-2 + 2 = 0
+-2 + 3 = 1
+
+-1 + -3 = -4
+-1 + -2 = -3
+-1 + -1 = -2
+-1 + 0 = -1
+-1 + 1 = 0
+-1 + 2 = 1
+-1 + 3 = 2
+
+0 + -3 = -3
+0 + -2 = -2
+0 + -1 = -1
+0 + 0 = 0
+0 + 1 = 1
+0 + 2 = 2
+0 + 3 = 3
+
+1 + -3 = -2
+1 + -2 = -1
+1 + -1 = 0
+1 + 0 = 1
+1 + 1 = 2
+1 + 2 = 3
+1 + 3 = 4
+
+2 + -3 = -1
+2 + -2 = 0
+2 + -1 = 1
+2 + 0 = 2
+2 + 1 = 3
+2 + 2 = 4
+2 + 3 = 5
+
+3 + -3 = 0
+3 + -2 = 1
+3 + -1 = 2
+3 + 0 = 3
+3 + 1 = 4
+3 + 2 = 5
+3 + 3 = 6
+
+#
+-3 - -3 = 0
+-3 - -2 = -1
+-3 - -1 = -2
+-3 - 0 = -3
+-3 - 1 = -4
+-3 - 2 = -5
+-3 - 3 = -6
+
+-2 - -3 = 1
+-2 - -2 = 0
+-2 - -1 = -1
+-2 - 0 = -2
+-2 - 1 = -3
+-2 - 2 = -4
+-2 - 3 = -5
+
+-1 - -3 = 2
+-1 - -2 = 1
+-1 - -1 = 0
+-1 - 0 = -1
+-1 - 1 = -2
+-1 - 2 = -3
+-1 - 3 = -4
+
+0 - -3 = 3
+0 - -2 = 2
+0 - -1 = 1
+0 - 0 = 0
+0 - 1 = -1
+0 - 2 = -2
+0 - 3 = -3
+
+1 - -3 = 4
+1 - -2 = 3
+1 - -1 = 2
+1 - 0 = 1
+1 - 1 = 0
+1 - 2 = -1
+1 - 3 = -2
+
+2 - -3 = 5
+2 - -2 = 4
+2 - -1 = 3
+2 - 0 = 2
+2 - 1 = 1
+2 - 2 = 0
+2 - 3 = -1
+
+3 - -3 = 6
+3 - -2 = 5
+3 - -1 = 4
+3 - 0 = 3
+3 - 1 = 2
+3 - 2 = 1
+3 - 3 = 0
+
+#
+-3 * -3 = 9
+-3 * -2 = 6
+-3 * -1 = 3
+-3 * 0 = 0
+-3 * 1 = -3
+-3 * 2 = -6
+-3 * 3 = -9
+
+-2 * -3 = 6
+-2 * -2 = 4
+-2 * -1 = 2
+-2 * 0 = 0
+-2 * 1 = -2
+-2 * 2 = -4
+-2 * 3 = -6
+
+-1 * -3 = 3
+-1 * -2 = 2
+-1 * -1 = 1
+-1 * 0 = 0
+-1 * 1 = -1
+-1 * 2 = -2
+-1 * 3 = -3
+
+0 * -3 = 0
+0 * -2 = 0
+0 * -1 = 0
+0 * 0 = 0
+0 * 1 = 0
+0 * 2 = 0
+0 * 3 = 0
+
+1 * -3 = -3
+1 * -2 = -2
+1 * -1 = -1
+1 * 0 = 0
+1 * 1 = 1
+1 * 2 = 2
+1 * 3 = 3
+
+2 * -3 = -6
+2 * -2 = -4
+2 * -1 = -2
+2 * 0 = 0
+2 * 1 = 2
+2 * 2 = 4
+2 * 3 = 6
+
+3 * -3 = -9
+3 * -2 = -6
+3 * -1 = -3
+3 * 0 = 0
+3 * 1 = 3
+3 * 2 = 6
+3 * 3 = 9
+
+#
+negate -3 = 3
+negate -2 = 2
+negate -1 = 1
+negate 0 = 0
+negate 1 = -1
+negate 2 = -2
+negate 3 = -3
+#
+testReal
+toRational -3 = -3 % 1
+toRational -2 = -2 % 1
+toRational -1 = -1 % 1
+toRational 0 = 0 % 1
+toRational 1 = 1 % 1
+toRational 2 = 2 % 1
+toRational 3 = 3 % 1
+#
+testIntegral
+-3 `divMod` -3 = (1,0)
+-3 `divMod` -2 = (1,-1)
+-3 `divMod` -1 = (3,0)
+-3 `divMod` 1 = (-3,0)
+-3 `divMod` 2 = (-2,1)
+-3 `divMod` 3 = (-1,0)
+
+-2 `divMod` -3 = (0,-2)
+-2 `divMod` -2 = (1,0)
+-2 `divMod` -1 = (2,0)
+-2 `divMod` 1 = (-2,0)
+-2 `divMod` 2 = (-1,0)
+-2 `divMod` 3 = (-1,1)
+
+-1 `divMod` -3 = (0,-1)
+-1 `divMod` -2 = (0,-1)
+-1 `divMod` -1 = (1,0)
+-1 `divMod` 1 = (-1,0)
+-1 `divMod` 2 = (-1,1)
+-1 `divMod` 3 = (-1,2)
+
+0 `divMod` -3 = (0,0)
+0 `divMod` -2 = (0,0)
+0 `divMod` -1 = (0,0)
+0 `divMod` 1 = (0,0)
+0 `divMod` 2 = (0,0)
+0 `divMod` 3 = (0,0)
+
+1 `divMod` -3 = (-1,-2)
+1 `divMod` -2 = (-1,-1)
+1 `divMod` -1 = (-1,0)
+1 `divMod` 1 = (1,0)
+1 `divMod` 2 = (0,1)
+1 `divMod` 3 = (0,1)
+
+2 `divMod` -3 = (-1,-1)
+2 `divMod` -2 = (-1,0)
+2 `divMod` -1 = (-2,0)
+2 `divMod` 1 = (2,0)
+2 `divMod` 2 = (1,0)
+2 `divMod` 3 = (0,2)
+
+3 `divMod` -3 = (-1,0)
+3 `divMod` -2 = (-2,-1)
+3 `divMod` -1 = (-3,0)
+3 `divMod` 1 = (3,0)
+3 `divMod` 2 = (1,1)
+3 `divMod` 3 = (1,0)
+
+#
+-3 `div` -3 = 1
+-3 `div` -2 = 1
+-3 `div` -1 = 3
+-3 `div` 1 = -3
+-3 `div` 2 = -2
+-3 `div` 3 = -1
+
+-2 `div` -3 = 0
+-2 `div` -2 = 1
+-2 `div` -1 = 2
+-2 `div` 1 = -2
+-2 `div` 2 = -1
+-2 `div` 3 = -1
+
+-1 `div` -3 = 0
+-1 `div` -2 = 0
+-1 `div` -1 = 1
+-1 `div` 1 = -1
+-1 `div` 2 = -1
+-1 `div` 3 = -1
+
+0 `div` -3 = 0
+0 `div` -2 = 0
+0 `div` -1 = 0
+0 `div` 1 = 0
+0 `div` 2 = 0
+0 `div` 3 = 0
+
+1 `div` -3 = -1
+1 `div` -2 = -1
+1 `div` -1 = -1
+1 `div` 1 = 1
+1 `div` 2 = 0
+1 `div` 3 = 0
+
+2 `div` -3 = -1
+2 `div` -2 = -1
+2 `div` -1 = -2
+2 `div` 1 = 2
+2 `div` 2 = 1
+2 `div` 3 = 0
+
+3 `div` -3 = -1
+3 `div` -2 = -2
+3 `div` -1 = -3
+3 `div` 1 = 3
+3 `div` 2 = 1
+3 `div` 3 = 1
+
+#
+-3 `mod` -3 = 0
+-3 `mod` -2 = -1
+-3 `mod` -1 = 0
+-3 `mod` 1 = 0
+-3 `mod` 2 = 1
+-3 `mod` 3 = 0
+
+-2 `mod` -3 = -2
+-2 `mod` -2 = 0
+-2 `mod` -1 = 0
+-2 `mod` 1 = 0
+-2 `mod` 2 = 0
+-2 `mod` 3 = 1
+
+-1 `mod` -3 = -1
+-1 `mod` -2 = -1
+-1 `mod` -1 = 0
+-1 `mod` 1 = 0
+-1 `mod` 2 = 1
+-1 `mod` 3 = 2
+
+0 `mod` -3 = 0
+0 `mod` -2 = 0
+0 `mod` -1 = 0
+0 `mod` 1 = 0
+0 `mod` 2 = 0
+0 `mod` 3 = 0
+
+1 `mod` -3 = -2
+1 `mod` -2 = -1
+1 `mod` -1 = 0
+1 `mod` 1 = 0
+1 `mod` 2 = 1
+1 `mod` 3 = 1
+
+2 `mod` -3 = -1
+2 `mod` -2 = 0
+2 `mod` -1 = 0
+2 `mod` 1 = 0
+2 `mod` 2 = 0
+2 `mod` 3 = 2
+
+3 `mod` -3 = 0
+3 `mod` -2 = -1
+3 `mod` -1 = 0
+3 `mod` 1 = 0
+3 `mod` 2 = 1
+3 `mod` 3 = 0
+
+#
+-3 `quotRem` -3 = (1,0)
+-3 `quotRem` -2 = (1,-1)
+-3 `quotRem` -1 = (3,0)
+-3 `quotRem` 1 = (-3,0)
+-3 `quotRem` 2 = (-1,-1)
+-3 `quotRem` 3 = (-1,0)
+
+-2 `quotRem` -3 = (0,-2)
+-2 `quotRem` -2 = (1,0)
+-2 `quotRem` -1 = (2,0)
+-2 `quotRem` 1 = (-2,0)
+-2 `quotRem` 2 = (-1,0)
+-2 `quotRem` 3 = (0,-2)
+
+-1 `quotRem` -3 = (0,-1)
+-1 `quotRem` -2 = (0,-1)
+-1 `quotRem` -1 = (1,0)
+-1 `quotRem` 1 = (-1,0)
+-1 `quotRem` 2 = (0,-1)
+-1 `quotRem` 3 = (0,-1)
+
+0 `quotRem` -3 = (0,0)
+0 `quotRem` -2 = (0,0)
+0 `quotRem` -1 = (0,0)
+0 `quotRem` 1 = (0,0)
+0 `quotRem` 2 = (0,0)
+0 `quotRem` 3 = (0,0)
+
+1 `quotRem` -3 = (0,1)
+1 `quotRem` -2 = (0,1)
+1 `quotRem` -1 = (-1,0)
+1 `quotRem` 1 = (1,0)
+1 `quotRem` 2 = (0,1)
+1 `quotRem` 3 = (0,1)
+
+2 `quotRem` -3 = (0,2)
+2 `quotRem` -2 = (-1,0)
+2 `quotRem` -1 = (-2,0)
+2 `quotRem` 1 = (2,0)
+2 `quotRem` 2 = (1,0)
+2 `quotRem` 3 = (0,2)
+
+3 `quotRem` -3 = (-1,0)
+3 `quotRem` -2 = (-1,1)
+3 `quotRem` -1 = (-3,0)
+3 `quotRem` 1 = (3,0)
+3 `quotRem` 2 = (1,1)
+3 `quotRem` 3 = (1,0)
+
+#
+-3 `quot` -3 = 1
+-3 `quot` -2 = 1
+-3 `quot` -1 = 3
+-3 `quot` 1 = -3
+-3 `quot` 2 = -1
+-3 `quot` 3 = -1
+
+-2 `quot` -3 = 0
+-2 `quot` -2 = 1
+-2 `quot` -1 = 2
+-2 `quot` 1 = -2
+-2 `quot` 2 = -1
+-2 `quot` 3 = 0
+
+-1 `quot` -3 = 0
+-1 `quot` -2 = 0
+-1 `quot` -1 = 1
+-1 `quot` 1 = -1
+-1 `quot` 2 = 0
+-1 `quot` 3 = 0
+
+0 `quot` -3 = 0
+0 `quot` -2 = 0
+0 `quot` -1 = 0
+0 `quot` 1 = 0
+0 `quot` 2 = 0
+0 `quot` 3 = 0
+
+1 `quot` -3 = 0
+1 `quot` -2 = 0
+1 `quot` -1 = -1
+1 `quot` 1 = 1
+1 `quot` 2 = 0
+1 `quot` 3 = 0
+
+2 `quot` -3 = 0
+2 `quot` -2 = -1
+2 `quot` -1 = -2
+2 `quot` 1 = 2
+2 `quot` 2 = 1
+2 `quot` 3 = 0
+
+3 `quot` -3 = -1
+3 `quot` -2 = -1
+3 `quot` -1 = -3
+3 `quot` 1 = 3
+3 `quot` 2 = 1
+3 `quot` 3 = 1
+
+#
+-3 `rem` -3 = 0
+-3 `rem` -2 = -1
+-3 `rem` -1 = 0
+-3 `rem` 1 = 0
+-3 `rem` 2 = -1
+-3 `rem` 3 = 0
+
+-2 `rem` -3 = -2
+-2 `rem` -2 = 0
+-2 `rem` -1 = 0
+-2 `rem` 1 = 0
+-2 `rem` 2 = 0
+-2 `rem` 3 = -2
+
+-1 `rem` -3 = -1
+-1 `rem` -2 = -1
+-1 `rem` -1 = 0
+-1 `rem` 1 = 0
+-1 `rem` 2 = -1
+-1 `rem` 3 = -1
+
+0 `rem` -3 = 0
+0 `rem` -2 = 0
+0 `rem` -1 = 0
+0 `rem` 1 = 0
+0 `rem` 2 = 0
+0 `rem` 3 = 0
+
+1 `rem` -3 = 1
+1 `rem` -2 = 1
+1 `rem` -1 = 0
+1 `rem` 1 = 0
+1 `rem` 2 = 1
+1 `rem` 3 = 1
+
+2 `rem` -3 = 2
+2 `rem` -2 = 0
+2 `rem` -1 = 0
+2 `rem` 1 = 0
+2 `rem` 2 = 0
+2 `rem` 3 = 2
+
+3 `rem` -3 = 0
+3 `rem` -2 = 1
+3 `rem` -1 = 0
+3 `rem` 1 = 0
+3 `rem` 2 = 1
+3 `rem` 3 = 0
+
+#
+testBits
+-3 .&. -3 = -3
+-3 .&. -2 = -4
+-3 .&. -1 = -3
+-3 .&. 1 = 1
+-3 .&. 2 = 0
+-3 .&. 3 = 1
+
+-2 .&. -3 = -4
+-2 .&. -2 = -2
+-2 .&. -1 = -2
+-2 .&. 1 = 0
+-2 .&. 2 = 2
+-2 .&. 3 = 2
+
+-1 .&. -3 = -3
+-1 .&. -2 = -2
+-1 .&. -1 = -1
+-1 .&. 1 = 1
+-1 .&. 2 = 2
+-1 .&. 3 = 3
+
+0 .&. -3 = 0
+0 .&. -2 = 0
+0 .&. -1 = 0
+0 .&. 1 = 0
+0 .&. 2 = 0
+0 .&. 3 = 0
+
+1 .&. -3 = 1
+1 .&. -2 = 0
+1 .&. -1 = 1
+1 .&. 1 = 1
+1 .&. 2 = 0
+1 .&. 3 = 1
+
+2 .&. -3 = 0
+2 .&. -2 = 2
+2 .&. -1 = 2
+2 .&. 1 = 0
+2 .&. 2 = 2
+2 .&. 3 = 2
+
+3 .&. -3 = 1
+3 .&. -2 = 2
+3 .&. -1 = 3
+3 .&. 1 = 1
+3 .&. 2 = 2
+3 .&. 3 = 3
+
+#
+-3 .|. -3 = -3
+-3 .|. -2 = -1
+-3 .|. -1 = -1
+-3 .|. 1 = -3
+-3 .|. 2 = -1
+-3 .|. 3 = -1
+
+-2 .|. -3 = -1
+-2 .|. -2 = -2
+-2 .|. -1 = -1
+-2 .|. 1 = -1
+-2 .|. 2 = -2
+-2 .|. 3 = -1
+
+-1 .|. -3 = -1
+-1 .|. -2 = -1
+-1 .|. -1 = -1
+-1 .|. 1 = -1
+-1 .|. 2 = -1
+-1 .|. 3 = -1
+
+0 .|. -3 = -3
+0 .|. -2 = -2
+0 .|. -1 = -1
+0 .|. 1 = 1
+0 .|. 2 = 2
+0 .|. 3 = 3
+
+1 .|. -3 = -3
+1 .|. -2 = -1
+1 .|. -1 = -1
+1 .|. 1 = 1
+1 .|. 2 = 3
+1 .|. 3 = 3
+
+2 .|. -3 = -1
+2 .|. -2 = -2
+2 .|. -1 = -1
+2 .|. 1 = 3
+2 .|. 2 = 2
+2 .|. 3 = 3
+
+3 .|. -3 = -1
+3 .|. -2 = -1
+3 .|. -1 = -1
+3 .|. 1 = 3
+3 .|. 2 = 3
+3 .|. 3 = 3
+
+#
+-3 `xor` -3 = 0
+-3 `xor` -2 = 3
+-3 `xor` -1 = 2
+-3 `xor` 1 = -4
+-3 `xor` 2 = -1
+-3 `xor` 3 = -2
+
+-2 `xor` -3 = 3
+-2 `xor` -2 = 0
+-2 `xor` -1 = 1
+-2 `xor` 1 = -1
+-2 `xor` 2 = -4
+-2 `xor` 3 = -3
+
+-1 `xor` -3 = 2
+-1 `xor` -2 = 1
+-1 `xor` -1 = 0
+-1 `xor` 1 = -2
+-1 `xor` 2 = -3
+-1 `xor` 3 = -4
+
+0 `xor` -3 = -3
+0 `xor` -2 = -2
+0 `xor` -1 = -1
+0 `xor` 1 = 1
+0 `xor` 2 = 2
+0 `xor` 3 = 3
+
+1 `xor` -3 = -4
+1 `xor` -2 = -1
+1 `xor` -1 = -2
+1 `xor` 1 = 0
+1 `xor` 2 = 3
+1 `xor` 3 = 2
+
+2 `xor` -3 = -1
+2 `xor` -2 = -4
+2 `xor` -1 = -3
+2 `xor` 1 = 3
+2 `xor` 2 = 0
+2 `xor` 3 = 1
+
+3 `xor` -3 = -2
+3 `xor` -2 = -3
+3 `xor` -1 = -4
+3 `xor` 1 = 2
+3 `xor` 2 = 1
+3 `xor` 3 = 0
+
+#
+complement -3 = 2
+complement -2 = 1
+complement -1 = 0
+complement 0 = -1
+complement 1 = -2
+complement 2 = -3
+complement 3 = -4
+#
+-3 `shift` 0 = -3
+-3 `shift` 1 = -6
+-3 `shift` 2 = -12
+-3 `shift` 3 = -24
+
+-2 `shift` 0 = -2
+-2 `shift` 1 = -4
+-2 `shift` 2 = -8
+-2 `shift` 3 = -16
+
+-1 `shift` 0 = -1
+-1 `shift` 1 = -2
+-1 `shift` 2 = -4
+-1 `shift` 3 = -8
+
+0 `shift` 0 = 0
+0 `shift` 1 = 0
+0 `shift` 2 = 0
+0 `shift` 3 = 0
+
+1 `shift` 0 = 1
+1 `shift` 1 = 2
+1 `shift` 2 = 4
+1 `shift` 3 = 8
+
+2 `shift` 0 = 2
+2 `shift` 1 = 4
+2 `shift` 2 = 8
+2 `shift` 3 = 16
+
+3 `shift` 0 = 3
+3 `shift` 1 = 6
+3 `shift` 2 = 12
+3 `shift` 3 = 24
+
+#
+-3 `setBit` 0 = -3
+-3 `setBit` 1 = -1
+-3 `setBit` 2 = -3
+-3 `setBit` 3 = -3
+
+-2 `setBit` 0 = -1
+-2 `setBit` 1 = -2
+-2 `setBit` 2 = -2
+-2 `setBit` 3 = -2
+
+-1 `setBit` 0 = -1
+-1 `setBit` 1 = -1
+-1 `setBit` 2 = -1
+-1 `setBit` 3 = -1
+
+0 `setBit` 0 = 1
+0 `setBit` 1 = 2
+0 `setBit` 2 = 4
+0 `setBit` 3 = 8
+
+1 `setBit` 0 = 1
+1 `setBit` 1 = 3
+1 `setBit` 2 = 5
+1 `setBit` 3 = 9
+
+2 `setBit` 0 = 3
+2 `setBit` 1 = 2
+2 `setBit` 2 = 6
+2 `setBit` 3 = 10
+
+3 `setBit` 0 = 3
+3 `setBit` 1 = 3
+3 `setBit` 2 = 7
+3 `setBit` 3 = 11
+
+#
+-3 `clearBit` 0 = -4
+-3 `clearBit` 1 = -3
+-3 `clearBit` 2 = -7
+-3 `clearBit` 3 = -11
+
+-2 `clearBit` 0 = -2
+-2 `clearBit` 1 = -4
+-2 `clearBit` 2 = -6
+-2 `clearBit` 3 = -10
+
+-1 `clearBit` 0 = -2
+-1 `clearBit` 1 = -3
+-1 `clearBit` 2 = -5
+-1 `clearBit` 3 = -9
+
+0 `clearBit` 0 = 0
+0 `clearBit` 1 = 0
+0 `clearBit` 2 = 0
+0 `clearBit` 3 = 0
+
+1 `clearBit` 0 = 0
+1 `clearBit` 1 = 1
+1 `clearBit` 2 = 1
+1 `clearBit` 3 = 1
+
+2 `clearBit` 0 = 2
+2 `clearBit` 1 = 0
+2 `clearBit` 2 = 2
+2 `clearBit` 3 = 2
+
+3 `clearBit` 0 = 2
+3 `clearBit` 1 = 1
+3 `clearBit` 2 = 3
+3 `clearBit` 3 = 3
+
+#
+-3 `complementBit` 0 = -4
+-3 `complementBit` 1 = -1
+-3 `complementBit` 2 = -7
+-3 `complementBit` 3 = -11
+
+-2 `complementBit` 0 = -1
+-2 `complementBit` 1 = -4
+-2 `complementBit` 2 = -6
+-2 `complementBit` 3 = -10
+
+-1 `complementBit` 0 = -2
+-1 `complementBit` 1 = -3
+-1 `complementBit` 2 = -5
+-1 `complementBit` 3 = -9
+
+0 `complementBit` 0 = 1
+0 `complementBit` 1 = 2
+0 `complementBit` 2 = 4
+0 `complementBit` 3 = 8
+
+1 `complementBit` 0 = 0
+1 `complementBit` 1 = 3
+1 `complementBit` 2 = 5
+1 `complementBit` 3 = 9
+
+2 `complementBit` 0 = 3
+2 `complementBit` 1 = 0
+2 `complementBit` 2 = 6
+2 `complementBit` 3 = 10
+
+3 `complementBit` 0 = 2
+3 `complementBit` 1 = 1
+3 `complementBit` 2 = 7
+3 `complementBit` 3 = 11
+
+#
+-3 `testBit` 0 = True
+-3 `testBit` 1 = False
+-3 `testBit` 2 = True
+-3 `testBit` 3 = True
+
+-2 `testBit` 0 = False
+-2 `testBit` 1 = True
+-2 `testBit` 2 = True
+-2 `testBit` 3 = True
+
+-1 `testBit` 0 = True
+-1 `testBit` 1 = True
+-1 `testBit` 2 = True
+-1 `testBit` 3 = True
+
+0 `testBit` 0 = False
+0 `testBit` 1 = False
+0 `testBit` 2 = False
+0 `testBit` 3 = False
+
+1 `testBit` 0 = True
+1 `testBit` 1 = False
+1 `testBit` 2 = False
+1 `testBit` 3 = False
+
+2 `testBit` 0 = False
+2 `testBit` 1 = True
+2 `testBit` 2 = False
+2 `testBit` 3 = False
+
+3 `testBit` 0 = True
+3 `testBit` 1 = True
+3 `testBit` 2 = False
+3 `testBit` 3 = False
+
+#
+bitSize -3 = 32
+bitSize -2 = 32
+bitSize -1 = 32
+bitSize 0 = 32
+bitSize 1 = 32
+bitSize 2 = 32
+bitSize 3 = 32
+#
+isSigned -3 = True
+isSigned -2 = True
+isSigned -1 = True
+isSigned 0 = True
+isSigned 1 = True
+isSigned 2 = True
+isSigned 3 = True
+#
+--------------------------------
+--------------------------------
+--Testing Word8
+--------------------------------
+testBounded
+(255,0,1)
+(254,255,0)
+testEnum
+[0,1,2,3,4,5,6,7,8,9]
+[0,2,4,6,8,10,12,14,16,18]
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
+[0,2,4,6,8,10,12,14,16,18,20]
+testReadShow
+[253,254,255,0,1,2,3]
+[253,254,255,0,1,2,3]
+testEq
+253 == 253 = True
+253 == 254 = False
+253 == 255 = False
+253 == 0 = False
+253 == 1 = False
+253 == 2 = False
+253 == 3 = False
+
+254 == 253 = False
+254 == 254 = True
+254 == 255 = False
+254 == 0 = False
+254 == 1 = False
+254 == 2 = False
+254 == 3 = False
+
+255 == 253 = False
+255 == 254 = False
+255 == 255 = True
+255 == 0 = False
+255 == 1 = False
+255 == 2 = False
+255 == 3 = False
+
+0 == 253 = False
+0 == 254 = False
+0 == 255 = False
+0 == 0 = True
+0 == 1 = False
+0 == 2 = False
+0 == 3 = False
+
+1 == 253 = False
+1 == 254 = False
+1 == 255 = False
+1 == 0 = False
+1 == 1 = True
+1 == 2 = False
+1 == 3 = False
+
+2 == 253 = False
+2 == 254 = False
+2 == 255 = False
+2 == 0 = False
+2 == 1 = False
+2 == 2 = True
+2 == 3 = False
+
+3 == 253 = False
+3 == 254 = False
+3 == 255 = False
+3 == 0 = False
+3 == 1 = False
+3 == 2 = False
+3 == 3 = True
+
+#
+253 /= 253 = False
+253 /= 254 = True
+253 /= 255 = True
+253 /= 0 = True
+253 /= 1 = True
+253 /= 2 = True
+253 /= 3 = True
+
+254 /= 253 = True
+254 /= 254 = False
+254 /= 255 = True
+254 /= 0 = True
+254 /= 1 = True
+254 /= 2 = True
+254 /= 3 = True
+
+255 /= 253 = True
+255 /= 254 = True
+255 /= 255 = False
+255 /= 0 = True
+255 /= 1 = True
+255 /= 2 = True
+255 /= 3 = True
+
+0 /= 253 = True
+0 /= 254 = True
+0 /= 255 = True
+0 /= 0 = False
+0 /= 1 = True
+0 /= 2 = True
+0 /= 3 = True
+
+1 /= 253 = True
+1 /= 254 = True
+1 /= 255 = True
+1 /= 0 = True
+1 /= 1 = False
+1 /= 2 = True
+1 /= 3 = True
+
+2 /= 253 = True
+2 /= 254 = True
+2 /= 255 = True
+2 /= 0 = True
+2 /= 1 = True
+2 /= 2 = False
+2 /= 3 = True
+
+3 /= 253 = True
+3 /= 254 = True
+3 /= 255 = True
+3 /= 0 = True
+3 /= 1 = True
+3 /= 2 = True
+3 /= 3 = False
+
+#
+testOrd
+253 <= 253 = True
+253 <= 254 = True
+253 <= 255 = True
+253 <= 0 = False
+253 <= 1 = False
+253 <= 2 = False
+253 <= 3 = False
+
+254 <= 253 = False
+254 <= 254 = True
+254 <= 255 = True
+254 <= 0 = False
+254 <= 1 = False
+254 <= 2 = False
+254 <= 3 = False
+
+255 <= 253 = False
+255 <= 254 = False
+255 <= 255 = True
+255 <= 0 = False
+255 <= 1 = False
+255 <= 2 = False
+255 <= 3 = False
+
+0 <= 253 = True
+0 <= 254 = True
+0 <= 255 = True
+0 <= 0 = True
+0 <= 1 = True
+0 <= 2 = True
+0 <= 3 = True
+
+1 <= 253 = True
+1 <= 254 = True
+1 <= 255 = True
+1 <= 0 = False
+1 <= 1 = True
+1 <= 2 = True
+1 <= 3 = True
+
+2 <= 253 = True
+2 <= 254 = True
+2 <= 255 = True
+2 <= 0 = False
+2 <= 1 = False
+2 <= 2 = True
+2 <= 3 = True
+
+3 <= 253 = True
+3 <= 254 = True
+3 <= 255 = True
+3 <= 0 = False
+3 <= 1 = False
+3 <= 2 = False
+3 <= 3 = True
+
+#
+253 < 253 = False
+253 < 254 = True
+253 < 255 = True
+253 < 0 = False
+253 < 1 = False
+253 < 2 = False
+253 < 3 = False
+
+254 < 253 = False
+254 < 254 = False
+254 < 255 = True
+254 < 0 = False
+254 < 1 = False
+254 < 2 = False
+254 < 3 = False
+
+255 < 253 = False
+255 < 254 = False
+255 < 255 = False
+255 < 0 = False
+255 < 1 = False
+255 < 2 = False
+255 < 3 = False
+
+0 < 253 = True
+0 < 254 = True
+0 < 255 = True
+0 < 0 = False
+0 < 1 = True
+0 < 2 = True
+0 < 3 = True
+
+1 < 253 = True
+1 < 254 = True
+1 < 255 = True
+1 < 0 = False
+1 < 1 = False
+1 < 2 = True
+1 < 3 = True
+
+2 < 253 = True
+2 < 254 = True
+2 < 255 = True
+2 < 0 = False
+2 < 1 = False
+2 < 2 = False
+2 < 3 = True
+
+3 < 253 = True
+3 < 254 = True
+3 < 255 = True
+3 < 0 = False
+3 < 1 = False
+3 < 2 = False
+3 < 3 = False
+
+#
+253 > 253 = False
+253 > 254 = False
+253 > 255 = False
+253 > 0 = True
+253 > 1 = True
+253 > 2 = True
+253 > 3 = True
+
+254 > 253 = True
+254 > 254 = False
+254 > 255 = False
+254 > 0 = True
+254 > 1 = True
+254 > 2 = True
+254 > 3 = True
+
+255 > 253 = True
+255 > 254 = True
+255 > 255 = False
+255 > 0 = True
+255 > 1 = True
+255 > 2 = True
+255 > 3 = True
+
+0 > 253 = False
+0 > 254 = False
+0 > 255 = False
+0 > 0 = False
+0 > 1 = False
+0 > 2 = False
+0 > 3 = False
+
+1 > 253 = False
+1 > 254 = False
+1 > 255 = False
+1 > 0 = True
+1 > 1 = False
+1 > 2 = False
+1 > 3 = False
+
+2 > 253 = False
+2 > 254 = False
+2 > 255 = False
+2 > 0 = True
+2 > 1 = True
+2 > 2 = False
+2 > 3 = False
+
+3 > 253 = False
+3 > 254 = False
+3 > 255 = False
+3 > 0 = True
+3 > 1 = True
+3 > 2 = True
+3 > 3 = False
+
+#
+253 >= 253 = True
+253 >= 254 = False
+253 >= 255 = False
+253 >= 0 = True
+253 >= 1 = True
+253 >= 2 = True
+253 >= 3 = True
+
+254 >= 253 = True
+254 >= 254 = True
+254 >= 255 = False
+254 >= 0 = True
+254 >= 1 = True
+254 >= 2 = True
+254 >= 3 = True
+
+255 >= 253 = True
+255 >= 254 = True
+255 >= 255 = True
+255 >= 0 = True
+255 >= 1 = True
+255 >= 2 = True
+255 >= 3 = True
+
+0 >= 253 = False
+0 >= 254 = False
+0 >= 255 = False
+0 >= 0 = True
+0 >= 1 = False
+0 >= 2 = False
+0 >= 3 = False
+
+1 >= 253 = False
+1 >= 254 = False
+1 >= 255 = False
+1 >= 0 = True
+1 >= 1 = True
+1 >= 2 = False
+1 >= 3 = False
+
+2 >= 253 = False
+2 >= 254 = False
+2 >= 255 = False
+2 >= 0 = True
+2 >= 1 = True
+2 >= 2 = True
+2 >= 3 = False
+
+3 >= 253 = False
+3 >= 254 = False
+3 >= 255 = False
+3 >= 0 = True
+3 >= 1 = True
+3 >= 2 = True
+3 >= 3 = True
+
+#
+253 `compare` 253 = EQ
+253 `compare` 254 = LT
+253 `compare` 255 = LT
+253 `compare` 0 = GT
+253 `compare` 1 = GT
+253 `compare` 2 = GT
+253 `compare` 3 = GT
+
+254 `compare` 253 = GT
+254 `compare` 254 = EQ
+254 `compare` 255 = LT
+254 `compare` 0 = GT
+254 `compare` 1 = GT
+254 `compare` 2 = GT
+254 `compare` 3 = GT
+
+255 `compare` 253 = GT
+255 `compare` 254 = GT
+255 `compare` 255 = EQ
+255 `compare` 0 = GT
+255 `compare` 1 = GT
+255 `compare` 2 = GT
+255 `compare` 3 = GT
+
+0 `compare` 253 = LT
+0 `compare` 254 = LT
+0 `compare` 255 = LT
+0 `compare` 0 = EQ
+0 `compare` 1 = LT
+0 `compare` 2 = LT
+0 `compare` 3 = LT
+
+1 `compare` 253 = LT
+1 `compare` 254 = LT
+1 `compare` 255 = LT
+1 `compare` 0 = GT
+1 `compare` 1 = EQ
+1 `compare` 2 = LT
+1 `compare` 3 = LT
+
+2 `compare` 253 = LT
+2 `compare` 254 = LT
+2 `compare` 255 = LT
+2 `compare` 0 = GT
+2 `compare` 1 = GT
+2 `compare` 2 = EQ
+2 `compare` 3 = LT
+
+3 `compare` 253 = LT
+3 `compare` 254 = LT
+3 `compare` 255 = LT
+3 `compare` 0 = GT
+3 `compare` 1 = GT
+3 `compare` 2 = GT
+3 `compare` 3 = EQ
+
+#
+testNum
+253 + 253 = 250
+253 + 254 = 251
+253 + 255 = 252
+253 + 0 = 253
+253 + 1 = 254
+253 + 2 = 255
+253 + 3 = 0
+
+254 + 253 = 251
+254 + 254 = 252
+254 + 255 = 253
+254 + 0 = 254
+254 + 1 = 255
+254 + 2 = 0
+254 + 3 = 1
+
+255 + 253 = 252
+255 + 254 = 253
+255 + 255 = 254
+255 + 0 = 255
+255 + 1 = 0
+255 + 2 = 1
+255 + 3 = 2
+
+0 + 253 = 253
+0 + 254 = 254
+0 + 255 = 255
+0 + 0 = 0
+0 + 1 = 1
+0 + 2 = 2
+0 + 3 = 3
+
+1 + 253 = 254
+1 + 254 = 255
+1 + 255 = 0
+1 + 0 = 1
+1 + 1 = 2
+1 + 2 = 3
+1 + 3 = 4
+
+2 + 253 = 255
+2 + 254 = 0
+2 + 255 = 1
+2 + 0 = 2
+2 + 1 = 3
+2 + 2 = 4
+2 + 3 = 5
+
+3 + 253 = 0
+3 + 254 = 1
+3 + 255 = 2
+3 + 0 = 3
+3 + 1 = 4
+3 + 2 = 5
+3 + 3 = 6
+
+#
+253 - 253 = 0
+253 - 254 = 255
+253 - 255 = 254
+253 - 0 = 253
+253 - 1 = 252
+253 - 2 = 251
+253 - 3 = 250
+
+254 - 253 = 1
+254 - 254 = 0
+254 - 255 = 255
+254 - 0 = 254
+254 - 1 = 253
+254 - 2 = 252
+254 - 3 = 251
+
+255 - 253 = 2
+255 - 254 = 1
+255 - 255 = 0
+255 - 0 = 255
+255 - 1 = 254
+255 - 2 = 253
+255 - 3 = 252
+
+0 - 253 = 3
+0 - 254 = 2
+0 - 255 = 1
+0 - 0 = 0
+0 - 1 = 255
+0 - 2 = 254
+0 - 3 = 253
+
+1 - 253 = 4
+1 - 254 = 3
+1 - 255 = 2
+1 - 0 = 1
+1 - 1 = 0
+1 - 2 = 255
+1 - 3 = 254
+
+2 - 253 = 5
+2 - 254 = 4
+2 - 255 = 3
+2 - 0 = 2
+2 - 1 = 1
+2 - 2 = 0
+2 - 3 = 255
+
+3 - 253 = 6
+3 - 254 = 5
+3 - 255 = 4
+3 - 0 = 3
+3 - 1 = 2
+3 - 2 = 1
+3 - 3 = 0
+
+#
+253 * 253 = 9
+253 * 254 = 6
+253 * 255 = 3
+253 * 0 = 0
+253 * 1 = 253
+253 * 2 = 250
+253 * 3 = 247
+
+254 * 253 = 6
+254 * 254 = 4
+254 * 255 = 2
+254 * 0 = 0
+254 * 1 = 254
+254 * 2 = 252
+254 * 3 = 250
+
+255 * 253 = 3
+255 * 254 = 2
+255 * 255 = 1
+255 * 0 = 0
+255 * 1 = 255
+255 * 2 = 254
+255 * 3 = 253
+
+0 * 253 = 0
+0 * 254 = 0
+0 * 255 = 0
+0 * 0 = 0
+0 * 1 = 0
+0 * 2 = 0
+0 * 3 = 0
+
+1 * 253 = 253
+1 * 254 = 254
+1 * 255 = 255
+1 * 0 = 0
+1 * 1 = 1
+1 * 2 = 2
+1 * 3 = 3
+
+2 * 253 = 250
+2 * 254 = 252
+2 * 255 = 254
+2 * 0 = 0
+2 * 1 = 2
+2 * 2 = 4
+2 * 3 = 6
+
+3 * 253 = 247
+3 * 254 = 250
+3 * 255 = 253
+3 * 0 = 0
+3 * 1 = 3
+3 * 2 = 6
+3 * 3 = 9
+
+#
+negate 253 = 3
+negate 254 = 2
+negate 255 = 1
+negate 0 = 0
+negate 1 = 255
+negate 2 = 254
+negate 3 = 253
+#
+testReal
+toRational 253 = 253 % 1
+toRational 254 = 254 % 1
+toRational 255 = 255 % 1
+toRational 0 = 0 % 1
+toRational 1 = 1 % 1
+toRational 2 = 2 % 1
+toRational 3 = 3 % 1
+#
+testIntegral
+253 `divMod` 253 = (1,0)
+253 `divMod` 254 = (0,253)
+253 `divMod` 255 = (0,253)
+253 `divMod` 1 = (253,0)
+253 `divMod` 2 = (126,1)
+253 `divMod` 3 = (84,1)
+
+254 `divMod` 253 = (1,1)
+254 `divMod` 254 = (1,0)
+254 `divMod` 255 = (0,254)
+254 `divMod` 1 = (254,0)
+254 `divMod` 2 = (127,0)
+254 `divMod` 3 = (84,2)
+
+255 `divMod` 253 = (1,2)
+255 `divMod` 254 = (1,1)
+255 `divMod` 255 = (1,0)
+255 `divMod` 1 = (255,0)
+255 `divMod` 2 = (127,1)
+255 `divMod` 3 = (85,0)
+
+0 `divMod` 253 = (0,0)
+0 `divMod` 254 = (0,0)
+0 `divMod` 255 = (0,0)
+0 `divMod` 1 = (0,0)
+0 `divMod` 2 = (0,0)
+0 `divMod` 3 = (0,0)
+
+1 `divMod` 253 = (0,1)
+1 `divMod` 254 = (0,1)
+1 `divMod` 255 = (0,1)
+1 `divMod` 1 = (1,0)
+1 `divMod` 2 = (0,1)
+1 `divMod` 3 = (0,1)
+
+2 `divMod` 253 = (0,2)
+2 `divMod` 254 = (0,2)
+2 `divMod` 255 = (0,2)
+2 `divMod` 1 = (2,0)
+2 `divMod` 2 = (1,0)
+2 `divMod` 3 = (0,2)
+
+3 `divMod` 253 = (0,3)
+3 `divMod` 254 = (0,3)
+3 `divMod` 255 = (0,3)
+3 `divMod` 1 = (3,0)
+3 `divMod` 2 = (1,1)
+3 `divMod` 3 = (1,0)
+
+#
+253 `div` 253 = 1
+253 `div` 254 = 0
+253 `div` 255 = 0
+253 `div` 1 = 253
+253 `div` 2 = 126
+253 `div` 3 = 84
+
+254 `div` 253 = 1
+254 `div` 254 = 1
+254 `div` 255 = 0
+254 `div` 1 = 254
+254 `div` 2 = 127
+254 `div` 3 = 84
+
+255 `div` 253 = 1
+255 `div` 254 = 1
+255 `div` 255 = 1
+255 `div` 1 = 255
+255 `div` 2 = 127
+255 `div` 3 = 85
+
+0 `div` 253 = 0
+0 `div` 254 = 0
+0 `div` 255 = 0
+0 `div` 1 = 0
+0 `div` 2 = 0
+0 `div` 3 = 0
+
+1 `div` 253 = 0
+1 `div` 254 = 0
+1 `div` 255 = 0
+1 `div` 1 = 1
+1 `div` 2 = 0
+1 `div` 3 = 0
+
+2 `div` 253 = 0
+2 `div` 254 = 0
+2 `div` 255 = 0
+2 `div` 1 = 2
+2 `div` 2 = 1
+2 `div` 3 = 0
+
+3 `div` 253 = 0
+3 `div` 254 = 0
+3 `div` 255 = 0
+3 `div` 1 = 3
+3 `div` 2 = 1
+3 `div` 3 = 1
+
+#
+253 `mod` 253 = 0
+253 `mod` 254 = 253
+253 `mod` 255 = 253
+253 `mod` 1 = 0
+253 `mod` 2 = 1
+253 `mod` 3 = 1
+
+254 `mod` 253 = 1
+254 `mod` 254 = 0
+254 `mod` 255 = 254
+254 `mod` 1 = 0
+254 `mod` 2 = 0
+254 `mod` 3 = 2
+
+255 `mod` 253 = 2
+255 `mod` 254 = 1
+255 `mod` 255 = 0
+255 `mod` 1 = 0
+255 `mod` 2 = 1
+255 `mod` 3 = 0
+
+0 `mod` 253 = 0
+0 `mod` 254 = 0
+0 `mod` 255 = 0
+0 `mod` 1 = 0
+0 `mod` 2 = 0
+0 `mod` 3 = 0
+
+1 `mod` 253 = 1
+1 `mod` 254 = 1
+1 `mod` 255 = 1
+1 `mod` 1 = 0
+1 `mod` 2 = 1
+1 `mod` 3 = 1
+
+2 `mod` 253 = 2
+2 `mod` 254 = 2
+2 `mod` 255 = 2
+2 `mod` 1 = 0
+2 `mod` 2 = 0
+2 `mod` 3 = 2
+
+3 `mod` 253 = 3
+3 `mod` 254 = 3
+3 `mod` 255 = 3
+3 `mod` 1 = 0
+3 `mod` 2 = 1
+3 `mod` 3 = 0
+
+#
+253 `quotRem` 253 = (1,0)
+253 `quotRem` 254 = (0,253)
+253 `quotRem` 255 = (0,253)
+253 `quotRem` 1 = (253,0)
+253 `quotRem` 2 = (126,1)
+253 `quotRem` 3 = (84,1)
+
+254 `quotRem` 253 = (1,1)
+254 `quotRem` 254 = (1,0)
+254 `quotRem` 255 = (0,254)
+254 `quotRem` 1 = (254,0)
+254 `quotRem` 2 = (127,0)
+254 `quotRem` 3 = (84,2)
+
+255 `quotRem` 253 = (1,2)
+255 `quotRem` 254 = (1,1)
+255 `quotRem` 255 = (1,0)
+255 `quotRem` 1 = (255,0)
+255 `quotRem` 2 = (127,1)
+255 `quotRem` 3 = (85,0)
+
+0 `quotRem` 253 = (0,0)
+0 `quotRem` 254 = (0,0)
+0 `quotRem` 255 = (0,0)
+0 `quotRem` 1 = (0,0)
+0 `quotRem` 2 = (0,0)
+0 `quotRem` 3 = (0,0)
+
+1 `quotRem` 253 = (0,1)
+1 `quotRem` 254 = (0,1)
+1 `quotRem` 255 = (0,1)
+1 `quotRem` 1 = (1,0)
+1 `quotRem` 2 = (0,1)
+1 `quotRem` 3 = (0,1)
+
+2 `quotRem` 253 = (0,2)
+2 `quotRem` 254 = (0,2)
+2 `quotRem` 255 = (0,2)
+2 `quotRem` 1 = (2,0)
+2 `quotRem` 2 = (1,0)
+2 `quotRem` 3 = (0,2)
+
+3 `quotRem` 253 = (0,3)
+3 `quotRem` 254 = (0,3)
+3 `quotRem` 255 = (0,3)
+3 `quotRem` 1 = (3,0)
+3 `quotRem` 2 = (1,1)
+3 `quotRem` 3 = (1,0)
+
+#
+253 `quot` 253 = 1
+253 `quot` 254 = 0
+253 `quot` 255 = 0
+253 `quot` 1 = 253
+253 `quot` 2 = 126
+253 `quot` 3 = 84
+
+254 `quot` 253 = 1
+254 `quot` 254 = 1
+254 `quot` 255 = 0
+254 `quot` 1 = 254
+254 `quot` 2 = 127
+254 `quot` 3 = 84
+
+255 `quot` 253 = 1
+255 `quot` 254 = 1
+255 `quot` 255 = 1
+255 `quot` 1 = 255
+255 `quot` 2 = 127
+255 `quot` 3 = 85
+
+0 `quot` 253 = 0
+0 `quot` 254 = 0
+0 `quot` 255 = 0
+0 `quot` 1 = 0
+0 `quot` 2 = 0
+0 `quot` 3 = 0
+
+1 `quot` 253 = 0
+1 `quot` 254 = 0
+1 `quot` 255 = 0
+1 `quot` 1 = 1
+1 `quot` 2 = 0
+1 `quot` 3 = 0
+
+2 `quot` 253 = 0
+2 `quot` 254 = 0
+2 `quot` 255 = 0
+2 `quot` 1 = 2
+2 `quot` 2 = 1
+2 `quot` 3 = 0
+
+3 `quot` 253 = 0
+3 `quot` 254 = 0
+3 `quot` 255 = 0
+3 `quot` 1 = 3
+3 `quot` 2 = 1
+3 `quot` 3 = 1
+
+#
+253 `rem` 253 = 0
+253 `rem` 254 = 253
+253 `rem` 255 = 253
+253 `rem` 1 = 0
+253 `rem` 2 = 1
+253 `rem` 3 = 1
+
+254 `rem` 253 = 1
+254 `rem` 254 = 0
+254 `rem` 255 = 254
+254 `rem` 1 = 0
+254 `rem` 2 = 0
+254 `rem` 3 = 2
+
+255 `rem` 253 = 2
+255 `rem` 254 = 1
+255 `rem` 255 = 0
+255 `rem` 1 = 0
+255 `rem` 2 = 1
+255 `rem` 3 = 0
+
+0 `rem` 253 = 0
+0 `rem` 254 = 0
+0 `rem` 255 = 0
+0 `rem` 1 = 0
+0 `rem` 2 = 0
+0 `rem` 3 = 0
+
+1 `rem` 253 = 1
+1 `rem` 254 = 1
+1 `rem` 255 = 1
+1 `rem` 1 = 0
+1 `rem` 2 = 1
+1 `rem` 3 = 1
+
+2 `rem` 253 = 2
+2 `rem` 254 = 2
+2 `rem` 255 = 2
+2 `rem` 1 = 0
+2 `rem` 2 = 0
+2 `rem` 3 = 2
+
+3 `rem` 253 = 3
+3 `rem` 254 = 3
+3 `rem` 255 = 3
+3 `rem` 1 = 0
+3 `rem` 2 = 1
+3 `rem` 3 = 0
+
+#
+testBits
+253 .&. 253 = 253
+253 .&. 254 = 252
+253 .&. 255 = 253
+253 .&. 1 = 1
+253 .&. 2 = 0
+253 .&. 3 = 1
+
+254 .&. 253 = 252
+254 .&. 254 = 254
+254 .&. 255 = 254
+254 .&. 1 = 0
+254 .&. 2 = 2
+254 .&. 3 = 2
+
+255 .&. 253 = 253
+255 .&. 254 = 254
+255 .&. 255 = 255
+255 .&. 1 = 1
+255 .&. 2 = 2
+255 .&. 3 = 3
+
+0 .&. 253 = 0
+0 .&. 254 = 0
+0 .&. 255 = 0
+0 .&. 1 = 0
+0 .&. 2 = 0
+0 .&. 3 = 0
+
+1 .&. 253 = 1
+1 .&. 254 = 0
+1 .&. 255 = 1
+1 .&. 1 = 1
+1 .&. 2 = 0
+1 .&. 3 = 1
+
+2 .&. 253 = 0
+2 .&. 254 = 2
+2 .&. 255 = 2
+2 .&. 1 = 0
+2 .&. 2 = 2
+2 .&. 3 = 2
+
+3 .&. 253 = 1
+3 .&. 254 = 2
+3 .&. 255 = 3
+3 .&. 1 = 1
+3 .&. 2 = 2
+3 .&. 3 = 3
+
+#
+253 .|. 253 = 253
+253 .|. 254 = 255
+253 .|. 255 = 255
+253 .|. 1 = 253
+253 .|. 2 = 255
+253 .|. 3 = 255
+
+254 .|. 253 = 255
+254 .|. 254 = 254
+254 .|. 255 = 255
+254 .|. 1 = 255
+254 .|. 2 = 254
+254 .|. 3 = 255
+
+255 .|. 253 = 255
+255 .|. 254 = 255
+255 .|. 255 = 255
+255 .|. 1 = 255
+255 .|. 2 = 255
+255 .|. 3 = 255
+
+0 .|. 253 = 253
+0 .|. 254 = 254
+0 .|. 255 = 255
+0 .|. 1 = 1
+0 .|. 2 = 2
+0 .|. 3 = 3
+
+1 .|. 253 = 253
+1 .|. 254 = 255
+1 .|. 255 = 255
+1 .|. 1 = 1
+1 .|. 2 = 3
+1 .|. 3 = 3
+
+2 .|. 253 = 255
+2 .|. 254 = 254
+2 .|. 255 = 255
+2 .|. 1 = 3
+2 .|. 2 = 2
+2 .|. 3 = 3
+
+3 .|. 253 = 255
+3 .|. 254 = 255
+3 .|. 255 = 255
+3 .|. 1 = 3
+3 .|. 2 = 3
+3 .|. 3 = 3
+
+#
+253 `xor` 253 = 0
+253 `xor` 254 = 3
+253 `xor` 255 = 2
+253 `xor` 1 = 252
+253 `xor` 2 = 255
+253 `xor` 3 = 254
+
+254 `xor` 253 = 3
+254 `xor` 254 = 0
+254 `xor` 255 = 1
+254 `xor` 1 = 255
+254 `xor` 2 = 252
+254 `xor` 3 = 253
+
+255 `xor` 253 = 2
+255 `xor` 254 = 1
+255 `xor` 255 = 0
+255 `xor` 1 = 254
+255 `xor` 2 = 253
+255 `xor` 3 = 252
+
+0 `xor` 253 = 253
+0 `xor` 254 = 254
+0 `xor` 255 = 255
+0 `xor` 1 = 1
+0 `xor` 2 = 2
+0 `xor` 3 = 3
+
+1 `xor` 253 = 252
+1 `xor` 254 = 255
+1 `xor` 255 = 254
+1 `xor` 1 = 0
+1 `xor` 2 = 3
+1 `xor` 3 = 2
+
+2 `xor` 253 = 255
+2 `xor` 254 = 252
+2 `xor` 255 = 253
+2 `xor` 1 = 3
+2 `xor` 2 = 0
+2 `xor` 3 = 1
+
+3 `xor` 253 = 254
+3 `xor` 254 = 253
+3 `xor` 255 = 252
+3 `xor` 1 = 2
+3 `xor` 2 = 1
+3 `xor` 3 = 0
+
+#
+complement 253 = 2
+complement 254 = 1
+complement 255 = 0
+complement 0 = 255
+complement 1 = 254
+complement 2 = 253
+complement 3 = 252
+#
+253 `shift` 0 = 253
+253 `shift` 1 = 250
+253 `shift` 2 = 244
+253 `shift` 3 = 232
+
+254 `shift` 0 = 254
+254 `shift` 1 = 252
+254 `shift` 2 = 248
+254 `shift` 3 = 240
+
+255 `shift` 0 = 255
+255 `shift` 1 = 254
+255 `shift` 2 = 252
+255 `shift` 3 = 248
+
+0 `shift` 0 = 0
+0 `shift` 1 = 0
+0 `shift` 2 = 0
+0 `shift` 3 = 0
+
+1 `shift` 0 = 1
+1 `shift` 1 = 2
+1 `shift` 2 = 4
+1 `shift` 3 = 8
+
+2 `shift` 0 = 2
+2 `shift` 1 = 4
+2 `shift` 2 = 8
+2 `shift` 3 = 16
+
+3 `shift` 0 = 3
+3 `shift` 1 = 6
+3 `shift` 2 = 12
+3 `shift` 3 = 24
+
+#
+253 `setBit` 0 = 253
+253 `setBit` 1 = 255
+253 `setBit` 2 = 253
+253 `setBit` 3 = 253
+
+254 `setBit` 0 = 255
+254 `setBit` 1 = 254
+254 `setBit` 2 = 254
+254 `setBit` 3 = 254
+
+255 `setBit` 0 = 255
+255 `setBit` 1 = 255
+255 `setBit` 2 = 255
+255 `setBit` 3 = 255
+
+0 `setBit` 0 = 1
+0 `setBit` 1 = 2
+0 `setBit` 2 = 4
+0 `setBit` 3 = 8
+
+1 `setBit` 0 = 1
+1 `setBit` 1 = 3
+1 `setBit` 2 = 5
+1 `setBit` 3 = 9
+
+2 `setBit` 0 = 3
+2 `setBit` 1 = 2
+2 `setBit` 2 = 6
+2 `setBit` 3 = 10
+
+3 `setBit` 0 = 3
+3 `setBit` 1 = 3
+3 `setBit` 2 = 7
+3 `setBit` 3 = 11
+
+#
+253 `clearBit` 0 = 252
+253 `clearBit` 1 = 253
+253 `clearBit` 2 = 249
+253 `clearBit` 3 = 245
+
+254 `clearBit` 0 = 254
+254 `clearBit` 1 = 252
+254 `clearBit` 2 = 250
+254 `clearBit` 3 = 246
+
+255 `clearBit` 0 = 254
+255 `clearBit` 1 = 253
+255 `clearBit` 2 = 251
+255 `clearBit` 3 = 247
+
+0 `clearBit` 0 = 0
+0 `clearBit` 1 = 0
+0 `clearBit` 2 = 0
+0 `clearBit` 3 = 0
+
+1 `clearBit` 0 = 0
+1 `clearBit` 1 = 1
+1 `clearBit` 2 = 1
+1 `clearBit` 3 = 1
+
+2 `clearBit` 0 = 2
+2 `clearBit` 1 = 0
+2 `clearBit` 2 = 2
+2 `clearBit` 3 = 2
+
+3 `clearBit` 0 = 2
+3 `clearBit` 1 = 1
+3 `clearBit` 2 = 3
+3 `clearBit` 3 = 3
+
+#
+253 `complementBit` 0 = 252
+253 `complementBit` 1 = 255
+253 `complementBit` 2 = 249
+253 `complementBit` 3 = 245
+
+254 `complementBit` 0 = 255
+254 `complementBit` 1 = 252
+254 `complementBit` 2 = 250
+254 `complementBit` 3 = 246
+
+255 `complementBit` 0 = 254
+255 `complementBit` 1 = 253
+255 `complementBit` 2 = 251
+255 `complementBit` 3 = 247
+
+0 `complementBit` 0 = 1
+0 `complementBit` 1 = 2
+0 `complementBit` 2 = 4
+0 `complementBit` 3 = 8
+
+1 `complementBit` 0 = 0
+1 `complementBit` 1 = 3
+1 `complementBit` 2 = 5
+1 `complementBit` 3 = 9
+
+2 `complementBit` 0 = 3
+2 `complementBit` 1 = 0
+2 `complementBit` 2 = 6
+2 `complementBit` 3 = 10
+
+3 `complementBit` 0 = 2
+3 `complementBit` 1 = 1
+3 `complementBit` 2 = 7
+3 `complementBit` 3 = 11
+
+#
+253 `testBit` 0 = True
+253 `testBit` 1 = False
+253 `testBit` 2 = True
+253 `testBit` 3 = True
+
+254 `testBit` 0 = False
+254 `testBit` 1 = True
+254 `testBit` 2 = True
+254 `testBit` 3 = True
+
+255 `testBit` 0 = True
+255 `testBit` 1 = True
+255 `testBit` 2 = True
+255 `testBit` 3 = True
+
+0 `testBit` 0 = False
+0 `testBit` 1 = False
+0 `testBit` 2 = False
+0 `testBit` 3 = False
+
+1 `testBit` 0 = True
+1 `testBit` 1 = False
+1 `testBit` 2 = False
+1 `testBit` 3 = False
+
+2 `testBit` 0 = False
+2 `testBit` 1 = True
+2 `testBit` 2 = False
+2 `testBit` 3 = False
+
+3 `testBit` 0 = True
+3 `testBit` 1 = True
+3 `testBit` 2 = False
+3 `testBit` 3 = False
+
+#
+bitSize 253 = 8
+bitSize 254 = 8
+bitSize 255 = 8
+bitSize 0 = 8
+bitSize 1 = 8
+bitSize 2 = 8
+bitSize 3 = 8
+#
+isSigned 253 = False
+isSigned 254 = False
+isSigned 255 = False
+isSigned 0 = False
+isSigned 1 = False
+isSigned 2 = False
+isSigned 3 = False
+#
+--------------------------------
+--------------------------------
+--Testing Word16
+--------------------------------
+testBounded
+(65535,0,1)
+(65534,65535,0)
+testEnum
+[0,1,2,3,4,5,6,7,8,9]
+[0,2,4,6,8,10,12,14,16,18]
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
+[0,2,4,6,8,10,12,14,16,18,20]
+testReadShow
+[65533,65534,65535,0,1,2,3]
+[65533,65534,65535,0,1,2,3]
+testEq
+65533 == 65533 = True
+65533 == 65534 = False
+65533 == 65535 = False
+65533 == 0 = False
+65533 == 1 = False
+65533 == 2 = False
+65533 == 3 = False
+
+65534 == 65533 = False
+65534 == 65534 = True
+65534 == 65535 = False
+65534 == 0 = False
+65534 == 1 = False
+65534 == 2 = False
+65534 == 3 = False
+
+65535 == 65533 = False
+65535 == 65534 = False
+65535 == 65535 = True
+65535 == 0 = False
+65535 == 1 = False
+65535 == 2 = False
+65535 == 3 = False
+
+0 == 65533 = False
+0 == 65534 = False
+0 == 65535 = False
+0 == 0 = True
+0 == 1 = False
+0 == 2 = False
+0 == 3 = False
+
+1 == 65533 = False
+1 == 65534 = False
+1 == 65535 = False
+1 == 0 = False
+1 == 1 = True
+1 == 2 = False
+1 == 3 = False
+
+2 == 65533 = False
+2 == 65534 = False
+2 == 65535 = False
+2 == 0 = False
+2 == 1 = False
+2 == 2 = True
+2 == 3 = False
+
+3 == 65533 = False
+3 == 65534 = False
+3 == 65535 = False
+3 == 0 = False
+3 == 1 = False
+3 == 2 = False
+3 == 3 = True
+
+#
+65533 /= 65533 = False
+65533 /= 65534 = True
+65533 /= 65535 = True
+65533 /= 0 = True
+65533 /= 1 = True
+65533 /= 2 = True
+65533 /= 3 = True
+
+65534 /= 65533 = True
+65534 /= 65534 = False
+65534 /= 65535 = True
+65534 /= 0 = True
+65534 /= 1 = True
+65534 /= 2 = True
+65534 /= 3 = True
+
+65535 /= 65533 = True
+65535 /= 65534 = True
+65535 /= 65535 = False
+65535 /= 0 = True
+65535 /= 1 = True
+65535 /= 2 = True
+65535 /= 3 = True
+
+0 /= 65533 = True
+0 /= 65534 = True
+0 /= 65535 = True
+0 /= 0 = False
+0 /= 1 = True
+0 /= 2 = True
+0 /= 3 = True
+
+1 /= 65533 = True
+1 /= 65534 = True
+1 /= 65535 = True
+1 /= 0 = True
+1 /= 1 = False
+1 /= 2 = True
+1 /= 3 = True
+
+2 /= 65533 = True
+2 /= 65534 = True
+2 /= 65535 = True
+2 /= 0 = True
+2 /= 1 = True
+2 /= 2 = False
+2 /= 3 = True
+
+3 /= 65533 = True
+3 /= 65534 = True
+3 /= 65535 = True
+3 /= 0 = True
+3 /= 1 = True
+3 /= 2 = True
+3 /= 3 = False
+
+#
+testOrd
+65533 <= 65533 = True
+65533 <= 65534 = True
+65533 <= 65535 = True
+65533 <= 0 = False
+65533 <= 1 = False
+65533 <= 2 = False
+65533 <= 3 = False
+
+65534 <= 65533 = False
+65534 <= 65534 = True
+65534 <= 65535 = True
+65534 <= 0 = False
+65534 <= 1 = False
+65534 <= 2 = False
+65534 <= 3 = False
+
+65535 <= 65533 = False
+65535 <= 65534 = False
+65535 <= 65535 = True
+65535 <= 0 = False
+65535 <= 1 = False
+65535 <= 2 = False
+65535 <= 3 = False
+
+0 <= 65533 = True
+0 <= 65534 = True
+0 <= 65535 = True
+0 <= 0 = True
+0 <= 1 = True
+0 <= 2 = True
+0 <= 3 = True
+
+1 <= 65533 = True
+1 <= 65534 = True
+1 <= 65535 = True
+1 <= 0 = False
+1 <= 1 = True
+1 <= 2 = True
+1 <= 3 = True
+
+2 <= 65533 = True
+2 <= 65534 = True
+2 <= 65535 = True
+2 <= 0 = False
+2 <= 1 = False
+2 <= 2 = True
+2 <= 3 = True
+
+3 <= 65533 = True
+3 <= 65534 = True
+3 <= 65535 = True
+3 <= 0 = False
+3 <= 1 = False
+3 <= 2 = False
+3 <= 3 = True
+
+#
+65533 < 65533 = False
+65533 < 65534 = True
+65533 < 65535 = True
+65533 < 0 = False
+65533 < 1 = False
+65533 < 2 = False
+65533 < 3 = False
+
+65534 < 65533 = False
+65534 < 65534 = False
+65534 < 65535 = True
+65534 < 0 = False
+65534 < 1 = False
+65534 < 2 = False
+65534 < 3 = False
+
+65535 < 65533 = False
+65535 < 65534 = False
+65535 < 65535 = False
+65535 < 0 = False
+65535 < 1 = False
+65535 < 2 = False
+65535 < 3 = False
+
+0 < 65533 = True
+0 < 65534 = True
+0 < 65535 = True
+0 < 0 = False
+0 < 1 = True
+0 < 2 = True
+0 < 3 = True
+
+1 < 65533 = True
+1 < 65534 = True
+1 < 65535 = True
+1 < 0 = False
+1 < 1 = False
+1 < 2 = True
+1 < 3 = True
+
+2 < 65533 = True
+2 < 65534 = True
+2 < 65535 = True
+2 < 0 = False
+2 < 1 = False
+2 < 2 = False
+2 < 3 = True
+
+3 < 65533 = True
+3 < 65534 = True
+3 < 65535 = True
+3 < 0 = False
+3 < 1 = False
+3 < 2 = False
+3 < 3 = False
+
+#
+65533 > 65533 = False
+65533 > 65534 = False
+65533 > 65535 = False
+65533 > 0 = True
+65533 > 1 = True
+65533 > 2 = True
+65533 > 3 = True
+
+65534 > 65533 = True
+65534 > 65534 = False
+65534 > 65535 = False
+65534 > 0 = True
+65534 > 1 = True
+65534 > 2 = True
+65534 > 3 = True
+
+65535 > 65533 = True
+65535 > 65534 = True
+65535 > 65535 = False
+65535 > 0 = True
+65535 > 1 = True
+65535 > 2 = True
+65535 > 3 = True
+
+0 > 65533 = False
+0 > 65534 = False
+0 > 65535 = False
+0 > 0 = False
+0 > 1 = False
+0 > 2 = False
+0 > 3 = False
+
+1 > 65533 = False
+1 > 65534 = False
+1 > 65535 = False
+1 > 0 = True
+1 > 1 = False
+1 > 2 = False
+1 > 3 = False
+
+2 > 65533 = False
+2 > 65534 = False
+2 > 65535 = False
+2 > 0 = True
+2 > 1 = True
+2 > 2 = False
+2 > 3 = False
+
+3 > 65533 = False
+3 > 65534 = False
+3 > 65535 = False
+3 > 0 = True
+3 > 1 = True
+3 > 2 = True
+3 > 3 = False
+
+#
+65533 >= 65533 = True
+65533 >= 65534 = False
+65533 >= 65535 = False
+65533 >= 0 = True
+65533 >= 1 = True
+65533 >= 2 = True
+65533 >= 3 = True
+
+65534 >= 65533 = True
+65534 >= 65534 = True
+65534 >= 65535 = False
+65534 >= 0 = True
+65534 >= 1 = True
+65534 >= 2 = True
+65534 >= 3 = True
+
+65535 >= 65533 = True
+65535 >= 65534 = True
+65535 >= 65535 = True
+65535 >= 0 = True
+65535 >= 1 = True
+65535 >= 2 = True
+65535 >= 3 = True
+
+0 >= 65533 = False
+0 >= 65534 = False
+0 >= 65535 = False
+0 >= 0 = True
+0 >= 1 = False
+0 >= 2 = False
+0 >= 3 = False
+
+1 >= 65533 = False
+1 >= 65534 = False
+1 >= 65535 = False
+1 >= 0 = True
+1 >= 1 = True
+1 >= 2 = False
+1 >= 3 = False
+
+2 >= 65533 = False
+2 >= 65534 = False
+2 >= 65535 = False
+2 >= 0 = True
+2 >= 1 = True
+2 >= 2 = True
+2 >= 3 = False
+
+3 >= 65533 = False
+3 >= 65534 = False
+3 >= 65535 = False
+3 >= 0 = True
+3 >= 1 = True
+3 >= 2 = True
+3 >= 3 = True
+
+#
+65533 `compare` 65533 = EQ
+65533 `compare` 65534 = LT
+65533 `compare` 65535 = LT
+65533 `compare` 0 = GT
+65533 `compare` 1 = GT
+65533 `compare` 2 = GT
+65533 `compare` 3 = GT
+
+65534 `compare` 65533 = GT
+65534 `compare` 65534 = EQ
+65534 `compare` 65535 = LT
+65534 `compare` 0 = GT
+65534 `compare` 1 = GT
+65534 `compare` 2 = GT
+65534 `compare` 3 = GT
+
+65535 `compare` 65533 = GT
+65535 `compare` 65534 = GT
+65535 `compare` 65535 = EQ
+65535 `compare` 0 = GT
+65535 `compare` 1 = GT
+65535 `compare` 2 = GT
+65535 `compare` 3 = GT
+
+0 `compare` 65533 = LT
+0 `compare` 65534 = LT
+0 `compare` 65535 = LT
+0 `compare` 0 = EQ
+0 `compare` 1 = LT
+0 `compare` 2 = LT
+0 `compare` 3 = LT
+
+1 `compare` 65533 = LT
+1 `compare` 65534 = LT
+1 `compare` 65535 = LT
+1 `compare` 0 = GT
+1 `compare` 1 = EQ
+1 `compare` 2 = LT
+1 `compare` 3 = LT
+
+2 `compare` 65533 = LT
+2 `compare` 65534 = LT
+2 `compare` 65535 = LT
+2 `compare` 0 = GT
+2 `compare` 1 = GT
+2 `compare` 2 = EQ
+2 `compare` 3 = LT
+
+3 `compare` 65533 = LT
+3 `compare` 65534 = LT
+3 `compare` 65535 = LT
+3 `compare` 0 = GT
+3 `compare` 1 = GT
+3 `compare` 2 = GT
+3 `compare` 3 = EQ
+
+#
+testNum
+65533 + 65533 = 65530
+65533 + 65534 = 65531
+65533 + 65535 = 65532
+65533 + 0 = 65533
+65533 + 1 = 65534
+65533 + 2 = 65535
+65533 + 3 = 0
+
+65534 + 65533 = 65531
+65534 + 65534 = 65532
+65534 + 65535 = 65533
+65534 + 0 = 65534
+65534 + 1 = 65535
+65534 + 2 = 0
+65534 + 3 = 1
+
+65535 + 65533 = 65532
+65535 + 65534 = 65533
+65535 + 65535 = 65534
+65535 + 0 = 65535
+65535 + 1 = 0
+65535 + 2 = 1
+65535 + 3 = 2
+
+0 + 65533 = 65533
+0 + 65534 = 65534
+0 + 65535 = 65535
+0 + 0 = 0
+0 + 1 = 1
+0 + 2 = 2
+0 + 3 = 3
+
+1 + 65533 = 65534
+1 + 65534 = 65535
+1 + 65535 = 0
+1 + 0 = 1
+1 + 1 = 2
+1 + 2 = 3
+1 + 3 = 4
+
+2 + 65533 = 65535
+2 + 65534 = 0
+2 + 65535 = 1
+2 + 0 = 2
+2 + 1 = 3
+2 + 2 = 4
+2 + 3 = 5
+
+3 + 65533 = 0
+3 + 65534 = 1
+3 + 65535 = 2
+3 + 0 = 3
+3 + 1 = 4
+3 + 2 = 5
+3 + 3 = 6
+
+#
+65533 - 65533 = 0
+65533 - 65534 = 65535
+65533 - 65535 = 65534
+65533 - 0 = 65533
+65533 - 1 = 65532
+65533 - 2 = 65531
+65533 - 3 = 65530
+
+65534 - 65533 = 1
+65534 - 65534 = 0
+65534 - 65535 = 65535
+65534 - 0 = 65534
+65534 - 1 = 65533
+65534 - 2 = 65532
+65534 - 3 = 65531
+
+65535 - 65533 = 2
+65535 - 65534 = 1
+65535 - 65535 = 0
+65535 - 0 = 65535
+65535 - 1 = 65534
+65535 - 2 = 65533
+65535 - 3 = 65532
+
+0 - 65533 = 3
+0 - 65534 = 2
+0 - 65535 = 1
+0 - 0 = 0
+0 - 1 = 65535
+0 - 2 = 65534
+0 - 3 = 65533
+
+1 - 65533 = 4
+1 - 65534 = 3
+1 - 65535 = 2
+1 - 0 = 1
+1 - 1 = 0
+1 - 2 = 65535
+1 - 3 = 65534
+
+2 - 65533 = 5
+2 - 65534 = 4
+2 - 65535 = 3
+2 - 0 = 2
+2 - 1 = 1
+2 - 2 = 0
+2 - 3 = 65535
+
+3 - 65533 = 6
+3 - 65534 = 5
+3 - 65535 = 4
+3 - 0 = 3
+3 - 1 = 2
+3 - 2 = 1
+3 - 3 = 0
+
+#
+65533 * 65533 = 9
+65533 * 65534 = 6
+65533 * 65535 = 3
+65533 * 0 = 0
+65533 * 1 = 65533
+65533 * 2 = 65530
+65533 * 3 = 65527
+
+65534 * 65533 = 6
+65534 * 65534 = 4
+65534 * 65535 = 2
+65534 * 0 = 0
+65534 * 1 = 65534
+65534 * 2 = 65532
+65534 * 3 = 65530
+
+65535 * 65533 = 3
+65535 * 65534 = 2
+65535 * 65535 = 1
+65535 * 0 = 0
+65535 * 1 = 65535
+65535 * 2 = 65534
+65535 * 3 = 65533
+
+0 * 65533 = 0
+0 * 65534 = 0
+0 * 65535 = 0
+0 * 0 = 0
+0 * 1 = 0
+0 * 2 = 0
+0 * 3 = 0
+
+1 * 65533 = 65533
+1 * 65534 = 65534
+1 * 65535 = 65535
+1 * 0 = 0
+1 * 1 = 1
+1 * 2 = 2
+1 * 3 = 3
+
+2 * 65533 = 65530
+2 * 65534 = 65532
+2 * 65535 = 65534
+2 * 0 = 0
+2 * 1 = 2
+2 * 2 = 4
+2 * 3 = 6
+
+3 * 65533 = 65527
+3 * 65534 = 65530
+3 * 65535 = 65533
+3 * 0 = 0
+3 * 1 = 3
+3 * 2 = 6
+3 * 3 = 9
+
+#
+negate 65533 = 3
+negate 65534 = 2
+negate 65535 = 1
+negate 0 = 0
+negate 1 = 65535
+negate 2 = 65534
+negate 3 = 65533
+#
+testReal
+toRational 65533 = 65533 % 1
+toRational 65534 = 65534 % 1
+toRational 65535 = 65535 % 1
+toRational 0 = 0 % 1
+toRational 1 = 1 % 1
+toRational 2 = 2 % 1
+toRational 3 = 3 % 1
+#
+testIntegral
+65533 `divMod` 65533 = (1,0)
+65533 `divMod` 65534 = (0,65533)
+65533 `divMod` 65535 = (0,65533)
+65533 `divMod` 1 = (65533,0)
+65533 `divMod` 2 = (32766,1)
+65533 `divMod` 3 = (21844,1)
+
+65534 `divMod` 65533 = (1,1)
+65534 `divMod` 65534 = (1,0)
+65534 `divMod` 65535 = (0,65534)
+65534 `divMod` 1 = (65534,0)
+65534 `divMod` 2 = (32767,0)
+65534 `divMod` 3 = (21844,2)
+
+65535 `divMod` 65533 = (1,2)
+65535 `divMod` 65534 = (1,1)
+65535 `divMod` 65535 = (1,0)
+65535 `divMod` 1 = (65535,0)
+65535 `divMod` 2 = (32767,1)
+65535 `divMod` 3 = (21845,0)
+
+0 `divMod` 65533 = (0,0)
+0 `divMod` 65534 = (0,0)
+0 `divMod` 65535 = (0,0)
+0 `divMod` 1 = (0,0)
+0 `divMod` 2 = (0,0)
+0 `divMod` 3 = (0,0)
+
+1 `divMod` 65533 = (0,1)
+1 `divMod` 65534 = (0,1)
+1 `divMod` 65535 = (0,1)
+1 `divMod` 1 = (1,0)
+1 `divMod` 2 = (0,1)
+1 `divMod` 3 = (0,1)
+
+2 `divMod` 65533 = (0,2)
+2 `divMod` 65534 = (0,2)
+2 `divMod` 65535 = (0,2)
+2 `divMod` 1 = (2,0)
+2 `divMod` 2 = (1,0)
+2 `divMod` 3 = (0,2)
+
+3 `divMod` 65533 = (0,3)
+3 `divMod` 65534 = (0,3)
+3 `divMod` 65535 = (0,3)
+3 `divMod` 1 = (3,0)
+3 `divMod` 2 = (1,1)
+3 `divMod` 3 = (1,0)
+
+#
+65533 `div` 65533 = 1
+65533 `div` 65534 = 0
+65533 `div` 65535 = 0
+65533 `div` 1 = 65533
+65533 `div` 2 = 32766
+65533 `div` 3 = 21844
+
+65534 `div` 65533 = 1
+65534 `div` 65534 = 1
+65534 `div` 65535 = 0
+65534 `div` 1 = 65534
+65534 `div` 2 = 32767
+65534 `div` 3 = 21844
+
+65535 `div` 65533 = 1
+65535 `div` 65534 = 1
+65535 `div` 65535 = 1
+65535 `div` 1 = 65535
+65535 `div` 2 = 32767
+65535 `div` 3 = 21845
+
+0 `div` 65533 = 0
+0 `div` 65534 = 0
+0 `div` 65535 = 0
+0 `div` 1 = 0
+0 `div` 2 = 0
+0 `div` 3 = 0
+
+1 `div` 65533 = 0
+1 `div` 65534 = 0
+1 `div` 65535 = 0
+1 `div` 1 = 1
+1 `div` 2 = 0
+1 `div` 3 = 0
+
+2 `div` 65533 = 0
+2 `div` 65534 = 0
+2 `div` 65535 = 0
+2 `div` 1 = 2
+2 `div` 2 = 1
+2 `div` 3 = 0
+
+3 `div` 65533 = 0
+3 `div` 65534 = 0
+3 `div` 65535 = 0
+3 `div` 1 = 3
+3 `div` 2 = 1
+3 `div` 3 = 1
+
+#
+65533 `mod` 65533 = 0
+65533 `mod` 65534 = 65533
+65533 `mod` 65535 = 65533
+65533 `mod` 1 = 0
+65533 `mod` 2 = 1
+65533 `mod` 3 = 1
+
+65534 `mod` 65533 = 1
+65534 `mod` 65534 = 0
+65534 `mod` 65535 = 65534
+65534 `mod` 1 = 0
+65534 `mod` 2 = 0
+65534 `mod` 3 = 2
+
+65535 `mod` 65533 = 2
+65535 `mod` 65534 = 1
+65535 `mod` 65535 = 0
+65535 `mod` 1 = 0
+65535 `mod` 2 = 1
+65535 `mod` 3 = 0
+
+0 `mod` 65533 = 0
+0 `mod` 65534 = 0
+0 `mod` 65535 = 0
+0 `mod` 1 = 0
+0 `mod` 2 = 0
+0 `mod` 3 = 0
+
+1 `mod` 65533 = 1
+1 `mod` 65534 = 1
+1 `mod` 65535 = 1
+1 `mod` 1 = 0
+1 `mod` 2 = 1
+1 `mod` 3 = 1
+
+2 `mod` 65533 = 2
+2 `mod` 65534 = 2
+2 `mod` 65535 = 2
+2 `mod` 1 = 0
+2 `mod` 2 = 0
+2 `mod` 3 = 2
+
+3 `mod` 65533 = 3
+3 `mod` 65534 = 3
+3 `mod` 65535 = 3
+3 `mod` 1 = 0
+3 `mod` 2 = 1
+3 `mod` 3 = 0
+
+#
+65533 `quotRem` 65533 = (1,0)
+65533 `quotRem` 65534 = (0,65533)
+65533 `quotRem` 65535 = (0,65533)
+65533 `quotRem` 1 = (65533,0)
+65533 `quotRem` 2 = (32766,1)
+65533 `quotRem` 3 = (21844,1)
+
+65534 `quotRem` 65533 = (1,1)
+65534 `quotRem` 65534 = (1,0)
+65534 `quotRem` 65535 = (0,65534)
+65534 `quotRem` 1 = (65534,0)
+65534 `quotRem` 2 = (32767,0)
+65534 `quotRem` 3 = (21844,2)
+
+65535 `quotRem` 65533 = (1,2)
+65535 `quotRem` 65534 = (1,1)
+65535 `quotRem` 65535 = (1,0)
+65535 `quotRem` 1 = (65535,0)
+65535 `quotRem` 2 = (32767,1)
+65535 `quotRem` 3 = (21845,0)
+
+0 `quotRem` 65533 = (0,0)
+0 `quotRem` 65534 = (0,0)
+0 `quotRem` 65535 = (0,0)
+0 `quotRem` 1 = (0,0)
+0 `quotRem` 2 = (0,0)
+0 `quotRem` 3 = (0,0)
+
+1 `quotRem` 65533 = (0,1)
+1 `quotRem` 65534 = (0,1)
+1 `quotRem` 65535 = (0,1)
+1 `quotRem` 1 = (1,0)
+1 `quotRem` 2 = (0,1)
+1 `quotRem` 3 = (0,1)
+
+2 `quotRem` 65533 = (0,2)
+2 `quotRem` 65534 = (0,2)
+2 `quotRem` 65535 = (0,2)
+2 `quotRem` 1 = (2,0)
+2 `quotRem` 2 = (1,0)
+2 `quotRem` 3 = (0,2)
+
+3 `quotRem` 65533 = (0,3)
+3 `quotRem` 65534 = (0,3)
+3 `quotRem` 65535 = (0,3)
+3 `quotRem` 1 = (3,0)
+3 `quotRem` 2 = (1,1)
+3 `quotRem` 3 = (1,0)
+
+#
+65533 `quot` 65533 = 1
+65533 `quot` 65534 = 0
+65533 `quot` 65535 = 0
+65533 `quot` 1 = 65533
+65533 `quot` 2 = 32766
+65533 `quot` 3 = 21844
+
+65534 `quot` 65533 = 1
+65534 `quot` 65534 = 1
+65534 `quot` 65535 = 0
+65534 `quot` 1 = 65534
+65534 `quot` 2 = 32767
+65534 `quot` 3 = 21844
+
+65535 `quot` 65533 = 1
+65535 `quot` 65534 = 1
+65535 `quot` 65535 = 1
+65535 `quot` 1 = 65535
+65535 `quot` 2 = 32767
+65535 `quot` 3 = 21845
+
+0 `quot` 65533 = 0
+0 `quot` 65534 = 0
+0 `quot` 65535 = 0
+0 `quot` 1 = 0
+0 `quot` 2 = 0
+0 `quot` 3 = 0
+
+1 `quot` 65533 = 0
+1 `quot` 65534 = 0
+1 `quot` 65535 = 0
+1 `quot` 1 = 1
+1 `quot` 2 = 0
+1 `quot` 3 = 0
+
+2 `quot` 65533 = 0
+2 `quot` 65534 = 0
+2 `quot` 65535 = 0
+2 `quot` 1 = 2
+2 `quot` 2 = 1
+2 `quot` 3 = 0
+
+3 `quot` 65533 = 0
+3 `quot` 65534 = 0
+3 `quot` 65535 = 0
+3 `quot` 1 = 3
+3 `quot` 2 = 1
+3 `quot` 3 = 1
+
+#
+65533 `rem` 65533 = 0
+65533 `rem` 65534 = 65533
+65533 `rem` 65535 = 65533
+65533 `rem` 1 = 0
+65533 `rem` 2 = 1
+65533 `rem` 3 = 1
+
+65534 `rem` 65533 = 1
+65534 `rem` 65534 = 0
+65534 `rem` 65535 = 65534
+65534 `rem` 1 = 0
+65534 `rem` 2 = 0
+65534 `rem` 3 = 2
+
+65535 `rem` 65533 = 2
+65535 `rem` 65534 = 1
+65535 `rem` 65535 = 0
+65535 `rem` 1 = 0
+65535 `rem` 2 = 1
+65535 `rem` 3 = 0
+
+0 `rem` 65533 = 0
+0 `rem` 65534 = 0
+0 `rem` 65535 = 0
+0 `rem` 1 = 0
+0 `rem` 2 = 0
+0 `rem` 3 = 0
+
+1 `rem` 65533 = 1
+1 `rem` 65534 = 1
+1 `rem` 65535 = 1
+1 `rem` 1 = 0
+1 `rem` 2 = 1
+1 `rem` 3 = 1
+
+2 `rem` 65533 = 2
+2 `rem` 65534 = 2
+2 `rem` 65535 = 2
+2 `rem` 1 = 0
+2 `rem` 2 = 0
+2 `rem` 3 = 2
+
+3 `rem` 65533 = 3
+3 `rem` 65534 = 3
+3 `rem` 65535 = 3
+3 `rem` 1 = 0
+3 `rem` 2 = 1
+3 `rem` 3 = 0
+
+#
+testBits
+65533 .&. 65533 = 65533
+65533 .&. 65534 = 65532
+65533 .&. 65535 = 65533
+65533 .&. 1 = 1
+65533 .&. 2 = 0
+65533 .&. 3 = 1
+
+65534 .&. 65533 = 65532
+65534 .&. 65534 = 65534
+65534 .&. 65535 = 65534
+65534 .&. 1 = 0
+65534 .&. 2 = 2
+65534 .&. 3 = 2
+
+65535 .&. 65533 = 65533
+65535 .&. 65534 = 65534
+65535 .&. 65535 = 65535
+65535 .&. 1 = 1
+65535 .&. 2 = 2
+65535 .&. 3 = 3
+
+0 .&. 65533 = 0
+0 .&. 65534 = 0
+0 .&. 65535 = 0
+0 .&. 1 = 0
+0 .&. 2 = 0
+0 .&. 3 = 0
+
+1 .&. 65533 = 1
+1 .&. 65534 = 0
+1 .&. 65535 = 1
+1 .&. 1 = 1
+1 .&. 2 = 0
+1 .&. 3 = 1
+
+2 .&. 65533 = 0
+2 .&. 65534 = 2
+2 .&. 65535 = 2
+2 .&. 1 = 0
+2 .&. 2 = 2
+2 .&. 3 = 2
+
+3 .&. 65533 = 1
+3 .&. 65534 = 2
+3 .&. 65535 = 3
+3 .&. 1 = 1
+3 .&. 2 = 2
+3 .&. 3 = 3
+
+#
+65533 .|. 65533 = 65533
+65533 .|. 65534 = 65535
+65533 .|. 65535 = 65535
+65533 .|. 1 = 65533
+65533 .|. 2 = 65535
+65533 .|. 3 = 65535
+
+65534 .|. 65533 = 65535
+65534 .|. 65534 = 65534
+65534 .|. 65535 = 65535
+65534 .|. 1 = 65535
+65534 .|. 2 = 65534
+65534 .|. 3 = 65535
+
+65535 .|. 65533 = 65535
+65535 .|. 65534 = 65535
+65535 .|. 65535 = 65535
+65535 .|. 1 = 65535
+65535 .|. 2 = 65535
+65535 .|. 3 = 65535
+
+0 .|. 65533 = 65533
+0 .|. 65534 = 65534
+0 .|. 65535 = 65535
+0 .|. 1 = 1
+0 .|. 2 = 2
+0 .|. 3 = 3
+
+1 .|. 65533 = 65533
+1 .|. 65534 = 65535
+1 .|. 65535 = 65535
+1 .|. 1 = 1
+1 .|. 2 = 3
+1 .|. 3 = 3
+
+2 .|. 65533 = 65535
+2 .|. 65534 = 65534
+2 .|. 65535 = 65535
+2 .|. 1 = 3
+2 .|. 2 = 2
+2 .|. 3 = 3
+
+3 .|. 65533 = 65535
+3 .|. 65534 = 65535
+3 .|. 65535 = 65535
+3 .|. 1 = 3
+3 .|. 2 = 3
+3 .|. 3 = 3
+
+#
+65533 `xor` 65533 = 0
+65533 `xor` 65534 = 3
+65533 `xor` 65535 = 2
+65533 `xor` 1 = 65532
+65533 `xor` 2 = 65535
+65533 `xor` 3 = 65534
+
+65534 `xor` 65533 = 3
+65534 `xor` 65534 = 0
+65534 `xor` 65535 = 1
+65534 `xor` 1 = 65535
+65534 `xor` 2 = 65532
+65534 `xor` 3 = 65533
+
+65535 `xor` 65533 = 2
+65535 `xor` 65534 = 1
+65535 `xor` 65535 = 0
+65535 `xor` 1 = 65534
+65535 `xor` 2 = 65533
+65535 `xor` 3 = 65532
+
+0 `xor` 65533 = 65533
+0 `xor` 65534 = 65534
+0 `xor` 65535 = 65535
+0 `xor` 1 = 1
+0 `xor` 2 = 2
+0 `xor` 3 = 3
+
+1 `xor` 65533 = 65532
+1 `xor` 65534 = 65535
+1 `xor` 65535 = 65534
+1 `xor` 1 = 0
+1 `xor` 2 = 3
+1 `xor` 3 = 2
+
+2 `xor` 65533 = 65535
+2 `xor` 65534 = 65532
+2 `xor` 65535 = 65533
+2 `xor` 1 = 3
+2 `xor` 2 = 0
+2 `xor` 3 = 1
+
+3 `xor` 65533 = 65534
+3 `xor` 65534 = 65533
+3 `xor` 65535 = 65532
+3 `xor` 1 = 2
+3 `xor` 2 = 1
+3 `xor` 3 = 0
+
+#
+complement 65533 = 2
+complement 65534 = 1
+complement 65535 = 0
+complement 0 = 65535
+complement 1 = 65534
+complement 2 = 65533
+complement 3 = 65532
+#
+65533 `shift` 0 = 65533
+65533 `shift` 1 = 65530
+65533 `shift` 2 = 65524
+65533 `shift` 3 = 65512
+
+65534 `shift` 0 = 65534
+65534 `shift` 1 = 65532
+65534 `shift` 2 = 65528
+65534 `shift` 3 = 65520
+
+65535 `shift` 0 = 65535
+65535 `shift` 1 = 65534
+65535 `shift` 2 = 65532
+65535 `shift` 3 = 65528
+
+0 `shift` 0 = 0
+0 `shift` 1 = 0
+0 `shift` 2 = 0
+0 `shift` 3 = 0
+
+1 `shift` 0 = 1
+1 `shift` 1 = 2
+1 `shift` 2 = 4
+1 `shift` 3 = 8
+
+2 `shift` 0 = 2
+2 `shift` 1 = 4
+2 `shift` 2 = 8
+2 `shift` 3 = 16
+
+3 `shift` 0 = 3
+3 `shift` 1 = 6
+3 `shift` 2 = 12
+3 `shift` 3 = 24
+
+#
+65533 `setBit` 0 = 65533
+65533 `setBit` 1 = 65535
+65533 `setBit` 2 = 65533
+65533 `setBit` 3 = 65533
+
+65534 `setBit` 0 = 65535
+65534 `setBit` 1 = 65534
+65534 `setBit` 2 = 65534
+65534 `setBit` 3 = 65534
+
+65535 `setBit` 0 = 65535
+65535 `setBit` 1 = 65535
+65535 `setBit` 2 = 65535
+65535 `setBit` 3 = 65535
+
+0 `setBit` 0 = 1
+0 `setBit` 1 = 2
+0 `setBit` 2 = 4
+0 `setBit` 3 = 8
+
+1 `setBit` 0 = 1
+1 `setBit` 1 = 3
+1 `setBit` 2 = 5
+1 `setBit` 3 = 9
+
+2 `setBit` 0 = 3
+2 `setBit` 1 = 2
+2 `setBit` 2 = 6
+2 `setBit` 3 = 10
+
+3 `setBit` 0 = 3
+3 `setBit` 1 = 3
+3 `setBit` 2 = 7
+3 `setBit` 3 = 11
+
+#
+65533 `clearBit` 0 = 65532
+65533 `clearBit` 1 = 65533
+65533 `clearBit` 2 = 65529
+65533 `clearBit` 3 = 65525
+
+65534 `clearBit` 0 = 65534
+65534 `clearBit` 1 = 65532
+65534 `clearBit` 2 = 65530
+65534 `clearBit` 3 = 65526
+
+65535 `clearBit` 0 = 65534
+65535 `clearBit` 1 = 65533
+65535 `clearBit` 2 = 65531
+65535 `clearBit` 3 = 65527
+
+0 `clearBit` 0 = 0
+0 `clearBit` 1 = 0
+0 `clearBit` 2 = 0
+0 `clearBit` 3 = 0
+
+1 `clearBit` 0 = 0
+1 `clearBit` 1 = 1
+1 `clearBit` 2 = 1
+1 `clearBit` 3 = 1
+
+2 `clearBit` 0 = 2
+2 `clearBit` 1 = 0
+2 `clearBit` 2 = 2
+2 `clearBit` 3 = 2
+
+3 `clearBit` 0 = 2
+3 `clearBit` 1 = 1
+3 `clearBit` 2 = 3
+3 `clearBit` 3 = 3
+
+#
+65533 `complementBit` 0 = 65532
+65533 `complementBit` 1 = 65535
+65533 `complementBit` 2 = 65529
+65533 `complementBit` 3 = 65525
+
+65534 `complementBit` 0 = 65535
+65534 `complementBit` 1 = 65532
+65534 `complementBit` 2 = 65530
+65534 `complementBit` 3 = 65526
+
+65535 `complementBit` 0 = 65534
+65535 `complementBit` 1 = 65533
+65535 `complementBit` 2 = 65531
+65535 `complementBit` 3 = 65527
+
+0 `complementBit` 0 = 1
+0 `complementBit` 1 = 2
+0 `complementBit` 2 = 4
+0 `complementBit` 3 = 8
+
+1 `complementBit` 0 = 0
+1 `complementBit` 1 = 3
+1 `complementBit` 2 = 5
+1 `complementBit` 3 = 9
+
+2 `complementBit` 0 = 3
+2 `complementBit` 1 = 0
+2 `complementBit` 2 = 6
+2 `complementBit` 3 = 10
+
+3 `complementBit` 0 = 2
+3 `complementBit` 1 = 1
+3 `complementBit` 2 = 7
+3 `complementBit` 3 = 11
+
+#
+65533 `testBit` 0 = True
+65533 `testBit` 1 = False
+65533 `testBit` 2 = True
+65533 `testBit` 3 = True
+
+65534 `testBit` 0 = False
+65534 `testBit` 1 = True
+65534 `testBit` 2 = True
+65534 `testBit` 3 = True
+
+65535 `testBit` 0 = True
+65535 `testBit` 1 = True
+65535 `testBit` 2 = True
+65535 `testBit` 3 = True
+
+0 `testBit` 0 = False
+0 `testBit` 1 = False
+0 `testBit` 2 = False
+0 `testBit` 3 = False
+
+1 `testBit` 0 = True
+1 `testBit` 1 = False
+1 `testBit` 2 = False
+1 `testBit` 3 = False
+
+2 `testBit` 0 = False
+2 `testBit` 1 = True
+2 `testBit` 2 = False
+2 `testBit` 3 = False
+
+3 `testBit` 0 = True
+3 `testBit` 1 = True
+3 `testBit` 2 = False
+3 `testBit` 3 = False
+
+#
+bitSize 65533 = 16
+bitSize 65534 = 16
+bitSize 65535 = 16
+bitSize 0 = 16
+bitSize 1 = 16
+bitSize 2 = 16
+bitSize 3 = 16
+#
+isSigned 65533 = False
+isSigned 65534 = False
+isSigned 65535 = False
+isSigned 0 = False
+isSigned 1 = False
+isSigned 2 = False
+isSigned 3 = False
+#
+--------------------------------
+--------------------------------
+--Testing Word32
+--------------------------------
+testBounded
+(4294967295,0,1)
+(4294967294,4294967295,0)
+testEnum
+[0,1,2,3,4,5,6,7,8,9]
+[0,2,4,6,8,10,12,14,16,18]
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
+[0,2,4,6,8,10,12,14,16,18,20]
+testReadShow
+[4294967293,4294967294,4294967295,0,1,2,3]
+[4294967293,4294967294,4294967295,0,1,2,3]
+testEq
+4294967293 == 4294967293 = True
+4294967293 == 4294967294 = False
+4294967293 == 4294967295 = False
+4294967293 == 0 = False
+4294967293 == 1 = False
+4294967293 == 2 = False
+4294967293 == 3 = False
+
+4294967294 == 4294967293 = False
+4294967294 == 4294967294 = True
+4294967294 == 4294967295 = False
+4294967294 == 0 = False
+4294967294 == 1 = False
+4294967294 == 2 = False
+4294967294 == 3 = False
+
+4294967295 == 4294967293 = False
+4294967295 == 4294967294 = False
+4294967295 == 4294967295 = True
+4294967295 == 0 = False
+4294967295 == 1 = False
+4294967295 == 2 = False
+4294967295 == 3 = False
+
+0 == 4294967293 = False
+0 == 4294967294 = False
+0 == 4294967295 = False
+0 == 0 = True
+0 == 1 = False
+0 == 2 = False
+0 == 3 = False
+
+1 == 4294967293 = False
+1 == 4294967294 = False
+1 == 4294967295 = False
+1 == 0 = False
+1 == 1 = True
+1 == 2 = False
+1 == 3 = False
+
+2 == 4294967293 = False
+2 == 4294967294 = False
+2 == 4294967295 = False
+2 == 0 = False
+2 == 1 = False
+2 == 2 = True
+2 == 3 = False
+
+3 == 4294967293 = False
+3 == 4294967294 = False
+3 == 4294967295 = False
+3 == 0 = False
+3 == 1 = False
+3 == 2 = False
+3 == 3 = True
+
+#
+4294967293 /= 4294967293 = False
+4294967293 /= 4294967294 = True
+4294967293 /= 4294967295 = True
+4294967293 /= 0 = True
+4294967293 /= 1 = True
+4294967293 /= 2 = True
+4294967293 /= 3 = True
+
+4294967294 /= 4294967293 = True
+4294967294 /= 4294967294 = False
+4294967294 /= 4294967295 = True
+4294967294 /= 0 = True
+4294967294 /= 1 = True
+4294967294 /= 2 = True
+4294967294 /= 3 = True
+
+4294967295 /= 4294967293 = True
+4294967295 /= 4294967294 = True
+4294967295 /= 4294967295 = False
+4294967295 /= 0 = True
+4294967295 /= 1 = True
+4294967295 /= 2 = True
+4294967295 /= 3 = True
+
+0 /= 4294967293 = True
+0 /= 4294967294 = True
+0 /= 4294967295 = True
+0 /= 0 = False
+0 /= 1 = True
+0 /= 2 = True
+0 /= 3 = True
+
+1 /= 4294967293 = True
+1 /= 4294967294 = True
+1 /= 4294967295 = True
+1 /= 0 = True
+1 /= 1 = False
+1 /= 2 = True
+1 /= 3 = True
+
+2 /= 4294967293 = True
+2 /= 4294967294 = True
+2 /= 4294967295 = True
+2 /= 0 = True
+2 /= 1 = True
+2 /= 2 = False
+2 /= 3 = True
+
+3 /= 4294967293 = True
+3 /= 4294967294 = True
+3 /= 4294967295 = True
+3 /= 0 = True
+3 /= 1 = True
+3 /= 2 = True
+3 /= 3 = False
+
+#
+testOrd
+4294967293 <= 4294967293 = True
+4294967293 <= 4294967294 = True
+4294967293 <= 4294967295 = True
+4294967293 <= 0 = False
+4294967293 <= 1 = False
+4294967293 <= 2 = False
+4294967293 <= 3 = False
+
+4294967294 <= 4294967293 = False
+4294967294 <= 4294967294 = True
+4294967294 <= 4294967295 = True
+4294967294 <= 0 = False
+4294967294 <= 1 = False
+4294967294 <= 2 = False
+4294967294 <= 3 = False
+
+4294967295 <= 4294967293 = False
+4294967295 <= 4294967294 = False
+4294967295 <= 4294967295 = True
+4294967295 <= 0 = False
+4294967295 <= 1 = False
+4294967295 <= 2 = False
+4294967295 <= 3 = False
+
+0 <= 4294967293 = True
+0 <= 4294967294 = True
+0 <= 4294967295 = True
+0 <= 0 = True
+0 <= 1 = True
+0 <= 2 = True
+0 <= 3 = True
+
+1 <= 4294967293 = True
+1 <= 4294967294 = True
+1 <= 4294967295 = True
+1 <= 0 = False
+1 <= 1 = True
+1 <= 2 = True
+1 <= 3 = True
+
+2 <= 4294967293 = True
+2 <= 4294967294 = True
+2 <= 4294967295 = True
+2 <= 0 = False
+2 <= 1 = False
+2 <= 2 = True
+2 <= 3 = True
+
+3 <= 4294967293 = True
+3 <= 4294967294 = True
+3 <= 4294967295 = True
+3 <= 0 = False
+3 <= 1 = False
+3 <= 2 = False
+3 <= 3 = True
+
+#
+4294967293 < 4294967293 = False
+4294967293 < 4294967294 = True
+4294967293 < 4294967295 = True
+4294967293 < 0 = False
+4294967293 < 1 = False
+4294967293 < 2 = False
+4294967293 < 3 = False
+
+4294967294 < 4294967293 = False
+4294967294 < 4294967294 = False
+4294967294 < 4294967295 = True
+4294967294 < 0 = False
+4294967294 < 1 = False
+4294967294 < 2 = False
+4294967294 < 3 = False
+
+4294967295 < 4294967293 = False
+4294967295 < 4294967294 = False
+4294967295 < 4294967295 = False
+4294967295 < 0 = False
+4294967295 < 1 = False
+4294967295 < 2 = False
+4294967295 < 3 = False
+
+0 < 4294967293 = True
+0 < 4294967294 = True
+0 < 4294967295 = True
+0 < 0 = False
+0 < 1 = True
+0 < 2 = True
+0 < 3 = True
+
+1 < 4294967293 = True
+1 < 4294967294 = True
+1 < 4294967295 = True
+1 < 0 = False
+1 < 1 = False
+1 < 2 = True
+1 < 3 = True
+
+2 < 4294967293 = True
+2 < 4294967294 = True
+2 < 4294967295 = True
+2 < 0 = False
+2 < 1 = False
+2 < 2 = False
+2 < 3 = True
+
+3 < 4294967293 = True
+3 < 4294967294 = True
+3 < 4294967295 = True
+3 < 0 = False
+3 < 1 = False
+3 < 2 = False
+3 < 3 = False
+
+#
+4294967293 > 4294967293 = False
+4294967293 > 4294967294 = False
+4294967293 > 4294967295 = False
+4294967293 > 0 = True
+4294967293 > 1 = True
+4294967293 > 2 = True
+4294967293 > 3 = True
+
+4294967294 > 4294967293 = True
+4294967294 > 4294967294 = False
+4294967294 > 4294967295 = False
+4294967294 > 0 = True
+4294967294 > 1 = True
+4294967294 > 2 = True
+4294967294 > 3 = True
+
+4294967295 > 4294967293 = True
+4294967295 > 4294967294 = True
+4294967295 > 4294967295 = False
+4294967295 > 0 = True
+4294967295 > 1 = True
+4294967295 > 2 = True
+4294967295 > 3 = True
+
+0 > 4294967293 = False
+0 > 4294967294 = False
+0 > 4294967295 = False
+0 > 0 = False
+0 > 1 = False
+0 > 2 = False
+0 > 3 = False
+
+1 > 4294967293 = False
+1 > 4294967294 = False
+1 > 4294967295 = False
+1 > 0 = True
+1 > 1 = False
+1 > 2 = False
+1 > 3 = False
+
+2 > 4294967293 = False
+2 > 4294967294 = False
+2 > 4294967295 = False
+2 > 0 = True
+2 > 1 = True
+2 > 2 = False
+2 > 3 = False
+
+3 > 4294967293 = False
+3 > 4294967294 = False
+3 > 4294967295 = False
+3 > 0 = True
+3 > 1 = True
+3 > 2 = True
+3 > 3 = False
+
+#
+4294967293 >= 4294967293 = True
+4294967293 >= 4294967294 = False
+4294967293 >= 4294967295 = False
+4294967293 >= 0 = True
+4294967293 >= 1 = True
+4294967293 >= 2 = True
+4294967293 >= 3 = True
+
+4294967294 >= 4294967293 = True
+4294967294 >= 4294967294 = True
+4294967294 >= 4294967295 = False
+4294967294 >= 0 = True
+4294967294 >= 1 = True
+4294967294 >= 2 = True
+4294967294 >= 3 = True
+
+4294967295 >= 4294967293 = True
+4294967295 >= 4294967294 = True
+4294967295 >= 4294967295 = True
+4294967295 >= 0 = True
+4294967295 >= 1 = True
+4294967295 >= 2 = True
+4294967295 >= 3 = True
+
+0 >= 4294967293 = False
+0 >= 4294967294 = False
+0 >= 4294967295 = False
+0 >= 0 = True
+0 >= 1 = False
+0 >= 2 = False
+0 >= 3 = False
+
+1 >= 4294967293 = False
+1 >= 4294967294 = False
+1 >= 4294967295 = False
+1 >= 0 = True
+1 >= 1 = True
+1 >= 2 = False
+1 >= 3 = False
+
+2 >= 4294967293 = False
+2 >= 4294967294 = False
+2 >= 4294967295 = False
+2 >= 0 = True
+2 >= 1 = True
+2 >= 2 = True
+2 >= 3 = False
+
+3 >= 4294967293 = False
+3 >= 4294967294 = False
+3 >= 4294967295 = False
+3 >= 0 = True
+3 >= 1 = True
+3 >= 2 = True
+3 >= 3 = True
+
+#
+4294967293 `compare` 4294967293 = EQ
+4294967293 `compare` 4294967294 = LT
+4294967293 `compare` 4294967295 = LT
+4294967293 `compare` 0 = GT
+4294967293 `compare` 1 = GT
+4294967293 `compare` 2 = GT
+4294967293 `compare` 3 = GT
+
+4294967294 `compare` 4294967293 = GT
+4294967294 `compare` 4294967294 = EQ
+4294967294 `compare` 4294967295 = LT
+4294967294 `compare` 0 = GT
+4294967294 `compare` 1 = GT
+4294967294 `compare` 2 = GT
+4294967294 `compare` 3 = GT
+
+4294967295 `compare` 4294967293 = GT
+4294967295 `compare` 4294967294 = GT
+4294967295 `compare` 4294967295 = EQ
+4294967295 `compare` 0 = GT
+4294967295 `compare` 1 = GT
+4294967295 `compare` 2 = GT
+4294967295 `compare` 3 = GT
+
+0 `compare` 4294967293 = LT
+0 `compare` 4294967294 = LT
+0 `compare` 4294967295 = LT
+0 `compare` 0 = EQ
+0 `compare` 1 = LT
+0 `compare` 2 = LT
+0 `compare` 3 = LT
+
+1 `compare` 4294967293 = LT
+1 `compare` 4294967294 = LT
+1 `compare` 4294967295 = LT
+1 `compare` 0 = GT
+1 `compare` 1 = EQ
+1 `compare` 2 = LT
+1 `compare` 3 = LT
+
+2 `compare` 4294967293 = LT
+2 `compare` 4294967294 = LT
+2 `compare` 4294967295 = LT
+2 `compare` 0 = GT
+2 `compare` 1 = GT
+2 `compare` 2 = EQ
+2 `compare` 3 = LT
+
+3 `compare` 4294967293 = LT
+3 `compare` 4294967294 = LT
+3 `compare` 4294967295 = LT
+3 `compare` 0 = GT
+3 `compare` 1 = GT
+3 `compare` 2 = GT
+3 `compare` 3 = EQ
+
+#
+testNum
+4294967293 + 4294967293 = 4294967290
+4294967293 + 4294967294 = 4294967291
+4294967293 + 4294967295 = 4294967292
+4294967293 + 0 = 4294967293
+4294967293 + 1 = 4294967294
+4294967293 + 2 = 4294967295
+4294967293 + 3 = 0
+
+4294967294 + 4294967293 = 4294967291
+4294967294 + 4294967294 = 4294967292
+4294967294 + 4294967295 = 4294967293
+4294967294 + 0 = 4294967294
+4294967294 + 1 = 4294967295
+4294967294 + 2 = 0
+4294967294 + 3 = 1
+
+4294967295 + 4294967293 = 4294967292
+4294967295 + 4294967294 = 4294967293
+4294967295 + 4294967295 = 4294967294
+4294967295 + 0 = 4294967295
+4294967295 + 1 = 0
+4294967295 + 2 = 1
+4294967295 + 3 = 2
+
+0 + 4294967293 = 4294967293
+0 + 4294967294 = 4294967294
+0 + 4294967295 = 4294967295
+0 + 0 = 0
+0 + 1 = 1
+0 + 2 = 2
+0 + 3 = 3
+
+1 + 4294967293 = 4294967294
+1 + 4294967294 = 4294967295
+1 + 4294967295 = 0
+1 + 0 = 1
+1 + 1 = 2
+1 + 2 = 3
+1 + 3 = 4
+
+2 + 4294967293 = 4294967295
+2 + 4294967294 = 0
+2 + 4294967295 = 1
+2 + 0 = 2
+2 + 1 = 3
+2 + 2 = 4
+2 + 3 = 5
+
+3 + 4294967293 = 0
+3 + 4294967294 = 1
+3 + 4294967295 = 2
+3 + 0 = 3
+3 + 1 = 4
+3 + 2 = 5
+3 + 3 = 6
+
+#
+4294967293 - 4294967293 = 0
+4294967293 - 4294967294 = 4294967295
+4294967293 - 4294967295 = 4294967294
+4294967293 - 0 = 4294967293
+4294967293 - 1 = 4294967292
+4294967293 - 2 = 4294967291
+4294967293 - 3 = 4294967290
+
+4294967294 - 4294967293 = 1
+4294967294 - 4294967294 = 0
+4294967294 - 4294967295 = 4294967295
+4294967294 - 0 = 4294967294
+4294967294 - 1 = 4294967293
+4294967294 - 2 = 4294967292
+4294967294 - 3 = 4294967291
+
+4294967295 - 4294967293 = 2
+4294967295 - 4294967294 = 1
+4294967295 - 4294967295 = 0
+4294967295 - 0 = 4294967295
+4294967295 - 1 = 4294967294
+4294967295 - 2 = 4294967293
+4294967295 - 3 = 4294967292
+
+0 - 4294967293 = 3
+0 - 4294967294 = 2
+0 - 4294967295 = 1
+0 - 0 = 0
+0 - 1 = 4294967295
+0 - 2 = 4294967294
+0 - 3 = 4294967293
+
+1 - 4294967293 = 4
+1 - 4294967294 = 3
+1 - 4294967295 = 2
+1 - 0 = 1
+1 - 1 = 0
+1 - 2 = 4294967295
+1 - 3 = 4294967294
+
+2 - 4294967293 = 5
+2 - 4294967294 = 4
+2 - 4294967295 = 3
+2 - 0 = 2
+2 - 1 = 1
+2 - 2 = 0
+2 - 3 = 4294967295
+
+3 - 4294967293 = 6
+3 - 4294967294 = 5
+3 - 4294967295 = 4
+3 - 0 = 3
+3 - 1 = 2
+3 - 2 = 1
+3 - 3 = 0
+
+#
+4294967293 * 4294967293 = 9
+4294967293 * 4294967294 = 6
+4294967293 * 4294967295 = 3
+4294967293 * 0 = 0
+4294967293 * 1 = 4294967293
+4294967293 * 2 = 4294967290
+4294967293 * 3 = 4294967287
+
+4294967294 * 4294967293 = 6
+4294967294 * 4294967294 = 4
+4294967294 * 4294967295 = 2
+4294967294 * 0 = 0
+4294967294 * 1 = 4294967294
+4294967294 * 2 = 4294967292
+4294967294 * 3 = 4294967290
+
+4294967295 * 4294967293 = 3
+4294967295 * 4294967294 = 2
+4294967295 * 4294967295 = 1
+4294967295 * 0 = 0
+4294967295 * 1 = 4294967295
+4294967295 * 2 = 4294967294
+4294967295 * 3 = 4294967293
+
+0 * 4294967293 = 0
+0 * 4294967294 = 0
+0 * 4294967295 = 0
+0 * 0 = 0
+0 * 1 = 0
+0 * 2 = 0
+0 * 3 = 0
+
+1 * 4294967293 = 4294967293
+1 * 4294967294 = 4294967294
+1 * 4294967295 = 4294967295
+1 * 0 = 0
+1 * 1 = 1
+1 * 2 = 2
+1 * 3 = 3
+
+2 * 4294967293 = 4294967290
+2 * 4294967294 = 4294967292
+2 * 4294967295 = 4294967294
+2 * 0 = 0
+2 * 1 = 2
+2 * 2 = 4
+2 * 3 = 6
+
+3 * 4294967293 = 4294967287
+3 * 4294967294 = 4294967290
+3 * 4294967295 = 4294967293
+3 * 0 = 0
+3 * 1 = 3
+3 * 2 = 6
+3 * 3 = 9
+
+#
+negate 4294967293 = 3
+negate 4294967294 = 2
+negate 4294967295 = 1
+negate 0 = 0
+negate 1 = 4294967295
+negate 2 = 4294967294
+negate 3 = 4294967293
+#
+testReal
+toRational 4294967293 = 4294967293 % 1
+toRational 4294967294 = 4294967294 % 1
+toRational 4294967295 = 4294967295 % 1
+toRational 0 = 0 % 1
+toRational 1 = 1 % 1
+toRational 2 = 2 % 1
+toRational 3 = 3 % 1
+#
+testIntegral
+4294967293 `divMod` 4294967293 = (1,0)
+4294967293 `divMod` 4294967294 = (0,4294967293)
+4294967293 `divMod` 4294967295 = (0,4294967293)
+4294967293 `divMod` 1 = (4294967293,0)
+4294967293 `divMod` 2 = (2147483646,1)
+4294967293 `divMod` 3 = (1431655764,1)
+
+4294967294 `divMod` 4294967293 = (1,1)
+4294967294 `divMod` 4294967294 = (1,0)
+4294967294 `divMod` 4294967295 = (0,4294967294)
+4294967294 `divMod` 1 = (4294967294,0)
+4294967294 `divMod` 2 = (2147483647,0)
+4294967294 `divMod` 3 = (1431655764,2)
+
+4294967295 `divMod` 4294967293 = (1,2)
+4294967295 `divMod` 4294967294 = (1,1)
+4294967295 `divMod` 4294967295 = (1,0)
+4294967295 `divMod` 1 = (4294967295,0)
+4294967295 `divMod` 2 = (2147483647,1)
+4294967295 `divMod` 3 = (1431655765,0)
+
+0 `divMod` 4294967293 = (0,0)
+0 `divMod` 4294967294 = (0,0)
+0 `divMod` 4294967295 = (0,0)
+0 `divMod` 1 = (0,0)
+0 `divMod` 2 = (0,0)
+0 `divMod` 3 = (0,0)
+
+1 `divMod` 4294967293 = (0,1)
+1 `divMod` 4294967294 = (0,1)
+1 `divMod` 4294967295 = (0,1)
+1 `divMod` 1 = (1,0)
+1 `divMod` 2 = (0,1)
+1 `divMod` 3 = (0,1)
+
+2 `divMod` 4294967293 = (0,2)
+2 `divMod` 4294967294 = (0,2)
+2 `divMod` 4294967295 = (0,2)
+2 `divMod` 1 = (2,0)
+2 `divMod` 2 = (1,0)
+2 `divMod` 3 = (0,2)
+
+3 `divMod` 4294967293 = (0,3)
+3 `divMod` 4294967294 = (0,3)
+3 `divMod` 4294967295 = (0,3)
+3 `divMod` 1 = (3,0)
+3 `divMod` 2 = (1,1)
+3 `divMod` 3 = (1,0)
+
+#
+4294967293 `div` 4294967293 = 1
+4294967293 `div` 4294967294 = 0
+4294967293 `div` 4294967295 = 0
+4294967293 `div` 1 = 4294967293
+4294967293 `div` 2 = 2147483646
+4294967293 `div` 3 = 1431655764
+
+4294967294 `div` 4294967293 = 1
+4294967294 `div` 4294967294 = 1
+4294967294 `div` 4294967295 = 0
+4294967294 `div` 1 = 4294967294
+4294967294 `div` 2 = 2147483647
+4294967294 `div` 3 = 1431655764
+
+4294967295 `div` 4294967293 = 1
+4294967295 `div` 4294967294 = 1
+4294967295 `div` 4294967295 = 1
+4294967295 `div` 1 = 4294967295
+4294967295 `div` 2 = 2147483647
+4294967295 `div` 3 = 1431655765
+
+0 `div` 4294967293 = 0
+0 `div` 4294967294 = 0
+0 `div` 4294967295 = 0
+0 `div` 1 = 0
+0 `div` 2 = 0
+0 `div` 3 = 0
+
+1 `div` 4294967293 = 0
+1 `div` 4294967294 = 0
+1 `div` 4294967295 = 0
+1 `div` 1 = 1
+1 `div` 2 = 0
+1 `div` 3 = 0
+
+2 `div` 4294967293 = 0
+2 `div` 4294967294 = 0
+2 `div` 4294967295 = 0
+2 `div` 1 = 2
+2 `div` 2 = 1
+2 `div` 3 = 0
+
+3 `div` 4294967293 = 0
+3 `div` 4294967294 = 0
+3 `div` 4294967295 = 0
+3 `div` 1 = 3
+3 `div` 2 = 1
+3 `div` 3 = 1
+
+#
+4294967293 `mod` 4294967293 = 0
+4294967293 `mod` 4294967294 = 4294967293
+4294967293 `mod` 4294967295 = 4294967293
+4294967293 `mod` 1 = 0
+4294967293 `mod` 2 = 1
+4294967293 `mod` 3 = 1
+
+4294967294 `mod` 4294967293 = 1
+4294967294 `mod` 4294967294 = 0
+4294967294 `mod` 4294967295 = 4294967294
+4294967294 `mod` 1 = 0
+4294967294 `mod` 2 = 0
+4294967294 `mod` 3 = 2
+
+4294967295 `mod` 4294967293 = 2
+4294967295 `mod` 4294967294 = 1
+4294967295 `mod` 4294967295 = 0
+4294967295 `mod` 1 = 0
+4294967295 `mod` 2 = 1
+4294967295 `mod` 3 = 0
+
+0 `mod` 4294967293 = 0
+0 `mod` 4294967294 = 0
+0 `mod` 4294967295 = 0
+0 `mod` 1 = 0
+0 `mod` 2 = 0
+0 `mod` 3 = 0
+
+1 `mod` 4294967293 = 1
+1 `mod` 4294967294 = 1
+1 `mod` 4294967295 = 1
+1 `mod` 1 = 0
+1 `mod` 2 = 1
+1 `mod` 3 = 1
+
+2 `mod` 4294967293 = 2
+2 `mod` 4294967294 = 2
+2 `mod` 4294967295 = 2
+2 `mod` 1 = 0
+2 `mod` 2 = 0
+2 `mod` 3 = 2
+
+3 `mod` 4294967293 = 3
+3 `mod` 4294967294 = 3
+3 `mod` 4294967295 = 3
+3 `mod` 1 = 0
+3 `mod` 2 = 1
+3 `mod` 3 = 0
+
+#
+4294967293 `quotRem` 4294967293 = (1,0)
+4294967293 `quotRem` 4294967294 = (0,4294967293)
+4294967293 `quotRem` 4294967295 = (0,4294967293)
+4294967293 `quotRem` 1 = (4294967293,0)
+4294967293 `quotRem` 2 = (2147483646,1)
+4294967293 `quotRem` 3 = (1431655764,1)
+
+4294967294 `quotRem` 4294967293 = (1,1)
+4294967294 `quotRem` 4294967294 = (1,0)
+4294967294 `quotRem` 4294967295 = (0,4294967294)
+4294967294 `quotRem` 1 = (4294967294,0)
+4294967294 `quotRem` 2 = (2147483647,0)
+4294967294 `quotRem` 3 = (1431655764,2)
+
+4294967295 `quotRem` 4294967293 = (1,2)
+4294967295 `quotRem` 4294967294 = (1,1)
+4294967295 `quotRem` 4294967295 = (1,0)
+4294967295 `quotRem` 1 = (4294967295,0)
+4294967295 `quotRem` 2 = (2147483647,1)
+4294967295 `quotRem` 3 = (1431655765,0)
+
+0 `quotRem` 4294967293 = (0,0)
+0 `quotRem` 4294967294 = (0,0)
+0 `quotRem` 4294967295 = (0,0)
+0 `quotRem` 1 = (0,0)
+0 `quotRem` 2 = (0,0)
+0 `quotRem` 3 = (0,0)
+
+1 `quotRem` 4294967293 = (0,1)
+1 `quotRem` 4294967294 = (0,1)
+1 `quotRem` 4294967295 = (0,1)
+1 `quotRem` 1 = (1,0)
+1 `quotRem` 2 = (0,1)
+1 `quotRem` 3 = (0,1)
+
+2 `quotRem` 4294967293 = (0,2)
+2 `quotRem` 4294967294 = (0,2)
+2 `quotRem` 4294967295 = (0,2)
+2 `quotRem` 1 = (2,0)
+2 `quotRem` 2 = (1,0)
+2 `quotRem` 3 = (0,2)
+
+3 `quotRem` 4294967293 = (0,3)
+3 `quotRem` 4294967294 = (0,3)
+3 `quotRem` 4294967295 = (0,3)
+3 `quotRem` 1 = (3,0)
+3 `quotRem` 2 = (1,1)
+3 `quotRem` 3 = (1,0)
+
+#
+4294967293 `quot` 4294967293 = 1
+4294967293 `quot` 4294967294 = 0
+4294967293 `quot` 4294967295 = 0
+4294967293 `quot` 1 = 4294967293
+4294967293 `quot` 2 = 2147483646
+4294967293 `quot` 3 = 1431655764
+
+4294967294 `quot` 4294967293 = 1
+4294967294 `quot` 4294967294 = 1
+4294967294 `quot` 4294967295 = 0
+4294967294 `quot` 1 = 4294967294
+4294967294 `quot` 2 = 2147483647
+4294967294 `quot` 3 = 1431655764
+
+4294967295 `quot` 4294967293 = 1
+4294967295 `quot` 4294967294 = 1
+4294967295 `quot` 4294967295 = 1
+4294967295 `quot` 1 = 4294967295
+4294967295 `quot` 2 = 2147483647
+4294967295 `quot` 3 = 1431655765
+
+0 `quot` 4294967293 = 0
+0 `quot` 4294967294 = 0
+0 `quot` 4294967295 = 0
+0 `quot` 1 = 0
+0 `quot` 2 = 0
+0 `quot` 3 = 0
+
+1 `quot` 4294967293 = 0
+1 `quot` 4294967294 = 0
+1 `quot` 4294967295 = 0
+1 `quot` 1 = 1
+1 `quot` 2 = 0
+1 `quot` 3 = 0
+
+2 `quot` 4294967293 = 0
+2 `quot` 4294967294 = 0
+2 `quot` 4294967295 = 0
+2 `quot` 1 = 2
+2 `quot` 2 = 1
+2 `quot` 3 = 0
+
+3 `quot` 4294967293 = 0
+3 `quot` 4294967294 = 0
+3 `quot` 4294967295 = 0
+3 `quot` 1 = 3
+3 `quot` 2 = 1
+3 `quot` 3 = 1
+
+#
+4294967293 `rem` 4294967293 = 0
+4294967293 `rem` 4294967294 = 4294967293
+4294967293 `rem` 4294967295 = 4294967293
+4294967293 `rem` 1 = 0
+4294967293 `rem` 2 = 1
+4294967293 `rem` 3 = 1
+
+4294967294 `rem` 4294967293 = 1
+4294967294 `rem` 4294967294 = 0
+4294967294 `rem` 4294967295 = 4294967294
+4294967294 `rem` 1 = 0
+4294967294 `rem` 2 = 0
+4294967294 `rem` 3 = 2
+
+4294967295 `rem` 4294967293 = 2
+4294967295 `rem` 4294967294 = 1
+4294967295 `rem` 4294967295 = 0
+4294967295 `rem` 1 = 0
+4294967295 `rem` 2 = 1
+4294967295 `rem` 3 = 0
+
+0 `rem` 4294967293 = 0
+0 `rem` 4294967294 = 0
+0 `rem` 4294967295 = 0
+0 `rem` 1 = 0
+0 `rem` 2 = 0
+0 `rem` 3 = 0
+
+1 `rem` 4294967293 = 1
+1 `rem` 4294967294 = 1
+1 `rem` 4294967295 = 1
+1 `rem` 1 = 0
+1 `rem` 2 = 1
+1 `rem` 3 = 1
+
+2 `rem` 4294967293 = 2
+2 `rem` 4294967294 = 2
+2 `rem` 4294967295 = 2
+2 `rem` 1 = 0
+2 `rem` 2 = 0
+2 `rem` 3 = 2
+
+3 `rem` 4294967293 = 3
+3 `rem` 4294967294 = 3
+3 `rem` 4294967295 = 3
+3 `rem` 1 = 0
+3 `rem` 2 = 1
+3 `rem` 3 = 0
+
+#
+testBits
+4294967293 .&. 4294967293 = 4294967293
+4294967293 .&. 4294967294 = 4294967292
+4294967293 .&. 4294967295 = 4294967293
+4294967293 .&. 1 = 1
+4294967293 .&. 2 = 0
+4294967293 .&. 3 = 1
+
+4294967294 .&. 4294967293 = 4294967292
+4294967294 .&. 4294967294 = 4294967294
+4294967294 .&. 4294967295 = 4294967294
+4294967294 .&. 1 = 0
+4294967294 .&. 2 = 2
+4294967294 .&. 3 = 2
+
+4294967295 .&. 4294967293 = 4294967293
+4294967295 .&. 4294967294 = 4294967294
+4294967295 .&. 4294967295 = 4294967295
+4294967295 .&. 1 = 1
+4294967295 .&. 2 = 2
+4294967295 .&. 3 = 3
+
+0 .&. 4294967293 = 0
+0 .&. 4294967294 = 0
+0 .&. 4294967295 = 0
+0 .&. 1 = 0
+0 .&. 2 = 0
+0 .&. 3 = 0
+
+1 .&. 4294967293 = 1
+1 .&. 4294967294 = 0
+1 .&. 4294967295 = 1
+1 .&. 1 = 1
+1 .&. 2 = 0
+1 .&. 3 = 1
+
+2 .&. 4294967293 = 0
+2 .&. 4294967294 = 2
+2 .&. 4294967295 = 2
+2 .&. 1 = 0
+2 .&. 2 = 2
+2 .&. 3 = 2
+
+3 .&. 4294967293 = 1
+3 .&. 4294967294 = 2
+3 .&. 4294967295 = 3
+3 .&. 1 = 1
+3 .&. 2 = 2
+3 .&. 3 = 3
+
+#
+4294967293 .|. 4294967293 = 4294967293
+4294967293 .|. 4294967294 = 4294967295
+4294967293 .|. 4294967295 = 4294967295
+4294967293 .|. 1 = 4294967293
+4294967293 .|. 2 = 4294967295
+4294967293 .|. 3 = 4294967295
+
+4294967294 .|. 4294967293 = 4294967295
+4294967294 .|. 4294967294 = 4294967294
+4294967294 .|. 4294967295 = 4294967295
+4294967294 .|. 1 = 4294967295
+4294967294 .|. 2 = 4294967294
+4294967294 .|. 3 = 4294967295
+
+4294967295 .|. 4294967293 = 4294967295
+4294967295 .|. 4294967294 = 4294967295
+4294967295 .|. 4294967295 = 4294967295
+4294967295 .|. 1 = 4294967295
+4294967295 .|. 2 = 4294967295
+4294967295 .|. 3 = 4294967295
+
+0 .|. 4294967293 = 4294967293
+0 .|. 4294967294 = 4294967294
+0 .|. 4294967295 = 4294967295
+0 .|. 1 = 1
+0 .|. 2 = 2
+0 .|. 3 = 3
+
+1 .|. 4294967293 = 4294967293
+1 .|. 4294967294 = 4294967295
+1 .|. 4294967295 = 4294967295
+1 .|. 1 = 1
+1 .|. 2 = 3
+1 .|. 3 = 3
+
+2 .|. 4294967293 = 4294967295
+2 .|. 4294967294 = 4294967294
+2 .|. 4294967295 = 4294967295
+2 .|. 1 = 3
+2 .|. 2 = 2
+2 .|. 3 = 3
+
+3 .|. 4294967293 = 4294967295
+3 .|. 4294967294 = 4294967295
+3 .|. 4294967295 = 4294967295
+3 .|. 1 = 3
+3 .|. 2 = 3
+3 .|. 3 = 3
+
+#
+4294967293 `xor` 4294967293 = 0
+4294967293 `xor` 4294967294 = 3
+4294967293 `xor` 4294967295 = 2
+4294967293 `xor` 1 = 4294967292
+4294967293 `xor` 2 = 4294967295
+4294967293 `xor` 3 = 4294967294
+
+4294967294 `xor` 4294967293 = 3
+4294967294 `xor` 4294967294 = 0
+4294967294 `xor` 4294967295 = 1
+4294967294 `xor` 1 = 4294967295
+4294967294 `xor` 2 = 4294967292
+4294967294 `xor` 3 = 4294967293
+
+4294967295 `xor` 4294967293 = 2
+4294967295 `xor` 4294967294 = 1
+4294967295 `xor` 4294967295 = 0
+4294967295 `xor` 1 = 4294967294
+4294967295 `xor` 2 = 4294967293
+4294967295 `xor` 3 = 4294967292
+
+0 `xor` 4294967293 = 4294967293
+0 `xor` 4294967294 = 4294967294
+0 `xor` 4294967295 = 4294967295
+0 `xor` 1 = 1
+0 `xor` 2 = 2
+0 `xor` 3 = 3
+
+1 `xor` 4294967293 = 4294967292
+1 `xor` 4294967294 = 4294967295
+1 `xor` 4294967295 = 4294967294
+1 `xor` 1 = 0
+1 `xor` 2 = 3
+1 `xor` 3 = 2
+
+2 `xor` 4294967293 = 4294967295
+2 `xor` 4294967294 = 4294967292
+2 `xor` 4294967295 = 4294967293
+2 `xor` 1 = 3
+2 `xor` 2 = 0
+2 `xor` 3 = 1
+
+3 `xor` 4294967293 = 4294967294
+3 `xor` 4294967294 = 4294967293
+3 `xor` 4294967295 = 4294967292
+3 `xor` 1 = 2
+3 `xor` 2 = 1
+3 `xor` 3 = 0
+
+#
+complement 4294967293 = 2
+complement 4294967294 = 1
+complement 4294967295 = 0
+complement 0 = 4294967295
+complement 1 = 4294967294
+complement 2 = 4294967293
+complement 3 = 4294967292
+#
+4294967293 `shift` 0 = 4294967293
+4294967293 `shift` 1 = 4294967290
+4294967293 `shift` 2 = 4294967284
+4294967293 `shift` 3 = 4294967272
+
+4294967294 `shift` 0 = 4294967294
+4294967294 `shift` 1 = 4294967292
+4294967294 `shift` 2 = 4294967288
+4294967294 `shift` 3 = 4294967280
+
+4294967295 `shift` 0 = 4294967295
+4294967295 `shift` 1 = 4294967294
+4294967295 `shift` 2 = 4294967292
+4294967295 `shift` 3 = 4294967288
+
+0 `shift` 0 = 0
+0 `shift` 1 = 0
+0 `shift` 2 = 0
+0 `shift` 3 = 0
+
+1 `shift` 0 = 1
+1 `shift` 1 = 2
+1 `shift` 2 = 4
+1 `shift` 3 = 8
+
+2 `shift` 0 = 2
+2 `shift` 1 = 4
+2 `shift` 2 = 8
+2 `shift` 3 = 16
+
+3 `shift` 0 = 3
+3 `shift` 1 = 6
+3 `shift` 2 = 12
+3 `shift` 3 = 24
+
+#
+4294967293 `setBit` 0 = 4294967293
+4294967293 `setBit` 1 = 4294967295
+4294967293 `setBit` 2 = 4294967293
+4294967293 `setBit` 3 = 4294967293
+
+4294967294 `setBit` 0 = 4294967295
+4294967294 `setBit` 1 = 4294967294
+4294967294 `setBit` 2 = 4294967294
+4294967294 `setBit` 3 = 4294967294
+
+4294967295 `setBit` 0 = 4294967295
+4294967295 `setBit` 1 = 4294967295
+4294967295 `setBit` 2 = 4294967295
+4294967295 `setBit` 3 = 4294967295
+
+0 `setBit` 0 = 1
+0 `setBit` 1 = 2
+0 `setBit` 2 = 4
+0 `setBit` 3 = 8
+
+1 `setBit` 0 = 1
+1 `setBit` 1 = 3
+1 `setBit` 2 = 5
+1 `setBit` 3 = 9
+
+2 `setBit` 0 = 3
+2 `setBit` 1 = 2
+2 `setBit` 2 = 6
+2 `setBit` 3 = 10
+
+3 `setBit` 0 = 3
+3 `setBit` 1 = 3
+3 `setBit` 2 = 7
+3 `setBit` 3 = 11
+
+#
+4294967293 `clearBit` 0 = 4294967292
+4294967293 `clearBit` 1 = 4294967293
+4294967293 `clearBit` 2 = 4294967289
+4294967293 `clearBit` 3 = 4294967285
+
+4294967294 `clearBit` 0 = 4294967294
+4294967294 `clearBit` 1 = 4294967292
+4294967294 `clearBit` 2 = 4294967290
+4294967294 `clearBit` 3 = 4294967286
+
+4294967295 `clearBit` 0 = 4294967294
+4294967295 `clearBit` 1 = 4294967293
+4294967295 `clearBit` 2 = 4294967291
+4294967295 `clearBit` 3 = 4294967287
+
+0 `clearBit` 0 = 0
+0 `clearBit` 1 = 0
+0 `clearBit` 2 = 0
+0 `clearBit` 3 = 0
+
+1 `clearBit` 0 = 0
+1 `clearBit` 1 = 1
+1 `clearBit` 2 = 1
+1 `clearBit` 3 = 1
+
+2 `clearBit` 0 = 2
+2 `clearBit` 1 = 0
+2 `clearBit` 2 = 2
+2 `clearBit` 3 = 2
+
+3 `clearBit` 0 = 2
+3 `clearBit` 1 = 1
+3 `clearBit` 2 = 3
+3 `clearBit` 3 = 3
+
+#
+4294967293 `complementBit` 0 = 4294967292
+4294967293 `complementBit` 1 = 4294967295
+4294967293 `complementBit` 2 = 4294967289
+4294967293 `complementBit` 3 = 4294967285
+
+4294967294 `complementBit` 0 = 4294967295
+4294967294 `complementBit` 1 = 4294967292
+4294967294 `complementBit` 2 = 4294967290
+4294967294 `complementBit` 3 = 4294967286
+
+4294967295 `complementBit` 0 = 4294967294
+4294967295 `complementBit` 1 = 4294967293
+4294967295 `complementBit` 2 = 4294967291
+4294967295 `complementBit` 3 = 4294967287
+
+0 `complementBit` 0 = 1
+0 `complementBit` 1 = 2
+0 `complementBit` 2 = 4
+0 `complementBit` 3 = 8
+
+1 `complementBit` 0 = 0
+1 `complementBit` 1 = 3
+1 `complementBit` 2 = 5
+1 `complementBit` 3 = 9
+
+2 `complementBit` 0 = 3
+2 `complementBit` 1 = 0
+2 `complementBit` 2 = 6
+2 `complementBit` 3 = 10
+
+3 `complementBit` 0 = 2
+3 `complementBit` 1 = 1
+3 `complementBit` 2 = 7
+3 `complementBit` 3 = 11
+
+#
+4294967293 `testBit` 0 = True
+4294967293 `testBit` 1 = False
+4294967293 `testBit` 2 = True
+4294967293 `testBit` 3 = True
+
+4294967294 `testBit` 0 = False
+4294967294 `testBit` 1 = True
+4294967294 `testBit` 2 = True
+4294967294 `testBit` 3 = True
+
+4294967295 `testBit` 0 = True
+4294967295 `testBit` 1 = True
+4294967295 `testBit` 2 = True
+4294967295 `testBit` 3 = True
+
+0 `testBit` 0 = False
+0 `testBit` 1 = False
+0 `testBit` 2 = False
+0 `testBit` 3 = False
+
+1 `testBit` 0 = True
+1 `testBit` 1 = False
+1 `testBit` 2 = False
+1 `testBit` 3 = False
+
+2 `testBit` 0 = False
+2 `testBit` 1 = True
+2 `testBit` 2 = False
+2 `testBit` 3 = False
+
+3 `testBit` 0 = True
+3 `testBit` 1 = True
+3 `testBit` 2 = False
+3 `testBit` 3 = False
+
+#
+bitSize 4294967293 = 32
+bitSize 4294967294 = 32
+bitSize 4294967295 = 32
+bitSize 0 = 32
+bitSize 1 = 32
+bitSize 2 = 32
+bitSize 3 = 32
+#
+isSigned 4294967293 = False
+isSigned 4294967294 = False
+isSigned 4294967295 = False
+isSigned 0 = False
+isSigned 1 = False
+isSigned 2 = False
+isSigned 3 = False
+#
+--------------------------------
+
--- /dev/null
+--!!! Testing the MVar primitives
+
+-- I quickly converted some of this code to work in the new system.
+-- Many of the rest haven't been updated or tested much and you'll
+-- find that the claims about what they "should print" are wrong
+-- being based on the old Hugs behaviour instead of assuming an
+-- arbitrary interleaving.
+--
+-- ADR - 5th nov 1998
+
+module TestMVar(test1,test2,test3,test4,test5,test6,test7,test8) where
+
+import Concurrent
+
+-- should print "a" then deadlock
+test1 = do
+ { v <- newEmptyMVar
+ ; putMVar v 'a'
+ ; get v
+ ; get v
+ }
+
+-- Nondeterministic
+test2 = do
+ { v <- newEmptyMVar
+ ; forkIO (p1 v)
+ ; p2 v
+ }
+ where
+ p1 v = do { put v 'a'; get v }
+ p2 v = do { get v ; put v 'b' }
+
+-- should print "a"
+test3 =
+ newEmptyMVar >>= \ v ->
+ forkIO (put v 'a') >>
+ get v
+
+-- should print "ab"
+-- NB: it's important that p1 is called from the main thread to make sure
+-- that the final get is executed
+test4 = do
+ { v1 <- newEmptyMVar
+ ; v2 <- newEmptyMVar
+ ; forkIO (p2 v1 v2)
+ ; p1 v1 v2
+ }
+ where
+ p1 v1 v2 = do { put v1 'a'; get v2 }
+ p2 v1 v2 = do { get v1 ; put v2 'b' }
+
+-- should abort: primPutMVar: full MVar
+test5 =
+ newEmptyMVar >>= \ v ->
+ put v 'a' >>
+ put v 'b'
+
+-- test blocking of two processes on the same variable.
+-- should print "aa"
+test6 = do
+ { x <- newEmptyMVar
+ ; ack <- newEmptyMVar
+ ; forkIO (get x >> put ack 'X')
+ ; forkIO (get x >> put ack 'X')
+ ; put x 'a' >> get ack -- use up one reader
+ ; put x 'b' >> get ack -- use up the other
+ ; put x 'c' >> get ack -- deadlock
+ }
+
+----------------------------------------------------------------
+-- Non-deterministic tests below this point
+-- Must be tested interactively and probably don't work using
+-- "logical concurrency".
+
+
+-- should print interleaving of a's and b's
+-- (degree of interleaving depends on granularity of concurrency)
+test7 =
+ forkIO a >> b
+ where
+ a = putStr "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b = putStr "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
+
+-- should give infinite interleaving of a's and b's
+-- (degree of interleaving depends on granularity of concurrency)
+-- Ming's example. The Hugs read-eval-print loop gets confused if
+-- there's no type signature
+test8 :: IO ()
+test8 =
+ forkIO a >> b
+ where
+ -- symbols carefully chosen to make them look very different on screen
+ a = putChar 'a' >> a
+ b = putChar 'B' >> b
+
+-- test blocking of two processes on the same variable.
+-- may print "aXbY{Deadlock}" or "aYbX{Deadlock}"
+test9 = do
+ { x <- newEmptyMVar
+ ; ack <- newEmptyMVar
+ ; forkIO (get x >> put ack 'X')
+ ; forkIO (get x >> put ack 'Y')
+ ; put x 'a' >> get ack -- use up one reader
+ ; put x 'b' >> get ack -- use up the other
+ ; put x 'c' >> get ack -- deadlock
+ }
+
+put v x =
+ putMVar v x
+
+get v =
+ takeMVar v >>= \ x ->
+ putChar x
--- /dev/null
+test1
+test3
+test4
+test5
--- /dev/null
+Reading file "Concurrent.lhs":
+Reading file "ChannelVar.lhs":
+Reading file "PrelConc.hs":
+Reading file "ChannelVar.lhs":
+Reading file "Channel.lhs":
+Reading file "Semaphore.lhs":
+Reading file "Merge.lhs":
+Reading file "SampleVar.lhs":
+Reading file "Concurrent.lhs":
+Reading file "test/exts/mvar.hs":
+Type :? for help
+Hugs:a{Deadlock}
+Hugs:a
+Hugs:ab
+Hugs:Program error: putMVar {full MVar}
+
--- /dev/null
+--!!! Testing Refs
+import IOExts
+
+a1 =
+ newIORef 'a' >>= \ v ->
+ readIORef v >>= \ x ->
+ print x
+
+a2 =
+ newIORef 'a' >>= \ v ->
+ writeIORef v 'b' >>
+ readIORef v >>= \ x ->
+ print x
+
+a3 =
+ newIORef 'a' >>= \ v1 ->
+ newIORef 'a' >>= \ v2 ->
+ print (v1 == v1, v1 == v2, v2 == v2)
+
+
--- /dev/null
+a1
+a2
+a3
--- /dev/null
+Reading file "IOExts.lhs":
+Reading file "ST.lhs":
+Reading file "Monad.hs":
+Reading file "ST.lhs":
+Reading file "IOExts.lhs":
+Reading file "test/exts/refs1.hs":
+Type :? for help
+Hugs:'a'
+
+Hugs:'b'
+
+Hugs:(True,False,True)
+
--- /dev/null
+--!!! Testing Mutvars
+
+import ST
+
+-- Note: equivalent code of the form: show (runST (newSTRef 'a' ...))
+-- won't typecheck under Hugs 1.01.
+
+a1 = show (runST prog)
+ where
+ prog :: ST s Char
+ prog =
+ newSTRef 'a' >>= \ v ->
+ readSTRef v
+
+a2 = show (runST prog)
+ where
+ prog :: ST s Char
+ prog =
+ newSTRef 'a' >>= \ v ->
+ writeSTRef v 'b' >>
+ readSTRef v
+
+a3 = show (runST prog)
+ where
+ prog :: ST s (Bool,Bool,Bool)
+ prog =
+ newSTRef 'a' >>= \ v1 ->
+ newSTRef 'a' >>= \ v2 ->
+ return (v1 == v1, v1 == v2, v2 == v2)
+
--- /dev/null
+a1
+a2
+a3
--- /dev/null
+Reading file "ST.lhs":
+Reading file "Monad.hs":
+Reading file "ST.lhs":
+Reading file "test/exts/refs2.hs":
+Type :? for help
+Hugs:"'a'"
+Hugs:"'b'"
+Hugs:"(True,False,True)"
--- /dev/null
+--!!! Testing typechecking of runST
+module RunSTTest where
+
+import ST
+
+t1 = runST (return '1')
+
+t2 = runST (do
+ v <- newSTRef '2'
+ readSTRef v
+ )
+
--- /dev/null
+Reading file "ST.lhs":
+Reading file "Monad.hs":
+Reading file "ST.lhs":
+Reading file "test/exts/refs3.hs":
+Type :? for help
+Hugs:'1'
+Hugs:'2'
--- /dev/null
+#!/usr/bin/perl
+#! /usr/local/bin/perl
+#
+# Given:
+# * a program to run (1st arg)
+# * some "command-line opts" ( -O<opt1> -O<opt2> ... )
+# [default: anything on the cmd line this script doesn't recognise ]
+# the first opt not starting w/ "-" is taken to be an input
+# file and (if it exists) is grepped for "what's going on here"
+# comments (^--!!!).
+# * a file to feed to stdin ( -i<file> ) [default: $dev_null ]
+# * a "time" command to use (-t <cmd>).
+# * a "start" line (-s <line>) - all preceeding lines of output
+# * are ignored (from stdout).
+# * a "start" pattern (-f <regexp>) - all preceeding lines of output
+# * are deleted (from stdout).
+# * an "end" pattern (-l <regexp>) - all later lines of output
+# * are deleted (from stdout).
+#
+# * alternatively, a "-script <script>" argument says: run the
+# named Bourne-shell script to do the test. It's passed the
+# pgm-to-run as the one-and-only arg.
+#
+# Run the program with those options and that input, and check:
+# if we get...
+#
+# * an expected exit status ( -x <val> ) [ default 0 ]
+# * expected output on stdout ( -o1 <file> ) [ default $dev_null ]
+# ( we'll accept one of several...)
+# * expected output on stderr ( -o2 <file> ) [ default $dev_null ]
+# ( we'll accept one of several...)
+#
+# (if the expected-output files' names end in .Z, then
+# they are uncompressed before doing the comparison)
+#
+# (This is supposed to be a "prettier" replacement for runstdtest.)
+#
+
+die "$0 requires perl 5.0 or higher" unless $] >= 5.0;
+
+($Pgm = $0) =~ s|.*/||;
+
+$tmpdir = &fromEnv('TMPDIR',"/tmp");
+$shell = "/bin/sh";
+$cmp = "diff -q";
+$diff = &fromEnv('CONTEXT_DIFF',"diff -c1");
+$dev_null = &fromEnv('DEV_NULL',"/dev/null");
+
+$Verbose = 0;
+$Status = 0;
+@PgmArgs = ();
+$PgmExitStatus = 0;
+$PgmStdinFile = $dev_null;
+$DefaultStdoutFile = "${tmpdir}/no_stdout$$"; # can't use $dev_null (e.g. Alphas)
+$DefaultStderrFile = "${tmpdir}/no_stderr$$";
+@PgmStdoutFile = ();
+@PgmStderrFile = ();
+$PgmStartLine = 0;
+$PgmStartPat = '.';
+$PgmEndPat = 'WILLNAEMATCH'; # hack!
+$AltScript = '';
+$TimeCmd = '';
+
+die "$Pgm: program to run not given as first argument\n" if $#ARGV < 0;
+$ToRun = $ARGV[0]; shift(@ARGV);
+# avoid picking up same-named thing from somewhere else on $PATH...
+$ToRun = "./$ToRun" if $ToRun !~ /^\//;
+
+arg: while ($_ = $ARGV[0]) {
+ shift(@ARGV);
+
+ /^-v$/ && do { $Verbose = 1; next arg; };
+ /^-O(.*)/ && do { push(@PgmArgs, &grab_arg_arg('-O',$1)); next arg; };
+ /^-i(.*)/ && do { $PgmStdinFile = &grab_arg_arg('-i',$1);
+ $Status++,
+ print STDERR "$Pgm: bogus -i input file: $PgmStdinFile\n"
+ if ! -f $PgmStdinFile;
+ next arg; };
+ /^-x(.*)/ && do { $PgmExitStatus = &grab_arg_arg('-x',$1);
+ $Status++ ,
+ print STDERR "$Pgm: bogus -x expected exit status: $PgmExitStatus\n"
+ if $PgmExitStatus !~ /^\d+$/;
+ next arg; };
+ /^-s(.*)/ && do { $PgmStartLine = &grab_arg_arg('-x',$1);
+ $Status++ ,
+ print STDERR "$Pgm: bogus -s start line: $PgmStartLine\n"
+ if $PgmStartLine !~ /^\d+$/;
+ next arg; };
+ /^-f(.*)/ && do { $PgmStartPat = &grab_arg_arg('-f',$1);
+ next arg; };
+ /^-l(.*)/ && do { $PgmEndPat = &grab_arg_arg('-l',$1);
+ next arg; };
+ /^-o1(.*)/ && do { $out_file = &grab_arg_arg('-o1',$1);
+ $Status++ ,
+ print STDERR "$Pgm: bogus -o1 expected-output file: $out_file\n"
+ if ! -f $out_file;
+ push(@PgmStdoutFile, $out_file);
+ next arg; };
+ /^-o2(.*)/ && do { $out_file = &grab_arg_arg('-o2',$1);
+ $Status++,
+ print STDERR "$Pgm: bogus -o2 expected-stderr file: $out_file\n"
+ if ! -f $out_file;
+ push(@PgmStderrFile, $out_file);
+ next arg; };
+ /^-script(.*)/ && do { $AltScript = &grab_arg_arg('-script',$1);
+ next arg; };
+ /^-t(.*)/ && do { $TimeCmd = &grab_arg_arg('-t', $1); next arg; };
+
+ # anything else is taken to be a pgm arg
+ push(@PgmArgs, $_);
+}
+exit 1 if $Status;
+
+# add on defaults if none specified
+@PgmStdoutFile = ( $DefaultStdoutFile ) if $#PgmStdoutFile < 0;
+@PgmStderrFile = ( $DefaultStderrFile ) if $#PgmStderrFile < 0;
+
+# tidy up the pgm args:
+# (1) look for the "first input file"
+# and grep it for "interesting" comments (--!!! )
+# (2) quote any args w/ whitespace in them.
+$grep_done = 0;
+foreach $a ( @PgmArgs ) {
+ if (! $grep_done && $a !~ /^-/ && -f $a) {
+ unless (open(ARG, $a)) {
+ print STDERR "Can't open $a: $!\n";
+ exit 1;
+ }
+ while (<ARG>) {
+ print if /^--!!!/;
+ }
+ close(ARG);
+ $grep_done = 1;
+ }
+ if ($a =~ /\s/ || $a =~ /'/) {
+ $a =~ s/'/\\'/g; # backslash the quotes;
+ $a =~ s/"/\\"/g; # backslash the quotes;
+ $a = "\"$a\""; # quote the arg
+ }
+}
+
+if ($AltScript ne '') {
+ local($to_do);
+ $to_do = `cat $AltScript`;
+ # glue in pgm to run...
+ $* = 1;
+ $to_do =~ s/^\$1 /$ToRun /;
+ &run_something($to_do);
+ exit 0;
+# exec "$AltScript $ToRun";
+# print STDERR "Failed to exec!!! $AltScript $ToRun\n";
+# exit 1;
+}
+
+# OK, so we're gonna do the normal thing...
+
+$Script = <<EOSCRIPT;
+CONTEXT_DIFF='/usr/bin/diff -C 1'
+export CONTEXT_DIFF
+DEV_NULL='/dev/null'
+export DEV_NULL
+myexit=0
+diffsShown=0
+/bin/rm -f $DefaultStdoutFile $DefaultStderrFile
+cat $dev_null > $DefaultStdoutFile
+cat $dev_null > $DefaultStderrFile
+$TimeCmd ${shell} -c \'$ToRun @PgmArgs < $PgmStdinFile 1> ${tmpdir}/runtest$$.1 2> ${tmpdir}/runtest$$.2\'
+progexit=\$?
+if [ \$progexit -ne $PgmExitStatus ]; then
+ echo $ToRun @PgmArgs \\< $PgmStdinFile
+ echo expected exit status $PgmExitStatus not seen \\; got \$progexit
+ myexit=1
+else
+ # Pipe that filters out stuff we don't want to check
+ tail +$PgmStartLine ${tmpdir}/runtest$$.1 | test/after "$PgmStartPat" | test/before "$PgmEndPat" >${tmpdir}/runtest$$.3
+
+ for out_file in @PgmStdoutFile ; do
+ $diff \$out_file ${tmpdir}/runtest$$.3 > ${tmpdir}/diffs$$
+ if [ \$? -ne 0 ]; then
+ echo $ToRun @PgmArgs \\< $PgmStdinFile
+ echo expected stdout not matched by reality
+ cat ${tmpdir}/diffs$$
+ myexit=1
+ fi
+ /bin/rm -f ${tmpdir}/diffs$$
+ done
+fi
+for out_file in @PgmStderrFile ; do
+ $diff \$out_file ${tmpdir}/runtest$$.2 > ${tmpdir}/diffs$$
+ if [ \$? -ne 0 ]; then
+ echo $ToRun @PgmArgs \\< $PgmStdinFile
+ echo expected stderr not matched by reality
+ cat ${tmpdir}/diffs$$
+ myexit=1
+ fi
+ /bin/rm -f ${tmpdir}/diffs$$
+done
+/bin/rm -f core $DefaultStdoutFile $DefaultStderrFile ${tmpdir}/runtest$$.1 ${tmpdir}/runtest$$.3 ${tmpdir}/runtest$$.2
+exit \$myexit
+EOSCRIPT
+
+&run_something($Script);
+# print $Script if $Verbose;
+# open(SH, "| ${shell}") || die "Can't open shell pipe\n";
+# print SH $Script;
+# close(SH);
+
+exit 0;
+
+sub fromEnv {
+ local($varname,$default) = @_;
+ local($val) = $ENV{$varname};
+ $val = $default if $val eq "";
+ return $val;
+}
+
+sub grab_arg_arg {
+ local($option, $rest_of_arg) = @_;
+
+ if ($rest_of_arg) {
+ return($rest_of_arg);
+ } elsif ($#ARGV >= 0) {
+ local($temp) = $ARGV[0]; shift(@ARGV);
+ return($temp);
+ } else {
+ print STDERR "$Pgm: no argument following $option option\n";
+ $Status++;
+ }
+}
+
+sub run_something {
+ local($str_to_do) = @_;
+
+ print STDERR "$str_to_do\n" if $Verbose;
+
+ local($return_val) = 0;
+
+ # On Windows NT, we have to build a file before we can interpret it.
+ local($scriptfile) = "./script$$";
+ open(FOO,">$scriptfile") || die "Can't create script $scriptfile";
+ print FOO $str_to_do;
+ close FOO;
+
+ system("sh $scriptfile");
+ $return_val = $?;
+ system("rm $scriptfile");
+
+ if ($return_val != 0) {
+#ToDo: this return-value mangling is wrong
+# local($die_msg) = "$Pgm: execution of the $tidy_name had trouble";
+# $die_msg .= " (program not found)" if $return_val == 255;
+# $die_msg .= " ($!)" if $Verbose && $! != 0;
+# $die_msg .= "\n";
+
+ exit (($return_val == 0) ? 0 : 1);
+ }
+}
--- /dev/null
+#! /usr/bin/perl
+
+foreach $file (@ARGV) {
+ ($base = $file) =~ s/\.l?hs$//;
+
+ $cmd = "perl test/runstdtest hugs +q -w -h300k -pHugs: -f\"$file\" -l\"Leaving Hugs\"";
+
+ die "Yoiks, file \"$file\" doesn't exist" unless -f "$file";
+ $cmd .= " -O$file";
+
+ $cmd .= " -i$base.in1" if (-f "$base.in1");
+ $cmd .= " -o1$base.out1" if (-f "$base.out1");
+ $cmd .= " -o2$base.out2" if (-f "$base.out2");
+
+ # print "$cmd\n";
+ system($cmd);
+}
+
+exit 0;
--- /dev/null
+#! /usr/bin/perl -i.bak
+
+while (<>) {
+ # Insert header line
+ if ($ARGV ne $oldargv) {
+ $ARGV =~ /\d+/;
+ $filenum = $&;
+ print <<EOTXT;
+Reading file "test/runtime/r$filenum.hs":
+EOTXT
+ $oldargv = $ARGV;
+ }
+
+ # Make this script idempotent
+ next if /^Reading file "test\/runtime\/r\d+\.hs":/;
+
+ # Fix error messages
+ s#test/[A-Za-z]+\d+\.hs#test/runtime/r$filenum.hs#g;
+
+ # Delete trailing line
+ s/^Hugs:\[Leaving Hugs\]\n//;
+
+ print;
+}
--- /dev/null
+----------------------------------------------------------------
+-- Testing runtime system.
+-- This group of checks will produce 12-16 lines of output of the form
+--
+-- --!!! <description of feature being tested>
+--
+-- It may also produce output that looks like this:
+--
+-- ./hugs +q -pHugs: test/???.hs < test/???.input
+-- expected stdout not matched by reality
+-- *** test/???.output Fri Jul 11 13:25:27 1997
+-- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
+-- ***************
+-- *** 1,3 ****
+-- ...
+-- | Hugs:\"[0.0, 0.304693, 0.643501, 1.5708]\"
+-- ...
+-- --- 1,3 ----
+-- ...
+-- | Hugs:\"[0.0, 0.30469323452, 0.643503234321, 1.5708234234]\"
+-- ...
+--
+-- This is harmless and reflects variations in the accuracy of floating
+-- point representation, calculations and printing.
+--
+-- You should report a problem if any other output is generated or if
+-- the size of the floating point errors seem excessively large.
+----------------------------------------------------------------
--- /dev/null
+--!!! Testing bignums
+
+-- Note: anything which prints an Integer automatically tests
+-- quotRem.
+
+egs1 = [-5..5] :: [Integer]
+egs2 = filter (/=0) egs1 -- avoid division by zero
+
+t0 = (1::Integer) == (1::Integer)
+
+t1 = shw $ table (+) egs1 egs1
+t2 = shw $ table (-) egs1 egs1
+t3 = shw $ table (*) egs1 egs1
+
+t4 = shw $ table div egs1 egs2
+t5 = shw $ table mod egs1 egs2
+t6 = shw $ table quot egs1 egs2
+t7 = shw $ table rem egs1 egs2
+
+u1 = shw $ table (==) egs1 egs1
+u2 = shw $ table (/=) egs1 egs1
+u3 = shw $ table (<=) egs1 egs1
+u4 = shw $ table (<) egs1 egs1
+u5 = shw $ table (>) egs1 egs1
+u6 = shw $ table (>=) egs1 egs1
+
+
+-- The implementation is based on 4 digit chunks - so let's test
+-- the results when we use values near those boundaries.
+
+egs3 = [9999,10000,10001,99999999,100000000,100000001] :: [Integer]
+egs4 = filter (/=0) egs3 -- avoid division by zero
+
+v1 = shw $ table (+) egs3 egs3
+v2 = shw $ table (-) egs3 egs3
+v3 = shw $ table (*) egs3 egs3
+
+v4 = shw $ table div egs3 egs4
+v5 = shw $ table mod egs3 egs4
+v6 = shw $ table quot egs3 egs4
+v7 = shw $ table rem egs3 egs4
+
+w1 = shw $ table (==) egs3 egs3
+w2 = shw $ table (/=) egs3 egs3
+w3 = shw $ table (<=) egs3 egs3
+w4 = shw $ table (<) egs3 egs3
+w5 = shw $ table (>) egs3 egs3
+w6 = shw $ table (>=) egs3 egs3
+
+-- Some utilities for generating neat tables of test results
+table :: (a -> a -> b) -> [a] -> [a] -> [[b]]
+table f xs ys = [ [ x `f` y | x <- xs ] | y <- ys ]
+
+shw :: Show a => [[a]] -> IO ()
+shw = putStr . unlines . map (unwords . map show)
+
--- /dev/null
+t0
+t1
+t2
+t3
+t4
+t5
+t6
+t7
+
+u1
+u2
+u3
+u4
+u5
+u6
+
+v1
+v2
+v3
+v4
+v5
+v6
+v7
+
+w1
+w2
+w3
+w4
+w5
+w6
+
--- /dev/null
+Type :? for help
+Hugs:True
+Hugs:-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0
+-9 -8 -7 -6 -5 -4 -3 -2 -1 0 1
+-8 -7 -6 -5 -4 -3 -2 -1 0 1 2
+-7 -6 -5 -4 -3 -2 -1 0 1 2 3
+-6 -5 -4 -3 -2 -1 0 1 2 3 4
+-5 -4 -3 -2 -1 0 1 2 3 4 5
+-4 -3 -2 -1 0 1 2 3 4 5 6
+-3 -2 -1 0 1 2 3 4 5 6 7
+-2 -1 0 1 2 3 4 5 6 7 8
+-1 0 1 2 3 4 5 6 7 8 9
+0 1 2 3 4 5 6 7 8 9 10
+
+Hugs:0 1 2 3 4 5 6 7 8 9 10
+-1 0 1 2 3 4 5 6 7 8 9
+-2 -1 0 1 2 3 4 5 6 7 8
+-3 -2 -1 0 1 2 3 4 5 6 7
+-4 -3 -2 -1 0 1 2 3 4 5 6
+-5 -4 -3 -2 -1 0 1 2 3 4 5
+-6 -5 -4 -3 -2 -1 0 1 2 3 4
+-7 -6 -5 -4 -3 -2 -1 0 1 2 3
+-8 -7 -6 -5 -4 -3 -2 -1 0 1 2
+-9 -8 -7 -6 -5 -4 -3 -2 -1 0 1
+-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0
+
+Hugs:25 20 15 10 5 0 -5 -10 -15 -20 -25
+20 16 12 8 4 0 -4 -8 -12 -16 -20
+15 12 9 6 3 0 -3 -6 -9 -12 -15
+10 8 6 4 2 0 -2 -4 -6 -8 -10
+5 4 3 2 1 0 -1 -2 -3 -4 -5
+0 0 0 0 0 0 0 0 0 0 0
+-5 -4 -3 -2 -1 0 1 2 3 4 5
+-10 -8 -6 -4 -2 0 2 4 6 8 10
+-15 -12 -9 -6 -3 0 3 6 9 12 15
+-20 -16 -12 -8 -4 0 4 8 12 16 20
+-25 -20 -15 -10 -5 0 5 10 15 20 25
+
+Hugs:1 0 0 0 0 0 -1 -1 -1 -1 -1
+1 1 0 0 0 0 -1 -1 -1 -1 -2
+1 1 1 0 0 0 -1 -1 -1 -2 -2
+2 2 1 1 0 0 -1 -1 -2 -2 -3
+5 4 3 2 1 0 -1 -2 -3 -4 -5
+-5 -4 -3 -2 -1 0 1 2 3 4 5
+-3 -2 -2 -1 -1 0 0 1 1 2 2
+-2 -2 -1 -1 -1 0 0 0 1 1 1
+-2 -1 -1 -1 -1 0 0 0 0 1 1
+-1 -1 -1 -1 -1 0 0 0 0 0 1
+
+Hugs:0 -4 -3 -2 -1 0 -4 -3 -2 -1 0
+-1 0 -3 -2 -1 0 -3 -2 -1 0 -3
+-2 -1 0 -2 -1 0 -2 -1 0 -2 -1
+-1 0 -1 0 -1 0 -1 0 -1 0 -1
+0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0
+1 0 1 0 1 0 1 0 1 0 1
+1 2 0 1 2 0 1 2 0 1 2
+3 0 1 2 3 0 1 2 3 0 1
+0 1 2 3 4 0 1 2 3 4 0
+
+Hugs:1 0 0 0 0 0 0 0 0 0 -1
+1 1 0 0 0 0 0 0 0 -1 -1
+1 1 1 0 0 0 0 0 -1 -1 -1
+2 2 1 1 0 0 0 -1 -1 -2 -2
+5 4 3 2 1 0 -1 -2 -3 -4 -5
+-5 -4 -3 -2 -1 0 1 2 3 4 5
+-2 -2 -1 -1 0 0 0 1 1 2 2
+-1 -1 -1 0 0 0 0 0 1 1 1
+-1 -1 0 0 0 0 0 0 0 1 1
+-1 0 0 0 0 0 0 0 0 0 1
+
+Hugs:0 -4 -3 -2 -1 0 1 2 3 4 0
+-1 0 -3 -2 -1 0 1 2 3 0 1
+-2 -1 0 -2 -1 0 1 2 0 1 2
+-1 0 -1 0 -1 0 1 0 1 0 1
+0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0
+-1 0 -1 0 -1 0 1 0 1 0 1
+-2 -1 0 -2 -1 0 1 2 0 1 2
+-1 0 -3 -2 -1 0 1 2 3 0 1
+0 -4 -3 -2 -1 0 1 2 3 4 0
+
+Hugs:Hugs:True False False False False False False False False False False
+False True False False False False False False False False False
+False False True False False False False False False False False
+False False False True False False False False False False False
+False False False False True False False False False False False
+False False False False False True False False False False False
+False False False False False False True False False False False
+False False False False False False False True False False False
+False False False False False False False False True False False
+False False False False False False False False False True False
+False False False False False False False False False False True
+
+Hugs:False True True True True True True True True True True
+True False True True True True True True True True True
+True True False True True True True True True True True
+True True True False True True True True True True True
+True True True True False True True True True True True
+True True True True True False True True True True True
+True True True True True True False True True True True
+True True True True True True True False True True True
+True True True True True True True True False True True
+True True True True True True True True True False True
+True True True True True True True True True True False
+
+Hugs:True False False False False False False False False False False
+True True False False False False False False False False False
+True True True False False False False False False False False
+True True True True False False False False False False False
+True True True True True False False False False False False
+True True True True True True False False False False False
+True True True True True True True False False False False
+True True True True True True True True False False False
+True True True True True True True True True False False
+True True True True True True True True True True False
+True True True True True True True True True True True
+
+Hugs:False False False False False False False False False False False
+True False False False False False False False False False False
+True True False False False False False False False False False
+True True True False False False False False False False False
+True True True True False False False False False False False
+True True True True True False False False False False False
+True True True True True True False False False False False
+True True True True True True True False False False False
+True True True True True True True True False False False
+True True True True True True True True True False False
+True True True True True True True True True True False
+
+Hugs:False True True True True True True True True True True
+False False True True True True True True True True True
+False False False True True True True True True True True
+False False False False True True True True True True True
+False False False False False True True True True True True
+False False False False False False True True True True True
+False False False False False False False True True True True
+False False False False False False False False True True True
+False False False False False False False False False True True
+False False False False False False False False False False True
+False False False False False False False False False False False
+
+Hugs:True True True True True True True True True True True
+False True True True True True True True True True True
+False False True True True True True True True True True
+False False False True True True True True True True True
+False False False False True True True True True True True
+False False False False False True True True True True True
+False False False False False False True True True True True
+False False False False False False False True True True True
+False False False False False False False False True True True
+False False False False False False False False False True True
+False False False False False False False False False False True
+
+Hugs:Hugs:19998 19999 20000 100009998 100009999 100010000
+19999 20000 20001 100009999 100010000 100010001
+20000 20001 20002 100010000 100010001 100010002
+100009998 100009999 100010000 199999998 199999999 200000000
+100009999 100010000 100010001 199999999 200000000 200000001
+100010000 100010001 100010002 200000000 200000001 200000002
+
+Hugs:0 1 2 99990000 99990001 99990002
+-1 0 1 99989999 99990000 99990001
+-2 -1 0 99989998 99989999 99990000
+-99990000 -99989999 -99989998 0 1 2
+-99990001 -99990000 -99989999 -1 0 1
+-99990002 -99990001 -99990000 -2 -1 0
+
+Hugs:99980001 99990000 99999999 999899990001 999900000000 999900009999
+99990000 100000000 100010000 999999990000 1000000000000 1000000010000
+99999999 100010000 100020001 1000099989999 1000100000000 1000100010001
+999899990001 999999990000 1000099989999 9999999800000001 9999999900000000 9999999999999999
+999900000000 1000000000000 1000100000000 9999999900000000 10000000000000000 10000000100000000
+999900009999 1000000010000 1000100010001 9999999999999999 10000000100000000 10000000200000001
+
+Hugs:1 1 1 10001 10001 10001
+0 1 1 9999 10000 10000
+0 0 1 9999 9999 9999
+0 0 0 1 1 1
+0 0 0 0 1 1
+0 0 0 0 0 1
+
+Hugs:0 1 2 0 1 2
+9999 0 1 9999 0 1
+9999 10000 0 0 1 2
+9999 10000 10001 0 1 2
+9999 10000 10001 99999999 0 1
+9999 10000 10001 99999999 100000000 0
+
+Hugs:1 1 1 10001 10001 10001
+0 1 1 9999 10000 10000
+0 0 1 9999 9999 9999
+0 0 0 1 1 1
+0 0 0 0 1 1
+0 0 0 0 0 1
+
+Hugs:0 1 2 0 1 2
+9999 0 1 9999 0 1
+9999 10000 0 0 1 2
+9999 10000 10001 0 1 2
+9999 10000 10001 99999999 0 1
+9999 10000 10001 99999999 100000000 0
+
+Hugs:Hugs:True False False False False False
+False True False False False False
+False False True False False False
+False False False True False False
+False False False False True False
+False False False False False True
+
+Hugs:False True True True True True
+True False True True True True
+True True False True True True
+True True True False True True
+True True True True False True
+True True True True True False
+
+Hugs:True False False False False False
+True True False False False False
+True True True False False False
+True True True True False False
+True True True True True False
+True True True True True True
+
+Hugs:False False False False False False
+True False False False False False
+True True False False False False
+True True True False False False
+True True True True False False
+True True True True True False
+
+Hugs:False True True True True True
+False False True True True True
+False False False True True True
+False False False False True True
+False False False False False True
+False False False False False False
+
+Hugs:True True True True True True
+False True True True True True
+False False True True True True
+False False False True True True
+False False False False True True
+False False False False False True
+
--- /dev/null
+--!!! Testing Enum
+
+module TestEnum where
+
+-- test for derived instances
+
+data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 deriving (Eq, Ord, Enum, Show)
+
+test1 = show $ [C1 .. ]
+test2 = show $ [C1 .. C4]
+test3 = show $ [C1, C3 ..]
+test4 = show $ [C1, C3 .. C6]
+test5 = show $ [C7, C5 .. ]
+test6 = show $ [C7, C5 .. C2]
+test7 = show $ map fromEnum [C1 .. ]
+test8 = show (map toEnum [0..6] :: [T])
+
+test9 = show (toEnum (-1) :: T) -- should fail
+test10 = show (toEnum 7 :: T) -- should fail
+
+test11 = show $ take 7 (iterate succ C1)
+test12 = show $ take 7 (iterate pred C7)
+
+test13 = show $ succ C7 -- should fail
+test14 = show $ pred C1 -- should fail
+
+-- test for built in Enum instances
+
+test20 = show $ ['a' ..]
+test21 = show $ ['a' ..'z']
+test22 = show $ ['a', 'd' ..]
+test23 = show $ ['a', 'd' .. 'z']
+test24 = show $ ['z','y'..'a']
+test25 = show $ map fromEnum ['a' ..]
+test26 = show $ map fromEnum ['a', 'd' ..]
+test27 = show $ map fromEnum ['a'..'z']
+test28 = show (map toEnum [fromEnum 'a'..fromEnum 'z'] :: [Char])
+
+test30 = show (take 50 $ [1..]::[Int])
+test31 = show ([1..10]::[Int])
+test32 = show (take 50 $ [1, 3 ..]::[Int])
+test33 = show ([1, 3 .. 10]::[Int])
+test34 = show ([10,9..1]::[Int])
+test35 = show (map fromEnum [1..10]::[Int])
+test36 = show (map toEnum [fromEnum 1..fromEnum 10]::[Int])
+
+
+test40 = show (take 50 $ [1..]::[Integer])
+test41 = show ([1..10]::[Integer])
+test42 = show (take 50 $ [1, 3 ..]::[Integer])
+test43 = show ([1, 3 .. 10]::[Integer])
+test44 = show ([10,9..1]::[Integer])
+test45 = show (map fromEnum [1..10]::[Int])
+test46 = show (map toEnum [fromEnum 1..fromEnum 10]::[Integer])
+
+-- All these tests use integers because roundoff errors have
+-- such bizarre effects on the printed number.
+test50 = show (take 50 $ [1..]::[Float])
+test51 = show ([1..10]::[Float])
+test52 = show (take 50 $ [1, 2 ..]::[Float])
+test53 = show ([1, 2 .. 20]::[Float])
+test54 = show ([20,19..10]::[Float])
+test55 = show (map fromEnum ([1..10]::[Float]))
+test56 = show (map toEnum [fromEnum 1..fromEnum 10]::[Float])
+
+
+test60 = show (take 50 $ [1..]::[Double])
+test61 = show ([1..10]::[Double])
+test62 = show (take 50 $ [1, 2 ..]::[Double])
+test63 = show ([1, 2 .. 20]::[Double])
+test64 = show ([20,19..10]::[Double])
+test65 = show (map fromEnum ([1..10]::[Double]))
+test66 = show (map toEnum [fromEnum 1..fromEnum 10]::[Double])
+
+
+
--- /dev/null
+test1
+test2
+test3
+test4
+test5
+test6
+test7
+test8
+test9
+test10
+test11
+test12
+test13
+test14
+
+test20
+test21
+test22
+test23
+test24
+test25
+test26
+test27
+test28
+
+test30
+test31
+test32
+test33
+test34
+test35
+test36
+
+test40
+test41
+test42
+test43
+test44
+test45
+test46
+
+test50
+test51
+test52
+test53
+test54
+test55
+test56
+
+test60
+test61
+test62
+test63
+test64
+test65
+test66
+
--- /dev/null
+Type :? for help
+Hugs:"[C1,C2,C3,C4,C5,C6,C7]"
+Hugs:"[C1,C2,C3,C4]"
+Hugs:"[C1,C3,C5,C7]"
+Hugs:"[C1,C3,C5]"
+Hugs:"[C7,C5,C3,C1]"
+Hugs:"[C7,C5,C3]"
+Hugs:"[0,1,2,3,4,5,6]"
+Hugs:"[C1,C2,C3,C4,C5,C6,C7]"
+Hugs:"
+Program error: {_ToEnum C1 (-1)}
+
+Hugs:"
+Program error: {_ToEnum C1 7}
+
+Hugs:"[C1,C2,C3,C4,C5,C6,C7]"
+Hugs:"[C7,C6,C5,C4,C3,C2,C1]"
+Hugs:"
+Program error: {_ToEnum C1 7}
+
+Hugs:"
+Program error: {_ToEnum C1 (-1)}
+
+Hugs:Hugs:"\"abcdefghijklmnopqrstuvwxyz{|}~\\DEL\\128\\129\\130\\131\\132\\133\\134\\135\\136\\137\\138\\139\\140\\141\\142\\143\\144\\145\\146\\147\\148\\149\\150\\151\\152\\153\\154\\155\\156\\157\\158\\159\\160\\161\\162\\163\\164\\165\\166\\167\\168\\169\\170\\171\\172\\173\\174\\175\\176\\177\\178\\179\\180\\181\\182\\183\\184\\185\\186\\187\\188\\189\\190\\191\\192\\193\\194\\195\\196\\197\\198\\199\\200\\201\\202\\203\\204\\205\\206\\207\\208\\209\\210\\211\\212\\213\\214\\215\\216\\217\\218\\219\\220\\221\\222\\223\\224\\225\\226\\227\\228\\229\\230\\231\\232\\233\\234\\235\\236\\237\\238\\239\\240\\241\\242\\243\\244\\245\\246\\247\\248\\249\\250\\251\\252\\253\\254\\255\""
+Hugs:"\"abcdefghijklmnopqrstuvwxyz\""
+Hugs:"\"adgjmpsvy|\\DEL\\130\\133\\136\\139\\142\\145\\148\\151\\154\\157\\160\\163\\166\\169\\172\\175\\178\\181\\184\\187\\190\\193\\196\\199\\202\\205\\208\\211\\214\\217\\220\\223\\226\\229\\232\\235\\238\\241\\244\\247\\250\\253\""
+Hugs:"\"adgjmpsvy\""
+Hugs:"\"zyxwvutsrqponmlkjihgfedcba\""
+Hugs:"[97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255]"
+Hugs:"[97,100,103,106,109,112,115,118,121,124,127,130,133,136,139,142,145,148,151,154,157,160,163,166,169,172,175,178,181,184,187,190,193,196,199,202,205,208,211,214,217,220,223,226,229,232,235,238,241,244,247,250,253]"
+Hugs:"[97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122]"
+Hugs:"\"abcdefghijklmnopqrstuvwxyz\""
+Hugs:Hugs:"[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:"[1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63,65,67,69,71,73,75,77,79,81,83,85,87,89,91,93,95,97,99]"
+Hugs:"[1,3,5,7,9]"
+Hugs:"[10,9,8,7,6,5,4,3,2,1]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:Hugs:"[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:"[1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63,65,67,69,71,73,75,77,79,81,83,85,87,89,91,93,95,97,99]"
+Hugs:"[1,3,5,7,9]"
+Hugs:"[10,9,8,7,6,5,4,3,2,1]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0]"
+Hugs:"[20.0,19.0,18.0,17.0,16.0,15.0,14.0,13.0,12.0,11.0,10.0]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
+Hugs:Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0]"
+Hugs:"[20.0,19.0,18.0,17.0,16.0,15.0,14.0,13.0,12.0,11.0,10.0]"
+Hugs:"[1,2,3,4,5,6,7,8,9,10]"
+Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
--- /dev/null
+--!!! Testing show minInt (interesting if minInt /= -maxInt)
+
+a1 = show (maxBound::Int)
+a2 = show (-maxBound::Int)
+a3 = show (minBound::Int)
--- /dev/null
+a1
+a2
+a3
--- /dev/null
+Type :? for help
+Hugs:"2147483647"
+Hugs:"-2147483647"
+Hugs:"-2147483648"
--- /dev/null
+-- test for derived Ord instances
+
+module TestOrd where
+
+data T = C1 | C2 deriving (Eq, Ord)
+
+cmps :: [T -> T -> Bool]
+cmps = [ (<), (<=), (==), (/=), (>=), (>) ]
+
+-- kind of a reversed zipWith...
+rzipWith :: [a -> b -> c] -> a -> b -> [c]
+rzipWith fs a b = [ f a b | f <- fs ]
+
+--!!! Testing derived Ord and Eq instances for enumeration type
+test1 = rzipWith cmps C1 C1 -- should be [F,T,T,F,T,F]
+test2 = rzipWith cmps C1 C2 -- should be [T,T,F,T,F,F]
+test3 = rzipWith cmps C2 C1 -- should be [F,F,F,T,T,T]
+
--- /dev/null
+show test1
+show test2
+show test3
--- /dev/null
+Type :? for help
+Hugs:"[False,True,True,False,True,False]"
+Hugs:"[True,True,False,True,False,False]"
+Hugs:"[False,False,False,True,True,True]"
--- /dev/null
+--!!! Testing Read (assuming that Eq, Show and Enum work!)
+
+module TestRead where
+
+import Ratio(Ratio,(%),Rational)
+import List(zip4,zip5,zip6,zip7)
+
+-- test that expected equality holds
+tst :: (Read a, Show a, Eq a) => a -> Bool
+tst x = read (show x) == x
+
+-- measure degree of error
+diff :: (Read a, Show a, Num a) => a -> a
+diff x = read (show x) - x
+
+----------------------------------------------------------------
+-- test for hand-written instances
+----------------------------------------------------------------
+
+test1 = tst ()
+test2 = all tst [False,True]
+test3 = all tst [minBound::Char ..]
+test4 = all tst [Nothing, Just (Just True)]
+test5 = all tst [Left True, Right (Just True)]
+test6 = all tst [LT .. GT]
+test7 = all tst [[],['a'..'z'],['A'..'Z']]
+test8 = all tst $ [minBound,maxBound]
+ ++ [-100..100 :: Int]
+test9 = all tst $ [(fromInt minBound)-1, (fromInt maxBound)+1]
+ ++ [-100..100 :: Integer]
+
+-- we don't test fractional Floats/Doubles because they don't work
+test10 = all tst $ [-100..100 :: Float]
+test11 = all tst $ [-100..100 :: Double]
+
+test12 = all tst $ [-2%2,-1%2,0%2,1%2,2%2]
+ ++ [-10.0,-9.9..10.0 :: Ratio Int]
+test13 = all tst $ [-2%2,-1%2,0%2,1%2,2%2]
+ ++ [-10.0,-9.9..10.0 :: Rational]
+
+----------------------------------------------------------------
+-- test for derived instances
+----------------------------------------------------------------
+
+-- Tuples
+
+test21 = all tst $ [-1..1]
+test22 = all tst $ zip [-1..1] [-1..1]
+test23 = all tst $ zip3 [-1..1] [-1..1] [-1..1]
+test24 = all tst $ zip4 [-1..1] [-1..1] [-1..1] [-1..1]
+test25 = all tst $ zip5 [-1..1] [-1..1] [-1..1] [-1..1] [-1..1]
+{- Not derived automatically
+test26 = all tst $ zip6 [-1..1] [-1..1] [-1..1] [-1..1] [-1..1] [-1..1]
+test27 = all tst $ zip7 [-1..1] [-1..1] [-1..1] [-1..1] [-1..1] [-1..1] [-1..1]
+-}
+
+-- Enumeration
+
+data T1 = C1 | C2 | C3 | C4 | C5 | C6 | C7
+ deriving (Eq, Ord, Enum, Read, Show)
+
+test30 = all tst [C1 .. C7]
+
+-- Records
+
+data T2 = A Int | B {x,y::Int, z::Bool} | C Bool
+ deriving (Eq, Read, Show)
+
+test31 = all tst [A 1, B 1 2 True, C True]
+
+-- newtype
+
+newtype T3 = T3 Int
+ deriving (Eq, Read, Show)
+
+test32 = all tst [ T3 i | i <- [-10..10] ]
+
+----------------------------------------------------------------
+-- Random tests for things which have failed in the past
+----------------------------------------------------------------
+
+test100 = read "(True)" :: Bool
+
+test101 = tst (pi :: Float)
+test102 = diff (pi :: Float)
+
+test103 = tst (pi :: Double)
+test104 = diff (pi :: Double)
+
+
+
--- /dev/null
+"hand written instances"
+test1
+test2
+test3
+test4
+test5
+test6
+test7
+test8
+test9
+test10
+test11
+test12
+test13
+"derived instances - tuples"
+test21
+test22
+test23
+test24
+test25
+"derived instances - datatypes"
+test30
+test31
+test32
+"random assortment"
+test100
+test101
+test102
+test103
+test104
--- /dev/null
+Reading file "List.hs":
+Reading file "test/runtime/r004.hs":
+Type :? for help
+Hugs:"hand written instances"
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:"derived instances - tuples"
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:"derived instances - datatypes"
+Hugs:True
+Hugs:True
+Hugs:True
+Hugs:"random assortment"
+Hugs:True
+Hugs:True
+Hugs:0.0
+Hugs:True
+Hugs:0.0
--- /dev/null
+--!!! Testing arithmetic operators
+
+-- Int primitives
+
+ -- standard show function will produce garbage for primMinInt
+test1 = show (1 + minBound::Int, minBound::Int)
+test2 = show (maxBound::Int)
+test3 = show $ (1 + 2::Int)
+test4 = show $ (1 - 2::Int)
+test5 = show $ (3 * 5::Int)
+test6 = show $ (-(10::Int))
+test7 = show $ (even (10::Int), even (11::Int))
+test8 = show $ (10 == (10::Int), 10 == (11::Int))
+test9 = show $ [ x `quotRem` (y::Int) | x <- [-5,0,5], y <- [-3,3] ]
+test10 = show $ [ x `divMod` (y::Int) | x <- [-5,0,5], y <- [-3,3] ]
+test11 = show $ 1 `quot` (0::Int)
+test12 = show $ 1 `rem` (0::Int)
+
+-- Integer primitives
+
+--test21 = show (1 + minBound::Integer, minBound::Integer)
+--test22 = show (maxBound::Integer)
+test23 = show $ (1 + 2::Integer)
+test24 = show $ (1 - 2::Integer)
+test25 = show $ (3 * 5::Integer)
+test26 = show $ (-(10::Integer))
+test27 = show $ (even (10::Integer), even (11::Integer))
+test28 = show $ (10 == (10::Integer), 10 == (11::Integer))
+test29 = show $ [ x `quotRem` (y::Integer) | x <- [-5,0,5], y <- [-3,3] ]
+test30 = show $ [ x `divMod` (y::Integer) | x <- [-5,0,5], y <- [-3,3] ]
+test31 = show $ 1 `quot` (0::Integer)
+test32 = show $ 1 `rem` (0::Integer)
+
+-- Float primitives
+
+--test41 = show (1 + minBound::Float, minBound::Float)
+--test42 = show (maxBound::Float)
+test43 = show $ (1 + 2::Float)
+test44 = show $ (1 - 2::Float)
+test45 = show $ (3 * 5::Float)
+test46 = show $ (-(10::Float))
+test47 = show $ (10 == (10::Float), 10 == (11::Float))
+test48 = show $ [ x / (y::Float) | x <- [-5,0,5], y <- [-3,3] ]
+test49 = show $ 1 / (0::Float)
+
+test50 = show $ (pi::Float)
+test51 = show $ map sin [0.0, 0.3, 0.6, 1.0::Float]
+test52 = show $ map cos [0.0, 0.3, 0.6, 1.0::Float]
+test53 = show $ map tan [0.0, 0.3, 0.6, 1.0::Float]
+test54 = show $ map asin [0.0, 0.3, 0.6, 1.0::Float]
+test55 = show $ map acos [0.0, 0.3, 0.6, 1.0::Float]
+test56 = show $ map atan [0.0, 0.3, 0.6, 1.0::Float]
+test57 = show $ map exp [0.0, 0.3, 0.6, 1.0::Float]
+
+test58 = show $ map log [0.3, 0.6, 1.0, 10.0::Float]
+test59 = show $ log 0.0
+
+--primitive primLog10Float "primLog10Float" :: Float -> Float
+--test60 = show $ map primLog10Float [0.3, 0.6, 1.0, 10.0]
+--test61 = show $ primLog10Float 0.0
+
+test62 = show $ map sqrt [0.0, 0.3, 0.6, 1.0::Float]
+test63 = show $ sqrt (-1.0::Float)
+
+-- not in Hugs prelude, rounds towards zero
+--primitive primFloatToInt "primFloatToInt" :: Float -> Int
+--test64 = show $ map primFloatToInt [-2,-1.6,-1.5,-1.4,-1,0,1,2.0,2.4,2.5,2.6,pi,10]
+
+test65 = show $ floatDigits (1.0 :: Float)
+test66 = show $ floatDigits (error "test66" :: Float) -- laziness check
+
+test67 = show $ floatRange (1.0 :: Float)
+test68 = show $ floatRange (error "test68" :: Float) -- laziness check
+
+test69 = show $ floatRadix (1.0 :: Float)
+test70 = show $ floatRadix (error "test70" :: Float) -- laziness check
+
+
+
+-- Double primitives
+
+--test81 = show (1 + minBound::Double, minBound::Double)
+--test82 = show (maxBound::Double)
+test83 = show $ (1 + 2::Double)
+test84 = show $ (1 - 2::Double)
+test85 = show $ (3 * 5::Double)
+test86 = show $ (-(10::Double))
+test87 = show $ (10 == (10::Double), 10 == (11::Double))
+test88 = show $ [ x / (y::Double) | x <- [-5,0,5], y <- [-3,3] ]
+test89 = show $ 1 / (0::Double)
+
+test90 = show $ (pi::Double)
+test91 = show $ map sin [0.0, 0.3, 0.6, 1.0::Double]
+test92 = show $ map cos [0.0, 0.3, 0.6, 1.0::Double]
+test93 = show $ map tan [0.0, 0.3, 0.6, 1.0::Double]
+test94 = show $ map asin [0.0, 0.3, 0.6, 1.0::Double]
+test95 = show $ map acos [0.0, 0.3, 0.6, 1.0::Double]
+test96 = show $ map atan [0.0, 0.3, 0.6, 1.0::Double]
+test97 = show $ map exp [0.0, 0.3, 0.6, 1.0::Double]
+
+test98 = show $ map log [0.3, 0.6, 1.0, 10.0::Double]
+test99 = show $ log 0.0
+
+--primitive primLog10Double "primLog10Double" :: Double -> Double
+--test100 = show $ map primLog10Double [0.3, 0.6, 1.0, 10.0]
+--test101 = show $ primLog10Double 0.0
+
+test102 = show $ map sqrt [0.0, 0.3, 0.6, 1.0::Double]
+test103 = show $ sqrt (-1.0::Double)
+
+-- not in Hugs prelude, rounds towards zero
+--primitive primDoubleToInt "primDoubleToInt" :: Double -> Int
+--test104 = show $ map primDoubleToInt [-2,-1.6,-1.5,-1.4,-1,0,1,2.0,2.4,2.5,2.6,pi,10]
+
+test105 = show $ floatDigits (1.0 :: Double)
+test106 = show $ floatDigits (error "test106" :: Double) -- laziness check
+
+test107 = show $ floatRange (1.0 :: Double)
+test108 = show $ floatRange (error "test108" :: Double) -- laziness check
+
+test109 = show $ floatRadix (1.0 :: Double)
+test110 = show $ floatRadix (error "test110" :: Double) -- laziness check
+
+
+-- Char primitives
+
+test120 = show ('a' == 'b', 'b' == 'b', 'b' == 'a')
+test121 = show ('a' <= 'b', 'b' <= 'b', 'b' <= 'a')
+
+
--- /dev/null
+"Int primitives"
+test1
+test2
+test3
+test4
+test5
+test6
+test7
+test8
+test9
+test10
+test11
+test12
+"Integer primitives"
+test23
+test24
+test25
+test26
+test27
+test28
+test29
+test30
+test31
+test32
+"Float primitives"
+test43
+test44
+test45
+test46
+test47
+test48
+test49
+test50
+test51
+test52
+test53
+test54
+test55
+test56
+test57
+test58
+test59
+test62
+test63
+test65
+test66
+test67
+test68
+test69
+test70
+"Double primitives"
+test83
+test84
+test85
+test86
+test87
+test88
+test89
+test90
+test91
+test92
+test93
+test94
+test95
+test96
+test97
+test98
+test99
+test102
+test103
+test105
+test106
+test107
+test108
+test109
+test110
+"Char primitives"
+test120
+test121
--- /dev/null
+Type :? for help
+Hugs:"Int primitives"
+Hugs:"(-2147483647,-2147483648)"
+Hugs:"2147483647"
+Hugs:"3"
+Hugs:"-1"
+Hugs:"15"
+Hugs:"-10"
+Hugs:"(True,False)"
+Hugs:"(True,False)"
+Hugs:"[(1,-2),(-1,-2),(0,0),(0,0),(-1,2),(1,2)]"
+Hugs:"[(1,-2),(-2,1),(0,0),(0,0),(-2,-1),(1,2)]"
+Hugs:"
+Program error: {primQuotInt 1 0}
+
+Hugs:"
+Program error: {primRemInt 1 0}
+
+Hugs:"Integer primitives"
+Hugs:"3"
+Hugs:"-1"
+Hugs:"15"
+Hugs:"-10"
+Hugs:"(True,False)"
+Hugs:"(True,False)"
+Hugs:"[(1,-2),(-1,-2),(0,0),(0,0),(-1,2),(1,2)]"
+Hugs:"[(1,-2),(-2,1),(0,0),(0,0),(-2,-1),(1,2)]"
+Hugs:"
+Program error: {primQrmInteger 1 0}
+
+Hugs:"
+Program error: {primQrmInteger 1 0}
+
+Hugs:"Float primitives"
+Hugs:"3.0"
+Hugs:"-1.0"
+Hugs:"15.0"
+Hugs:"-10.0"
+Hugs:"(True,False)"
+Hugs:"[1.6666666,-1.6666666,-0.0,0.0,-1.6666666,1.6666666]"
+Hugs:"Infinity"
+Hugs:"3.1415927"
+Hugs:"[0.0,0.29552022,0.5646425,0.84147096]"
+Hugs:"[1.0,0.9553365,0.8253356,0.5403023]"
+Hugs:"[0.0,0.30933627,0.68413687,1.5574077]"
+Hugs:"[0.0,0.30469266,0.64350116,1.5707964]"
+Hugs:"[1.5707964,1.2661036,0.9272952,0.0]"
+Hugs:"[0.0,0.29145682,0.5404195,0.7853982]"
+Hugs:"[1.0,1.3498589,1.8221189,2.7182817]"
+Hugs:"[-1.2039728,-0.5108256,0.0,2.3025851]"
+Hugs:"-Infinity"
+Hugs:"[0.0,0.5477226,0.7745967,1.0]"
+Hugs:"NaN"
+Hugs:"24"
+Hugs:"24"
+Hugs:"(-125,128)"
+Hugs:"(-125,128)"
+Hugs:"2"
+Hugs:"2"
+Hugs:"Double primitives"
+Hugs:"3.0"
+Hugs:"-1.0"
+Hugs:"15.0"
+Hugs:"-10.0"
+Hugs:"(True,False)"
+Hugs:"[1.6666666666666667,-1.6666666666666667,-0.0,0.0,-1.6666666666666667,1.6666666666666667]"
+Hugs:"Infinity"
+Hugs:"3.141592653589793"
+Hugs:"[0.0,0.29552020666133955,0.5646424733950354,0.8414709848078965]"
+Hugs:"[1.0,0.955336489125606,0.8253356149096783,0.5403023058681398]"
+Hugs:"[0.0,0.30933624960962325,0.6841368083416923,1.5574077246549023]"
+Hugs:"[0.0,0.3046926540153975,0.6435011087932844,1.5707963267948966]"
+Hugs:"[1.5707963267948966,1.2661036727794992,0.9272952180016123,0.0]"
+Hugs:"[0.0,0.2914567944778671,0.5404195002705842,0.7853981633974483]"
+Hugs:"[1.0,1.3498588075760032,1.8221188003905089,2.718281828459045]"
+Hugs:"[-1.2039728043259361,-0.5108256237659907,0.0,2.302585092994046]"
+Hugs:"-Infinity"
+Hugs:"[0.0,0.5477225575051661,0.7745966692414834,1.0]"
+Hugs:"NaN"
+Hugs:"53"
+Hugs:"53"
+Hugs:"(-1021,1024)"
+Hugs:"(-1021,1024)"
+Hugs:"2"
+Hugs:"2"
+Hugs:"Char primitives"
+Hugs:"(False,True,False)"
+Hugs:"(True,True,False)"
--- /dev/null
+--!!! Testing list operations
+
+-- Hack: The only purpose of this script is to give us a place to put
+-- the above comment...
+-- It might be useful to import the List library so that we can test it too.
+
+-- padding so that this isn't an empty script
+module TestList where
+import Prelude
--- /dev/null
+map succ [1..10]
+
+filter odd [1..10]
+
+takeWhile (<5) [1..10]
+dropWhile (<5) [1..10]
+span (<5) [1..10]
+break (<5) [1..10]
+span (>5) [1..10]
+break (>5) [1..10]
+
+length [1..10]
+[1..10] !! 5
+
+take 5 [1..10]
+drop 5 [1..10]
+splitAt 5 [1..10]
--- /dev/null
+Type :? for help
+Hugs:[2,3,4,5,6,7,8,9,10,11]
+Hugs:Hugs:[1,3,5,7,9]
+Hugs:Hugs:[1,2,3,4]
+Hugs:[5,6,7,8,9,10]
+Hugs:([1,2,3,4],[5,6,7,8,9,10])
+Hugs:([],[1,2,3,4,5,6,7,8,9,10])
+Hugs:([],[1,2,3,4,5,6,7,8,9,10])
+Hugs:([1,2,3,4,5],[6,7,8,9,10])
+Hugs:Hugs:10
+Hugs:6
+Hugs:Hugs:[1,2,3,4,5]
+Hugs:[6,7,8,9,10]
+Hugs:([1,2,3,4,5],[6,7,8,9,10])
--- /dev/null
+--!!! Testing Immutable Arrays (part 1)
+
+import Array
+
+a1 :: Array Int Int
+a1 = array (1,10) [ (i,i*i) | i <- [1..10] ]
+
+
+test1 = bounds a1
+test2 = assocs a1
+test3 = indices a1
+test4 = elems a1
+
+test5 = a1 // [(3,3),(4,4)]
+
+-- note duplicate value and absent value
+a1' :: Array Int Char
+a1' = array (1,3) [(1,'a'), (1,'b'), (3,'c')]
+
+test6 = a1' ! 1 -- duplicate array index
+test7 = a1' ! 2 -- undefined array element
+test8 = a1' ! 3 -- 'c'
+
+test10 = a1 ! 0 -- should fail
+test11 = a1 ! 11 -- should fail
+test12 = [ a1 ! i | i <- [1..10] ]
+
--- /dev/null
+test1
+test2
+test3
+test4
+test5
+test6
+test7
+test8
+test10
+test11
+test12
+
--- /dev/null
+Type :? for help
+Hugs:(1,10)
+Hugs:[(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]
+Hugs:[1,2,3,4,5,6,7,8,9,10]
+Hugs:[1,4,9,16,25,36,49,64,81,100]
+Hugs:array (1,10) [(1,1),(2,4),(3,3),(4,4),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]
+Hugs:'b'
+Hugs:
+Program error: (Array.!): undefined array element
+
+Hugs:'c'
+Hugs:
+Program error: Ix.index.Int: Index out of range.
+
+Hugs:
+Program error: Ix.index.Int: Index out of range.
+
+Hugs:[1,4,9,16,25,36,49,64,81,100]
--- /dev/null
+--!!! Dictionary bug demo
+import Array
+
+a :: Array Int Int
+a = array (1,10) [ (i,i*i) | i <- [1..10] ]
+
+test1 = show a
+test2 = show a
+
+test3 = let a = array (1,10) [ (i,i*i) | i <- [1..10] ] in show a
+test4 = let a = array (1,10) [ (i,i*i) | i <- [1..10] ] in show a
\ No newline at end of file
--- /dev/null
+test1
+test2
+test3
+test4
--- /dev/null
+Type :? for help
+Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
+Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
+Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
+Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
--- /dev/null
+--!!! Some simple examples using arrays.
+
+module ArrayEx where
+import Array
+
+-- Some applications, most taken from the Gentle Introduction ... -------------
+
+timesTable :: Array (Int,Int) Int
+timesTable = array ((1,1),(10,10)) [ ((i,j), i*j) | i<-[1..10], j<-[1..10] ]
+
+fibs n = a where a = array (0,n) ([ (0,1), (1,1) ] ++
+ [ (i, a!(i-2) + a!(i-1)) | i <- [2..n] ])
+
+wavefront n = a where a = array ((1,1),(n,n))
+ ([ ((1,j), 1) | j <- [1..n] ] ++
+ [ ((i,1), 1) | i <- [2..n] ] ++
+ [ ((i,j), a!(i,j-1) + a!(i-1,j-1) + a!(i-1,j))
+ | i <- [2..n], j <- [2..n] ])
+
+listwave n = [ [wf!(i,j) | j <- [1..n]] | i <- [1..n] ]
+ where wf = wavefront n
+
+eg1 :: Array Integer Integer
+eg1 = array (1,100) ((1, 1) : [ (i, i * eg1!(i-1)) | i <- [2..100] ])
+
+-------------------------------------------------------------------------------
--- /dev/null
+show timesTable
--- /dev/null
+Type :? for help
+Hugs:"array ((1,1),(10,10)) [((1,1),1),((1,2),2),((1,3),3),((1,4),4),((1,5),5),((1,6),6),((1,7),7),((1,8),8),((1,9),9),((1,10),10),((2,1),2),((2,2),4),((2,3),6),((2,4),8),((2,5),10),((2,6),12),((2,7),14),((2,8),16),((2,9),18),((2,10),20),((3,1),3),((3,2),6),((3,3),9),((3,4),12),((3,5),15),((3,6),18),((3,7),21),((3,8),24),((3,9),27),((3,10),30),((4,1),4),((4,2),8),((4,3),12),((4,4),16),((4,5),20),((4,6),24),((4,7),28),((4,8),32),((4,9),36),((4,10),40),((5,1),5),((5,2),10),((5,3),15),((5,4),20),((5,5),25),((5,6),30),((5,7),35),((5,8),40),((5,9),45),((5,10),50),((6,1),6),((6,2),12),((6,3),18),((6,4),24),((6,5),30),((6,6),36),((6,7),42),((6,8),48),((6,9),54),((6,10),60),((7,1),7),((7,2),14),((7,3),21),((7,4),28),((7,5),35),((7,6),42),((7,7),49),((7,8),56),((7,9),63),((7,10),70),((8,1),8),((8,2),16),((8,3),24),((8,4),32),((8,5),40),((8,6),48),((8,7),56),((8,8),64),((8,9),72),((8,10),80),((9,1),9),((9,2),18),((9,3),27),((9,4),36),((9,5),45),((9,6),54),((9,7),63),((9,8),72),((9,9),81),((9,10),90),((10,1),10),((10,2),20),((10,3),30),((10,4),40),((10,5),50),((10,6),60),((10,7),70),((10,8),80),((10,9),90),((10,10),100)]"
--- /dev/null
+#! /usr/bin/perl -i.bak
+
+while (<>) {
+ # Insert header line
+ if ($ARGV ne $oldargv) {
+ $ARGV =~ /\d+/;
+ $filenum = $&;
+ print <<EOTXT;
+Reading file "test/static/s$filenum.hs":
+EOTXT
+ $oldargv = $ARGV;
+ }
+
+ # Make this script idempotent
+ next if /^Reading file "test\/static\/s\d+\.hs":/;
+
+ # Fix error messages
+ s#test/[A-Za-z]+\d+\.hs#test/static/s$filenum.hs#g;
+
+ # Delete trailing line
+ s/^Hugs:\[Leaving Hugs\]\n//;
+
+ print;
+}
--- /dev/null
+----------------------------------------------------------------
+-- Testing syntax checking, static checking and modules.
+-- This group of checks will produce about 100 lines of output of the form
+--
+-- --!!! <description of feature being tested>
+--
+-- You should report a problem if any other output is generated.
+----------------------------------------------------------------"
--- /dev/null
+--!!! Testing error checking in qualified names (patterns)
+
+-- No qualified variables in patterns
+module TestQual1 where
+f (A.x : xs) = xs
+
--- /dev/null
+ERROR "test/static/s001.hs" (line 5): Illegal use of qualified variable in pattern
--- /dev/null
+--!!! Testing error checking in qualified names (type variables)
+
+-- No qualified type variables
+module TestQual2 where
+x :: A.a
+x = x
+
+
--- /dev/null
+ERROR "test/static/s002.hs" (line 5): Syntax error in type expression (unexpected symbol "A.a")
--- /dev/null
+--!!! Testing error checking in qualified names (local variables)
+
+-- No qualified local variables
+module TestQual3 where
+f x = A.y where A.y = x
--- /dev/null
+ERROR "test/static/s003.hs" (line 5): Binding for qualified variable "A.y" not allowed
--- /dev/null
+--!!! Testing error checking in qualified names (top level variables)
+
+-- No qualified top level variables
+module TestQual4 where
+A.f x = x
--- /dev/null
+ERROR "test/static/s004.hs" (line 5): Binding for qualified variable "A.f" not allowed
--- /dev/null
+--!!! Testing error checking in qualified names (unknown module)
+
+-- Qualifying with a module that isn't imported
+module TestQual5 where
+foo = A.foo
--- /dev/null
+ERROR "test/static/s005.hs" (line 5): Undefined qualified variable "A.foo"
--- /dev/null
+--!!! Testing Haskell 1.3 syntax
+
+-- Haskell 1.3 syntax differs from Haskell 1.2 syntax in several ways:
+
+-- * Qualified names in export lists
+module TestSyntax where
+
+-- * Qualified import/export
+
+-- 1) Syntax:
+
+import qualified Prelude as P
+
+import Prelude
+import qualified Prelude
+
+import Prelude ()
+import Prelude (fst,snd)
+import qualified Prelude(fst,snd)
+
+-- bizarre syntax allowed in draft of Haskell 1.3
+import Prelude(,)
+import Prelude(fst,snd,)
+import Prelude(Ord(..),Eq((==),(/=)),)
+import Prelude hiding (fst,snd,)
+
+import Prelude hiding (fst,snd)
+import qualified Prelude hiding (fst,snd)
+
+import Prelude as P
+import qualified Prelude as P
+
+import Prelude as P(fst,snd)
+import Prelude as P(,)
+import qualified Prelude as P(fst,snd)
+
+import Prelude as P hiding (fst,snd)
+import qualified Prelude as P hiding (fst,snd)
+
+-- 2) Use of qualified type names
+-- 3) Use of qualified constructors
+-- 4) Use of qualified variables
+
+-- * No n+k patterns (yippee!)
+-- (No tests yet)
+
+-- Some things are unchanged.
+
+-- * Unqualified imports and use of hiding/selective import.
+--
+-- Note: it's not clear how these various imports are supposed to
+-- interact with one another.
+-- John explains:
+-- 1) "hiding" lists etc are just abbreviations for very long
+-- lists.
+-- 2) Multiple imports are additive.
+-- (This makes the meaning order-independent!)
+-- Note: Hugs allows imports anywhere a topdecl is allowed.
+-- This isn't legal Haskell - but it does no harm.
+
+-- import Prelude(lex)
+-- import Prelude
+-- import Prelude hiding (lex)
+-- lex = 1 :: Int -- error unless we've hidden lex.
+
+
+
+-- * Qualified names
+
+-- Function/operator names
+myfilter x = Prelude.filter x -- argument added to avoid monomorphism restn
+mycompose = (Prelude..)
+
+-- Use of module synonyms
+myfilter2 p = P.filter p
+
+-- Method names
+myplus :: Num a => a -> a -> a
+myplus = (Prelude.+)
+
+-- Tycons
+myminus = (Prelude.-) :: Prelude.Int -> Prelude.Int -> Prelude.Int
+
+-- Type synonyms
+foo :: P.ShowS
+foo = foo
+
+-- Class names in instances
+instance P.Num P.Bool where
+ (+) = (P.||)
+ (*) = (P.&&)
+ negate = P.not
+
+instance (P.Num a, P.Num b) => P.Num (a,b) where
+ x + y = (fst x + fst y, snd x + snd y)
+
+-- Constructor names in expressions
+
+-- this used to break tidyInfix in parser.y
+-- Note that P.[] is _not_ legal!
+testInfixQualifiedCon = 'a' P.: [] :: String
+
+-- Constructor names in patterns
+f (P.Just x) = True
+f (P.Nothing) = False
+
+g (x P.: xs) = x
+
+y P.: ys = ['a'..]
+
+-- * Support for octal and hexadecimal numbers
+-- Note: 0xff and 0xFF are legal but 0Xff and 0XFF are not.
+-- ToDo: negative tests to make sure invalid numbers are excluded.
+
+d = ( -1, -0, 0, 1) :: (Int,Int,Int,Int)
+o = (-0o1,-0o0,0o0,0o1) :: (Int,Int,Int,Int)
+x = (-0x1,-0x0,0x0,0x1) :: (Int,Int,Int,Int)
+x' = (0xff,0xFf,0xfF,0xFF) :: (Int,Int,Int,Int)
+
+-- * No renaming or interface files
+-- We test that "interface", "renaming" and "to" are not reserved.
+
+interface = 1 :: Int
+renaming = 42 :: Int
+to = 2 :: Int
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Importing unknown module
+module M where
+import N
--- /dev/null
+Reading file "N":
+ERROR "N": Unable to open file "N"
--- /dev/null
+--!!! Qualified import of unknown module
+module M where
+import qualified N
--- /dev/null
+Reading file "N":
+ERROR "N": Unable to open file "N"
--- /dev/null
+--!!! Exporting "constructor" of a type synonym
+module M(T(K1)) where
+type T = T'
+data T' = K1
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s009.hs": Explicit constructor list given for type synonym "T" in export list of module "M"
--- /dev/null
+--!!! Exporting unknown constructor
+module M(T(K1,K2)) where
+data T = K1
--- /dev/null
+ERROR "test/static/s010.hs": Entity "K2" is not a constructor of type "T"
--- /dev/null
+--!!! Duplicate export of constructor
+module M(T(K1,K1)) where
+data T = K1
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Omitted constructor from export list
+module M(T(K1)) where
+data T = K1|K2
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Exporting non-existent type/class
+module M(T) where
+x = 'a' -- dummy definition to get round a separate bug
--- /dev/null
+ERROR "test/static/s013.hs": Unknown entity "T" exported from module "M"
--- /dev/null
+--!!! Exporting non-existent module
+module M(module N) where
+x = 'a' -- dummy definition to get round a separate bug
--- /dev/null
+ERROR "test/static/s014.hs": Unknown module "N" exported from module "M"
--- /dev/null
+--!!! Exporting non-existent type transparently
+module M(T(..)) where
+x = 'a' -- dummy definition to get round a separate bug
--- /dev/null
+ERROR "test/static/s015.hs": Explicit export list given for non-class/datatype "T" in export list of module "M"
--- /dev/null
+--!!! Exporting non-existent datatype transparently
+module M(T(K1)) where
+x = 'a' -- dummy definition to get round a separate bug
--- /dev/null
+ERROR "test/static/s016.hs": Explicit export list given for non-class/datatype "T" in export list of module "M"
--- /dev/null
+--!!! Empty module body
+module M where
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct class export
+module M(C(m1,m2,m3)) where
+class C a where
+ m1 :: a
+ m2, m3 :: a
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Omitted member from export list
+module M(C(m1,m3)) where
+class C a where
+ m1 :: a
+ m2, m3 :: a
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Duplicate member in export list
+module M(C(m1,m2,m2,m3)) where
+class C a where
+ m1 :: a
+ m2, m3 :: a
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct class export
+module M(C(..)) where
+class C a where
+ m1 :: a
+ m2, m3 :: a
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct abstract class export
+module M(C) where
+class C a where
+ m1 :: a
+ m2, m3 :: a
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Testing non-member function in explicit class export list
+module M(C(m1,m2,m3,Left)) where
+class C a where
+ m1 :: a
+ m2, m3 :: a
--- /dev/null
+ERROR "test/static/s023.hs": Entity "Left" is not a member of class "C"
--- /dev/null
+--!!! Testing duplicate type synonyms
+type T = Int
+type T = Float
--- /dev/null
+ERROR "test/static/s024.hs" (line 3): Repeated definition of type constructor "T"
--- /dev/null
+--!!! Testing duplicate classes
+class C a where m :: a
+class C a where m :: a
--- /dev/null
+ERROR "test/static/s025.hs" (line 3): Repeated definition of class "C"
--- /dev/null
+--!!! Testing duplicate members
+class C1 a where m :: a
+class C2 a where m :: a
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s026.hs" (line 2): Repeated definition for member function "m"
--- /dev/null
+--!!! Testing duplicate type constructors
+data T = K1
+data T = K2
--- /dev/null
+ERROR "test/static/s027.hs" (line 3): Repeated definition of type constructor "T"
--- /dev/null
+--!!! Testing duplicate data constructors
+data T1 = K
+data T2 = K
--- /dev/null
+ERROR "test/static/s028.hs" (line 2): Repeated definition for constructor function "K"
--- /dev/null
+--!!! Testing duplicate type variables
+type T a a = Either a a
--- /dev/null
+ERROR "test/static/s029.hs" (line 2): Repeated type variable "a" on left hand side
--- /dev/null
+--!!! Testing duplicate type variables
+data T a a = K a a
--- /dev/null
+ERROR "test/static/s030.hs" (line 2): Repeated type variable "a" on left hand side
--- /dev/null
+--!!! Testing existential type variables
+data T a = K a b
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Testing bogus (or existential) type variables
+type T a = Either a b
--- /dev/null
+ERROR "test/static/s032.hs" (line 2): Undefined type variable "b"
--- /dev/null
+--!!! Testing recursive type synonyms
+type T1 = (Int,T2)
+type T2 = (Int,T1)
--- /dev/null
+ERROR "test/static/s033.hs" (line 2): Type synonyms "T1" and "T2" are mutually recursive
--- /dev/null
+--!!! Trying to export restricted type synonyms
+module M(T(..)) where
+type T = Char in x :: T
+x = 'a'
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s034.hs": Transparent export of restricted type synonym "T" in export list of module "M"
--- /dev/null
+--!!! Imported tycon clashes with local definition
+module M where
+import Prelude(Int)
+type Int = Char
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s035.hs": Tycon "Int" imported from "Prelude" already defined in module "M"
--- /dev/null
+--!!! Imported class clashes with local class definition
+module M where
+import Prelude(Eq,Bool)
+class Eq a where (==) :: a -> a -> Bool
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s036.hs": Class "Eq" imported from "Prelude" already defined in module "M"
--- /dev/null
+--!!! Imported class clashes with local type definition
+module M where
+import Prelude(Eq,Bool)
+type Eq = Bool
--- /dev/null
+ERROR "test/static/s037.hs": Import of class "Eq" clashes with type constructor in module "Prelude"
--- /dev/null
+--!!! Imported tycon clashes with local class definition
+module M where
+import Prelude(Int,Bool)
+class Int a where (==) :: a -> a -> Bool
--- /dev/null
+ERROR "test/static/s038.hs": Import of type constructor "Int" clashes with class in module "PreludeBuiltin"
--- /dev/null
+--!!! Imported var clashes with local var definition
+module M where
+--import Prelude(id)
+id x = x
--- /dev/null
+ERROR "test/static/s039.hs" (line 4): Definition of variable "id" clashes with import
--- /dev/null
+--!!! Imported member fun clashes with local var definition
+module M where
+import Ix(Ix(..))
+index x = x
--- /dev/null
+ERROR "test/static/s040.hs" (line 4): Definition of variable "index" clashes with import
--- /dev/null
+--!!! Imported constructor clashes with local constructor
+module M where
+import Prelude(Bool(True,False))
+data T = True
--- /dev/null
+ERROR "test/static/s041.hs" (line 4): Definition of constructor function "True" clashes with import
--- /dev/null
+--!!! Hiding lists "intersect" part 1
+module M where
+import Prelude hiding (const,id)
+import Prelude hiding (const)
+x = const
--- /dev/null
+ERROR "test/static/s042.hs" (line 5): Undefined variable "const"
--- /dev/null
+--!!! Hiding lists "intersect" part 2
+module M where
+import Prelude hiding (const,id)
+import Prelude hiding (const)
+x = id
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Class decl clashes with type decl
+module M where
+type C = Int
+class C a where f :: a
--- /dev/null
+ERROR "test/static/s044.hs" (line 4): "C" used as both class and type constructor
--- /dev/null
+--!!! Illegal constraints on member funs
+module M where
+class C a where f :: Eq a => a
--- /dev/null
+ERROR "test/static/s045.hs" (line 3): Illegal constraints on class variable "a" in type of member function "f"
--- /dev/null
+--!!! Cyclic class hierarchy
+module M where
+class C2 a => C1 a where f :: a
+class C1 a => C2 a where g :: a
--- /dev/null
+ERROR "test/static/s046.hs" (line 4): Class hierarchy for "C2" is not acyclic
--- /dev/null
+--!!! Overlapping instances
+module M where
+instance Eq a => Eq (Either a a)
--- /dev/null
+ERROR "test/static/s047.hs" (line 3): Overlapping instances for class "Eq"
+*** This instance : Eq (Either a a)
+*** Overlaps with : Eq (Either a b)
+*** Common instance : Eq (Either a a)
+
--- /dev/null
+--!!! Overlapping instances
+module M where
+instance Eq a
--- /dev/null
+ERROR "test/static/s048.hs" (line 3): Overlapping instances for class "Eq"
+*** This instance : Eq a
+*** Overlaps with : Eq (Ref a b)
+*** Common instance : Eq (Ref a b)
+
--- /dev/null
+--!!! Type synonym in instance
+module M where
+type T = S
+data S = MkS
+instance Eq T
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Repeated instance decl
+module M where
+data T = T Int
+instance Eq T
+instance Eq T
--- /dev/null
+ERROR "test/static/s050.hs" (line 5): Overlapping instances for class "Eq"
+*** This instance : Eq T
+*** Overlaps with : Eq T
+*** Common instance : Eq T
+
--- /dev/null
+--!!! Type sigs in instance decl
+module M where
+data T = T Int
+instance Eq T where
+ (==) :: T -> T -> Bool
+ T x == T y = x == y
+
--- /dev/null
+ERROR "test/static/s051.hs" (line 4): Type signature decls not permitted in instance decl
--- /dev/null
+--!!! Instances of superclasses exist
+module M where
+data T = T Int
+instance Ord T
--- /dev/null
+ERROR "test/static/s052.hs" (line 4): Cannot build superclass instance
+*** Instance : Ord T
+*** Context supplied : ()
+*** Required superclass : Eq T
+
--- /dev/null
+--!!! Instance context can't satisfy class-hierarchy constraint
+module M where
+class Foo a
+class Foo a => Bar a
+instance Num a => Foo [a]
+instance (Eq a, Enum a) => Bar [a]
+
--- /dev/null
+ERROR "test/static/s053.hs" (line 6): Cannot build superclass instance
+*** Instance : Bar [a]
+*** Context supplied : (Enum a, Eq a)
+*** Required superclass : Foo [a]
+
--- /dev/null
+--!!! Class decl can't use pattern bindings
+module M where
+class C a where
+ x,y :: a
+ (x,y) = error "foo"
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s054.hs" (line 5): Pattern binding illegal in class declaration
--- /dev/null
+--!!! Default decl for non-method
+module M where
+class C a where
+ x :: a
+ y = error "foo"
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s055.hs" (line 5): No member "y" in class "C"
--- /dev/null
+--!!! Default decl for non-method
+module M where
+data T = C deriving (Foo)
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s056.hs" (line 3): Unknown class "Foo" in derived instance
--- /dev/null
+--!!! Duplicate derived instance
+module M where
+data T = C deriving (Eq,Eq)
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s057.hs" (line 3): Overlapping instances for class "Eq"
+*** This instance : Eq T
+*** Overlaps with : Eq T
+*** Common instance : Eq T
+
--- /dev/null
+--!!! Duplicate derived instance
+module M where
+data T = C deriving (Eq)
+instance Eq T
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s058.hs" (line 3): Overlapping instances for class "Eq"
+*** This instance : Eq T
+*** Overlaps with : Eq T
+*** Common instance : Eq T
+
--- /dev/null
+--!!! Duplicate derived instance
+module M where
+class C a
+data T = K deriving (C)
--- /dev/null
+ERROR "test/static/s059.hs" (line 4): Cannot derive instances of class "C"
--- /dev/null
+--!!! Duplicate derived instance
+module M where
+data T = K deriving (Ord)
--- /dev/null
+ERROR "test/static/s060.hs" (line 3): Cannot build superclass instance
+*** Instance : Ord T
+*** Context supplied : ()
+*** Required superclass : Eq T
+
--- /dev/null
+--!!! Illegal deriving Enum
+module M where
+data T = K Int deriving (Enum)
--- /dev/null
+ERROR "test/static/s061.hs" (line 3): Can only derive instances of Enum for enumeration types
--- /dev/null
+--!!! Illegal deriving Ix
+module M where
+import Ix(Ix(..))
+data T = K1 Int | K2 deriving (Eq,Ord,Ix)
--- /dev/null
+ERROR "test/static/s062.hs" (line 4): Can only derive instances of Ix for enumeration or product types
--- /dev/null
+--!!! Multiple (identical) default decls
+module M where
+default (Int,Integer)
+default (Int,Integer)
--- /dev/null
+ERROR "test/static/s064.hs" (line 4): Multiple default declarations are not permitted ina single script file.
+
--- /dev/null
+--!!! Malformed pattern (unknown constructor)
+module M where
+f K = error "foo"
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s065.hs" (line 3): Undefined constructor function "K"
--- /dev/null
+--!!! Malformed pattern (arity)
+module M where
+f (Left) = error "foo"
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s066.hs" (line 3): Constructor function "Left" needs 1 args in pattern
--- /dev/null
+--!!! Malformed infix expression
+module M where
+f a b c = a==b==c
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s067.hs" (line 3): Ambiguous use of operator "==" with "=="
--- /dev/null
+--!!! Malformed binding (qualified)
+module M where
+x = let M.y = 'a' in M.y
--- /dev/null
+ERROR "test/static/s068.hs" (line 3): Binding for qualified variable "M.y" not allowed
--- /dev/null
+--!!! Bindings of different arities
+module M where
+f 0 = id
+f x y = x+y
--- /dev/null
+ERROR "test/static/s069.hs" (line 3): Equations give different arities for "f"
--- /dev/null
+--!!! Pattern binding must bind (not an error in standard Haskell)
+module M where
+x = let ['a'] = "a" in 'a'
--- /dev/null
+ERROR "test/static/s070.hs" (line 3): No variables defined in lhs pattern
--- /dev/null
+--!!! Malformed lhs (pointless but legal in Haskell 1.3, rejected by Hugs)
+module M where
+x = let [] = "a" in 'a'
--- /dev/null
+ERROR "test/static/s071.hs" (line 3): No variables defined in lhs pattern
--- /dev/null
+--!!! Multiple value bindings
+module M where
+f x = 'a'
+g x = 'b'
+f x = 'c'
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s072.hs" (line 3): "f" multiply defined
--- /dev/null
+--!!! Type decl but no body
+module M where
+f :: Int -> Bool
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s073.hs" (line 3): Type declaration for variable "f" with no body
--- /dev/null
+--!!! Multiple type decls
+module M where
+f :: Int -> Bool
+f :: Int -> Bool
+f = even
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s074.hs" (line 4): Repeated type declaration for "f"
--- /dev/null
+--!!! Illegal @ in expression
+module M where
+f x = x@1
--- /dev/null
+ERROR "test/static/s075.hs" (line 3): Illegal `@' in expression
--- /dev/null
+--!!! Illegal ~ in expression
+module M where
+f x = x~1
--- /dev/null
+ERROR "test/static/s076.hs" (line 3): Illegal `~' in expression
--- /dev/null
+--!!! Illegal _ in expression
+module M where
+f x = x _ 1
--- /dev/null
+ERROR "test/static/s077.hs" (line 3): Illegal `_' in expression
--- /dev/null
+--!!! Undefined variable in expression
+module M where
+f x = g x
--- /dev/null
+ERROR "test/static/s078.hs" (line 3): Undefined variable "g"
--- /dev/null
+--!!! Undefined qualified variable in expression
+module M where
+f x = Prelude.g x
--- /dev/null
+ERROR "test/static/s079.hs" (line 3): Undefined qualified variable "Prelude.g"
--- /dev/null
+--!!! Undefined qualifier in expression
+module M where
+f x = N.g x
--- /dev/null
+ERROR "test/static/s080.hs" (line 3): Undefined qualified variable "N.g"
--- /dev/null
+--!!! Qualifying with local module name
+module M where
+f x = M.f x
--- /dev/null
+ERROR "test/static/s081.hs" (line 3): Undefined qualified variable "M.f"
--- /dev/null
+--!!! Multiple modules per file
+module M where
+foo = 'a'
+
+module N where
+bar = 'b'
+
--- /dev/null
+ERROR "test/static/s082.hs" (line 5): Syntax error in input (unexpected keyword "module")
--- /dev/null
+--!!! Naked fixity declaration
+module M where
+infix $$$
+x = 'a'
--- /dev/null
+ERROR "test/static/s083.hs": No top level definition for operator symbol "$$$"
--- /dev/null
+--!!! Undefined var in restricted synonym
+module M where
+type T = Int in x
+
--- /dev/null
+ERROR "test/static/s084.hs" (line 3): No top level binding of "x" for restricted synonym "T"
--- /dev/null
+--!!! Importing unknown class/tycon
+module M where
+import Prelude(C)
+
--- /dev/null
+ERROR "test/static/s085.hs": Unknown entity "C" imported from module "Prelude"
--- /dev/null
+--!!! Importing unknown name
+module M where
+import Prelude(f)
+
--- /dev/null
+ERROR "test/static/s086.hs": Unknown entity "f" imported from module "Prelude"
--- /dev/null
+--!!! Importing Tycon with bogus constructor
+module M where
+import Prelude(Either(Left,Right,Foo))
+
--- /dev/null
+ERROR "test/static/s087.hs": Entity "Foo" is not a constructor of type "Either"
--- /dev/null
+--!!! Importing Tycon with missing constructor
+module M where
+import Prelude(Either(Left))
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Importing Tycon with duplicate constructor
+module M where
+import Prelude(Either(Left,Right,Right))
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct tycon import (explicit constructor list)
+module M where
+import Prelude(Either(Left,Right))
+x = (Left 'a', Right 'a')
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct tycon import (implicit constructor list)
+module M where
+import Prelude(Either(..))
+x = (Left 'a', Right 'a')
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct abstract tycon import
+module M where
+import Prelude(Either)
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Trying to use constructors of abstractly imported type.
+module M where
+import Prelude(Either)
+x = Left 'a'
--- /dev/null
+ERROR "test/static/s093.hs" (line 4): Undefined constructor function "Left"
--- /dev/null
+--!!! Known bug: Qualified import ignores import list
+module M where
+import qualified Prelude (map)
+x = Prelude.Left 'a'
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Sublist for non-class/tycon
+module M where
+import Prelude(map(..))
+
--- /dev/null
+ERROR "test/static/s095.hs" (line 3): Syntax error in import declaration (unexpected `(')
--- /dev/null
+--!!! Sublist for non-class/tycon
+module M where
+import Prelude(Left(..))
+
--- /dev/null
+ERROR "test/static/s096.hs": Unknown entity "Left" imported from module "Prelude"
--- /dev/null
+--!!! Importing Class with bogus member
+module M where
+import Prelude(Eq((==),(/=),eq))
+
--- /dev/null
+ERROR "test/static/s097.hs": Entity "eq" is not a member of class "Eq"
--- /dev/null
+--!!! Importing Class with missing member
+module M where
+import Prelude(Eq((==)))
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Importing Class with duplicate member
+module M where
+import Prelude(Eq((==),(/=),(==)))
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct Class import (explicit member list)
+module M where
+import Prelude(Eq((==),(/=)))
+x = 'a' == 'b'
+y = 'a' /= 'b'
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct Class import (explicit member list)
+module M where
+import Prelude(Eq(..))
+x = 'a' == 'b'
+y = 'a' /= 'b'
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Correct abstract class import
+module M where
+import Prelude(Eq)
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Trying to use members of abstractly imported class
+module M where
+import Prelude(Eq)
+x = 'a' == 'b'
--- /dev/null
+ERROR "test/static/s103.hs" (line 4): Undefined variable "=="
--- /dev/null
+--!!! Type signature for qualified name
+module M where
+M.x :: Char
+x = 'a'
--- /dev/null
+ERROR "test/static/s104.hs" (line 3): Type signature for qualified variable "M.x" is not allowed
--- /dev/null
+--!!! Opaque import/export of tycons
+module T2 where
+import T1
--- /dev/null
+Reading file "test/static/T1.hs":
+Reading file "test/static/s105.hs":
+Type :? for help
--- /dev/null
+--!!! Transparent import of type synonyms
+module T3 where
+import Prelude(ReadS(..))
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Testing export of class members
+
+module T7 where
+
+import T6
+
+p :: (W a,X a, Y a, Z a) => [a]
+p = [y,z]
--- /dev/null
+Reading file "test/static/T6.hs":
+Reading file "test/static/s107.hs":
+Type :? for help
--- /dev/null
+--!!! Testing export of unknown name\r
+module Bar(bar) where\r
+foo = foo
\ No newline at end of file
--- /dev/null
+ERROR "test/static/s108.hs": Unknown entity "bar" exported from module "Bar"
--- /dev/null
+--!!! Repeated type variable "a" in instance predicate
+module M where
+data T a b = MkT a b
+instance Eq a => Eq (T a a)
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Empty field list in update
+data T = T { x,y :: Int }
+f t = t {}
--- /dev/null
+ERROR "test/static/s110.hs" (line 3): Empty field list in update
--- /dev/null
+--!!! No constructor has all of the fields specified
+data T = T {x,y::Int}
+data U = U {z::Int}
+
+f a b c = T{x=a,y=b,z=c}
+
--- /dev/null
+ERROR "test/static/s111.hs" (line 5): No constructor has all of the fields specified in T{x = a, y = b, z = c}
+
--- /dev/null
+--!!! Constructor ... does not have selected fields in ...
+data T = T1 {x,y :: Int}
+ | T2 { y,z :: Int}
+
+f a b c = T1{y=b,z=c}
+
--- /dev/null
+ERROR "test/static/s112.hs" (line 5): Constructor "T1" does not have selected fields in T1{y = b, z = c}
+
--- /dev/null
+--!!! Repeated field name ... in field list
+data T = T {x,y :: Int}
+
+f a b = T{x=a,x=b}
+
--- /dev/null
+ERROR "test/static/s113.hs" (line 4): Repeated field name "x" in field list
--- /dev/null
+--!!! Repeated field name ... for constructor ...
+
+data T = T {x,x :: Int}
+
--- /dev/null
+ERROR "test/static/s114.hs" (line 3): Repeated field name "x" for constructor "T"
--- /dev/null
+--!!! Known bug: can't have strict fieldnames (I think this is trivial to fix)
+
+data T = T {x :: Int, y :: !Int} deriving Show
+
+
+
--- /dev/null
+--!!! Construction does not define strict field
+
+data T = T {x :: Int, y :: !Int}
+
+f a = T{x=a}
+
--- /dev/null
+--!!! Attempt to redefine variable ...
+
+data T = T {x::Int}
+
+x = 'c'
--- /dev/null
+ERROR "test/static/s117.hs" (line 5): Attempt to redefine variable "x"
--- /dev/null
+--!!! Redeclaration of foreign ...
+
+foreign import "libc.so.6" "putchar" primPutChar :: Char -> IO ()
+foreign import "libc.so.6" "putchar" primPutChar :: Char -> IO ()
--- /dev/null
+ERROR "test/static/s118.hs" (line 4): Redeclaration of foreign "primPutChar"
--- /dev/null
+--!!! Testing error catching
+
+test1, test2 :: Either HugsObject Int
+
+test1 = primCatchError (error "foo")
+test2 = primCatchError 1
+
+
+test3, test4, test5 :: Int
+
+test3 = myCatch (1+error "foo") 2
+test4 = myCatch 1 (error "bar")
+test5 = myCatch (error "foo") (error "bar")
+
+
+test6, test7, test8, test9 :: IO ()
+
+test6 = printString "abcdefg"
+test7 = printString (error "a" : "bcdefg")
+test8 = printString ("abc" ++ error "defg")
+test9 = printString (error "a" : "bc" ++ error "defg")
+
+-- if an error occurs, replace it with a default (hopefully error-free) value
+myCatch :: a -> a -> a
+myCatch x deflt = case primCatchError x of
+ Right x' -> x'
+ Left _ -> deflt
+
+-- lazily print a string - catching any errors as necessary
+printString :: String -> IO ()
+printString str =
+ case primCatchError str of
+ Left _ -> putStr "<error>"
+ Right [] -> return ()
+ Right (c:cs) -> case primCatchError c of
+ Left _ -> putStr "<error>" >> printString cs
+ Right c' -> putChar c' >> printString cs
+
--- /dev/null
+test1
+test2
+test3
+test4
+test5
+
+test6
+test7
+test8
+test9
--- /dev/null
+Left {HugsObject ...}
+Right 1
+2
+1
+{error "bar"}
+abcdefg
+<error>bcdefg
+abc<error>
+<error>bc<error>
--- /dev/null
+--!!! Testing error catching
+
+--module TestCatch where
+
+test1, test2 :: String
+
+test1 = show $ primCatchError (error "foo"::Int)
+test2 = show $ primCatchError 1
+
+
+test3, test4, test5 :: String
+
+test3 = show $ catch (1+error "foo") 2
+test4 = show $ catch 1 (error "bar")
+test5 = show $ catch (error "foo") (error "bar" :: Int)
+
+
+test6, test7, test8, test9 :: IO ()
+
+test6 = printString "abcdefg"
+test7 = printString (error "a" : "bcdefg")
+test8 = printString ("abc" ++ error "defg")
+test9 = printString (error "a" : "bc" ++ error "defg")
+
+-- if an error occurs, replace it with a default (hopefully error-free) value
+catch :: a -> a -> a
+catch x deflt = case primCatchError x of
+ Just x' -> x'
+ Nothing -> deflt
+
+-- lazily print a string - catching any errors as necessary
+printString :: String -> IO ()
+printString str =
+ case primCatchError str of
+ Nothing -> putStr "<error>"
+ Just [] -> return ()
+ Just (c:cs) -> case primCatchError c of
+ Nothing -> putStr "<error>" >> printString cs
+ Just c' -> putChar c' >> printString cs
+
--- /dev/null
+Nothing
+Just 1
+2
+1
+
+Program Error
+
+abcdefg
+<error>bcdefg
+abc<error>
+<error>bc<error>
--- /dev/null
+polar (0:+0)
--- /dev/null
+Type :? for help
+Hugs:(0.0, 0.0)
+Hugs:[Leaving Hugs]
--- /dev/null
+--!!! Testing IOError
+
+import IO
+
+-- printing IOError values
+a1 = userError "foo"
+
+-- testing IOError values
+a2 = isUserError (userError "foo")
+
+-- catching IOErrors
+a3 = catch (fail (userError "foo")) (\err -> putStr "Caught error\n")
+
+-- continuing after catching errors
+a4 = catch (fail (userError "foo")) (\err -> putStr "Caught error\n") >>
+ putStr "Continuing\n"
+
+-- raising uncaught errors
+a5 :: IO () -- signature required to override "IO a"
+a5 = fail (userError "foo")
--- /dev/null
+a1
+a2
+a3
+a4
+a5
--- /dev/null
+userError "foo"
+Just "foo"
+Caught error
+
+Caught error
+Continuing
+
+
+foo
--- /dev/null
+--!!! Testing IOError
+
+-- These should both raise the same error - not IOErrors!
+a1 = ["a" !! 1]
+a2 = writeFile "foo" (["a"] !! 1)
--- /dev/null
+
+Program error: PreludeList.!!: index too large
+
+
+Program error: PreludeList.!!: index too large
+
--- /dev/null
+--!!! Testing File I/O operations and errors
+
+import IO
+
+testFile = "test/iohandle.tst"
+unreadable = "test/unreadable.tst"
+unwritable = "test/unwritable.tst"
+nonexistent = "test/nonexistent.tst"
+
+-- Handle free ops
+a1 = writeFile testFile (show [1..10])
+a2 = readFile testFile >>= \ s -> putStr s
+a3 = appendFile testFile (show [11..20])
+a4 = readFile testFile >>= \ s -> putStr s
+
+-- Same stuff - but using handle-based operations
+b1 = openFile testFile WriteMode >>= \ h ->
+ hPutStr h (show [1..10])
+b2 = openFile testFile ReadMode >>= \ h ->
+ hGetContents h >>= \ s ->
+ putStr s
+b3 = openFile testFile AppendMode >>= \ h ->
+ hPutStr h (show [11..20])
+b4 = openFile testFile ReadMode >>= \ h ->
+ hGetContents h >>= \ s ->
+ putStr s
+
+-- Miscellaneous little functions
+c1 = openFile testFile WriteMode >>= \ h ->
+ mapM_ (hPutChar h) (show [1..10]) >>
+ hClose h
+c2 = openFile testFile ReadMode >>= \ h ->
+ let loop =
+ hGetChar h >>= \ c ->
+ putChar c >>
+ loop
+ in
+ loop :: IO ()
+c3 = openFile testFile AppendMode >>= \ h ->
+ hPutStr h (show [11..20]) >>
+ hClose h
+c4 = openFile testFile ReadMode >>= \ h ->
+ let loop =
+ hGetChar h >>= \ c ->
+ putChar c >>
+ loop
+ in
+ loop `catch` (\err -> if isEOFError err then return () else fail err)
+-- If this function raises an uncaught EOF error, then hIsEOF probably
+-- implements ANSI C feof semantics which is quite different from
+-- Haskell 1.3 semantics (but much easier to implement).
+c5 = openFile testFile ReadMode >>= \ h ->
+ let loop =
+ hIsEOF h >>= \ eof ->
+ if eof then return () else
+ hGetChar h >>= \ c ->
+ putChar c >>
+ loop
+ in
+ loop :: IO ()
+
+c6 = openFile testFile ReadMode >>= \ h ->
+ hFlush h >>
+ hGetContents h >>= \ s ->
+ putStr s
+
+-- should print first 10 characters of file twice
+c7 = openFile testFile ReadMode >>= \ h ->
+ hGetContents h >>= \ s ->
+ putStr (take 10 s) >>
+ hClose h >>
+ putStr s
+
+
+-- Deliberately trying to trigger IOErrors:
+
+-- Note: Linux allows a file to be opened twice
+d1 = openFile testFile WriteMode >>= \ h1 ->
+ openFile testFile WriteMode >>= \ h2 ->
+ let x = [h1,h2] in -- try to make sure both pointers remain live
+ return ()
+
+d2 = openFile testFile WriteMode >>= \ h ->
+ hGetContents h >>= \ s ->
+ putStr s
+
+d3 = openFile testFile ReadMode >>= \ h ->
+ hPutStr h (show [5..10])
+
+-- This should succeed
+d4 = openFile unreadable WriteMode >>= \ h ->
+ return ()
+
+-- This should fail
+d5 = openFile unreadable ReadMode >>= \ h ->
+ return ()
+
+-- This should succeed
+d6 = openFile unwritable ReadMode >>= \ h ->
+ return ()
+
+-- This should fail
+d7 = openFile unwritable WriteMode >>= \ h ->
+ return ()
+
+d8 = openFile testFile ReadMode >>= \ h ->
+ hClose h >>
+ hGetContents h >>= \ s ->
+ putStr s
+
+d9 = openFile testFile ReadMode >>= \ h ->
+ hClose h >>
+ hClose h
+
+-- should fail
+d10 = openFile testFile ReadMode >>= \ h ->
+ hGetContents h >>= \ s1 ->
+ hGetContents h >>= \ s2 ->
+ putStr s1 >>
+ putStr s2
+
+
+
--- /dev/null
+a1
+a2
+a3
+a4
+
+b1
+b2
+b3
+b4
+
+c1
+c2
+c3
+c4
+c5
+c6
+c7
+
+d1
+d2
+d3
+d4
+d5
+d6
+d7
+d8
+d9
+d10
--- /dev/null
+
+[1,2,3,4,5,6,7,8,9,10]
+
+[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
+
+[1,2,3,4,5,6,7,8,9,10]
+
+[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
+
+[1,2,3,4,5,6,7,8,9,10]
+End of file
+
+[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
+[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
+[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
+[1,2,3,4,5[1,2,3,4,5
+
+
+Illegal operation
+
+Illegal operation
+
+
+Illegal operation
+
+
+Illegal operation
+
+Illegal operation
+
+Illegal operation
+
+Illegal operation
--- /dev/null
+--!!! Testing (List.\\) and related functions
+module T where
+
+import List( deleteBy, delete, (\\) )
+
+test1 :: [Int]
+test1 = deleteBy (==) 1 [0,1,1,2,3,4]
+
+test2 :: [Int]
+test2 = delete 1 [0,1,1,2,3,4]
+
+test3 :: [Int]
+test3 = [0,1,1,2,3,4] \\ [3,2,1]
+
--- /dev/null
+test1
+test2
+test3
--- /dev/null
+Reading file "List.hs":
+Reading file "test/std/list1.hs":
+Type :? for help
+Hugs:[0,1,2,3,4]
+Hugs:[0,1,2,3,4]
+Hugs:[0,1,4]
--- /dev/null
+--!!! Testing System
+module T where
+
+import System(getArgs,getProgName,getEnv,system)
+
+-- like print but no annoying "\n"
+pr :: Show a => a -> IO ()
+pr = putStr . show
+
+test1 = system "exit 0" >>= pr
+test2 = system "exit 1" >>= pr
+test3 = system "exit 2" >>= pr
+
+test4 = getArgs >>= pr
+test5 = getProgName >>= pr
+
+-- We want to test getEnv - but there's too much variety in possible
+-- environments so we pick an env var that doesn't vary too much
+-- and list every variation we've ever come across.
+test6 = do
+ shell <- getEnv "SHELL"
+ let sh = last $ chop '/' shell
+ if (sh `elem` shells)
+ then
+ putStr "getEnv \"SHELL\" returns known shell"
+ else
+ putStr "getEnv \"SHELL\" returns unknown shell"
+ return ()
+ where
+ shells = ["sh"
+ ,"csh"
+ ,"tcsh"
+ ,"bash"
+ ,"zsh"
+ ]
+
+chop :: Eq a => a -> [a] -> [[a]]
+chop seq [] = []
+chop sep xs = ys : case zs of
+ [] -> []
+ _:zs' -> chop sep zs'
+ where
+ (ys,zs) = break (sep ==) xs
--- /dev/null
+test1
+test2
+test3
+test4
+test5
+test6
--- /dev/null
+Reading file "System.lhs":
+Reading file "test/std/system1.hs":
+Type :? for help
+Hugs:ExitSuccess
+Hugs:ExitFailure 1
+Hugs:ExitFailure 2
+Hugs:[]
+Hugs:"Hugs"
+Hugs:getEnv "SHELL" returns known shell
--- /dev/null
+#! /usr/bin/perl -i.bak
+
+while (<>) {
+ # Insert header line
+ if ($ARGV ne $oldargv) {
+ $ARGV =~ /\d+/;
+ $filenum = $&;
+ print <<EOTXT;
+Reading file "test/typechecker/t$filenum.hs":
+EOTXT
+ $oldargv = $ARGV;
+ }
+
+ # Make this script idempotent
+ next if /^Reading file "test\/typechecker\/t\d+\.hs":/;
+
+ # Fix error messages
+ s#test/T[A-Za-z0-9]*\.hs#test/typechecker/t$filenum.hs#g;
+
+ # Delete trailing line
+ s/^Hugs:\[Leaving Hugs\]\n//;
+
+ print;
+}
--- /dev/null
+----------------------------------------------------------------
+-- Testing type checking.
+-- This group of checks will produce about 7 lines of output of the form
+--
+-- --!!! <description of feature being tested>
+--
+-- It may also produce output that looks like this:
+--
+-- ./hugs +q -pHugs: test/dicts.hs < test/dicts.input
+-- expected stdout not matched by reality
+-- *** test/dicts.output Fri Jul 11 13:25:27 1997
+-- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
+-- ***************
+-- *** 1,3 ****
+-- Hugs:\"(14,14,14)\"
+-- ! Hugs:Garbage collection recovered 93815 cells
+-- Hugs:\"(14,14,14)\"
+-- --- 1,3 ----
+-- Hugs:\"(14,14,14)\"
+-- ! Hugs:Garbage collection recovered 93781 cells
+-- Hugs:\"(14,14,14)\"
+--
+-- This is harmless and might be caused by minor variations between different
+-- machines, or slightly out of date sample output.
+--
+-- You should report a problem if any other output is generated.
+----------------------------------------------------------------
--- /dev/null
+--!!! Testing typechecker (fixed in Hugs 1.01)
+
+{-
+Hi again,
+
+While I am at bug reporting I should as well inform you of another
+problem that I encountered.
+
+While testing different variations of the gc-bug test program I
+found a difference between what would compile in the original hugs.1.01
+and the hacked.hugs that I downloaded from the ftp directory.
+
+In the hacked.hugs I have only changed: SUNOS 0, LINUX 1, and finally
+I had to remove the external definition of strchr because it conflicted
+with some include file definition. (Of course this will turn out
+to be the reason, right?)
+
+I also had to add the Ordering type in hugs.prelude that came with
+hacked.hugs.tar.gz, because it was required to be loaded.
+
+Have fun,
+
+Sverker
+
+PS:
+
+The error message was:
+
+ERROR "/home/nilsson/ngof/simpleprims/src/tbugx.gs" (line 15): Insufficient class constraints in instance member binding
+*** Context : (T a, T b, T c)
+*** Required : T d
+
+The test program, tbugx.gs, is:
+
+-}
+module TestTypes where
+
+class T a where
+ t :: Int -> a
+
+instance T Int where
+ t = id
+
+instance (T a, T b) => T (a, b) where
+ t p =
+ (t p, t p)
+
+
+instance (T a, T b, T c) => T (a, b, c) where
+-- The following compiles in hugs1.01, but not in hacked.hugs!
+-- It induces the GC bug as well.
+ t p = (a, b, c) where
+ tp = t p
+ a = fst tp
+ bc = snd tp
+ b = fst bc
+ c = snd bc
+-- The following does not induce the GC bug.
+-- But as the previous one, it compiles only in hugs1.01, not in hacked.hugs.
+-- t p = (a, b, c) where
+-- a = t p
+-- bc = t p
+-- b = fst bc
+-- c = snd bc
+
+t2:: Int -> (Int,Int)
+t2 = t -- t2 has no problems
+
+t3:: Int -> (Int,Int,Int)
+t3 = t -- t3 has problems
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Testing error-line numbers II (fixed from Hugs 1.01)
+f :: (Show a, Read a) => a -> String
+(f,g) = (show,read)
--- /dev/null
+ERROR "test/typechecker/t001.hs" (line 3): Explicit overloaded type for "f" not permitted in restricted binding
--- /dev/null
+--!!! Testing error-line numbers I (fixed from Hugs 1.01)
+(x,y)=('a','b')
+x :: a
+
--- /dev/null
+ERROR "test/typechecker/t002.hs" (line 2): Inferred type is not general enough
+*** Expression : x
+*** Expected type : a
+*** Inferred type : Char
+
--- /dev/null
+--!!! Testing monad comprehensions
+module MonadTest where
+
+-- Old uses of list comprehensions
+as :: [Bool]
+as = [ odd x | x <- [1..10] ]
+
+-- The next 4 tests used to check that list comprehension syntax
+-- could be used for monad comprehensions.
+-- Anticipating Standard Haskell's removal of this feature, we don't
+-- test (or implement!) that anymore.
+
+-- Use in monad comprehensions
+mmap :: (a -> b) -> ([] a -> [] b)
+mmap f xs = [ f x | x <- xs ]
+
+-- use ","
+bind1 :: [] a -> (a -> [] b) -> [] b
+bind1 m k = [ b | a <- m, b <- k a ]
+
+bind2 :: [] Int -> (Int -> [] b) -> [] b
+bind2 m k = [ b | a <- m, odd a, b <- k a ]
+
+-- use local binding
+bind3 :: [] a -> (a -> b) -> (b -> [] c) -> [] c
+bind3 m f k = [ c | a <- m, let b = f a, c <- k b ]
+
+
+-- The next 4 tests check the use of "do-syntax" for monad comprehensions
+
+-- Use in monad comprehensions
+mmap2 :: Monad m => (a -> b) -> (m a -> m b)
+mmap2 f xs = do { x <- xs; return (f x) }
+
+-- use ","
+bind12 :: Monad m => m a -> (a -> m b) -> m b
+bind12 m k = do { a <- m; b <- k a; return b }
+
+bind22 :: MonadZero m => m Int -> (Int -> m b) -> m b
+bind22 m k = do { a <- m; guard (odd a); b <- k a; return b }
+
+-- use local binding
+bind32 :: Monad m => m a -> (a -> b) -> (b -> m c) -> m c
+bind32 m f k = do { a <- m; let { b = f a }; c <- k b; return c }
+
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Testing (one aspect of) the dictionary bug
+{-
+Hello,
+
+Thanks for your reply and advice about the GC debugging. Before I got
+it, (our mail server is slow and undeterministic for incoming mail,
+and I have to call it up manually) I had boiled down my program to a
+quite simple test example, and prepared a mail to send to you.
+
+I don't know if the two problems are related. With my test program,
+the bug occurs only after a (manual) GC. Each time. I have to
+reload the script to get it going again.
+
+The following is the mail I intended to send, with enclosed test
+program:
+
+Hi Alastair,
+
+I have verified that there is a garbage collection related bug in
+Hugs 1.01, both in the unpatched and the patched version, compiled
+for Linux. The unpatched one had no changes to the source expect
+SUNOS 0 and LINUX 1 in prelude.h
+
+I have boiled it down to a simple test program. The program won't
+compile in either Gofer or Hugs 1.0! This seems suspicious to me,
+but maybe the program can be simplified further.
+
+I still suspect it has something to do with the dictionaries not
+being marked correctly.
+
+Maybe this will be of some relevance for your new GC as well.
+
+I don't know what / if there is a Hugs bug mailing list, maybe
+you will forward this there or to Mark directly?
+
+I'll tell you if I find out anything more specific.
+
+It seems pretty certain the problem has nothing to do with that the
+suspicious thing begins on Line 13, though...
+
+Sverker
+
+PS: Boiled down bug-provoking program enclosed, tbug.gs:
+
+-}
+module TestDicts where
+
+class T a where -- Line 1
+ t :: Int -> a
+
+instance T Int where
+ t = id
+
+instance (T a, T b) => T (a, b) where
+ t p =
+ (t p, t p)
+
+
+instance (T a, T b, T c) => T (a, b, c) where
+ t p = -- Line 13
+ (a, b, c) where
+ (a, (b, c)) = t p
+-- The following seems to give the same effect:
+-- t p =
+-- case t (p + 3) of
+-- (a, (b, c)) -> (a, b, c)
+-- But the following seems to work:
+-- t p = (t p, t p, t p)
+
+
+t2:: Int -> (Int,Int)
+t2 = t -- t2 has no problems
+
+t3:: Int -> (Int,Int,Int)
+t3 = t -- t3 has problems, see session transcript
+
+
+{-
+
+-- Gofer or Hugs 1.0 would not allow this program. Extract from Hugs 1.0:
+
+? :l /home/nilsson/ngof/simpleprims/src/tbug.gs
+Reading script file "/home/nilsson/ngof/simpleprims/src/tbug.gs":
+Type checking
+ERROR "/home/nilsson/ngof/simpleprims/src/tbug.gs" (line 13): Insufficient class constraints in instance member binding
+*** Context : (T a, T b, T c)
+*** Required : T d
+
+-- Hugs 1.01 allows it, as well as hacked.hugs. But in both the GC bug occurs.
+-- Extract from Hugs 1.01:
+
+Hugs session for:
+/usr/local/lib/Hugs/hugs.prelude
+tbug.gs
+? t3 14
+(14,14,14)
+? :gc
+Garbage collection recovered 94995 cells
+? t3 14
+(
+
+INTERNAL ERROR: Error in graph
+? t3 17
+(
+INTERNAL ERROR: Error in graph
+?
+
+-- Rewriting the tbug.gs file and reloading restores conditions.
+
+Hugs session for:
+/usr/local/lib/Hugs/hugs.prelude
+tbug.gs
+? t3 14
+(14,14,14)
+? :gc
+Garbage collection recovered 94995 cells
+? t3 14
+(
+INTERNAL ERROR: Error in graph
+
+-}
+
--- /dev/null
+show $ t3 14
+:gc
+show $ t3 14
--- /dev/null
+Type :? for help
+Hugs:"(14,14,14)"
+Hugs:Garbage collection recovered 93637 cells
+Hugs:"(14,14,14)"
--- /dev/null
+--!!! Test for error in type error message (fixed in Hugs 1.4)
+module TyErr where
+
+newtype StateMonad m s a = MkStateMonad (s -> (m (s, a)))
+
+instance Monad m => Monad (StateMonad m s) where
+ (>>=) (MkStateMonad fn1) f
+ = MkStateMonad (\st -> (do res <- fn1 st
+ case res of
+ (st', res') -> extrStateMonad (f res') st'))
+ return val = MkStateMonad (\st -> (return (st, val)))
+
+extrStateMonad (MkStateMonad f) = f
+
+getState :: Monad m => StateMonad m s s
+getState = MkStateMonad (\st -> return (st, st))
+
+-- popIndentList :: StateMonad IO Int ()
+popIndentList =
+ (do getState
+ return ())
--- /dev/null
+ERROR "test/typechecker/t005.hs" (line 19): Unresolved top-level overloading
+*** Binding : popIndentList
+*** Outstanding context : Monad b
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Another example from the 1.3c documentation
+
+data Monad2 m = MkMonad2 (forall a. a -> m a)
+ (forall a, b. m a -> (a -> m b) -> m b)
+
+halfListMonad :: (forall a,b. [a] -> (a -> [b]) -> [b]) -> Monad2 []
+halfListMonad b = MkMonad2 (\x -> [x]) b
+
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Using distinct scoped type variables for same type
+
+invalid1 = (\(x::a) (y::b) -> [x,y])
+
--- /dev/null
+ERROR "test/typechecker/t008.hs" (line 3): Type annotation uses distinct variables a and b where a single variable was inferred
--- /dev/null
+--!!! No scoped type variables in pattern bindings (sorry)
+
+((x::a):xs) = [1..] -- invalid
+
--- /dev/null
+ERROR "test/typechecker/t009.hs" (line 3): Sorry, no type variables are allowed in pattern binding type annotations
--- /dev/null
+--!!! Escaping existential variable I
+
+data Appl = MkAppl (a -> Int) a (a -> a)
+
+bad1 (MkAppl f x i) = x
--- /dev/null
+ERROR "test/typechecker/t010.hs" (line 5): Existentially quantified variable in result type
+variable : _4
+from pattern : MkAppl f x i
+result type : Appl -> _4
+
--- /dev/null
+--!!! Escaping existential variable II
+
+data Appl = MkAppl (a -> Int) a (a -> a)
+
+bad3 y = let g (MkAppl f x i) = length [x,y] + 1
+ in True
--- /dev/null
+ERROR "test/typechecker/t011.hs" (line 5): Existentially quantified variable from pattern MkAppl f x i appears in enclosing assumptions
--- /dev/null
+--!!! runST (the classic rank 2 type example)
+
+newtype ST s a = MkST (s -> (a,s))
+
+unST :: ST s a -> (s -> (a,s))
+unST (MkST f) = f
+
+runST :: (forall s. ST s a) -> a
+runST m = case unST m () of { (a,_) ->
+ a
+ }
+
+returnST :: a -> ST s a
+returnST a = MkST (\s -> (a,s))
+
+thenST :: ST s a -> (a -> ST s b) -> ST s b
+thenST m k = MkST (\ s0 -> case unST m s0 of { (a,s1) -> unST (k a) s1 })
+
+instance Monad (ST s) where
+ return = returnST
+ (>>=) = thenST
+
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Expr a (the classic existential types + polymorphic recursion example)
+
+data Expr a = App (Expr (b -> a)) (Expr b)
+ | K a
+
+eval :: Expr a -> a
+eval (App f x) = (eval f) (eval x)
+eval (K x) = x
--- /dev/null
+Type :? for help
--- /dev/null
+--!!! Leaving out signature in polymorphic recursion
+
+data Expr a = App (Expr (b -> a)) (Expr b)
+ | K a
+
+--eval :: Expr a -> a
+eval (App f x) = (eval f) (eval x)
+eval (K x) = x
--- /dev/null
+ERROR "test/typechecker/t014.hs" (line 7): Type error in application
+*** Expression : eval f (eval x)
+*** Term : eval x
+*** Type : a -> b
+*** Does not match : a
+*** Because : unification would give infinite type
+
--- /dev/null
+--!!! Can't derive instances if you use existentials
+
+data Expr a = App (Expr (b -> a)) (Expr b)
+ | K a
+ deriving (Show)
--- /dev/null
+ERROR "test/typechecker/t015.hs" (line 3): Cannot derive instances for types with existentially typed components
--- /dev/null
+!cp test/DictHW1.hs DictHW.hs
+:l DictHW.hs
+!cp test/DictHW2.hs DictHW.hs
+:r
+f 1
\ No newline at end of file
--- /dev/null
+Hugs:Hugs:Reading file "DictHW.hs":
+ERROR "DictHW.hs" (line 4): Int is not an instance of class "Fractional"
+Hugs:Hugs:Reading file "DictHW.hs":
+Hugs:"(1, 1, 1)"
+Hugs:[Leaving Hugs]
--- /dev/null
+f :: Int -> String
+f x = show (x,x,x)
+
+g = 1.0 :: Int
--- /dev/null
+f :: Int -> String
+f x = show (x,x,x)
+
+--g = 1.0 :: Int
--- /dev/null
+Type :? for help
+Hugs:[Leaving Hugs]
--- /dev/null
+Type :? for help
+Hugs:[Leaving Hugs]
--- /dev/null
+--!!! Error detection in class declarations.
+
+-- From the GHC bugs mailing list - this isn't legal Haskell.
+-- (reported by Einar Wolfgang Karlsen <ewk@informatik.uni-bremen.de>)
+
+class Silly x where
+ dump :: Silly x => x -> String -- context is illegal
--- /dev/null
+--!!! Testing the garbage collector
+module TestGC where
+
+-- All these tests should be run in a freshly started system
+-- and with the specified heap size/ heap configuration.
+--
+-- (Of course, they should run successfully in a non-fresh system,
+-- with different heap sizes, etc. - but they've been known to fail
+-- with the specified size.)
+
+
+-- build Hugs with all gc tests turned on and run with a small heap.
+
+-- 27/11/95: This test works fine - but fails when entered on the
+-- command line. The difference must be that the top level
+-- thunk isn't being treated as a root by the GC system.
+-- 3/6/96: Requires 210kbyte heap to run - which is double the size of
+-- the string it generates. This has to get stored since
+-- test1 is a CAF and the 2-space GC doubles the requirement.
+-- If evaluated on the command line, it runs in 16kbytes
+-- which is about the smallest possible heap given the
+-- setting of minRecovery (1000), the size of a cell (8 bytes)
+-- and the GC's need for two equally size semispaces.
+test1 = show [1..1500]
+
+-- 27/11/95: This test produces different results on command line
+-- and when executed as given. Again, I think I'm failing to make
+-- the top-level object a root.
+-- 20/5/96: This test runs out of space - I think black holing would fix it.
+-- 3/6/96: Now works fine. Nothing to do with blackholing! All I had to do
+-- was restore Mark's definitions of sum and product. These used
+-- foldl' which is a strict version of foldl.
+test2 = show (sum [1..100000])
+
--- /dev/null
+:module TestGC
+test1
--- /dev/null
+[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999,1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011,1012,1013,1014,1015,1016,1017,1018,1019,1020,1021,1022,1023,1024,1025,1026,1027,1028,1029,1030,1031,1032,1033,1034,1035,1036,1037,1038,1039,1040,1041,1042,1043,1044,1045,1046,1047,1048,1049,1050,1051,1052,1053,1054,1055,1056,1057,1058,1059,1060,1061,1062,1063,1064,1065,1066,1067,1068,1069,1070,1071,1072,1073,1074,1075,1076,1077,1078,1079,1080,1081,1082,1083,1084,1085,1086,1087,1088,1089,1090,1091,1092,1093,1094,1095,1096,1097,1098,1099,1100,1101,1102,1103,1104,1105,1106,1107,1108,1109,1110,1111,1112,1113,1114,1115,1116,1117,1118,1119,1120,1121,1122,1123,1124,1125,1126,1127,1128,1129,1130,1131,1132,1133,1134,1135,1136,1137,1138,1139,1140,1141,1142,1143,1144,1145,1146,1147,1148,1149,1150,1151,1152,1153,1154,1155,1156,1157,1158,1159,1160,1161,1162,1163,1164,1165,1166,1167,1168,1169,1170,1171,1172,1173,1174,1175,1176,1177,1178,1179,1180,1181,1182,1183,1184,1185,1186,1187,1188,1189,1190,1191,1192,1193,1194,1195,1196,1197,1198,1199,1200,1201,1202,1203,1204,1205,1206,1207,1208,1209,1210,1211,1212,1213,1214,1215,1216,1217,1218,1219,1220,1221,1222,1223,1224,1225,1226,1227,1228,1229,1230,1231,1232,1233,1234,1235,1236,1237,1238,1239,1240,1241,1242,1243,1244,1245,1246,1247,1248,1249,1250,1251,1252,1253,1254,1255,1256,1257,1258,1259,1260,1261,1262,1263,1264,1265,1266,1267,1268,1269,1270,1271,1272,1273,1274,1275,1276,1277,1278,1279,1280,1281,1282,1283,1284,1285,1286,1287,1288,1289,1290,1291,1292,1293,1294,1295,1296,1297,1298,1299,1300,1301,1302,1303,1304,1305,1306,1307,1308,1309,1310,1311,1312,1313,1314,1315,1316,1317,1318,1319,1320,1321,1322,1323,1324,1325,1326,1327,1328,1329,1330,1331,1332,1333,1334,1335,1336,1337,1338,1339,1340,1341,1342,1343,1344,1345,1346,1347,1348,1349,1350,1351,1352,1353,1354,1355,1356,1357,1358,1359,1360,1361,1362,1363,1364,1365,1366,1367,1368,1369,1370,1371,1372,1373,1374,1375,1376,1377,1378,1379,1380,1381,1382,1383,1384,1385,1386,1387,1388,1389,1390,1391,1392,1393,1394,1395,1396,1397,1398,1399,1400,1401,1402,1403,1404,1405,1406,1407,1408,1409,1410,1411,1412,1413,1414,1415,1416,1417,1418,1419,1420,1421,1422,1423,1424,1425,1426,1427,1428,1429,1430,1431,1432,1433,1434,1435,1436,1437,1438,1439,1440,1441,1442,1443,1444,1445,1446,1447,1448,1449,1450,1451,1452,1453,1454,1455,1456,1457,1458,1459,1460,1461,1462,1463,1464,1465,1466,1467,1468,1469,1470,1471,1472,1473,1474,1475,1476,1477,1478,1479,1480,1481,1482,1483,1484,1485,1486,1487,1488,1489,1490,1491,1492,1493,1494,1495,1496,1497,1498,1499,1500]
--- /dev/null
+--!!! Testing the printing of infix constructors
+data Music = Note
+ | Music :+: Music
+ | Scale Music
+ deriving Show
+
+m = Scale (Note :+: Note)
--- /dev/null
+Hugs:Scale (Note :+: Note)
+Hugs:"Scale (Note :+: Note)"
+Hugs:[Leaving Hugs]
--- /dev/null
+--!!! Testing top level printer (note that this doesn't necessarily test show)
+
+-- Test things of type String
+
+test1, test2, test3 :: String
+
+test1 = "abcd"
+test2 = ""
+test3 = "abcd\0efgh\0"
+test4 = "abc" ++ error "def" ++ "hij"
+test5 = "abc" ++ [error "def"] ++ "hij"
+test6 = 'a' : 'b' : 'c' : error "foo"
+test7 = 'a' : 'b' : 'c' : error "foo" : []
+test8 = show (error "foo"::String)
+
+test11, test12 :: String
+test11 = case (error "foo") of _ -> "abcd"
+test12 = case (error "foo") of [] -> "abcd"
+
+test13, test14 :: String
+test13 = error (error "foo")
+test14 = error test14
+
+
+
+-- Test things of type IO ()
+
+{- can't include this in backwards compatability tests
+
+-- Normal
+
+test101, test102, test103 :: IO ()
+test101 = putStr "abcd"
+test102 = return ()
+test103 = putChar 'a'
+
+-- Errors
+
+test111, test112, test113, test114 :: IO ()
+test111 = error "foo"
+test112 = putStr (error "foo")
+test113 = putStr "abcd" >> putStr (error "foo") >> putStr "efgh"
+test114 = putStr "abcd" >> error "foo" >> putStr "efgh"
+
+test123, test124, test125 :: IO ()
+test123 = error (error "foo")
+test124 = error x where x = error x
+test125 = error x where x = 'a' : error x
+
+-}
+
+-- Test things of type a
+
+-- Unit
+
+test241, test242 :: ()
+test241 = ()
+test242 = error "foo"
+
+-- Ints
+
+test251, test252 :: Int
+test251 = 10
+test252 = -10
+
+test253, test254 :: Int
+test253 = 42 + error "foo"
+test254 = error "foo" + 42
+
+-- Integers
+
+test261, test262 :: Integer
+test261 = 10
+test262 = 10
+
+-- Floats
+
+test271, test272 :: Float
+test271 = 10
+test272 = -10
+
+-- Doubles
+
+test281, test282 :: Double
+test281 = 10
+test282 = -10
+
+-- Char
+
+test291, test292, test293 :: Char
+test291 = 'a'
+test292 = '\0'
+test293 = '\DEL'
+
+-- Lists
+
+test301, test302 :: [Int]
+test301 = []
+test302 = [1]
+
+-- Bool
+
+test311 = True
+test312 = False
+
+-- Tuples
+
+test321 = ('a','b')
+test322 = ('a','b','c')
+
+test323 :: (Int,Int, Int)
+test323 = (1, error "foo", 3)
+
+-- Datatypes
+
+data E a b = L a | R b
+test331 = R (1::Int)
+test332 = L 'a'
+
+data M a = N | J a
+test333 = J True
+test334 = N
+
+-- No dialogue tests in this file
--- /dev/null
+test1
+test2
+test3
+test4
+test5
+test6
+test7
+test8
+test11
+test12
+test13
+1--test14 -- omitted - infinite loop
+1--test101 -- IO tests omitted (not supported by original system)
+1--test102
+1--test103
+1--test111
+1--test112
+1--test113
+1--test114
+1--test123
+1--test124
+1--test125
+test241
+test242
+test251
+test252
+test253
+test254
+test261
+test262
+test271
+test272
+test281
+test282
+test291
+test292
+test293
+test301
+test302
+test311
+test312
+test321
+test322
+test323
+test331
+test332
+test333
+test334
--- /dev/null
+Hugs:"abcd"
+Hugs:[]
+Hugs:"abcd\NULefgh\NUL"
+Hugs:"abc
+Program error: def
+
+Hugs:"abc
+Program error: def
+
+Hugs:"abc
+Program error: foo
+
+Hugs:"abc
+Program error: foo
+
+Hugs:"\"
+Program error: foo
+
+Hugs:"abcd"
+Hugs:
+Program error: foo
+
+Hugs:
+Program error:
+Program error: foo
+
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:()
+Hugs:
+Program error: foo
+
+Hugs:10
+Hugs:-10
+Hugs:
+Program error: foo
+
+Hugs:
+Program error: foo
+
+Hugs:10
+Hugs:10
+Hugs:10.0
+Hugs:-10.0
+Hugs:10.0
+Hugs:-10.0
+Hugs:'a'
+Hugs:'\NUL'
+Hugs:'\DEL'
+Hugs:[]
+Hugs:[1]
+Hugs:True
+Hugs:False
+Hugs:('a','b')
+Hugs:('a','b','c')
+Hugs:(1,
+Program error: foo
+
+Hugs:R 1
+Hugs:L 'a'
+Hugs:J True
+Hugs:N
+Hugs:[Leaving Hugs]
--- /dev/null
+Hugs:"abcd"
+Hugs:[]
+Hugs:"abcd\NULefgh\NUL"
+Hugs:"abc" ++ {error "def"}
+Hugs:"abc" ++ [{error "def"}, 'h', 'i', 'j']
+Hugs:"abc" ++ {error "foo"}
+Hugs:"abc" ++ [{error "foo"}]
+Hugs:"\"" ++ {error "foo"}
+Hugs:"abcd"
+Hugs:{error "foo"}
+Hugs:{error (error "foo")}
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:1
+Hugs:()
+Hugs:{error "foo"}
+Hugs:10
+Hugs:-10
+Hugs:{error "foo"}
+Hugs:{error "foo"}
+Hugs:10
+Hugs:10
+Hugs:10.0
+Hugs:-10.0
+Hugs:10.0
+Hugs:-10.0
+Hugs:'a'
+Hugs:'\NUL'
+Hugs:'\DEL'
+Hugs:[]
+Hugs:[1]
+Hugs:True
+Hugs:False
+Hugs:('a','b')
+Hugs:('a','b','c')
+Hugs:(1,{error "foo"},3)
+Hugs:R 1
+Hugs:L 'a'
+Hugs:J True
+Hugs:N
+Hugs:[Leaving Hugs]
--- /dev/null
+foo :: Float -> Float
+foo = cache sin
+
+-- A lazy cache.
+-- Uses pointer equality (which is not referentially transparent)
+-- in a referentially transparent way to allow the test to be:
+-- 1) Fully polymorphic (no Eq context)
+-- 2) Safe (no assumption that Eq is correct)
+-- 3) Lazy -- no need to evaluate the entire argument.
+-- Unlike John Hughes' lazy memo functions, there's no assistance
+-- from the garbage collector to delete entries which can never be
+-- used in the future.
+
+cache :: (a -> b) -> (a -> b)
+cache f = \x -> unsafePerformIO (f' x)
+ where
+ ref = unsafePerformIO (newRef (error "cache", error "cache"))
+ f' x = derefRef ref >>= \ (x',a) ->
+ if x `primPtrEq` x' then
+ hit >>
+ return a
+ else
+ miss >>
+ let a = f x in
+ assignRef ref (x, a) >>
+ return a
+
+primitive primPtrEq "primPtrEq" :: a -> a -> Bool
+
+
+-- Hooks for recording cache hits and misses
+{-
+hit = return ()
+miss = return ()
+-}
+
+hit = putStrLn "hit"
+miss = putStrLn "miss"
+
+{-
+hitRef, missRef :: Ref Int
+hitRef = unsafePerformIO (newRef 0)
+missRef = unsafePerformIO (newRef 0)
+hit = derefRef hitRef >>= \ x -> assignRef hitRef (x+1)
+miss = derefRef missRef >>= \ x -> assignRef missRef (x+1)
+
+report =
+ derefRef hitRef >>= \ hits ->
+ derefRef missRef >>= \ misses ->
+ putStrLn ("Cache hits: " ++ show hits ++ "; cache misses: " ++ show misses)
+-}
+
+
--- /dev/null
+let x = 1.0 in print (foo x + foo x + foo 2 + foo x)
--- /dev/null
+miss
+hit
+miss
+miss
+3.43371
+
--- /dev/null
+--!!! Testing Haskell 1.3 syntax
+
+-- Haskell 1.3 syntax differs from Haskell 1.2 syntax in several ways:
+
+-- * Qualified names in export lists
+module TestSyntax where
+
+-- * Qualified import/export
+
+-- 1) Syntax:
+
+import qualified Prelude as P
+
+import Prelude
+import qualified Prelude
+
+import Prelude ()
+import Prelude (fst,snd)
+import qualified Prelude(fst,snd)
+
+-- bizarre syntax allowed in draft of Haskell 1.3
+import Prelude(,)
+import Prelude(fst,snd,)
+import Prelude(Ord(..),Eq((==),(/=)),)
+import Prelude hiding (fst,snd,)
+
+import Prelude hiding (fst,snd)
+import qualified Prelude hiding (fst,snd)
+
+import Prelude as P
+import qualified Prelude as P
+
+import Prelude as P(fst,snd)
+import Prelude as P(,)
+import qualified Prelude as P(fst,snd)
+
+import Prelude as P hiding (fst,snd)
+import qualified Prelude as P hiding (fst,snd)
+
+-- 2) Use of qualified type names
+-- 3) Use of qualified constructors
+-- 4) Use of qualified variables
+
+-- * No n+k patterns (yippee!)
+-- (No tests yet)
+
+-- Some things are unchanged.
+
+-- * Unqualified imports and use of hiding/selective import.
+--
+-- Note: it's not clear how these various imports are supposed to
+-- interact with one another.
+-- John explains:
+-- 1) "hiding" lists etc are just abbreviations for very long
+-- lists.
+-- 2) Multiple imports are additive.
+-- (This makes the meaning order-independent!)
+-- Note: Hugs allows imports anywhere a topdecl is allowed.
+-- This isn't legal Haskell - but it does no harm.
+
+-- import Prelude(lex)
+-- import Prelude
+-- import Prelude hiding (lex)
+-- lex = 1 :: Int -- error unless we've hidden lex.
+
+
+
+-- * Qualified names
+
+-- Function/operator names
+myfilter x = Prelude.filter x -- argument added to avoid monomorphism restn
+mycompose = (Prelude..)
+
+-- Use of module synonyms
+myfilter2 p = P.filter p
+
+-- Method names
+myplus :: Num a => a -> a -> a
+myplus = (Prelude.+)
+
+-- Tycons
+myminus = (Prelude.-) :: Prelude.Int -> Prelude.Int -> Prelude.Int
+
+-- Type synonyms
+foo :: P.ShowS
+foo = foo
+
+-- Class names in instances
+instance P.Num P.Bool where
+ (+) = (P.||)
+ (*) = (P.&&)
+ negate = P.not
+
+instance (P.Num a, P.Num b) => P.Num (a,b) where
+ x + y = (fst x + fst y, snd x + snd y)
+
+-- Constructor names in expressions
+
+-- this used to break tidyInfix in parser.y
+-- Note that P.[] is _not_ legal!
+testInfixQualifiedCon = 'a' P.: [] :: String
+
+-- Constructor names in patterns
+f (P.Just x) = True
+f (P.Nothing) = False
+
+g (x P.: xs) = x
+
+y P.: ys = ['a'..]
+
+-- * Support for octal and hexadecimal numbers
+-- Note: 0xff and 0xFF are legal but 0Xff and 0XFF are not.
+-- ToDo: negative tests to make sure invalid numbers are excluded.
+
+d = ( -1, -0, 0, 1) :: (Int,Int,Int,Int)
+o = (-0o1,-0o0,0o0,0o1) :: (Int,Int,Int,Int)
+x = (-0x1,-0x0,0x0,0x1) :: (Int,Int,Int,Int)
+x' = (0xff,0xFf,0xfF,0xFF) :: (Int,Int,Int,Int)
+
+-- * No renaming or interface files
+-- We test that "interface", "renaming" and "to" are not reserved.
+
+interface = 1 :: Int
+renaming = 42 :: Int
+to = 2 :: Int
+
--- /dev/null
+Type :? for help
+Hugs:[Leaving Hugs]
--- /dev/null
+
+simpleLazyPrint :: a -> IO ()
+simpleLazyPrint x = print (primGetHugsObject x)
+ where
+ -- Extra level of indirection introduced to overcome lack of
+ -- polymorphic recursion!
+ print :: HugsObject -> IO ()
+ print x =
+ primClassifyObject False x >>= \ kind ->
+ case kind of
+ HugsApply fun args ->
+ putChar '(' >>
+ print fun >>
+ for_ args (\arg ->
+ putChar ' ' >>
+ print arg
+ ) >>
+ putChar ')'
+
+ HugsFun nm ->
+ putStr (primNameString nm)
+
+ HugsCon nm ->
+ putStr (primNameString nm)
+
+ HugsTuple arity ->
+ putStr ('(' : replicate arity ',' ++ ")")
+
+ HugsInt x ->
+ putStr (show x)
+
+ HugsInteger x ->
+ putStr (show x)
+
+ HugsFloat x ->
+ putStr (show x)
+
+ HugsChar x ->
+ putStr ('\'' : showLitChar x "\'")
+
+ HugsPrim prim ->
+ putStr prim
+
+ HugsError err ->
+ print err
+
+simpleStrictPrint :: a -> IO ()
+simpleStrictPrint x = print (primGetHugsObject x)
+ where
+ -- Extra level of indirection introduced to overcome lack of
+ -- polymorphic recursion!
+ print :: HugsObject -> IO ()
+ print x =
+ primClassifyObject True x >>= \ kind ->
+ case kind of
+ HugsApply fun args ->
+ putChar '(' >>
+ print fun >>
+ for_ args (\arg ->
+ putChar ' ' >>
+ print arg
+ ) >>
+ putChar ')'
+
+ HugsFun nm ->
+ putStr (primNameString nm)
+
+ HugsCon nm ->
+ putStr (primNameString nm)
+
+ HugsTuple arity ->
+ putStr ('(' : replicate arity ',' ++ ")")
+
+ HugsInt x ->
+ putStr (show x)
+
+ HugsInteger x ->
+ putStr (show x)
+
+ HugsFloat x ->
+ putStr (show x)
+
+ HugsChar x ->
+ putStr ('\'' : showLitChar x "\'")
+
+ HugsPrim prim ->
+ putStr prim
+
+ HugsError err ->
+ -- could call lazy print (if object printer was exposed)
+ putStr "{error}"
+
+s1 = simpleStrictPrint (error "foo")
+s2 = simpleStrictPrint (1 + error "foo")
+
+
+-- test
+
+lazyPrint x = hugsPrinter False (primGetHugsObject x)
+strictPrint x = hugsPrinter True (primGetHugsObject x)
+
+t1 = lazyPrint (True &&)
+t2 = lazyPrint (1:)
+t3 = lazyPrint ('a':)
+t4 = lazyPrint (1 `elem`)
+t5 = lazyPrint "abcd"
+t6 = strict lazyPrint (1 `elem`)
+
+t11 = strictPrint (True &&)
+t12 = strictPrint (1:)
+t13 = strictPrint ('a':)
+t14 = strictPrint (1 `elem`)
+t15 = strictPrint "abcd"
+t16 = strictPrint (take 10 [1..])
+t17 = strictPrint [1..]
+t18 = strictPrint (pi::Float) -- used to fail because pi is a CAF.
+t19 = strictPrint '\DEL'
+
+{-
+Known Bugs:
+
+* Prints "(||) True False" (in lazy mode) instead of "True || False".
+
+ This is a deliberate change from the original Hugs version (in builtin.c)
+ which would print: '{dict} !! "abcd"' for ("abcd" !!) instead of
+ '(!!) {dict} "abcd"' or '("abcd" `(||) {dict}`)'.
+
+ (This is a feature not a bug!)
+
+* Should print errors to stderr.
+
+-}
\ No newline at end of file
--- /dev/null
+#! /bin/sh
+
+CONTEXT_DIFF='@CONTEXT_DIFF@'
+export CONTEXT_DIFF
+DEV_NULL='@DEV_NULL@'
+export DEV_NULL
+
+test_static() {
+ echo "\
+----------------------------------------------------------------
+-- Testing syntax checking, static checking and modules.
+-- This group of checks will produce about 100 lines of output of the form
+--
+-- --!!! <description of feature being tested>
+--
+-- You should report a problem if any other output is generated.
+----------------------------------------------------------------"
+
+ # Test syntax/static checks on use of qualified names
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual1.hs" "-o1test/qual1.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual2.hs" "-o1test/qual2.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual3.hs" "-o1test/qual3.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual4.hs" "-o1test/qual4.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual5.hs" "-o1test/qual5.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/syntax.hs" "-o1test/syntax.output"
+
+ # ToDo: test for duplicate modules
+ perl runstdtest hugs -O-i +q -pHugs: -s13 "-Otest/mod1.hs" "-o1test/mod1.output"
+ perl runstdtest hugs -O-i +q -pHugs: -s13 "-Otest/mod2.hs" "-o1test/mod2.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod3.hs" "-o1test/mod3.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod4.hs" "-o1test/mod4.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod5.hs" "-o1test/mod5.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod6.hs" "-o1test/mod6.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod7.hs" "-o1test/mod7.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod8.hs" "-o1test/mod8.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod9.hs" "-o1test/mod9.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod10.hs" "-o1test/mod10.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod11.hs" "-o1test/mod11.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod12.hs" "-o1test/mod12.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod13.hs" "-o1test/mod13.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod14.hs" "-o1test/mod14.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod15.hs" "-o1test/mod15.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod16.hs" "-o1test/mod16.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod17.hs" "-o1test/mod17.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod18.hs" "-o1test/mod18.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod19.hs" "-o1test/mod19.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod20.hs" "-o1test/mod20.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod21.hs" "-o1test/mod21.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod22.hs" "-o1test/mod22.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod23.hs" "-o1test/mod23.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod24.hs" "-o1test/mod24.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod25.hs" "-o1test/mod25.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod26.hs" "-o1test/mod26.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod27.hs" "-o1test/mod27.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod28.hs" "-o1test/mod28.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod29.hs" "-o1test/mod29.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod30.hs" "-o1test/mod30.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod31.hs" "-o1test/mod31.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod32.hs" "-o1test/mod32.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod33.hs" "-o1test/mod33.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod34.hs" "-o1test/mod34.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod35.hs" "-o1test/mod35.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod36.hs" "-o1test/mod36.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod37.hs" "-o1test/mod37.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod38.hs" "-o1test/mod38.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod39.hs" "-o1test/mod39.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod40.hs" "-o1test/mod40.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod41.hs" "-o1test/mod41.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod42.hs" "-o1test/mod42.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod43.hs" "-o1test/mod43.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod44.hs" "-o1test/mod44.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod45.hs" "-o1test/mod45.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod46.hs" "-o1test/mod46.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod47.hs" "-o1test/mod47.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod48.hs" "-o1test/mod48.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod49.hs" "-o1test/mod49.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod50.hs" "-o1test/mod50.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod51.hs" "-o1test/mod51.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod52.hs" "-o1test/mod52.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod53.hs" "-o1test/mod53.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod54.hs" "-o1test/mod54.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod55.hs" "-o1test/mod55.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod56.hs" "-o1test/mod56.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod57.hs" "-o1test/mod57.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod58.hs" "-o1test/mod58.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod59.hs" "-o1test/mod59.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod60.hs" "-o1test/mod60.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod61.hs" "-o1test/mod61.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod62.hs" "-o1test/mod62.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod63.hs" "-o1test/mod63.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod64.hs" "-o1test/mod64.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod65.hs" "-o1test/mod65.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod66.hs" "-o1test/mod66.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod67.hs" "-o1test/mod67.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod68.hs" "-o1test/mod68.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod69.hs" "-o1test/mod69.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod70.hs" "-o1test/mod70.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod71.hs" "-o1test/mod71.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod72.hs" "-o1test/mod72.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod73.hs" "-o1test/mod73.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod74.hs" "-o1test/mod74.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod75.hs" "-o1test/mod75.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod76.hs" "-o1test/mod76.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod77.hs" "-o1test/mod77.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod78.hs" "-o1test/mod78.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod79.hs" "-o1test/mod79.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod80.hs" "-o1test/mod80.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod81.hs" "-o1test/mod81.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod82.hs" "-o1test/mod82.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod83.hs" "-o1test/mod83.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod84.hs" "-o1test/mod84.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod85.hs" "-o1test/mod85.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod86.hs" "-o1test/mod86.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod87.hs" "-o1test/mod87.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod88.hs" "-o1test/mod88.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod89.hs" "-o1test/mod89.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod90.hs" "-o1test/mod90.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod91.hs" "-o1test/mod91.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod92.hs" "-o1test/mod92.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod93.hs" "-o1test/mod93.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod94.hs" "-o1test/mod94.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod95.hs" "-o1test/mod95.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod96.hs" "-o1test/mod96.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod97.hs" "-o1test/mod97.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod98.hs" "-o1test/mod98.output"
+
+ # Check opaque import/export of tycons
+ perl runstdtest hugs +q -pHugs: -s21 "-Otest/T2.hs" "-o1test/T2.output"
+ # Check transparent import of type synonyms
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/T3.hs" "-o1test/T3.output"
+
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/export1.hs" "-o1test/export1.output"
+
+ # Check opaque import/export of member functions
+ perl runstdtest hugs +q -pHugs: -s20 "-Otest/T7.hs" "-o1test/Loaded.output"
+
+} # End of static tests
+
+test_tcheck() {
+
+ echo "\
+----------------------------------------------------------------
+-- Testing type checking.
+-- This group of checks will produce about 7 lines of output of the form
+--
+-- --!!! <description of feature being tested>
+--
+-- It may also produce output that looks like this:
+--
+-- ./hugs +q -pHugs: test/dicts.hs < test/dicts.input
+-- expected stdout not matched by reality
+-- *** test/dicts.output Fri Jul 11 13:25:27 1997
+-- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
+-- ***************
+-- *** 1,3 ****
+-- Hugs:\"(14,14,14)\"
+-- ! Hugs:Garbage collection recovered 93815 cells
+-- Hugs:\"(14,14,14)\"
+-- --- 1,3 ----
+-- Hugs:\"(14,14,14)\"
+-- ! Hugs:Garbage collection recovered 93781 cells
+-- Hugs:\"(14,14,14)\"
+--
+-- This is harmless and might be caused by minor variations between different
+-- machines, or slightly out of date sample output.
+--
+-- You should report a problem if any other output is generated.
+----------------------------------------------------------------"
+
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/types.hs" "-o1test/types.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/dicts.hs" "-itest/dicts.input" "-o1test/dicts.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/ty1.hs" "-o1test/ty1.output"
+ perl runstdtest hugs +q -pHugs: -s13 "-Otest/ty2.hs" "-o1test/ty2.output"
+ perl runstdtest hugs +q -pHugs: -s17 "-Otest/monad.hs" "-o1test/monad.output"
+ # Very tricky test - the input script uses /bin/cp to mimic the
+ # effect of editing a file and reloading
+ perl runstdtest hugs -w +q -pHugs: -s13 "-itest/DictHW.input" "-o1test/DictHW.output"
+ perl runstdtest hugs -w +q -pHugs: test/TyErr.hs -s12 "-o1test/TyErr.output"
+}
+
+test_rts() {
+
+ echo "\
+----------------------------------------------------------------
+-- Testing runtime system.
+-- This group of checks will produce 12-16 lines of output of the form
+--
+-- --!!! <description of feature being tested>
+--
+-- It may also produce output that looks like this:
+--
+-- ./hugs +q -pHugs: test/???.hs < test/???.input
+-- expected stdout not matched by reality
+-- *** test/???.output Fri Jul 11 13:25:27 1997
+-- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
+-- ***************
+-- *** 1,3 ****
+-- ...
+-- | Hugs:\"[0.0, 0.304693, 0.643501, 1.5708]\"
+-- ...
+-- --- 1,3 ----
+-- ...
+-- | Hugs:\"[0.0, 0.30469323452, 0.643503234321, 1.5708234234]\"
+-- ...
+--
+-- This is harmless and reflects variations in the accuracy of floating
+-- point representation, calculations and printing.
+--
+-- You should report a problem if any other output is generated or if
+-- the size of the floating point errors seem excessively large.
+----------------------------------------------------------------"
+
+ # Test bignums early since printing depends on bignums
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/bignums.hs" "-itest/bignums.input" "-o1test/bignums.output"
+
+ # Using generic printer
+ perl runstdtest hugs +q -pHugs: -u -s18 "-Otest/print.hs" "-itest/print.input" "-o1test/print1.output"
+ perl runstdtest hugs +q -pHugs: -u -f -s18 "-Otest/print.hs" "-itest/print.input" "-o1test/print2.output"
+ #perl runstdtest hugs +q -pHugs: -u -f -s18 "-Otest/catch.hs" "-itest/catch.input" "-o1test/catch.output"
+ perl runstdtest hugs +q -pHugs: -u -s18 "-Otest/enum.hs" "-itest/enum.input" "-o1test/enum.output1"
+ perl runstdtest hugs +q -pHugs: -u -s18 "-Otest/infix.hs" "-itest/infix.input" "-o1test/infix.output"
+
+ # Using derived show instance
+ #perl runstdtest hugs +q -pHugs: +u -f -s18 "-Otest/catch2.hs" "-itest/catch.input" "-o1test/catch2.output"
+
+ # Using derived instances
+ perl runstdtest hugs +q -pHugs: +u -s18 "-Otest/enum.hs" "-itest/enum.input" "-o1test/enum.output2"
+ perl runstdtest hugs +q -pHugs: +u -s18 "-Otest/maxint.hs" "-itest/maxint.input" "-o1test/maxint.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/ord.hs" "-itest/ord.input" "-o1test/ord.output"
+ perl runstdtest hugs +q -pHugs: -s25 "-Otest/read.hs" "-itest/read.input" "-o1test/read.output"
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/arith.hs" "-itest/arith.input" "-o1test/arith.output"
+
+ perl runstdtest hugs +q -pHugs: -s18 "-Otest/testlist.hs" "-itest/testlist.input" "-o1test/testlist.output"
+
+ perl runstdtest hugs +q -pHugs: -s29 "-Otest/arrayt.hs" "-itest/array1.input" "-o1test/array1.output"
+ perl runstdtest hugs +q -pHugs: -s29 "-Otest/array2.hs" "-itest/array2.input" "-o1test/array2.output"
+ perl runstdtest hugs +q -pHugs: -s29 "-Otest/arrayEx.hs" "-itest/arrayEx.input" "-o1test/arrayEx.output"
+
+
+ # Old test code from hugs +q -pHugs:0 - it will probably get resurrected at some stage
+ #
+ # if TESTREFS
+ # if IO_REFS
+ # perl runstdtest hugs +q -pHugs: "-Otest/refs.hs" "-itest/refs.input" "-o1test/refs.output"
+ # fi
+ # else
+ # echo "Not testing Refs"
+ # fi
+ #
+ # if TESTPTREQ
+ # if IO_REFS
+ # perl runstdtest hugs +q -pHugs: "-Otest/ptrEq.hs" "-itest/ptrEq.input" "-o1test/ptrEq.output"
+ # fi
+ # else
+ # echo "Not testing Pointer equality"
+ # fi
+ #
+ # if TESTMUTVARS
+ # if ST_MUTVARS
+ # perl runstdtest hugs +q -pHugs: "-Otest/mutvars.hs" "-itest/mutvars.input" "-o1test/mutvars.output"
+ # fi
+ # else
+ # echo "Not testing MutVars"
+ # fi
+ #
+ # if TESTIOERROR
+ # if !OLD_IOMONAD
+ # perl runstdtest hugs +q -pHugs: "-Otest/ioerror1.hs" "-itest/ioerror1.input" "-o1test/ioerror1.output"
+ # perl runstdtest hugs +q -pHugs: "-Otest/ioerror2.hs" "-itest/ioerror2.input" "-o1test/ioerror2.output"
+ # if IO_HANDLES
+ # /* Create an unreadable file (its impossible to supply one in a tar file!) */
+ # cat >test/unreadable.tst <<EOF
+ # This file should be read+q -protected.
+ # perl runstdtests/iohandle.hs attempts to write it.
+ # EOF
+ # CHMOD 200 "test/unreadable.tst"
+ # perl runstdtest hugs +q -pHugs: "-Otest/iohandle.hs" "-itest/iohandle.input" "-o1test/iohandle.output"
+ # RM "test/unreadable.tst"
+ # fi
+ # fi /* !OLD_IOMONAD */
+ # else
+ # echo "Not testing IOError"
+ # fi /* TESTIOERROR */
+ #
+ # if TESTCONCURRENCY
+ # if CONCURRENCY
+ # perl runstdtest hugs +q -pHugs: "-Otest/mvar.hs" "-itest/mvar.input" "-o1test/mvar.output"
+ # fi
+ # else
+ # echo "Not testing concurrency"
+ # fi
+ #
+ # if TESTGC
+ # perl runstdtest hugs +q -pHugs: "-Otest/gc.hs" "-itest/gc1.input" "-o1test/gc1.output"
+ # perl runstdtest hugs +q -pHugs: -H200000" "-Otest/gc.hs" "-itest/gc1.input" "-o1test/gc1.output"
+ # perl runstdtest hugs +q -pHugs: -H100000" "-Otest/gc.hs" "-itest/gc2.input" "-o1test/gc2.output"
+ # else
+ # echo "Not testing GC"
+ # fi
+ #
+ # else
+ # echo "Not testing runtime system"
+ # fi
+
+} # End of test_rts
+
+test_libs() {
+ echo "\
+----------------------------------------------------------------
+-- Testing standard libraries for static errors and some old bugs.
+--
+-- This group of checks tests that each of the standard libraries
+-- loads correctly. This generates no output if it works.
+-- It also tests the results generated by a few of the standard
+-- libraries. This produces the following output.
+--
+-- --!!! Performing static tests on standard libraries - please wait
+-- --!!! Performing static tests on GHC-compatible libraries
+-- --!!! Performing static tests on Hugs libraries
+-- --!!! Performing static tests on Haskore libraries
+-- --!!! Performing dynamic tests on libraries
+-- --!!! Testing (List.\\) and related functions
+-- --!!! Testing System
+-- --!!! Testing Int and Word
+--
+-- On Windows, it may also produce output that looks like this:
+--
+-- ./hugs +q -pHugs: test/system1.hs < test/system1.input
+-- expected stdout not matched by reality
+-- *** test/system1.output Fri Jul 11 13:25:27 1997
+-- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
+-- ***************
+-- *** 1,3 ****
+-- ...
+-- | Hugs:ExitFailure 1
+-- | Hugs:ExitFailure 2
+-- ...
+-- --- 1,3 ----
+-- ...
+-- | Hugs:ExitSuccess
+-- | Hugs:ExitSuccess
+-- ...
+--
+-- This reflects the sad fact that System.system always returns
+-- ExitSuccess on DOS machines. This is a known bug in DOS.
+--
+-- You should report a problem if any other output is generated.
+----------------------------------------------------------------"
+
+ echo "--!!! Performing static tests on standard libraries - please wait"
+ perl runstdtest hugs +q -pHugs: Array -s27
+ perl runstdtest hugs +q -pHugs: Char -s19
+ perl runstdtest hugs +q -pHugs: Complex -s19
+ perl runstdtest hugs +q -pHugs: IO -s24
+ perl runstdtest hugs +q -pHugs: Ix -s19
+ perl runstdtest hugs +q -pHugs: List -s22
+ perl runstdtest hugs +q -pHugs: Maybe -s19
+ perl runstdtest hugs +q -pHugs: Monad -s19
+ perl runstdtest hugs +q -pHugs: Ratio -s19
+ perl runstdtest hugs +q -pHugs: System -s19
+
+ echo "--!!! Performing static tests on GHC-compatible libraries"
+ perl runstdtest hugs +q -pHugs: IOExts -s27 "-o1test/Loaded.output"
+ perl runstdtest hugs +q -pHugs: ST -s33 "-o1test/Loaded.output"
+ perl runstdtest hugs +q -pHugs: LazyST -s33 "-o1test/Loaded.output"
+ perl runstdtest hugs +q -pHugs: Concurrent -s42 "-o1test/Loaded.output"
+ perl runstdtest hugs +q -pHugs: Addr -s17 "-o1test/Loaded.output"
+ perl runstdtest hugs +q -pHugs: Word -s22 "-o1test/Loaded.output"
+ perl runstdtest hugs +q -pHugs: Int -s20 "-o1test/Loaded.output"
+
+ echo "--!!! Performing static tests on Hugs libraries"
+ perl runstdtest hugs +q -pHugs: HugsLibs -s68 "-o1test/HugsLibs.output"
+
+ echo "--!!! Performing static tests on Haskore libraries"
+ perl runstdtest hugs +q -pHugs: Haskore -s60 "-o1test/Loaded.output"
+
+ echo "--!!! Performing dynamic tests on libraries"
+ # Specific tests - checking that old bugs have been fixed
+ perl runstdtest hugs +q -pHugs: List -s22 "-Otest/list1.hs" "-itest/list1.input" "-o1test/list1.output"
+ perl runstdtest hugs +q -pHugs: System -s19 "-Otest/system1.hs" "-itest/system1.input" "-o1test/system1.output"
+ perl runstdtest hugs +q -pHugs: Complex -s17 "-itest/complex1.input" "-o1test/complex1.output"
+ perl runstdtest hugs +q -pHugs: Int -s25 "-Otest/intTest.hs" "-itest/intTest.input" "-o1test/intTest.output"
+ perl runstdtest hugs +q -pHugs: test/FixIO.lhs -s33 "-itest/FixIO.input" "-o1test/FixIO.output"
+
+} # End of test_libs
+
+test_demos() {
+ echo "\
+----------------------------------------------------------------
+-- Testing demos for static errors.
+--
+-- This group of checks tests that each of the demos loads correctly.
+-- It should generate this output:
+--
+-- --!!! Performing static checks on demos
+-- --!!! Performing static checks on Haskore demos
+--
+-- You should report a problem if any other output is generated.
+----------------------------------------------------------------"
+
+ echo "--!!! Performing static checks on demos"
+ perl runstdtest hugs -w +q -pHugs: ../demos/Demos -s58 "-o1test/Loaded.output"
+ perl runstdtest hugs -w +q -pHugs: ../demos/prolog/Main -s23 "-o1test/Loaded.output"
+ perl runstdtest hugs -w +q -pHugs: ../demos/cgi/Counter -s30 "-o1test/Loaded.output"
+
+ # Test that Haskore demos load successfully
+ echo "--!!! Performing static checks on Haskore demos"
+ perl runstdtest hugs -w +q -pHugs: ../lib/Haskore/demos/HaskoreExamples -s42 "-o1test/Loaded.output"
+ perl runstdtest hugs -w +q -pHugs: ../lib/Haskore/demos/SelfSim -s40 "-o1test/Loaded.output"
+ perl runstdtest hugs -w +q -pHugs: ../lib/Haskore/demos/ChildSong6 -s40 "-o1test/Loaded.output"
+
+} # End of test demos
+
+test_temp() {
+ echo "\
+----------------------------------------------------------------
+-- Testing temporary tests
+-- These aren't invoked by the usual "make check" - they serve
+-- as a marshalling area when adding new tests
+----------------------------------------------------------------"
+
+} # End of test temp
+
+case "$1" in
+static) test_static;;
+tcheck) test_tcheck;;
+rts) test_rts;;
+libs) test_libs;;
+demos) test_demos;;
+temp) test_temp;;
+*) echo Unknown test $1;;
+esac
+
+echo "----------------------------------------------------------------"
+
--- /dev/null
+-- test:
+-- A split-screen program:
+-- User input is displayed in top half of screen;
+-- Program output in the bottom half of the screen.
+
+module TestCVar(talk) where
+import Concurrent(
+ forkIO, CVar, newCVar, readCVar, writeCVar
+ )
+
+-- from ansi.hs (modified for Xterm settings)
+goto :: Int -> Int -> String
+goto x y = "\ESC[" ++ show (y+1) ++ ";" ++ show (x+1) ++ "H"
+
+cls :: String
+cls = "\ESC[H\ESC[2J" -- for Xterm
+
+-- Raw terminal handler:
+-- Atomically writes characters to screen at specific coordinates.
+
+type Terminal = CVar (Int,Int,Char)
+
+terminal :: IO Terminal
+terminal
+ = newCVar >>= \ buf ->
+ forkIO (server_loop buf) >>
+ return buf
+ where
+ -- possible optimisation:
+ -- remember current screen location to let us omit goto sometimes
+ server_loop buf
+ = readCVar buf >>= \ (x,y,c) ->
+ putStr (goto x y) >>
+ putChar c >>
+ server_loop buf
+
+-- Window handler:
+-- Keeps track of cursor position so that user program doesn't have to.
+-- Doesn't do redraw, scrolling, clipping, etc
+
+type DemoWindow = CVar Char
+
+window :: Terminal -> Int -> Int -> IO DemoWindow
+window t left top
+ = newCVar >>= \ buf ->
+ forkIO (server_loop buf left top) >>
+ return buf
+ where
+ server_loop buf x y
+ = readCVar buf >>= \ c ->
+ if c == '\n' then
+ server_loop buf left (y+1)
+ else
+ writeCVar t (x,y,c) >>
+ server_loop buf (x+1) y
+
+put :: DemoWindow -> Char -> IO ()
+put w c = writeCVar w c
+
+-- copy input to top of screen, output to bottom of screen
+talk :: (Char -> Char) -> IO ()
+talk f =
+ putStr cls >>
+ terminal >>= \ t ->
+ window t 0 0 >>= \ w1 ->
+ window t 0 12 >>= \ w2 ->
+ loop w1 w2
+ where
+ loop w1 w2
+ = getCh >>= \ c ->
+ put w1 c >>
+ put w2 (f c) >>
+ loop w1 w2
+
+-- Non-blocking getchar
+-- ToDo: find a way to replace the busy wait.
+-- (Not easy in Unix!)
+getCh :: IO Char
+getCh
+ = primIOAvailable >>= \ avail ->
+ if avail then
+ getChar
+ else
+ primWait >>
+ getCh
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * This file provides a simple mechanism for measuring elapsed time on Unix
+ * machines (more precisely, on any machine with an rusage() function).
+ * A somewhat limited version for other systems is also included, believed
+ * to be ANSI compatible, but not guaranteed ...
+ *
+ * It is included in the Hugs distribution for the purpose of benchmarking
+ * the Hugs interpreter, comparing its performance across a variety of
+ * different machines, and with other systems for similar languages.
+ *
+ * To make use of these functions, use the --enable-timer when configuring
+ * Hugs or change the setting of "WANT_TIMER" in config.h and recompile
+ * Hugs.
+ *
+ * It would be somewhat foolish to try to use the timings produced in this
+ * way for anything other than the purpose described above. In particular,
+ * using timings to compare the performance of different versions of an
+ * algorithm is likely to give very misleading results. The current
+ * implementation of Hugs as an interpreter, without any significant
+ * optimizations, means that there are much more significant overheads than
+ * can be accounted for by small variations in Hugs code.
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: timer.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:46 $
+ * ------------------------------------------------------------------------*/
+
+
+#if defined(HAVE_SYS_TIME_H) && defined(HAVE_SYS_RESOURCE_H)
+#include <sys/time.h>
+#include <sys/resource.h>
+
+void updateTimers Args((void));
+long millisecs Args((long));
+long userElapsed, systElapsed;
+
+void updateTimers() {
+ static long lastUser = 0;
+ static long lastSyst = 0;
+ long curr;
+ struct rusage ruse;
+ getrusage(RUSAGE_SELF,&ruse);
+
+ curr = ruse.ru_utime.tv_sec*1000000L + ruse.ru_utime.tv_usec;
+ userElapsed = curr - lastUser;
+ lastUser = curr;
+
+ curr = ruse.ru_stime.tv_sec*1000000L + ruse.ru_stime.tv_usec;
+ systElapsed = curr - lastSyst;
+ lastSyst = curr;
+}
+
+long millisecs(t)
+long t; {
+ return (t+500)/1000;
+}
+#else
+#include <time.h>
+
+void updateTimers Args((void));
+long millisecs Args((clock_t));
+clock_t userElapsed=0, systElapsed=0;
+
+void updateTimers() {
+ static clock_t lastUser = 0;
+ clock_t curr;
+ curr = clock();
+ userElapsed = curr - lastUser;
+ lastUser = curr;
+}
+
+long millisecs(t)
+clock_t t; {
+ return (long)((t * 1000)/CLK_TCK);
+}
+#endif
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Translator: generates stg code from output of pattern matching
+ * compiler.
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: translate.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:22:47 $
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "errors.h"
+#include "stg.h"
+#include "compiler.h"
+#include "pmc.h" /* for discrArity */
+#include "hugs.h" /* for debugCode */
+#include "type.h" /* for conToTagType, tagToConType */
+#include "link.h"
+#include "pp.h"
+#include "dynamic.h"
+#include "Assembler.h"
+#include "translate.h"
+
+/* ---------------------------------------------------------------- */
+
+static StgVar local stgOffset Args((Offset,List));
+static StgVar local stgText Args((Text,List));
+static StgRhs local stgRhs Args((Cell,Int,List));
+static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
+static StgExpr local stgExpr Args((Cell,Int,List,StgExpr));
+
+/* ---------------------------------------------------------------- */
+
+/* Association list storing globals assigned to dictionaries, tuples, etc */
+List stgGlobals = NIL;
+
+static StgVar local getSTGTupleVar Args((Cell));
+
+static StgVar local getSTGTupleVar( Cell d )
+{
+ Pair p = cellAssoc(d,stgGlobals);
+ /* Yoiks - only the Prelude sees Tuple decls! */
+ if (isNull(p)) {
+ implementTuple(tupleOf(d));
+ p = cellAssoc(d,stgGlobals);
+ }
+ assert(nonNull(p));
+ return snd(p);
+}
+
+/* ---------------------------------------------------------------- */
+
+static Cell local stgOffset(Offset o, List sc)
+{
+ Cell r = cellAssoc(o,sc);
+ assert(nonNull(r));
+ return snd(r);
+}
+
+static Cell local stgText(Text t,List sc)
+{
+ List xs = sc;
+ for (; nonNull(xs); xs=tl(xs)) {
+ Cell x = hd(xs);
+ Cell v = fst(x);
+ if (!isOffset(v) && t == textOf(v)) {
+ return snd(x);
+ }
+ }
+ internal("stgText");
+}
+
+/* ---------------------------------------------------------------- */
+
+static StgRhs local stgRhs(e,co,sc)
+Cell e;
+Int co;
+List sc; {
+ switch (whatIs(e)) {
+
+ /* Identifiers */
+ case OFFSET:
+ return stgOffset(e,sc);
+ case VARIDCELL:
+ case VAROPCELL:
+ return stgText(textOf(e),sc);
+ case TUPLE:
+ return getSTGTupleVar(e);
+ case NAME:
+ return e;
+ /* Literals */
+ case CHARCELL:
+ return mkStgCon(nameMkC,singleton(e));
+ case INTCELL:
+ return mkStgCon(nameMkI,singleton(e));
+ case BIGCELL:
+ return mkStgCon(nameMkBignum,singleton(e));
+ case FLOATCELL:
+ return mkStgCon(nameMkD,singleton(e));
+ case STRCELL:
+#if USE_ADDR_FOR_STRINGS
+ {
+ StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
+ return mkStgLet(singleton(v),
+ makeStgApp(nameUnpackString,singleton(v)));
+ }
+#else
+ return mkStgApp(nameUnpackString,singleton(e));
+#endif
+ case AP:
+ return stgExpr(e,co,sc,namePMFail);
+ case NIL:
+ internal("stgRhs2");
+ default:
+ return stgExpr(e,co,sc,namePMFail);
+ }
+}
+
+static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
+Cell alt;
+Int co;
+List sc;
+StgExpr failExpr;
+{
+ StgDiscr d = fst(alt);
+ Int da = discrArity(d);
+ Cell vs = NIL;
+ Int i;
+ for(i=1; i<=da; ++i) {
+ StgVar nv = mkStgVar(NIL,NIL);
+ vs = cons(nv,vs);
+ sc = cons(pair(mkOffset(co+i),nv),sc);
+ }
+ return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
+}
+
+static StgExpr local stgExpr(e,co,sc,failExpr)
+Cell e;
+Int co;
+List sc;
+StgExpr failExpr;
+{
+ switch (whatIs(e)) {
+ case COND:
+ {
+ return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
+ stgExpr(snd3(snd(e)),co,sc,failExpr),
+ stgExpr(thd3(snd(e)),co,sc,failExpr));
+ }
+ case GUARDED:
+ {
+ List guards = reverse(snd(e));
+ e = failExpr;
+ for(; nonNull(guards); guards=tl(guards)) {
+ Cell g = hd(guards);
+ Cell c = stgExpr(fst(g),co,sc,namePMFail);
+ Cell rhs = stgExpr(snd(g),co,sc,failExpr);
+ e = makeStgIf(c,rhs,e);
+ }
+ return e;
+ }
+ case FATBAR:
+ {
+ StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
+ StgVar alt = mkStgVar(e2,NIL);
+ return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
+ }
+ case CASE:
+ {
+ List alts = snd(snd(e));
+ Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
+ if (isNull(alts)) {
+ return failExpr;
+ } else if (isChar(fst(hd(alts)))) {
+ Cell alt = hd(alts);
+ StgDiscr d = fst(alt);
+ StgVar c = mkStgVar(mkStgCon(nameMkC,singleton(d)),NIL);
+ StgExpr test = nameEqChar;
+ /* duplicates scrut but it should be atomic */
+ return makeStgIf(makeStgLet(singleton(c),makeStgApp(test,doubleton(scrut,c))),
+ stgExpr(snd(alt),co,sc,failExpr),
+ stgExpr(ap(CASE,pair(fst(snd(e)),tl(alts))),co,sc,failExpr));
+ } else {
+ List as = NIL;
+ for(; nonNull(alts); alts=tl(alts)) {
+ as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
+ }
+ return mkStgCase(scrut, revOnto(as, singleton(mkStgDefault(mkStgVar(NIL,NIL),failExpr))));
+ }
+ }
+ case NUMCASE:
+#if OVERLOADED_CONSTANTS
+ {
+ Triple nc = snd(e);
+ Offset o = fst3(nc);
+ Cell discr = snd3(nc);
+ Cell r = thd3(nc);
+ Cell scrut = stgOffset(o,sc);
+ Cell h = getHead(discr);
+ Int da = discrArity(discr);
+
+#if NPLUSK
+ if (whatIs(h) == ADDPAT && argCount == 1) {
+ /* ADDPAT num dictIntegral
+ * ==>
+ * let n = fromInteger num in
+ * if pmLe dictIntegral n scrut
+ * then let v = pmSubtract dictIntegral scrut v
+ * else fail
+ */
+ Cell n = snd(h);
+ Cell dictIntegral = arg(discr); /* Integral dictionary */
+ StgVar v = NIL;
+ List binds = NIL;
+ StgVar dIntegral = NIL;
+
+ /* bind dictionary */
+ dIntegral = stgRhs(dictIntegral,co,sc);
+ if (!isAtomic(dIntegral)) { /* wasn't atomic */
+ dIntegral = mkStgVar(dIntegral,NIL);
+ binds = cons(dIntegral,binds);
+ }
+ /* box number */
+ n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),NIL);
+ binds = cons(n,binds);
+
+ /* coerce number to right type (using Integral dict) */
+ n = mkStgVar(mkStgApp(namePmFromInteger,doubleton(dIntegral,n)),NIL);
+ binds = cons(n,binds);
+
+ ++co;
+ v = mkStgVar(mkStgApp(namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
+ return mkStgLet(binds,
+ makeStgIf(mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
+ mkStgLet(singleton(v),
+ stgExpr(r,
+ co,
+ cons(pair(mkOffset(co),v),sc),
+ failExpr)),
+ failExpr));
+ }
+#endif /* NPLUSK */
+
+ assert(isName(h) && argCount == 2);
+ {
+ /* This code is rather ugly.
+ * We ought to desugar it using one of the following:
+ * if (==) dEq (fromInt dNum pat) scrut
+ * if (==) dEq (fromInteger dNum pat) scrut
+ * if (==) dEq (fromFloat dFractional pat) scrut
+ * But it would be very hard to obtain the Eq dictionary
+ * from the Num or Fractional dictionary we have.
+ * Instead, we rely on the Prelude to supply 3 helper
+ * functions which do the test for us.
+ * primPmInt :: Num a => Int -> a -> Bool
+ * primPmInteger :: Num a => Integer -> a -> Bool
+ * primPmDouble :: Fractional a => Double -> a -> Bool
+ */
+ Cell n = arg(discr);
+ Cell dict = arg(fun(discr));
+ StgExpr d = NIL;
+ List binds = NIL;
+ StgExpr m = NIL;
+ Name box
+ = h == nameFromInt ? nameMkI
+ : h == nameFromInteger ? nameMkBignum
+ : nameMkD;
+ Name testFun
+ = h == nameFromInt ? namePmInt
+ : h == nameFromInteger ? namePmInteger
+ : namePmDouble;
+ Cell altsc = sc;
+ Cell vs = NIL;
+ Int i;
+
+ for(i=1; i<=da; ++i) {
+ Cell nv = mkStgVar(NIL,NIL);
+ vs = cons(nv,vs);
+ altsc = cons(pair(mkOffset(co+i),nv),altsc);
+ }
+ /* bind dictionary */
+ d = stgRhs(dict,co,sc);
+ if (!isAtomic(d)) { /* wasn't atomic */
+ d = mkStgVar(d,NIL);
+ binds = cons(d,binds);
+ }
+ /* bind number */
+ n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
+ binds = cons(n,binds);
+
+ return makeStgIf(mkStgLet(binds,
+ mkStgApp(testFun,tripleton(d,n,scrut))),
+ stgExpr(r,co+da,altsc,failExpr),
+ failExpr);
+ }
+ }
+#else /* ! OVERLOADED_CONSTANTS */
+ {
+ Triple nc = snd(e);
+ Offset o = fst3(nc);
+ Cell discr = snd3(nc);
+ Cell r = thd3(nc);
+ Cell scrut = stgOffset(o,sc);
+ Cell h = getHead(discr);
+ Int da = discrArity(discr);
+ Cell n = discr;
+ List binds = NIL;
+ Name eq
+ = isInt(discr) ? nameEqInt
+ : isBignum(discr) ? nameEqInteger
+ : nameEqDouble;
+ Name box
+ = isInt(discr) ? nameMkI
+ : isBignum(discr) ? nameMkBignum
+ : nameMkD;
+ StgExpr test = NIL;
+ Cell altsc = sc;
+ Cell vs = NIL;
+ Int i;
+
+ for(i=1; i<=da; ++i) {
+ Cell nv = mkStgVar(NIL,NIL);
+ vs = cons(nv,vs);
+ altsc = cons(pair(mkOffset(co+i),nv),altsc);
+ }
+
+ /* bind number */
+ n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
+ binds = cons(n,binds);
+
+ test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
+ return makeStgIf(test,
+ stgExpr(r,co+da,altsc,failExpr),
+ failExpr);
+ }
+#endif /* ! OVERLOADED_CONSTANTS */
+ case LETREC:
+ {
+ List binds = NIL;
+ List vs = NIL;
+ List bs;
+ /* allocate variables, extend scope */
+ for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
+ Cell nv = mkStgVar(NIL,NIL);
+ sc = cons(pair(fst3(hd(bs)),nv),sc);
+ binds = cons(nv,binds);
+ vs = cons(nv,vs);
+ }
+ for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
+ Cell nv = mkStgVar(NIL,NIL);
+ sc = cons(pair(mkOffset(++co),nv),sc);
+ binds = cons(nv,binds);
+ vs = cons(nv,vs);
+ }
+ vs = rev(vs);
+ /* transform functions */
+ for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
+ Cell fun = hd(bs);
+ Cell nv = hd(vs);
+ List as = NIL;
+ List funsc = sc;
+ Int arity = intOf(snd3(fun));
+ Int i;
+ for(i=1; i<=arity; ++i) {
+ Cell v = mkStgVar(NIL,NIL);
+ as = cons(v,as);
+ funsc = cons(pair(mkOffset(co+i),v),funsc);
+ }
+ stgVarBody(nv) = mkStgLambda(as,stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
+ }
+ /* transform expressions */
+ for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
+ Cell rhs = hd(bs);
+ Cell nv = hd(vs);
+ stgVarBody(nv) = stgRhs(rhs,co,sc);
+ }
+ return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc));
+ }
+ default: /* convert to an StgApp or StgVar plus some bindings */
+ {
+ List args = NIL;
+ List binds = NIL;
+ List as = NIL;
+
+ /* Unwind args */
+ while (isAp(e)) {
+ Cell arg = arg(e);
+ e = fun(e);
+ args = cons(arg,args);
+ }
+
+ /* Special cases */
+ if (e == nameSel && length(args) == 3) {
+ Cell con = hd(args);
+#if 0
+ StgVar v = stgOffset(hd(tl(args)),sc);
+#else
+ StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
+#endif
+ Int ix = intOf(hd(tl(tl(args))));
+ Int da = discrArity(con);
+ List vs = NIL;
+ Int i;
+ for(i=1; i<=da; ++i) {
+ Cell nv = mkStgVar(NIL,NIL);
+ vs=cons(nv,vs);
+ }
+ return mkStgCase(v,
+ doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
+ mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
+ }
+
+ /* Arguments must be StgAtoms */
+ for(as=args; nonNull(as); as=tl(as)) {
+ StgRhs a = stgRhs(hd(as),co,sc);
+#if 1 /* optional flattening of let bindings */
+ if (whatIs(a) == LETREC) {
+ binds = appendOnto(stgLetBinds(a),binds);
+ a = stgLetBody(a);
+ }
+#endif
+
+ if (!isAtomic(a)) {
+ a = mkStgVar(a,NIL);
+ binds = cons(a,binds);
+ }
+ hd(as) = a;
+ }
+
+ /* Function must be StgVar or Name */
+ e = stgRhs(e,co,sc);
+ if (!isStgVar(e) && !isName(e)) {
+ e = mkStgVar(e,NIL);
+ binds = cons(e,binds);
+ }
+
+ return makeStgLet(binds,makeStgApp(e,args));
+ }
+ }
+}
+
+static Void ppExp( Name n, Int arity, Cell e );
+static Void ppExp( Name n, Int arity, Cell e )
+{
+#if DEBUG_CODE
+ if (debugCode) {
+ Int i;
+ printf("BEFORE: %s", textToStr(name(n).text));
+ for (i = arity; i > 0; i--) {
+ printf(" o%d", i);
+ }
+ printf(" = ");
+ printExp(stdout,e);
+ printf("\n");
+ }
+#endif
+}
+
+Void stgDefn( Name n, Int arity, Cell e )
+{
+ List vs = NIL;
+ List sc = NIL;
+ Int i;
+ ppExp(n,arity,e);
+ for (i = 1; i <= arity; ++i) {
+ Cell nv = mkStgVar(NIL,NIL);
+ vs = cons(nv,vs);
+ sc = cons(pair(mkOffset(i),nv),sc);
+ }
+ stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
+ ppStg(name(n).stgVar);
+}
+
+static StgExpr forceArgs( List is, List args, StgExpr e );
+
+/* force the args numbered in is */
+static StgExpr forceArgs( List is, List args, StgExpr e )
+{
+ for(; nonNull(is); is=tl(is)) {
+ e = mkSeq(nth(intOf(hd(is))-1,args),e);
+ }
+ return e;
+}
+
+/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
+Void implementConToTag(t)
+Tycon t; {
+ if (isNull(tycon(t).conToTag)) {
+ List cs = tycon(t).defn;
+ Name nm = newName(inventText());
+ StgVar v = mkStgVar(NIL,NIL);
+ List alts = NIL; /* can't fail */
+
+ assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),NIL);
+ StgExpr tag = mkStgLet(singleton(r),r);
+ List vs = NIL;
+ Int i;
+ for(i=0; i < name(c).arity; ++i) {
+ vs = cons(mkStgVar(NIL,NIL),vs);
+ }
+ alts = cons(mkStgCaseAlt(c,vs,tag),alts);
+ }
+
+ name(nm).line = tycon(t).line;
+ name(nm).type = conToTagType(t);
+ name(nm).arity = 1;
+ name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),NIL);
+ tycon(t).conToTag = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ }
+}
+
+/* \ v -> case v of { ...; i -> Ci; ... } */
+Void implementTagToCon(t)
+Tycon t; {
+ if (isNull(tycon(t).tagToCon)) {
+ List cs = tycon(t).defn;
+ Name nm = newName(inventText());
+ StgVar v1 = mkStgVar(NIL,NIL);
+ StgVar v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
+ List alts = singleton(mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),namePMFail));
+
+ assert(namePMFail);
+ assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
+ for (; hasCfun(cs); cs=tl(cs)) {
+ Name c = hd(cs);
+ Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
+ StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
+ assert(name(c).arity==0);
+ alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
+ }
+
+ name(nm).line = tycon(t).line;
+ name(nm).type = tagToConType(t);
+ name(nm).arity = 1;
+ name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v1),
+ mkStgCase(v1,singleton(mkStgCaseAlt(nameMkI,singleton(v2),
+ mkStgPrimCase(v2,alts))))),NIL);
+ tycon(t).tagToCon = nm;
+ /* hack to make it print out */
+ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ }
+}
+
+Void implementCfun(c,scs) /* Build implementation for constr */
+Name c; /* fun c. scs lists integers (1..)*/
+List scs; { /* in incr order of strict comps. */
+ Int a = name(c).arity;
+ if (name(c).arity > 0) {
+ List args = makeArgs(a);
+ StgVar tv = mkStgVar(mkStgCon(c,args),NIL);
+ StgExpr e1 = mkStgLet(singleton(tv),tv);
+ StgExpr e2 = forceArgs(scs,args,e1);
+ StgVar v = mkStgVar(mkStgLambda(args,e2),NIL);
+ name(c).stgVar = v;
+ } else {
+ StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
+ name(c).stgVar = v;
+ }
+ /* hack to make it print out */
+ stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
+}
+
+/* --------------------------------------------------------------------------
+ * Foreign function calls and primops
+ * ------------------------------------------------------------------------*/
+
+static String charListToString( List cs );
+static Cell foreignResultTy( Type t );
+static Cell foreignArgTy( Type t );
+static Name repToBox Args(( char c ));
+static StgRhs makeStgPrim Args(( Name,Bool,List,String,String ));
+
+static String charListToString( List cs )
+{
+ static char s[100];
+
+ Int i = 0;
+ assert( length(cs) < 100 );
+ for(; nonNull(cs); ++i, cs=tl(cs)) {
+ s[i] = charOf(hd(cs));
+ }
+ s[i] = '\0';
+ return textToStr(findText(s));
+}
+
+static Cell foreignResultTy( Type t )
+{
+ if (t == typeChar) return mkChar(CHAR_REP);
+ else if (t == typeInt) return mkChar(INT_REP);
+#ifdef PROVIDE_INT64
+ else if (t == typeInt64) return mkChar(INT64_REP);
+#endif
+#ifdef PROVIDE_INTEGER
+ else if (t == typeInteger)return mkChar(INTEGER_REP);
+#endif
+#ifdef PROVIDE_WORD
+ else if (t == typeWord) return mkChar(WORD_REP);
+#endif
+#ifdef PROVIDE_ADDR
+ else if (t == typeAddr) return mkChar(ADDR_REP);
+#endif
+ else if (t == typeFloat) return mkChar(FLOAT_REP);
+ else if (t == typeDouble) return mkChar(DOUBLE_REP);
+#ifdef PROVIDE_FOREIGN
+ else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */
+#endif
+#ifdef PROVIDE_ARRAY
+ else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */
+ else if (whatIs(t) == AP) {
+ Type h = getHead(t);
+ if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */
+ }
+#endif
+ /* ToDo: decent line numbers! */
+ ERRMSG(0) "Illegal foreign type" ETHEN
+ ERRTEXT " \"" ETHEN ERRTYPE(t);
+ ERRTEXT "\""
+ EEND;
+}
+
+static Cell foreignArgTy( Type t )
+{
+ return foreignResultTy( t );
+}
+
+static Name repToBox( char c )
+{
+ switch (c) {
+ case CHAR_REP: return nameMkC;
+ case INT_REP: return nameMkI;
+#ifdef PROVIDE_INT64
+ case INT64_REP: return nameMkInt64;
+#endif
+#ifdef PROVIDE_INTEGER
+ case INTEGER_REP: return nameMkInteger;
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP: return nameMkW;
+#endif
+#ifdef PROVIDE_ADDR
+ case ADDR_REP: return nameMkA;
+#endif
+ case FLOAT_REP: return nameMkF;
+ case DOUBLE_REP: return nameMkD;
+#ifdef PROVIDE_ARRAY
+ case ARR_REP: return nameMkPrimArray;
+ case BARR_REP: return nameMkPrimByteArray;
+ case REF_REP: return nameMkRef;
+ case MUTARR_REP: return nameMkPrimMutableArray;
+ case MUTBARR_REP: return nameMkPrimMutableByteArray;
+#endif
+#ifdef PROVIDE_STABLE
+ case STABLE_REP: return nameMkStable;
+#endif
+#ifdef PROVIDE_WEAK
+ case WEAK_REP: return nameMkWeak;
+#endif
+#ifdef PROVIDE_FOREIGN
+ case FOREIGN_REP: return nameMkForeign;
+#endif
+#ifdef PROVIDE_CONCURRENT
+ case THREADID_REP: return nameMkThreadId;
+ case MVAR_REP: return nameMkMVar;
+#endif
+ default: return NIL;
+ }
+}
+
+static StgPrimAlt boxResults( String reps, StgVar state )
+{
+ List rs = NIL; /* possibly unboxed results */
+ List bs = NIL; /* boxed results of wrapper */
+ List rbinds = NIL; /* bindings used to box results */
+ StgExpr e = NIL;
+ Int i;
+ for(i=0; reps[i] != '\0'; ++i) {
+ StgRep k = mkStgRep(reps[i]);
+ Cell v = mkStgPrimVar(NIL,k,NIL);
+ Name box = repToBox(reps[i]);
+ if (isNull(box)) {
+ bs = cons(v,bs);
+ } else {
+ StgRhs rhs = mkStgCon(box,singleton(v));
+ StgVar bv = mkStgVar(rhs,NIL); /* boxed */
+ bs = cons(bv,bs);
+ rbinds = cons(bv,rbinds);
+ }
+ rs = cons(v,rs);
+ }
+ /* Construct tuple of results */
+ if (i == 1) {
+ e = hd(bs);
+ } else { /* includes i==0 case */
+ StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
+ rbinds = cons(r,rbinds);
+ e = r;
+ }
+ /* construct result pair if needed */
+ if (nonNull(state)) {
+ /* Note that this builds a tuple directly - we know it's
+ * saturated.
+ */
+ StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
+ rbinds = cons(r,rbinds);
+ rs = cons(state,rs); /* last result is a state */
+ e = r;
+ }
+ return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
+}
+
+static List mkUnboxedVars( String reps )
+{
+ List as = NIL;
+ Int i;
+ for(i=0; reps[i] != '\0'; ++i) {
+ Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
+ as = cons(v,as);
+ }
+ return rev(as);
+}
+
+static List mkBoxedVars( String reps )
+{
+ List as = NIL;
+ Int i;
+ for(i=0; reps[i] != '\0'; ++i) {
+ as = cons(mkStgVar(NIL,NIL),as);
+ }
+ return rev(as);
+}
+
+static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
+{
+ if (nonNull(b_args)) {
+ StgVar b_arg = hd(b_args); /* boxed arg */
+ StgVar u_arg = hd(u_args); /* unboxed arg */
+ StgRep k = mkStgRep(*reps);
+ Name box = repToBox(*reps);
+ e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
+ if (isNull(box)) {
+ /* Use a trivial let-binding */
+ stgVarBody(u_arg) = b_arg;
+ return mkStgLet(singleton(u_arg),e);
+ } else {
+ StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
+ return mkStgCase(b_arg,singleton(alt));
+ }
+ } else {
+ return e;
+ }
+}
+
+/* Generate wrapper for primop based on list of arg types and result types:
+ *
+ * makeStgPrim op# False "II" "II" =
+ * \ x y -> "case x of { I# x# ->
+ * case y of { I# y# ->
+ * case op#{x#,y#} of { r1# r2# ->
+ * let r1 = I# r1#; r2 = I# r2# in
+ * (r1, r2)
+ * }}}"
+ */
+static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
+Name op;
+Bool addState;
+List extra_args;
+String a_reps;
+String r_reps; {
+ List b_args = NIL; /* boxed args to primop */
+ List u_args = NIL; /* possibly unboxed args to primop */
+ List alts = NIL;
+ StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
+ StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
+
+ /* box results */
+ if (strcmp(r_reps,"B") == 0) {
+ StgPrimAlt altF = mkStgPrimAlt(singleton(mkStgPrimVar(mkInt(0),mkStgRep(INT_REP),NIL)),
+ nameFalse);
+ StgPrimAlt altT = mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
+ nameTrue);
+ alts = doubleton(altF,altT);
+ assert(nonNull(nameTrue));
+ assert(!addState);
+ } else {
+ alts = singleton(boxResults(r_reps,s1));
+ }
+ b_args = mkBoxedVars(a_reps);
+ u_args = mkUnboxedVars(a_reps);
+ if (addState) {
+ List actual_args = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
+ StgRhs rhs = makeStgLambda(singleton(s0),
+ unboxVars(a_reps,b_args,u_args,
+ mkStgPrimCase(mkStgPrim(op,actual_args),
+ alts)));
+ StgVar m = mkStgVar(rhs,NIL);
+ return makeStgLambda(b_args,
+ mkStgLet(singleton(m),
+ mkStgApp(nameMkIO,singleton(m))));
+ } else {
+ List actual_args = appendOnto(extra_args,u_args);
+ return makeStgLambda(b_args,
+ unboxVars(a_reps,b_args,u_args,mkStgPrimCase(mkStgPrim(op,actual_args),alts)));
+ }
+}
+
+Void implementPrim( n )
+Name n; {
+ const AsmPrim* p = name(n).primop;
+ StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
+ StgVar v = mkStgVar(rhs,NIL);
+ name(n).stgVar = v;
+ stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
+}
+
+/* Generate wrapper code from (in,out) type lists.
+ *
+ * For example:
+ *
+ * inTypes = [Int,Float]
+ * outTypes = [Char,Addr]
+ * ==>
+ * \ fun a1 a2 ->
+ * let m = (\ s0 ->
+ * case a1 of { I# a1# ->
+ * case s2 of { F# a2# ->
+ * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
+ * let r1 = C# r1# in
+ * let r2 = A# r2# in
+ * let r = (r1,r2) in
+ * (r,s1)
+ * }}})
+ * in primMkIO m
+ * ::
+ * Addr -> (Int -> Float -> IO (Char,Addr)
+ */
+Void implementForeignImport( Name n )
+{
+ Type t = name(n).type;
+ List argTys = NIL;
+ List resultTys = NIL;
+ CFunDescriptor* descriptor = 0;
+ Bool addState = TRUE;
+ while (getHead(t)==typeArrow && argCount==2) {
+ Type ta = fullExpand(arg(fun(t)));
+ Type tr = arg(t);
+ argTys = cons(ta,argTys);
+ t = tr;
+ }
+ argTys = rev(argTys);
+ if (getHead(t) == typeIO) {
+ resultTys = getArgs(t);
+ assert(length(resultTys) == 1);
+ resultTys = hd(resultTys);
+ addState = TRUE;
+ } else {
+ resultTys = t;
+ addState = FALSE;
+ }
+ resultTys = fullExpand(resultTys);
+ if (isTuple(getHead(resultTys))) {
+ resultTys = getArgs(resultTys);
+ } else if (getHead(resultTys) == typeUnit) {
+ resultTys = NIL;
+ } else {
+ resultTys = singleton(resultTys);
+ }
+ mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
+ mapOver(foreignResultTy,resultTys);/* doesn't */
+ descriptor = mkDescriptor(charListToString(argTys),
+ charListToString(resultTys));
+ name(n).primop = addState ? &ccall_IO : &ccall_Id;
+ {
+ Pair extName = name(n).defn;
+ void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))),
+ textToStr(textOf(snd(extName))));
+ List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
+ StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,descriptor->result_tys);
+ StgVar v = mkStgVar(rhs,NIL);
+ if (funPtr == 0) {
+ ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
+ textToStr(textOf(snd(extName))),
+ textToStr(textOf(fst(extName)))
+ EEND;
+ }
+ ppStg(v);
+ name(n).defn = NIL;
+ name(n).stgVar = v;
+ stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
+ }
+}
+
+Void implementForeignExport( Name n )
+{
+ internal("implementForeignExport: not implemented");
+}
+
+Void implementTuple(size)
+Int size; {
+ if (size > 0) {
+ Cell t = mkTuple(size);
+ List args = makeArgs(size);
+ StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
+ StgExpr e = mkStgLet(singleton(tv),tv);
+ StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
+ stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
+ } else {
+ StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
+ stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* so we can see it */
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Compiler control:
+ * ------------------------------------------------------------------------*/
+
+Void translateControl(what)
+Int what; {
+ switch (what) {
+ case INSTALL:
+ {
+ /* deliberate fall through */
+ }
+ case RESET:
+ stgGlobals=NIL;
+ break;
+ case MARK:
+ mark(stgGlobals);
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+extern Void stgDefn Args(( Name n, Int arity, Cell e ));
+
+extern Void implementForeignImport Args((Name));
+extern Void implementForeignExport Args((Name));
+extern Void implementCfun Args((Name, List));
+extern Void implementConToTag Args((Tycon));
+extern Void implementTagToCon Args((Tycon));
+extern Void implementPrim Args((Name));
+extern Void implementTuple Args((Int));
+#if TREX
+extern Name implementRecShw Args((Text));
+extern Name implementRecEq Args((Text));
+#endif
+
+/* Association list storing globals assigned to dictionaries, tuples, etc */
+extern List stgGlobals;
+
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * type.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
+ * See NOTICE for details and conditions of use etc...
+ * Hugs version 1.3c, March 1998
+ *
+ * This is the Hugs type checker
+ * ------------------------------------------------------------------------*/
+
+#include "prelude.h"
+#include "storage.h"
+#include "connect.h"
+#include "input.h"
+#include "static.h"
+#include "hugs.h" /* for target */
+#include "pat.h" /* for failFree */
+#include "errors.h"
+#include "subst.h"
+#include "type.h"
+#include "link.h"
+#include "Assembler.h" /* for AsmCTypes */
+
+/*#define DEBUG_TYPES*/
+/*#define DEBUG_KINDS*/
+/*#define DEBUG_DEFAULTS*/
+/*#define DEBUG_SELS*/
+/*#define DEBUG_CODE*/
+/*#define DEBUG_DEPENDS*/
+/*#define DEBUG_DERIVING*/
+
+Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
+ /* types produce error */
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Void local emptyAssumption Args((Void));
+static Void local enterBindings Args((Void));
+static Void local leaveBindings Args((Void));
+static Int local defType Args((Cell));
+static Type local useType Args((Cell));
+static Void local markAssumList Args((List));
+static Cell local findAssum Args((Text));
+static Pair local findInAssumList Args((Text,List));
+static List local intsIntersect Args((List,List));
+static List local genvarAllAss Args((List));
+static List local genvarAnyAss Args((List));
+static Int local newVarsBind Args((Cell));
+static Void local newDefnBind Args((Cell,Type));
+
+static Void local enterPendingBtyvs Args((Void));
+static Void local leavePendingBtyvs Args((Void));
+static Cell local patBtyvs Args((Cell));
+static Void local doneBtyvs Args((Int));
+
+static Void local typeError Args((Int,Cell,Cell,String,Type,Int));
+static Void local reportTypeError Args((Int,Cell,Cell,String,Type,Type));
+static Void local cantEstablish Args((Int,String,Cell,Type,List));
+static Void local tooGeneral Args((Int,Cell,Type,Type));
+
+static Cell local typeExpr Args((Int,Cell));
+
+static Cell local typeAp Args((Int,Cell));
+static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool));
+static Void local typeAlt Args((String,Cell,Cell,Type,Int,Int));
+static Int local funcType Args((Int));
+static Void local typeCase Args((Int,Int,Cell));
+static Void local typeComp Args((Int,Type,Cell,List));
+static Void local typeDo Args((Int,Cell));
+static Cell local compZero Args((List,Int));
+static Void local typeConFlds Args((Int,Cell));
+static Void local typeUpdFlds Args((Int,Cell));
+static Cell local typeFreshPat Args((Int,Cell));
+
+static Void local typeBindings Args((List));
+static Void local removeTypeSigs Args((Cell));
+
+static Void local monorestrict Args((List));
+static Void local restrictedBindAss Args((Cell));
+static Void local restrictedAss Args((Int,Cell,Type));
+
+static Void local unrestricted Args((List));
+static List local itbscc Args((List));
+static Void local addEvidParams Args((List,Cell));
+
+static Void local typeClassDefn Args((Class));
+static Void local typeInstDefn Args((Inst));
+static Void local typeMember Args((String,Name,Cell,List,Cell,Int));
+
+static Void local typeBind Args((Cell));
+static Void local typeDefAlt Args((Int,Cell,Pair));
+static Cell local typeRhs Args((Cell));
+static Void local guardedType Args((Int,Cell));
+
+static Void local genBind Args((List,Cell));
+static Void local genAss Args((Int,List,Cell,Type));
+static Type local genTest Args((Int,Cell,List,Type,Type,Int));
+static Type local generalize Args((List,Type));
+static Bool local equalTypes Args((Type,Type));
+
+static Void local typeDefnGroup Args((List));
+static Pair local typeSel Args((Name));
+
+/* --------------------------------------------------------------------------
+ * Frequently used type skeletons:
+ * ------------------------------------------------------------------------*/
+
+static Type arrow; /* mkOffset(0) -> mkOffset(1) */
+static Type boundPair; /* (mkOffset(0),mkOffset(0)) */
+static Type listof; /* [ mkOffset(0) ] */
+static Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
+
+static Cell predNum; /* Num (mkOffset(0)) */
+static Cell predFractional; /* Fractional (mkOffset(0)) */
+static Cell predIntegral; /* Integral (mkOffset(0)) */
+static Kind starToStar; /* Type -> Type */
+static Cell predMonad; /* Monad (mkOffset(0)) */
+static Cell predMonad0; /* Monad0 (mkOffset(0)) */
+
+/* --------------------------------------------------------------------------
+ * Assumptions:
+ *
+ * A basic typing statement is a pair (Var,Type) and an assumption contains
+ * an ordered list of basic typing statements in which the type for a given
+ * variable is given by the most recently added assumption about that var.
+ *
+ * In practice, the assumption set is split between a pair of lists, one
+ * holding assumptions for vars defined in bindings, the other for vars
+ * defined in patterns/binding parameters etc. The reason for this
+ * separation is that vars defined in bindings may be overloaded (with the
+ * overloading being unknown until the whole binding is typed), whereas the
+ * vars defined in patterns have no overloading. A form of dependency
+ * analysis (at least as far as calculating dependents within the same group
+ * of value bindings) is required to implement this. Where it is known that
+ * no overloaded values are defined in a binding (i.e., when the `dreaded
+ * monomorphism restriction' strikes), the list used to record dependents
+ * is flagged with a NODEPENDS tag to avoid gathering dependents at that
+ * level.
+ *
+ * To interleave between vars for bindings and vars for patterns, we use
+ * a list of lists of typing statements for each. These lists are always
+ * the same length. The implementation here is very similar to that of the
+ * dependency analysis used in the static analysis component of this system.
+ *
+ * To deal with polymorphic recursion, variables defined in bindings can be
+ * assigned types of the form (POLYREC,(def,use)), where def is a type
+ * variable for the type of the defining occurence, and use is a type
+ * scheme for (recursive) calls/uses of the variable.
+ * ------------------------------------------------------------------------*/
+
+static List defnBounds; /*::[[(Var,Type)]] possibly ovrlded*/
+static List varsBounds; /*::[[(Var,Type)]] not overloaded */
+static List depends; /*::[?[Var]] dependents/NODEPENDS */
+static List skolVars; /*::[[Var]] skolem vars */
+static Cell dummyVar; /* Used to put extra tvars into ass*/
+
+#define saveVarsAss() List saveAssump = hd(varsBounds)
+#define restoreVarsAss() hd(varsBounds) = saveAssump
+#define addVarAssump(v,t) hd(varsBounds) = cons(pair(v,t),hd(varsBounds))
+#define findTopBinding(v) findInAssumList(textOf(v),hd(defnBounds))
+
+static Void local emptyAssumption() { /* set empty type assumption */
+ defnBounds = NIL;
+ varsBounds = NIL;
+ depends = NIL;
+ skolVars = NIL;
+}
+
+static Void local enterBindings() { /* Add new level to assumption sets */
+ defnBounds = cons(NIL,defnBounds);
+ varsBounds = cons(NIL,varsBounds);
+ depends = cons(NIL,depends);
+}
+
+static Void local leaveBindings() { /* Drop one level of assumptions */
+ defnBounds = tl(defnBounds);
+ varsBounds = tl(varsBounds);
+ depends = tl(depends);
+}
+
+static Int local defType(a) /* Return type for defining occ. */
+Cell a; { /* of a var from assumption pair */
+ return (isPair(a) && fst(a)==POLYREC) ? fst(snd(a)) : a;
+}
+
+static Type local useType(a) /* Return type for use of a var */
+Cell a; { /* defined in an assumption */
+ return (isPair(a) && fst(a)==POLYREC) ? snd(snd(a)) : a;
+}
+
+static Void local markAssumList(as) /* Mark all types in assumption set*/
+List as; { /* :: [(Var, Type)] */
+ for (; nonNull(as); as=tl(as)) { /* No need to mark generic types; */
+ Type t = defType(snd(hd(as))); /* the only free variables in those*/
+ if (!isPolyType(t)) /* must have been free earlier too */
+ markType(t,0);
+ }
+}
+
+static Cell local findAssum(t) /* Find most recent assumption about*/
+Text t; { /* variable named t, if any */
+ List defnBounds1 = defnBounds; /* return translated variable, with */
+ List varsBounds1 = varsBounds; /* type in typeIs */
+ List depends1 = depends;
+
+ while (nonNull(defnBounds1)) {
+ Pair ass = findInAssumList(t,hd(varsBounds1));/* search varsBounds */
+ if (nonNull(ass)) {
+ typeIs = snd(ass);
+ return fst(ass);
+ }
+
+ ass = findInAssumList(t,hd(defnBounds1)); /* search defnBounds */
+ if (nonNull(ass)) {
+ Cell v = fst(ass);
+ typeIs = snd(ass);
+
+ if (hd(depends1)!=NODEPENDS && /* save dependent? */
+ isNull(v=varIsMember(t,hd(depends1))))
+ /* N.B. make new copy of variable and store this on list of*/
+ /* dependents, and in the assumption so that all uses of */
+ /* the variable will be at the same node, if we need to */
+ /* overwrite the call of a function with a translation... */
+ hd(depends1) = cons(v=mkVar(t),hd(depends1));
+
+ return v;
+ }
+
+ defnBounds1 = tl(defnBounds1); /* look in next level*/
+ varsBounds1 = tl(varsBounds1); /* of assumption set */
+ depends1 = tl(depends1);
+ }
+ return NIL;
+}
+
+static Pair local findInAssumList(t,as)/* Search for assumption for var */
+Text t; /* named t in list of assumptions as*/
+List as; {
+ for (; nonNull(as); as=tl(as))
+ if (textOf(fst(hd(as)))==t)
+ return hd(as);
+ return NIL;
+}
+
+static List local intsIntersect(as,bs) /* calculate intersection of lists */
+List as, bs; { /* of integers (as sets) */
+ List ts = NIL; /* destructively modifies as */
+ while (nonNull(as))
+ if (intIsMember(intOf(hd(as)),bs)) {
+ List temp = tl(as);
+ tl(as) = ts;
+ ts = as;
+ as = temp;
+ }
+ else
+ as = tl(as);
+ return ts;
+}
+
+static List local genvarAllAss(as) /* calculate generic vars that are */
+List as; { /* in every type in assumptions as */
+ List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
+ for (as=tl(as); nonNull(as) && nonNull(vs); as=tl(as))
+ vs = intsIntersect(vs,genvarTyvar(intOf(defType(snd(hd(as)))),NIL));
+ return vs;
+}
+
+static List local genvarAnyAss(as) /* calculate generic vars that are */
+List as; { /* in any type in assumptions as */
+ List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
+ for (as=tl(as); nonNull(as); as=tl(as))
+ vs = genvarTyvar(intOf(defType(snd(hd(as)))),vs);
+ return vs;
+}
+
+static Int local newVarsBind(v) /* make new assump for pattern var */
+Cell v; {
+ Int beta = newTyvars(1);
+ addVarAssump(v,mkInt(beta));
+#ifdef DEBUG_TYPES
+ printf("variable, assume ");
+ printExp(stdout,v);
+ printf(" :: _%d\n",beta);
+#endif
+ return beta;
+}
+
+static Void local newDefnBind(v,type) /* make new assump for defn var */
+Cell v; /* and set type if given (nonNull) */
+Type type; {
+ Int beta = newTyvars(1);
+ Cell ta = mkInt(beta);
+ instantiate(type);
+ if (nonNull(type) && isPolyType(type))
+ ta = pair(POLYREC,pair(ta,type));
+ hd(defnBounds) = cons(pair(v,ta), hd(defnBounds));
+#ifdef DEBUG_TYPES
+ printf("definition, assume ");
+ printExp(stdout,v);
+ printf(" :: _%d\n",beta);
+#endif
+ bindTv(beta,typeIs,typeOff); /* Bind beta to new type skeleton */
+}
+
+/* --------------------------------------------------------------------------
+ * Bound and skolemized type variables:
+ * ------------------------------------------------------------------------*/
+
+static List pendingBtyvs = NIL;
+
+static Void local enterPendingBtyvs() {
+ enterBtyvs();
+ pendingBtyvs = cons(NIL,pendingBtyvs);
+}
+
+static Void local leavePendingBtyvs() {
+ List pts = hd(pendingBtyvs);
+ pendingBtyvs = tl(pendingBtyvs);
+ for (; nonNull(pts); pts=tl(pts)) {
+ Int line = intOf(fst(hd(pts)));
+ List vs = snd(hd(pts));
+ Int i = 0;
+ clearMarks();
+ for (; nonNull(vs); vs=tl(vs)) {
+ Cell v = fst(hd(vs));
+ Cell t = copyTyvar(intOf(snd(hd(vs))));
+ if (!isOffset(t)) {
+ ERRMSG(line) "Type annotation uses variable " ETHEN ERREXPR(v);
+ ERRTEXT " where a more specific type " ETHEN ERRTYPE(t);
+ ERRTEXT " was inferred"
+ EEND;
+ }
+ else if (offsetOf(t)!=i) {
+ List us = snd(hd(pts));
+ Int j = offsetOf(t);
+ if (j>=i)
+ internal("leavePendingBtyvs");
+ for (; j>0; j--)
+ us = tl(us);
+ ERRMSG(line) "Type annotation uses distinct variables " ETHEN
+ ERREXPR(v); ERRTEXT " and " ETHEN ERREXPR(fst(hd(us)));
+ ERRTEXT " where a single variable was inferred"
+ EEND;
+ }
+ else
+ i++;
+ }
+ }
+ leaveBtyvs();
+}
+
+static Cell local patBtyvs(p) /* Strip bound type vars from pat */
+Cell p; {
+ if (whatIs(p)==BIGLAM) {
+ List bts = hd(btyvars) = fst(snd(p));
+ for (p=snd(snd(p)); nonNull(bts); bts=tl(bts)) {
+ Int beta = newTyvars(1);
+ tyvar(beta)->kind = snd(hd(bts));
+ snd(hd(bts)) = mkInt(beta);
+ }
+ }
+ skolVars = cons(NIL,skolVars);
+ return p;
+}
+
+static Void local doneBtyvs(l)
+Int l; {
+ if (nonNull(hd(btyvars))) { /* Save bound tyvars */
+ hd(pendingBtyvs) = cons(pair(mkInt(l),hd(btyvars)),hd(pendingBtyvs));
+ hd(btyvars) = NIL;
+ }
+
+ if (nonNull(hd(skolVars))) { /* Check that Skolem vars do not */
+ List vs; /* escape their scope */
+
+ clearMarks(); /* Look for occurences in the */
+ markType(typeIs,typeOff); /* result type */
+
+ for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
+ Int vn = intOf(fst(hd(vs)));
+ if (tyvar(vn)->offs == FIXED_TYVAR) {
+ Cell tv = copyTyvar(vn);
+ Type t = copyType(typeIs,typeOff);
+ ERRMSG(l) "Existentially quantified variable in result type"
+ ETHEN
+ ERRTEXT "\nvariable : " ETHEN ERRTYPE(tv);
+ ERRTEXT "\nfrom pattern : " ETHEN ERREXPR(snd(hd(vs)));
+ ERRTEXT "\nresult type : " ETHEN ERRTYPE(t);
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+
+ markBtyvs(); /* Now check assumptions */
+ mapProc(markAssumList,defnBounds);
+ mapProc(markAssumList,varsBounds);
+
+ for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
+ Int vn = intOf(fst(hd(vs)));
+ if (tyvar(vn)->offs == FIXED_TYVAR) {
+ ERRMSG(l) "Existentially quantified variable from pattern "
+ ETHEN ERREXPR(snd(hd(vs)));
+ ERRTEXT " appears in enclosing assumptions" /*so there!*/
+ EEND;
+ }
+ }
+ }
+ skolVars = tl(skolVars);
+}
+
+/* --------------------------------------------------------------------------
+ * Predicates:
+ * ------------------------------------------------------------------------*/
+
+#include "preds.c"
+
+/* --------------------------------------------------------------------------
+ * Type errors:
+ * ------------------------------------------------------------------------*/
+
+static Void local typeError(l,e,in,wh,t,o)
+Int l; /* line number near type error */
+String wh; /* place in which error occurs */
+Cell e; /* source of error */
+Cell in; /* context if any (NIL if not) */
+Type t; /* should be of type (t,o) */
+Int o; { /* type inferred is (typeIs,typeOff) */
+
+ clearMarks(); /* types printed here are monotypes */
+ /* use marking to give sensible names*/
+#ifdef DEBUG_KINDS
+{ List vs = genericVars;
+ for (; nonNull(vs); vs=tl(vs)) {
+ Int v = intOf(hd(vs));
+ printf("%c :: ", ('a'+tyvar(v)->offs));
+ printKind(stdout,tyvar(v)->kind);
+ putchar('\n');
+ }
+}
+#endif
+
+ reportTypeError(l,e,in,wh,copyType(typeIs,typeOff),copyType(t,o));
+}
+
+static Void local reportTypeError(l,e,in,wh,inft,expt)
+Int l; /* Error printing part of typeError*/
+Cell e, in;
+String wh;
+Type inft, expt; {
+ ERRMSG(l) "Type error in %s", wh ETHEN
+ if (nonNull(in)) {
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(in);
+ }
+ ERRTEXT "\n*** Term : " ETHEN ERREXPR(e);
+ ERRTEXT "\n*** Type : " ETHEN ERRTYPE(inft);
+ ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(expt);
+ if (unifyFails) {
+ ERRTEXT "\n*** Because : %s", unifyFails ETHEN
+ }
+ ERRTEXT "\n"
+ EEND;
+}
+
+#define shouldBe(l,e,in,where,t,o) if (!unify(typeIs,typeOff,t,o)) \
+ typeError(l,e,in,where,t,o);
+#define check(l,e,in,where,t,o) e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
+#define inferType(t,o) typeIs=t; typeOff=o
+
+static Void local cantEstablish(line,wh,e,t,ps)
+Int line; /* Complain when declared preds */
+String wh; /* are not sufficient to discharge */
+Cell e; /* or defer the inferred context. */
+Type t;
+List ps; {
+ ERRMSG(line) "Cannot justify constraints in %s", wh ETHEN
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
+ ERRTEXT "\n*** Type : " ETHEN ERRTYPE(t);
+ ERRTEXT "\n*** Given context : " ETHEN ERRCONTEXT(ps);
+ ERRTEXT "\n*** Constraints : " ETHEN ERRCONTEXT(copyPreds(preds));
+ ERRTEXT "\n"
+ EEND;
+}
+
+static Void local tooGeneral(l,e,dt,it) /* explicit type sig. too general */
+Int l;
+Cell e;
+Type dt, it; {
+ ERRMSG(l) "Inferred type is not general enough" ETHEN
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
+ ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(dt);
+ ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(it);
+ ERRTEXT "\n"
+ EEND;
+}
+
+/* --------------------------------------------------------------------------
+ * Typing of expressions:
+ * ------------------------------------------------------------------------*/
+
+#define EXPRESSION 0 /* type checking expression */
+#define NEW_PATTERN 1 /* pattern, introducing new vars */
+#define OLD_PATTERN 2 /* pattern, involving bound vars */
+static int tcMode = EXPRESSION;
+
+#ifdef DEBUG_TYPES
+static Cell local mytypeExpr Args((Int,Cell));
+static Cell local typeExpr(l,e)
+Int l;
+Cell e; {
+ static int number = 0;
+ Cell retv;
+ int mynumber = number++;
+ printf("%d) to check: ",mynumber);
+ printExp(stdout,e);
+ putchar('\n');
+ retv = mytypeExpr(l,e);
+ printf("%d) result: ",mynumber);
+ printType(stdout,debugType(typeIs,typeOff));
+ putchar('\n');
+ return retv;
+}
+static Cell local mytypeExpr(l,e) /* Determine type of expr/pattern */
+#else
+static Cell local typeExpr(l,e) /* Determine type of expr/pattern */
+#endif
+Int l;
+Cell e; {
+ static String cond = "conditional";
+ static String list = "list";
+ static String discr = "case discriminant";
+ static String aspat = "as (@) pattern";
+ static String typeSig = "type annotation";
+ static String lambda = "lambda expression";
+
+ switch (whatIs(e)) {
+
+ /* The following cases can occur in either pattern or expr. mode */
+
+ case AP :
+ case NAME :
+ case VAROPCELL :
+ case VARIDCELL : return typeAp(l,e);
+
+ case TUPLE : typeTuple(e);
+ break;
+
+#if OVERLOADED_CONSTANTS
+ case BIGCELL : { Int alpha = newTyvars(1);
+ inferType(aVar,alpha);
+ return ap2(nameFromInteger,
+ assumeEvid(predNum,alpha),
+ e);
+ }
+
+ case INTCELL : { Int alpha = newTyvars(1);
+ inferType(aVar,alpha);
+ return ap2(nameFromInt,
+ assumeEvid(predNum,alpha),
+ e);
+ }
+
+ case FLOATCELL : { Int alpha = newTyvars(1);
+ inferType(aVar,alpha);
+ return ap2(nameFromDouble,
+ assumeEvid(predFractional,alpha),
+ e);
+ }
+#else
+ case BIGCELL : inferType(typeBignum,0);
+ break;
+ case INTCELL : inferType(typeInt,0);
+ break;
+ case FLOATCELL : inferType(typeFloat,0);
+ break;
+#endif
+
+ case STRCELL : inferType(typeString,0);
+ break;
+
+ case CHARCELL : inferType(typeChar,0);
+ break;
+
+ case CONFLDS : typeConFlds(l,e);
+ break;
+
+ case ESIGN : snd(snd(e)) = localizeBtyvs(snd(snd(e)));
+ return typeExpected(l,typeSig,
+ fst(snd(e)),snd(snd(e)),
+ 0,0,FALSE);
+
+#if TREX
+ case EXT : { Int beta = newTyvars(2);
+ Cell pi = ap(e,aVar);
+ Type t = fn(mkOffset(0),
+ fn(ap(typeRec,mkOffset(1)),
+ ap(typeRec,ap2(e,mkOffset(0),
+ mkOffset(1)))));
+ tyvar(beta+1)->kind = ROW;
+ inferType(t,beta);
+ return ap(e,assumeEvid(pi,beta+1));
+ }
+#endif
+
+ /* The following cases can only occur in expr mode */
+
+ case UPDFLDS : typeUpdFlds(l,e);
+ break;
+
+ case COND : { Int beta = newTyvars(1);
+ check(l,fst3(snd(e)),e,cond,typeBool,0);
+ check(l,snd3(snd(e)),e,cond,aVar,beta);
+ check(l,thd3(snd(e)),e,cond,aVar,beta);
+ tyvarType(beta);
+ }
+ break;
+
+ case LETREC : enterBindings();
+ mapProc(typeBindings,fst(snd(e)));
+ snd(snd(e)) = typeExpr(l,snd(snd(e)));
+ leaveBindings();
+ break;
+
+ case FINLIST : { Int beta = newTyvars(1);
+ List xs;
+ for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
+ check(l,hd(xs),e,list,aVar,beta);
+ }
+ inferType(listof,beta);
+ }
+ break;
+
+ case DOCOMP : typeDo(l,e);
+ break;
+
+ case COMP : { Int beta = newTyvars(1);
+ typeComp(l,listof,snd(e),snd(snd(e)));
+ bindTv(beta,typeIs,typeOff);
+ inferType(listof,beta);
+ }
+ break;
+
+ case CASE : { Int beta = newTyvars(2); /* discr result */
+ check(l,fst(snd(e)),NIL,discr,aVar,beta);
+ map2Proc(typeCase,l,beta,snd(snd(e)));
+ tyvarType(beta+1);
+ }
+ break;
+
+ case LAMBDA : { Int beta = newTyvars(1);
+ enterPendingBtyvs();
+ typeAlt(lambda,e,snd(e),aVar,beta,1);
+ leavePendingBtyvs();
+ tyvarType(beta);
+ }
+ break;
+
+#if TREX
+ case RECSEL : { Int beta = newTyvars(2);
+ Cell pi = ap(snd(e),aVar);
+ Type t = fn(ap(typeRec,
+ ap2(snd(e),mkOffset(0),
+ mkOffset(1))),aVar);
+ tyvar(beta+1)->kind = ROW;
+ inferType(t,beta);
+ return ap(e,assumeEvid(pi,beta+1));
+ }
+#endif
+
+ /* The remaining cases can only occur in pattern mode: */
+
+ case WILDCARD : inferType(aVar,newTyvars(1));
+ break;
+
+ case ASPAT : { Int beta = newTyvars(1);
+ snd(snd(e)) = typeExpr(l,snd(snd(e)));
+ bindTv(beta,typeIs,typeOff);
+ check(l,fst(snd(e)),e,aspat,aVar,beta);
+ tyvarType(beta);
+ }
+ break;
+
+ case LAZYPAT : snd(e) = typeExpr(l,snd(e));
+ break;
+
+#if NPLUSK
+ case ADDPAT : { Int alpha = newTyvars(1);
+ inferType(typeVarToVar,alpha);
+ return ap(e,assumeEvid(predIntegral,alpha));
+ }
+#endif
+
+ default : internal("typeExpr");
+ }
+
+ return e;
+}
+
+/* --------------------------------------------------------------------------
+ * Typing rules for particular special forms:
+ * ------------------------------------------------------------------------*/
+
+static Cell local typeAp(l,e) /* Type check application, which */
+Int l; /* may be headed with a variable */
+Cell e; { /* requires polymorphism, qualified*/
+ static String app = "application"; /* types, and possible rank2 args. */
+ Cell h = getHead(e);
+ Int n = argCount;
+ Cell p = NIL;
+ Cell a = e;
+ Int i;
+
+ switch (whatIs(h)) {
+ case NAME : typeIs = name(h).type;
+ break;
+
+ case VAROPCELL :
+ case VARIDCELL : if (tcMode==NEW_PATTERN) {
+ inferType(aVar,newVarsBind(e));
+ }
+ else {
+ Cell v = findAssum(textOf(h));
+ if (nonNull(v)) {
+ h = v;
+ typeIs = (tcMode==OLD_PATTERN)
+ ? defType(typeIs)
+ : useType(typeIs);
+ }
+ else {
+ h = findName(textOf(h));
+ if (isNull(h))
+ internal("typeAp0");
+ typeIs = name(h).type;
+ }
+ }
+ break;
+
+ default : h = typeExpr(l,h);
+ break;
+ }
+
+ if (isNull(typeIs))
+ internal("typeAp1");
+
+ instantiate(typeIs); /* Deal with polymorphism ... */
+ if (nonNull(predsAre)) { /* ... and with qualified types. */
+ Cell evs = NIL;
+ for (; nonNull(predsAre); predsAre=tl(predsAre))
+ evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
+ if (!isName(h) || !isCfun(h))
+ h = applyToArgs(h,rev(evs));
+ }
+
+ if (whatIs(typeIs)==EXIST) { /* Deal with existential arguments */
+ Int n = intOf(fst(snd(typeIs)));
+ typeIs = snd(snd(typeIs));
+ if (!isCfun(h) || n>typeFree)
+ internal("typeAp2");
+ else if (tcMode!=EXPRESSION) {
+ Int alpha = typeOff + typeFree;
+ for (; n>0; n--) {
+ bindTv(alpha-n,SKOLEM,0);
+ hd(skolVars) = cons(pair(mkInt(alpha-n),e),hd(skolVars));
+ }
+ }
+ }
+
+ if (whatIs(typeIs)==RANK2) { /* Deal with rank 2 arguments */
+ Int alpha = typeOff;
+ Int m = typeFree;
+ Int nr2 = intOf(fst(snd(typeIs)));
+ Type body = snd(snd(typeIs));
+ List as = e;
+ Bool added = FALSE;
+
+ if (n<nr2) { /* Must have enough arguments */
+ ERRMSG(l) "Use of " ETHEN ERREXPR(h);
+ if (n>1) {
+ ERRTEXT " in " ETHEN ERREXPR(e);
+ }
+ ERRTEXT " requires at least %d argument%s\n",
+ nr2, (nr2==1 ? "" : "s")
+ EEND;
+ }
+
+ for (i=nr2; i<n; ++i) /* Find rank two arguments */
+ as = fun(as);
+
+ for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
+ Type expect = dropRank1(arg(fun(body)),alpha,m);
+ if (isPolyType(expect)) {
+ if (tcMode==EXPRESSION) /* poly/qual type in expr */
+ hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
+ else if (hd(as)!=WILDCARD) { /* Pattern binding/match */
+ if (!isVar(hd(as))) {
+ ERRMSG(l) "Argument " ETHEN ERREXPR(arg(as));
+ ERRTEXT " in pattern " ETHEN ERREXPR(e);
+ ERRTEXT " where a variable is required\n"
+ EEND;
+ }
+ if (tcMode==NEW_PATTERN) { /* Pattern match */
+ if (m>0 && !added) {
+ for (i=0; i<m; i++)
+ addVarAssump(dummyVar,mkInt(alpha+i));
+ added = TRUE;
+ }
+ addVarAssump(hd(as),expect);
+ }
+ else { /* Pattern binding */
+ Text t = textOf(hd(as));
+ Cell a = findInAssumList(t,hd(defnBounds));
+ if (isNull(a))
+ internal("typeAp3");
+ instantiate(expect);
+ if (nonNull(predsAre)) {
+ ERRMSG(l) "Cannot use pattern binding for " ETHEN
+ ERREXPR(hd(as));
+ ERRTEXT " as a component with a qualified type\n"
+ EEND;
+ }
+ shouldBe(l,hd(as),e,app,aVar,intOf(defType(snd(a))));
+ }
+ }
+ }
+ else { /* Not a poly/qual type */
+ check(l,hd(as),e,app,expect,alpha);
+ }
+ h = ap(h,hd(as)); /* Save checked argument */
+ }
+ inferType(body,alpha);
+ n -= nr2;
+ }
+
+ if (n>0) { /* Deal with remaining args */
+ Int beta = funcType(n); /* check h::t1->t2->...->tn->rn+1 */
+ shouldBe(l,h,e,app,aVar,beta);
+ for (i=n; i>0; --i) { /* check e_i::t_i for each i */
+ check(l,arg(a),e,app,aVar,beta+2*i-1);
+ p = a;
+ a = fun(a);
+ }
+ tyvarType(beta+2*n); /* Inferred type is r_n+1 */
+ }
+
+ if (isNull(p)) /* Replace head with translation */
+ e = h;
+ else
+ fun(p) = h;
+
+ return e;
+}
+
+static Cell local typeExpected(l,wh,e,reqd,alpha,n,addEvid)
+Int l; /* Type check expression e in wh */
+String wh; /* at line l, expecting type reqd, */
+Cell e; /* and treating vars alpha through */
+Type reqd; /* (alpha+n-1) as fixed. */
+Int alpha;
+Int n;
+Bool addEvid; { /* TRUE => add \ev -> ... */
+ List savePreds = preds;
+ Type t;
+ Int o;
+ Int m;
+ List ps;
+ Int i;
+
+ instantiate(reqd);
+ t = typeIs;
+ o = typeOff;
+ m = typeFree;
+ ps = makePredAss(predsAre,o);
+
+ preds = NIL;
+ check(l,e,NIL,wh,t,o);
+
+ clearMarks();
+ mapProc(markAssumList,defnBounds);
+ mapProc(markAssumList,varsBounds);
+ mapProc(markPred,savePreds);
+ markBtyvs();
+
+ for (i=0; i<n; i++)
+ markTyvar(alpha+i);
+
+ savePreds = elimPredsUsing(ps,savePreds);
+ if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
+ savePreds = elimPredsUsing(ps,savePreds);
+ if (nonNull(preds)) {
+ Type ty = copyType(t,o);
+ List qs = copyPreds(ps);
+ cantEstablish(l,wh,e,ty,qs);
+ }
+
+ resetGenerics();
+ for (i=0; i<m; i++)
+ if (copyTyvar(o+i)!=mkOffset(i)) {
+ List qs = copyPreds(ps);
+ Type it = copyType(t,o);
+ tooGeneral(l,e,reqd,generalize(qs,it));
+ }
+
+ if (addEvid) {
+ e = qualifyExpr(l,ps,e);
+ preds = savePreds;
+ }
+ else
+ preds = revOnto(ps,savePreds);
+
+ inferType(t,o);
+ return e;
+}
+
+static Void local typeAlt(wh,e,a,t,o,m) /* Type check abstraction (Alt) */
+String wh; /* a = ( [p1, ..., pn], rhs ) */
+Cell e;
+Cell a;
+Type t;
+Int o;
+Int m; {
+ Type origt = t;
+ List ps = fst(a) = patBtyvs(fst(a));
+ Int n = length(ps);
+ Int l = rhsLine(snd(a));
+ Int nr2 = 0;
+ List as = NIL;
+ Bool added = FALSE;
+
+ saveVarsAss();
+ if (whatIs(t)==RANK2) {
+ if (n<(nr2=intOf(fst(snd(t))))) {
+ ERRMSG(l) "Definition requires at least %d parameters on lhs",
+ intOf(fst(snd(t)))
+ EEND;
+ }
+ t = snd(snd(t));
+ }
+
+ while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
+ Type ta = arg(fun(t));
+ if (isPolyType(ta)) {
+ if (hd(ps)!=WILDCARD) {
+ if (!isVar(hd(ps))) {
+ ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
+ ERRTEXT " used where a variable or wildcard is required\n"
+ EEND;
+ }
+ if (m>0 && !added) {
+ Int i = 0;
+ for (; i<m; i++)
+ addVarAssump(dummyVar,mkInt(o+i));
+ added = TRUE;
+ }
+ addVarAssump(hd(ps),ta);
+ }
+ }
+ else {
+ hd(ps) = typeFreshPat(l,hd(ps));
+ shouldBe(l,hd(ps),NIL,wh,ta,o);
+ }
+ t = arg(t);
+ ps = tl(ps);
+ as = fn(ta,as);
+ n--;
+ }
+
+ if (n==0)
+ snd(a) = typeRhs(snd(a));
+ else {
+ Int beta = funcType(n);
+ Int i = 0;
+ for (; i<n; ++i) {
+ hd(ps) = typeFreshPat(l,hd(ps));
+ bindTv(beta+2*i+1,typeIs,typeOff);
+ ps = tl(ps);
+ }
+ snd(a) = typeRhs(snd(a));
+ bindTv(beta+2*n,typeIs,typeOff);
+ tyvarType(beta);
+ }
+
+ if (!unify(typeIs,typeOff,t,o)) {
+ Type req, got;
+ clearMarks();
+ req = liftRank2(origt,o,m);
+ liftRank2Args(as,o,m);
+ got = ap(RANK2,pair(mkInt(nr2),revOnto(as,copyType(typeIs,typeOff))));
+ reportTypeError(l,e,NIL,wh,got,req);
+ }
+
+ restoreVarsAss();
+ doneBtyvs(l);
+}
+
+static Int local funcType(n) /*return skeleton for function type*/
+Int n; { /*with n arguments, taking the form*/
+ Int beta = newTyvars(2*n+1); /* r1 t1 r2 t2 ... rn tn rn+1 */
+ Int i; /* with r_i := t_i -> r_i+1 */
+ for (i=0; i<n; ++i)
+ bindTv(beta+2*i,arrow,beta+2*i+1);
+ return beta;
+}
+
+static Void local typeCase(l,beta,c) /* type check case: pat -> rhs */
+Int l; /* (case given by c == (pat,rhs)) */
+Int beta; /* need: pat :: (var,beta) */
+Cell c; { /* rhs :: (var,beta+1) */
+ static String casePat = "case pattern";
+ static String caseExpr = "case expression";
+
+ saveVarsAss();
+
+ fst(c) = typeFreshPat(l,patBtyvs(fst(c)));
+ shouldBe(l,fst(c),NIL,casePat,aVar,beta);
+ snd(c) = typeRhs(snd(c));
+ shouldBe(l,rhsExpr(snd(c)),NIL,caseExpr,aVar,beta+1);
+
+ restoreVarsAss();
+ doneBtyvs(l);
+}
+
+static Void local typeComp(l,m,e,qs) /* type check comprehension */
+Int l;
+Type m; /* monad (mkOffset(0)) */
+Cell e;
+List qs; {
+ static String boolQual = "boolean qualifier";
+ static String genQual = "generator";
+
+ if (isNull(qs)) /* no qualifiers left */
+ fst(e) = typeExpr(l,fst(e));
+ else {
+ Cell q = hd(qs);
+ List qs1 = tl(qs);
+ switch (whatIs(q)) {
+ case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
+ typeComp(l,m,e,qs1);
+ break;
+
+ case QWHERE : enterBindings();
+ mapProc(typeBindings,snd(q));
+ typeComp(l,m,e,qs1);
+ leaveBindings();
+ break;
+
+ case FROMQUAL : { Int beta = newTyvars(1);
+ saveVarsAss();
+ check(l,snd(snd(q)),NIL,genQual,m,beta);
+ fst(snd(q))
+ = typeFreshPat(l,patBtyvs(fst(snd(q))));
+ shouldBe(l,fst(snd(q)),NIL,genQual,aVar,beta);
+ typeComp(l,m,e,qs1);
+ restoreVarsAss();
+ doneBtyvs(l);
+ }
+ break;
+
+ case DOQUAL : check(l,snd(q),NIL,genQual,m,newTyvars(1));
+ typeComp(l,m,e,qs1);
+ break;
+ }
+ }
+}
+
+static Void local typeDo(l,e) /* type check do-notation */
+Int l;
+Cell e; {
+ static String finGen = "final generator";
+ Int alpha = newTyvars(1);
+ Int beta = newTyvars(1);
+ Cell mon = ap(mkInt(beta),aVar);
+ Cell m = assumeEvid(predMonad,beta);
+ tyvar(beta)->kind = starToStar;
+
+ typeComp(l,mon,snd(e),snd(snd(e)));
+ shouldBe(l,fst(snd(e)),NIL,finGen,mon,alpha);
+ snd(e) = pair(pair(m,compZero(snd(snd(e)),beta)),snd(e));
+}
+
+static Cell local compZero(qs,beta) /* return evidence for Monad0 beta */
+List qs; /* if needed for qualifiers qs */
+Int beta; {
+ for (; nonNull(qs); qs=tl(qs))
+ switch (whatIs(hd(qs))) {
+ case FROMQUAL : if (failFree(fst(snd(hd(qs)))))
+ break;
+ /* intentional fall-thru */
+ case BOOLQUAL : return assumeEvid(predMonad0,beta);
+ }
+ return NIL;
+}
+
+static Void local typeConFlds(l,e) /* Type check a construction */
+Int l;
+Cell e; {
+ static String conExpr = "value construction";
+ Name c = fst(snd(e));
+ List fs = snd(snd(e));
+ Type tc;
+ Int to;
+ Int tf;
+ Int i;
+
+ instantiate(name(c).type);
+ for (; nonNull(predsAre); predsAre=tl(predsAre))
+ assumeEvid(hd(predsAre),typeOff);
+ if (whatIs(typeIs)==RANK2)
+ typeIs = snd(snd(typeIs));
+ tc = typeIs;
+ to = typeOff;
+ tf = typeFree;
+
+ for (; nonNull(fs); fs=tl(fs)) {
+ Type t = tc;
+ for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
+ ;
+ t = dropRank1(arg(fun(t)),to,tf);
+ if (isPolyType(t))
+ snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
+ else {
+ check(l,snd(hd(fs)),e,conExpr,t,to);
+ }
+ }
+ for (i=name(c).arity; i>0; i--)
+ tc = arg(tc);
+ inferType(tc,to);
+}
+
+static Void local typeUpdFlds(line,e) /* Type check an update */
+Int line; /* (Written in what might seem a */
+Cell e; { /* bizarre manner for the benefit */
+ static String update = "update"; /* of as yet unreleased extensions)*/
+ List cs = snd3(snd(e)); /* List of constructors */
+ List fs = thd3(snd(e)); /* List of field specifications */
+ List ts = NIL; /* List of types for fields */
+ Int n = length(fs);
+ Int alpha = newTyvars(2+n);
+ Int i;
+ List fs1;
+
+ /* Calculate type and translation for each expr in the field list */
+ for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
+ snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
+ bindTv(i,typeIs,typeOff);
+ }
+
+ clearMarks();
+ mapProc(markAssumList,defnBounds);
+ mapProc(markAssumList,varsBounds);
+ mapProc(markPred,preds);
+ markBtyvs();
+
+ for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
+ resetGenerics();
+ ts = cons(generalize(NIL,copyTyvar(i)),ts);
+ }
+ ts = rev(ts);
+
+ /* Type check expression to be updated */
+ fst3(snd(e)) = typeExpr(line,fst3(snd(e)));
+ bindTv(alpha,typeIs,typeOff);
+
+ for (; nonNull(cs); cs=tl(cs)) { /* Loop through constrs */
+ Name c = hd(cs);
+ List ta = replicate(name(c).arity,NIL);
+ Type td, tr;
+ Int od, or;
+
+ tcMode = NEW_PATTERN; /* Domain type */
+ instantiate(name(c).type);
+ tcMode = EXPRESSION;
+ td = typeIs;
+ od = typeOff;
+ for (; nonNull(predsAre); predsAre=tl(predsAre))
+ assumeEvid(hd(predsAre),typeOff);
+
+ if (whatIs(typeIs)==RANK2) {
+ ERRMSG(line) "Sorry, record update syntax cannot currently be used for datatypes with polymorphic components"
+ EEND;
+ }
+
+ instantiate(name(c).type); /* Range type */
+ tr = typeIs;
+ or = typeOff;
+ for (; nonNull(predsAre); predsAre=tl(predsAre))
+ assumeEvid(hd(predsAre),typeOff);
+
+ for (fs1=fs, i=1; nonNull(fs1); fs1=tl(fs1), i++) {
+ Int n = sfunPos(fst(hd(fs1)),c);
+ Cell ta1 = ta;
+ for (; n>1; n--)
+ ta1 = tl(ta1);
+ hd(ta1) = mkInt(i);
+ }
+
+ for (; nonNull(ta); ta=tl(ta)) { /* For each cfun arg */
+ if (nonNull(hd(ta))) { /* Field to updated? */
+ Int n = intOf(hd(ta));
+ Cell f = fs;
+ Cell t = ts;
+ for (; n-- > 1; f=tl(f), t=tl(t))
+ ;
+ f = hd(f);
+ t = hd(t);
+ instantiate(t);
+ shouldBe(line,snd(f),e,update,arg(fun(tr)),or);
+ } /* Unmentioned component */
+ else if (!unify(arg(fun(td)),od,arg(fun(tr)),or))
+ internal("typeUpdFlds");
+
+ tr = arg(tr);
+ td = arg(td);
+ }
+
+ inferType(td,od); /* Check domain type */
+ shouldBe(line,fst3(snd(e)),e,update,aVar,alpha);
+ inferType(tr,or); /* Check range type */
+ shouldBe(line,e,NIL,update,aVar,alpha+1);
+ }
+ /* (typeIs,typeOff) still carry the result type when we exit the loop */
+}
+
+static Cell local typeFreshPat(l,p) /* find type of pattern, assigning */
+Int l; /* fresh type variables to each var */
+Cell p; { /* bound in the pattern */
+ tcMode = NEW_PATTERN;
+ p = typeExpr(l,p);
+ tcMode = EXPRESSION;
+ return p;
+}
+
+/* --------------------------------------------------------------------------
+ * Type check group of bindings:
+ * ------------------------------------------------------------------------*/
+
+static Void local typeBindings(bs) /* type check a binding group */
+List bs; {
+ Bool usesPatBindings = FALSE; /* TRUE => pattern binding in bs */
+ Bool usesUntypedVar = FALSE; /* TRUE => var bind w/o type decl */
+ List bs1;
+
+ /* The following loop is used to determine whether the monomorphism */
+ /* restriction should be applied. It could be written marginally more */
+ /* efficiently by using breaks, but clarity is more important here ... */
+
+ for (bs1=bs; nonNull(bs1); bs1=tl(bs1)) { /* Analyse binding group */
+ Cell b = hd(bs1);
+ if (!isVar(fst(b)))
+ usesPatBindings = TRUE;
+ else if (isNull(fst(hd(snd(snd(b))))) /* no arguments */
+ && whatIs(fst(snd(b)))==IMPDEPS) /* implicitly typed*/
+ usesUntypedVar = TRUE;
+ }
+
+ if (usesPatBindings || usesUntypedVar)
+ monorestrict(bs);
+ else
+ unrestricted(bs);
+
+ mapProc(removeTypeSigs,bs); /* Remove binding type info */
+ hd(varsBounds) = revOnto(hd(defnBounds), /* transfer completed assmps*/
+ hd(varsBounds)); /* out of defnBounds */
+ hd(defnBounds) = NIL;
+ hd(depends) = NIL;
+}
+
+static Void local removeTypeSigs(b) /* Remove type info from a binding */
+Cell b; {
+ snd(b) = snd(snd(b));
+}
+
+/* --------------------------------------------------------------------------
+ * Type check a restricted binding group:
+ * ------------------------------------------------------------------------*/
+
+static Void local monorestrict(bs) /* Type restricted binding group */
+List bs; {
+ List savePreds = preds;
+ Int line = isVar(fst(hd(bs))) ? rhsLine(snd(hd(snd(snd(hd(bs))))))
+ : rhsLine(snd(snd(snd(hd(bs)))));
+ hd(defnBounds) = NIL;
+ hd(depends) = NODEPENDS; /* No need for dependents here */
+
+ preds = NIL; /* Type check the bindings */
+ mapProc(restrictedBindAss,bs);
+ mapProc(typeBind,bs);
+ normPreds(line);
+ elimTauts();
+ preds = revOnto(preds,savePreds);
+
+ clearMarks(); /* Mark fixed variables */
+ mapProc(markAssumList,tl(defnBounds));
+ mapProc(markAssumList,tl(varsBounds));
+ mapProc(markPred,preds);
+ markBtyvs();
+
+ if (isNull(tl(defnBounds))) { /* Top-level may need defaulting */
+ normPreds(line);
+ if (nonNull(preds) && resolveDefs(genvarAnyAss(hd(defnBounds))))
+ elimTauts();
+
+ clearMarks();
+ reducePreds();
+ if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
+ elimTauts();
+
+ if (nonNull(preds)) { /* Look for unresolved overloading */
+ Cell v = isVar(fst(hd(bs))) ? fst(hd(bs)) : hd(fst(hd(bs)));
+ Cell ass = findInAssumList(textOf(v),hd(varsBounds));
+ preds = scSimplify(preds);
+
+ ERRMSG(line) "Unresolved top-level overloading" ETHEN
+ ERRTEXT "\n*** Binding : %s", textToStr(textOf(v))
+ ETHEN
+ if (nonNull(ass)) {
+ ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(snd(ass));
+ }
+ ERRTEXT "\n*** Outstanding context : " ETHEN
+ ERRCONTEXT(copyPreds(preds));
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+
+ map1Proc(genBind,NIL,bs); /* Generalize types of def'd vars */
+}
+
+static Void local restrictedBindAss(b) /* Make assums for vars in binding */
+Cell b; { /* gp with restricted overloading */
+
+ if (isVar(fst(b))) { /* function-binding? */
+ Cell t = fst(snd(b));
+ if (whatIs(t)==IMPDEPS) /* Discard implicitly typed deps */
+ fst(snd(b)) = t = NIL; /* in a restricted binding group. */
+ fst(snd(b)) = localizeBtyvs(t);
+ restrictedAss(rhsLine(snd(hd(snd(snd(b))))), fst(b), t);
+ }
+ else { /* pattern-binding? */
+ List vs = fst(b);
+ List ts = fst(snd(b));
+ Int line = rhsLine(snd(snd(snd(b))));
+
+ for (; nonNull(vs); vs=tl(vs))
+ if (nonNull(ts)) {
+ restrictedAss(line,hd(vs),hd(ts)=localizeBtyvs(hd(ts)));
+ ts = tl(ts);
+ }
+ else
+ restrictedAss(line,hd(vs),NIL);
+ }
+}
+
+static Void local restrictedAss(l,v,t) /* Assume that type of binding var v*/
+Int l; /* is t (if nonNull) in restricted */
+Cell v; /* binding group */
+Type t; {
+ newDefnBind(v,t);
+ if (nonNull(predsAre)) {
+ ERRMSG(l) "Explicit overloaded type for \"%s\"",textToStr(textOf(v))
+ ETHEN
+ ERRTEXT " not permitted in restricted binding"
+ EEND;
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Unrestricted binding group:
+ * ------------------------------------------------------------------------*/
+
+static Void local unrestricted(bs) /* Type unrestricted binding group */
+List bs; {
+ List savePreds = preds;
+ List imps = NIL; /* Implicitly typed bindings */
+ List exps = NIL; /* Explicitly typed bindings */
+ List bs1;
+
+ /* ----------------------------------------------------------------------
+ * STEP 1: Separate implicitly typed bindings from explicitly typed
+ * bindings and do a dependency analyis, where f depends on g iff f
+ * is implicitly typed and involves a call to g.
+ * --------------------------------------------------------------------*/
+
+ for (; nonNull(bs); bs=tl(bs)) {
+ Cell b = hd(bs);
+ if (whatIs(fst(snd(b)))==IMPDEPS)
+ imps = cons(b,imps); /* N.B. New lists are built to */
+ else /* avoid breaking the original */
+ exps = cons(b,exps); /* list structure for bs. */
+ }
+
+ for (bs=imps; nonNull(bs); bs=tl(bs)) {
+ Cell b = hd(bs); /* Restrict implicitly typed dep */
+ List ds = snd(fst(snd(b))); /* lists to bindings in imps */
+ List cs = NIL;
+ while (nonNull(ds)) {
+ bs1 = tl(ds);
+ if (cellIsMember(hd(ds),imps)) {
+ tl(ds) = cs;
+ cs = ds;
+ }
+ ds = bs1;
+ }
+ fst(snd(b)) = cs;
+ }
+ imps = itbscc(imps); /* Dependency analysis on imps */
+ for (bs=imps; nonNull(bs); bs=tl(bs))
+ for (bs1=hd(bs); nonNull(bs1); bs1=tl(bs1))
+ fst(snd(hd(bs1))) = NIL; /* reset imps type fields */
+
+#ifdef DEBUG_DEPENDS
+ printf("Binding group:");
+ for (bs1=imps; nonNull(bs1); bs1=tl(bs1)) {
+ printf(" [imp:");
+ for (bs=hd(bs1); nonNull(bs); bs=tl(bs))
+ printf(" %s",textToStr(textOf(fst(hd(bs)))));
+ printf("]");
+ }
+ if (nonNull(exps)) {
+ printf(" [exp:");
+ for (bs=exps; nonNull(bs); bs=tl(bs))
+ printf(" %s",textToStr(textOf(fst(hd(bs)))));
+ printf("]");
+ }
+ printf("\n");
+#endif
+
+ /* ----------------------------------------------------------------------
+ * STEP 2: Add type assumptions about any explicitly typed variable.
+ * --------------------------------------------------------------------*/
+
+ for (bs=exps; nonNull(bs); bs=tl(bs)) {
+ fst(snd(hd(bs))) = localizeBtyvs(fst(snd(hd(bs))));
+ hd(varsBounds) = cons(pair(fst(hd(bs)),fst(snd(hd(bs)))),
+ hd(varsBounds));
+ }
+
+ /* ----------------------------------------------------------------------
+ * STEP 3: Calculate types for each group of implicitly typed bindings.
+ * --------------------------------------------------------------------*/
+
+ for (; nonNull(imps); imps=tl(imps)) {
+ Cell b = hd(hd(imps));
+ Int line = isVar(fst(b)) ? rhsLine(snd(hd(snd(snd(b)))))
+ : rhsLine(snd(snd(snd(b))));
+ hd(defnBounds) = NIL;
+ hd(depends) = NIL;
+ for (bs1=hd(imps); nonNull(bs1); bs1=tl(bs1))
+ newDefnBind(fst(hd(bs1)),NIL);
+
+ preds = NIL;
+ mapProc(typeBind,hd(imps));
+
+ clearMarks();
+ mapProc(markAssumList,tl(defnBounds));
+ mapProc(markAssumList,tl(varsBounds));
+ mapProc(markPred,savePreds);
+ markBtyvs();
+
+ normPreds(line);
+ savePreds = elimOuterPreds(savePreds);
+ if (nonNull(preds) && resolveDefs(genvarAllAss(hd(defnBounds))))
+ savePreds = elimOuterPreds(savePreds);
+
+ map1Proc(genBind,preds,hd(imps));
+ if (nonNull(preds)) {
+ map1Proc(addEvidParams,preds,hd(depends));
+ map1Proc(qualifyBinding,preds,hd(imps));
+ }
+
+ hd(varsBounds) = revOnto(hd(defnBounds),hd(varsBounds));
+ }
+
+ /* ----------------------------------------------------------------------
+ * STEP 4: Now infer a type for each explicitly typed variable and
+ * check for compatibility with the declared type.
+ * --------------------------------------------------------------------*/
+
+ for (; nonNull(exps); exps=tl(exps)) {
+ static String extbind = "explicitly typed binding";
+ Cell b = hd(exps);
+ List alts = snd(snd(b));
+ Int line = rhsLine(snd(hd(alts)));
+ Type t;
+ Int o;
+ Int m;
+ List ps;
+
+ hd(defnBounds) = NIL;
+ hd(depends) = NODEPENDS;
+ preds = NIL;
+
+ instantiate(fst(snd(b)));
+ o = typeOff;
+ m = typeFree;
+ t = dropRank2(typeIs,o,m);
+ ps = makePredAss(predsAre,o);
+
+ enterPendingBtyvs();
+ for (; nonNull(alts); alts=tl(alts))
+ typeAlt(extbind,fst(b),hd(alts),t,o,m);
+ leavePendingBtyvs();
+
+ if (nonNull(ps)) /* Add dict params, if necessary */
+ qualifyBinding(ps,b);
+
+ clearMarks();
+ mapProc(markAssumList,tl(defnBounds));
+ mapProc(markAssumList,tl(varsBounds));
+ mapProc(markPred,savePreds);
+ markBtyvs();
+
+ savePreds = elimPredsUsing(ps,savePreds);
+ if (nonNull(preds)) {
+ List vs = NIL;
+ Int i = 0;
+ for (; i<m; ++i)
+ vs = cons(mkInt(o+i),vs);
+ if (resolveDefs(vs))
+ savePreds = elimPredsUsing(ps,savePreds);
+ if (nonNull(preds)) {
+ clearMarks();
+ reducePreds();
+ if (nonNull(preds) && resolveDefs(vs))
+ savePreds = elimPredsUsing(ps,savePreds);
+ }
+ }
+
+ resetGenerics(); /* Make sure we're general enough */
+ ps = copyPreds(ps);
+ t = generalize(ps,liftRank2(t,o,m));
+ if (!sameSchemes(t,fst(snd(b))))
+ tooGeneral(line,fst(b),fst(snd(b)),t);
+
+ if (nonNull(preds)) /* Check context was strong enough */
+ cantEstablish(line,extbind,fst(b),t,ps);
+ }
+
+ preds = savePreds; /* Restore predicates */
+ hd(defnBounds) = NIL;
+}
+
+#define SCC itbscc /* scc for implicitly typed binds */
+#define LOWLINK itblowlink
+#define DEPENDS(t) fst(snd(t))
+#define SETDEPENDS(c,v) fst(snd(c))=v
+#include "scc.c"
+#undef SETDEPENDS
+#undef DEPENDS
+#undef LOWLINK
+#undef SCC
+
+static Void local addEvidParams(qs,v) /* overwrite VARID/OPCELL v with */
+List qs; /* application of variable to evid. */
+Cell v; { /* parameters given by qs */
+ if (nonNull(qs)) {
+ Cell nv;
+
+ if (!isVar(v))
+ internal("addEvidParams");
+
+ for (nv=mkVar(textOf(v)); nonNull(tl(qs)); qs=tl(qs))
+ nv = ap(nv,thd3(hd(qs)));
+ fst(v) = nv;
+ snd(v) = thd3(hd(qs));
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Type check bodies of class and instance declarations:
+ * ------------------------------------------------------------------------*/
+
+static Void local typeClassDefn(c) /* Type check implementations of */
+Class c; { /* defaults for class c */
+
+ /* ----------------------------------------------------------------------
+ * Generate code for default dictionary builder function:
+ *
+ * class.C sc1 ... scn d = let v1 ... = ...
+ * vm ... = ...
+ * in Make.C sc1 ... scn v1 ... vm
+ *
+ * where sci are superclass dictionary parameters, vj are implementations
+ * for member functions, either taken from defaults, or using "error" to
+ * produce a suitable error message. (Additional line number values must
+ * be added at appropriate places but, for clarity, these are not shown
+ * above.)
+ * --------------------------------------------------------------------*/
+
+ Int beta = newKindedVars(cclass(c).kinds);
+ List params = makePredAss(cclass(c).supers,beta);
+ Cell body = cclass(c).dcon;
+ Cell pat = body;
+ List mems = cclass(c).members;
+ List defs = cclass(c).defaults;
+ List dsels = cclass(c).dsels;
+ Cell d = inventDictVar();
+ List args = NIL;
+ List locs = NIL;
+ Cell l = mkInt(cclass(c).line);
+ List ps;
+
+ for (ps=params; nonNull(ps); ps=tl(ps)) {
+ Cell v = thd3(hd(ps));
+ body = ap(body,v);
+ pat = ap(pat,inventVar());
+ args = cons(v,args);
+ }
+ args = revOnto(args,singleton(d));
+ params = appendOnto(params,
+ singleton(triple(cclass(c).head,mkInt(beta),d)));
+
+ for (; nonNull(mems); mems=tl(mems)) {
+ Cell v = inventVar(); /* Pick a name for component */
+ Cell imp = NIL;
+
+ if (nonNull(defs)) { /* Look for default implementation */
+ imp = hd(defs);
+ defs = tl(defs);
+ }
+
+ if (isNull(imp)) { /* Generate undefined member msg */
+ static String header = "Undefined member: ";
+ String name = textToStr(name(hd(mems)).text);
+ char msg[FILENAME_MAX+1];
+ Int i;
+ Int j;
+
+ for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
+ msg[i] = header[i];
+ for (j=0; (i+j)<FILENAME_MAX && name[j]!='\0'; j++)
+ msg[i+j] = name[j];
+ msg[i+j] = '\0';
+
+ imp = pair(v,singleton(pair(NIL,ap(l,ap(nameError,
+ mkStr(findText(msg)))))));
+ }
+ else { /* Use default implementation */
+ fst(imp) = v;
+ typeMember("default member binding",
+ hd(mems),
+ snd(imp),
+ params,
+ cclass(c).head,
+ beta);
+ }
+
+ locs = cons(imp,locs);
+ body = ap(body,v);
+ pat = ap(pat,v);
+ }
+ body = ap(l,body);
+ if (nonNull(locs))
+ body = ap(LETREC,pair(singleton(locs),body));
+ name(cclass(c).dbuild).defn
+ = singleton(pair(args,body));
+ genDefns = cons(cclass(c).dbuild,genDefns);
+ cclass(c).defaults = NIL;
+
+ /* ----------------------------------------------------------------------
+ * Generate code for superclass and member function selectors:
+ * --------------------------------------------------------------------*/
+
+ args = getArgs(pat);
+ pat = singleton(pat);
+ for (; nonNull(dsels); dsels=tl(dsels)) {
+ name(hd(dsels)).defn = singleton(pair(pat,ap(l,hd(args))));
+ args = tl(args);
+ genDefns = cons(hd(dsels),genDefns);
+ }
+ for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
+ name(hd(mems)).defn = singleton(pair(pat,ap(mkInt(name(hd(mems)).line),
+ hd(args))));
+ args = tl(args);
+ genDefns = cons(hd(mems),genDefns);
+ }
+}
+
+static Void local typeInstDefn(in) /* Type check implementations of */
+Inst in; { /* member functions for instance in*/
+
+ /* ----------------------------------------------------------------------
+ * Generate code for instance specific dictionary builder function:
+ *
+ * inst.maker d1 ... dn = let sc1 = ...
+ * .
+ * .
+ * .
+ * scm = ...
+ * d = f (class.C sc1 ... scm d)
+ * omit if the / f (Make.C sc1' ... scm' v1' ... vk')
+ * instance decl { = let vj ... = ...
+ * has no imps \ in Make.C sc1' ... scm' ... vj ...
+ * in d
+ *
+ * where sci are superclass dictionaries, d and f are new names, vj
+ * is a newly generated name corresponding to the implementation of a
+ * member function. (Additional line number values must be added at
+ * appropriate places but, for clarity, these are not shown above.)
+ * --------------------------------------------------------------------*/
+
+ Int alpha = newKindedVars(cclass(inst(in).c).kinds);
+ List supers = makePredAss(cclass(inst(in).c).supers,alpha);
+ Int beta = newKindedVars(inst(in).kinds);
+ List params = makePredAss(inst(in).specifics,beta);
+ Cell d = inventDictVar();
+ List evids = cons(triple(inst(in).head,mkInt(beta),d),
+ appendOnto(dupList(params),supers));
+
+ List imps = inst(in).implements;
+ Cell l = mkInt(inst(in).line);
+ Cell dictDef = cclass(inst(in).c).dbuild;
+ List args = NIL;
+ List locs = NIL;
+ List ps;
+
+ if (!unifyPred(cclass(inst(in).c).head,alpha,inst(in).head,beta))
+ internal("typeInstDefn");
+
+ for (ps=params; nonNull(ps); ps=tl(ps)) /* Build arglist */
+ args = cons(thd3(hd(ps)),args);
+ args = rev(args);
+
+ for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */
+ Cell pi = hd(ps);
+ Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)));
+ if (isNull(ev))
+ ev = inEntail(evids,fst3(pi),intOf(snd3(pi)));
+ if (isNull(ev)) {
+ clearMarks();
+ ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
+ ERRTEXT "\n*** Instance : " ETHEN
+ ERRPRED(copyPred(inst(in).head,beta));
+ ERRTEXT "\n*** Context supplied : " ETHEN
+ ERRCONTEXT(copyPreds(params));
+ ERRTEXT "\n*** Required superclass : " ETHEN
+ ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
+ ERRTEXT "\n"
+ EEND;
+ }
+ locs = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
+ dictDef = ap(dictDef,thd3(pi));
+ }
+ dictDef = ap(dictDef,d);
+
+ if (isNull(imps)) /* No implementations */
+ locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
+ else { /* Implementations supplied*/
+ List mems = cclass(inst(in).c).members;
+ Cell f = inventVar();
+ Cell pat = cclass(inst(in).c).dcon;
+ Cell res = pat;
+ List locs1 = NIL;
+
+ locs = cons(pair(d,singleton(pair(NIL,ap(l,ap(f,dictDef))))),
+ locs);
+
+ for (ps=supers; nonNull(ps); ps=tl(ps)){/* Add param for each sc */
+ Cell v = inventVar();
+ pat = ap(pat,v);
+ res = ap(res,v);
+ }
+
+ for (; nonNull(mems); mems=tl(mems)) { /* For each member: */
+ Cell v = inventVar();
+ Cell imp = NIL;
+
+ if (nonNull(imps)) { /* Look for implementation */
+ imp = hd(imps);
+ imps = tl(imps);
+ }
+
+ if (isNull(imp)) { /* If none, f will copy */
+ pat = ap(pat,v); /* its argument unchanged */
+ res = ap(res,v);
+ }
+ else { /* Otherwise, add the impl */
+ pat = ap(pat,WILDCARD); /* to f as a local defn */
+ res = ap(res,v);
+ typeMember("instance member binding",
+ hd(mems),
+ snd(imp),
+ evids,
+ inst(in).head,
+ beta);
+ locs1 = cons(pair(v,snd(imp)),locs1);
+ }
+ }
+ res = ap(l,res);
+ if (nonNull(locs1)) /* Build the body of f */
+ res = ap(LETREC,pair(singleton(locs1),res));
+ pat = singleton(pat); /* And the arglist for f */
+ locs = cons(pair(f,singleton(pair(pat,res))),locs);
+ }
+ d = ap(l,d);
+
+ name(inst(in).builder).defn /* Register builder imp */
+ = singleton(pair(args,ap(LETREC,pair(singleton(locs),d))));
+ genDefns = cons(inst(in).builder,genDefns);
+}
+
+static Void local typeMember(wh,mem,alts,evids,head,beta)
+String wh; /* Type check alternatives alts of */
+Name mem; /* member mem for inst type head */
+Cell alts; /* at offset beta using predicate */
+List evids; /* assignment evids */
+Cell head;
+Int beta; {
+ Int line = rhsLine(snd(hd(alts)));
+ Type t;
+ Int o;
+ Int m;
+ List ps;
+ List qs;
+ Type rt;
+
+#ifdef DEBUG_TYPES
+ printf("Type check member: ");
+ printExp(stdout,mem);
+ printf(" :: ");
+ printType(stdout,name(mem).type);
+ printf("\nfor the instance: ");
+ printPred(stdout,head);
+ printf("\n");
+#endif
+
+ instantiate(name(mem).type); /* Find required type */
+ o = typeOff;
+ m = typeFree;
+ t = dropRank2(typeIs,o,m);
+ ps = makePredAss(predsAre,o);
+ if (!unifyPred(hd(predsAre),typeOff,head,beta))
+ internal("typeMember1");
+ clearMarks();
+ qs = copyPreds(ps);
+ rt = generalize(qs,liftRank2(t,o,m));
+
+#ifdef DEBUG_TYPES
+ printf("Required type is: ");
+ printType(stdout,rt);
+ printf("\n");
+#endif
+
+ hd(defnBounds) = NIL; /* Type check each alternative */
+ hd(depends) = NODEPENDS;
+ enterPendingBtyvs();
+ for (preds=NIL; nonNull(alts); alts=tl(alts)) {
+ typeAlt(wh,mem,hd(alts),t,o,m);
+ qualify(tl(ps),hd(alts)); /* Add any extra dict params */
+ }
+ leavePendingBtyvs();
+
+ evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts */
+ evids);
+ clearMarks();
+ qs = elimPredsUsing(evids,NIL);
+ if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
+ qs = elimPredsUsing(evids,qs);
+ if (nonNull(qs)) {
+ ERRMSG(line)
+ "Implementation of %s requires extra context",
+ textToStr(name(mem).text) ETHEN
+ ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(rt);
+ ERRTEXT "\n*** Missing context : " ETHEN ERRCONTEXT(copyPreds(qs));
+ ERRTEXT "\n"
+ EEND;
+ }
+
+ resetGenerics(); /* Make sure we're general enough */
+ ps = copyPreds(ps);
+ t = generalize(ps,liftRank2(t,o,m));
+#ifdef DEBUG_TYPES
+ printf("Inferred type is: ");
+ printType(stdout,t);
+ printf("\n");
+#endif
+ if (!sameSchemes(t,rt))
+ tooGeneral(line,mem,rt,t);
+ if (nonNull(preds))
+ cantEstablish(line,wh,mem,t,ps);
+}
+
+/* --------------------------------------------------------------------------
+ * Type check bodies of bindings:
+ * ------------------------------------------------------------------------*/
+
+static Void local typeBind(b) /* Type check binding */
+Cell b; {
+ if (isVar(fst(b))) { /* function binding */
+ Cell ass = findTopBinding(fst(b));
+ Int beta;
+
+ if (isNull(ass))
+ internal("typeBind");
+
+ beta = intOf(defType(snd(ass)));
+ enterPendingBtyvs();
+ map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
+ leavePendingBtyvs();
+ }
+ else { /* pattern binding */
+ static String lhsPat = "lhs pattern";
+ static String rhs = "right hand side";
+ Int beta = newTyvars(1);
+ Pair pb = snd(snd(b));
+ Int l = rhsLine(snd(pb));
+
+ tcMode = OLD_PATTERN;
+ check(l,fst(pb),NIL,lhsPat,aVar,beta);
+ tcMode = EXPRESSION;
+ snd(pb) = typeRhs(snd(pb));
+ shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,aVar,beta);
+ }
+}
+
+static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding */
+Int beta;
+Cell v;
+Pair a; {
+ static String valDef = "function binding";
+ typeAlt(valDef,v,a,aVar,beta,0);
+}
+
+static Cell local typeRhs(e) /* check type of rhs of definition */
+Cell e; {
+ switch (whatIs(e)) {
+ case GUARDED : { Int beta = newTyvars(1);
+ map1Proc(guardedType,beta,snd(e));
+ tyvarType(beta);
+ }
+ break;
+
+ case LETREC : enterBindings();
+ mapProc(typeBindings,fst(snd(e)));
+ snd(snd(e)) = typeRhs(snd(snd(e)));
+ leaveBindings();
+ break;
+
+ default : snd(e) = typeExpr(intOf(fst(e)),snd(e));
+ break;
+ }
+ return e;
+}
+
+static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
+Int beta; /* should have gd :: Bool, */
+Cell gded; { /* ex :: (var,beta) */
+ static String guarded = "guarded expression";
+ static String guard = "guard";
+ Int line = intOf(fst(gded));
+
+ gded = snd(gded);
+ check(line,fst(gded),NIL,guard,typeBool,0);
+ check(line,snd(gded),NIL,guarded,aVar,beta);
+}
+
+Cell rhsExpr(rhs) /* find first expression on a rhs */
+Cell rhs; {
+ switch (whatIs(rhs)) {
+ case GUARDED : return snd(snd(hd(snd(rhs))));
+ case LETREC : return rhsExpr(snd(snd(rhs)));
+ default : return snd(rhs);
+ }
+}
+
+Int rhsLine(rhs) /* find line number associated with */
+Cell rhs; { /* a right hand side */
+ switch (whatIs(rhs)) {
+ case GUARDED : return intOf(fst(hd(snd(rhs))));
+ case LETREC : return rhsLine(snd(snd(rhs)));
+ default : return intOf(fst(rhs));
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Calculate generalization of types and compare with declared type schemes:
+ * ------------------------------------------------------------------------*/
+
+static Void local genBind(ps,b) /* Generalize the type of each var */
+List ps; /* defined in binding b, qualifying*/
+Cell b; { /* each with the predicates in ps. */
+ Cell v = fst(b);
+ Cell t = fst(snd(b));
+
+ if (isVar(fst(b)))
+ genAss(rhsLine(snd(hd(snd(snd(b))))),ps,v,t);
+ else {
+ Int line = rhsLine(snd(snd(snd(b))));
+ for (; nonNull(v); v=tl(v)) {
+ Type ty = NIL;
+ if (nonNull(t)) {
+ ty = hd(t);
+ t = tl(t);
+ }
+ genAss(line,ps,hd(v),ty);
+ }
+ }
+}
+
+static Void local genAss(l,ps,v,dt) /* Calculate inferred type of v and*/
+Int l; /* compare with declared type, dt, */
+List ps; /* if given & check for ambiguity. */
+Cell v;
+Type dt; {
+ Cell ass = findTopBinding(v);
+
+ if (isNull(ass))
+ internal("genAss");
+
+ snd(ass) = genTest(l,v,ps,dt,aVar,intOf(defType(snd(ass))));
+
+#ifdef DEBUG_TYPES
+ printExp(stdout,v);
+ printf(" :: ");
+ printType(stdout,snd(ass));
+ printf("\n");
+#endif
+}
+
+static Type local genTest(l,v,ps,dt,t,o)/* Generalize and test inferred */
+Int l; /* type (t,o) with context ps */
+Cell v; /* against declared type dt for v. */
+List ps;
+Type dt;
+Type t;
+Int o; {
+ Type bt = NIL; /* Body of inferred type */
+ Type it = NIL; /* Full inferred type */
+
+ resetGenerics(); /* Calculate Haskell typing */
+ ps = copyPreds(ps);
+ bt = copyType(t,o);
+ it = generalize(ps,bt);
+
+ if (nonNull(dt)) { /* If a declared type was given, */
+ instantiate(dt); /* check body for match. */
+ if (!equalTypes(typeIs,bt))
+ tooGeneral(l,v,dt,it);
+ }
+ else if (nonNull(ps)) /* Otherwise test for ambiguity in */
+ if (isAmbiguous(it)) /* inferred type. */
+ ambigError(l,"inferred type",v,it);
+
+ return it;
+}
+
+static Type local generalize(qs,t) /* calculate generalization of t */
+List qs; /* having already marked fixed vars*/
+Type t; { /* with qualifying preds qs */
+ if (nonNull(qs))
+ t = ap(QUAL,pair(qs,t));
+ if (nonNull(genericVars)) {
+ Kind k = STAR;
+ List vs = genericVars;
+ for (; nonNull(vs); vs=tl(vs)) {
+ Tyvar *tyv = tyvar(intOf(hd(vs)));
+ Kind ka = tyv->kind;
+ k = ap(ka,k);
+ }
+ t = mkPolyType(k,t);
+#ifdef DEBUG_KINDS
+ printf("Generalized type: ");
+ printType(stdout,t);
+ printf(" ::: ");
+ printKind(stdout,k);
+ printf("\n");
+#endif
+ }
+ return t;
+}
+
+static Bool local equalTypes(t1,t2) /* Compare simple types for equality*/
+Type t1, t2; {
+
+et: if (whatIs(t1)!=whatIs(t2))
+ return FALSE;
+
+ switch (whatIs(t1)) {
+#if TREX
+ case EXT :
+#endif
+ case TYCON :
+ case OFFSET :
+ case TUPLE : return t1==t2;
+
+ case INTCELL : return intOf(t1)!=intOf(t2);
+
+ case AP : if (equalTypes(fun(t1),fun(t2))) {
+ t1 = arg(t1);
+ t2 = arg(t2);
+ goto et;
+ }
+ return FALSE;
+
+ default : internal("equalTypes");
+ }
+
+ return TRUE;/*NOTREACHED*/
+}
+
+/* --------------------------------------------------------------------------
+ * Entry points to type checker:
+ * ------------------------------------------------------------------------*/
+
+Type typeCheckExp(useDefs) /* Type check top level expression */
+Bool useDefs; { /* using defaults if reqd */
+ Type type;
+ List ctxt;
+ Int beta;
+
+ typeChecker(RESET);
+ emptySubstitution();
+ enterBindings();
+ inputExpr = typeExpr(0,inputExpr);
+ type = typeIs;
+ beta = typeOff;
+ clearMarks();
+ normPreds(0);
+ elimTauts();
+ preds = scSimplify(preds);
+ if (useDefs && nonNull(preds)) {
+ clearMarks();
+ reducePreds();
+ if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
+ elimTauts();
+ }
+ resetGenerics();
+ ctxt = copyPreds(preds);
+ type = generalize(ctxt,copyType(type,beta));
+ inputExpr = qualifyExpr(0,preds,inputExpr);
+ typeChecker(RESET);
+ emptySubstitution();
+ return type;
+}
+
+Void typeCheckDefns() { /* Type check top level bindings */
+ Target t = length(selDefns) + length(valDefns) +
+ length(instDefns) + length(classDefns);
+ Target i = 0;
+ List gs;
+
+ typeChecker(RESET);
+ emptySubstitution();
+ enterBindings();
+ setGoal("Type checking",t);
+
+ for (gs=selDefns; nonNull(gs); gs=tl(gs)) {
+ mapOver(typeSel,hd(gs));
+ soFar(i++);
+ }
+ for (gs=valDefns; nonNull(gs); gs=tl(gs)) {
+ typeDefnGroup(hd(gs));
+ soFar(i++);
+ }
+ clearTypeIns();
+ for (gs=classDefns; nonNull(gs); gs=tl(gs)) {
+ emptySubstitution();
+ typeClassDefn(hd(gs));
+ soFar(i++);
+ }
+ for (gs=instDefns; nonNull(gs); gs=tl(gs)) {
+ emptySubstitution();
+ typeInstDefn(hd(gs));
+ soFar(i++);
+ }
+
+ typeChecker(RESET);
+ emptySubstitution();
+ done();
+}
+
+static Void local typeDefnGroup(bs) /* type check group of value defns */
+List bs; { /* (one top level scc) */
+ List as;
+
+ emptySubstitution();
+ hd(defnBounds) = NIL;
+ preds = NIL;
+ setTypeIns(bs);
+ typeBindings(bs); /* find types for vars in bindings */
+
+ if (nonNull(preds)) {
+ Cell v = fst(hd(hd(varsBounds)));
+ Name n = findName(textOf(v));
+ Int l = nonNull(n) ? name(n).line : 0;
+ preds = scSimplify(preds);
+ ERRMSG(l) "Instance%s of ", (length(preds)==1 ? "" : "s") ETHEN
+ ERRCONTEXT(copyPreds(preds));
+ ERRTEXT " required for definition of " ETHEN
+ ERREXPR(nonNull(n)?n:v);
+ ERRTEXT "\n"
+ EEND;
+ }
+
+ for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
+ Cell a = hd(as); /* add infered types to environment*/
+ Name n = findName(textOf(fst(a)));
+ if (isNull(n))
+ internal("typeDefnGroup");
+ name(n).type = snd(a);
+ }
+ hd(varsBounds) = NIL;
+}
+
+static Pair local typeSel(s) /* Calculate a suitable type for a */
+Name s; { /* particular selector, s. */
+ List cns = name(s).defn;
+ Int line = name(s).line;
+ Type dom = NIL; /* Inferred domain */
+ Type rng = NIL; /* Inferred range */
+ Cell nv = inventVar();
+ List alts = NIL;
+ Int o;
+ Int m;
+
+#ifdef DEBUG_SELS
+ printf("Selector %s, cns=",textToStr(name(s).text));
+ printExp(stdout,cns);
+ putchar('\n');
+#endif
+
+ emptySubstitution();
+ preds = NIL;
+
+ for (; nonNull(cns); cns=tl(cns)) {
+ Name c = fst(hd(cns));
+ Int n = intOf(snd(hd(cns)));
+ Int a = name(c).arity;
+ Cell pat = c;
+ Type dom1;
+ Type rng1;
+ Int o1;
+ Int m1;
+
+ instantiate(name(c).type); /* Instantiate constructor type */
+ o1 = typeOff;
+ m1 = typeFree;
+ for (; nonNull(predsAre); predsAre=tl(predsAre))
+ assumeEvid(hd(predsAre),o1);
+
+ if (whatIs(typeIs)==RANK2) /* Skip rank2 annotation, if any */
+ typeIs = snd(snd(typeIs));
+ for (; --n>0; a--) { /* Get range */
+ pat = ap(pat,WILDCARD);
+ typeIs = arg(typeIs);
+ }
+ rng1 = dropRank1(arg(fun(typeIs)),o1,m1);
+ pat = ap(pat,nv);
+ typeIs = arg(typeIs);
+ while (--a>0) { /* And then look for domain */
+ pat = ap(pat,WILDCARD);
+ typeIs = arg(typeIs);
+ }
+ dom1 = typeIs;
+
+ if (isNull(dom)) { /* Save first domain type and then */
+ dom = dom1; /* unify with subsequent domains to*/
+ o = o1; /* match up preds and range types */
+ m = m1;
+ }
+ else if (!unify(dom1,o1,dom,o))
+ internal("typeSel1");
+
+ if (isNull(rng)) /* Compare component types */
+ rng = rng1;
+ else if (!sameSchemes(rng1,rng)) {
+ clearMarks();
+ rng = liftRank1(rng,o,m);
+ rng1 = liftRank1(rng1,o1,m1);
+ ERRMSG(name(s).line) "Mismatch in field types for selector \"%s\"",
+ textToStr(name(s).text) ETHEN
+ ERRTEXT "\n*** Field type : " ETHEN ERRTYPE(rng1);
+ ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(rng);
+ ERRTEXT "\n"
+ EEND;
+ }
+ alts = cons(pair(singleton(pat),pair(mkInt(line),nv)),alts);
+ }
+ alts = rev(alts);
+
+ if (isNull(dom) || isNull(rng)) /* Should have been initialized by */
+ internal("typeSel2"); /* now, assuming length cns >= 1. */
+
+ clearMarks(); /* No fixed variables here */
+ preds = scSimplify(preds); /* Simplify context */
+ dom = copyType(dom,o); /* Calculate domain type */
+ instantiate(rng);
+ rng = copyType(typeIs,typeOff);
+ if (nonNull(predsAre)) {
+ List ps = makePredAss(predsAre,typeOff);
+ List alts1 = alts;
+ for (; nonNull(alts1); alts1=tl(alts1)) {
+ Cell body = nv;
+ List qs = ps;
+ for (; nonNull(qs); qs=tl(qs))
+ body = ap(body,thd3(hd(qs)));
+ snd(snd(hd(alts1))) = body;
+ }
+ preds = appendOnto(preds,ps);
+ }
+ name(s).type = generalize(copyPreds(preds),fn(dom,rng));
+ name(s).arity = 1 + length(preds);
+ map1Proc(qualify,preds,alts);
+
+#ifdef DEBUG_SELS
+ printf("Inferred arity = %d, type = ",name(s).arity);
+ printType(stdout,name(s).type);
+ putchar('\n');
+#endif
+
+ return pair(s,alts);
+}
+
+/* --------------------------------------------------------------------------
+ * Local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static Type local basicType Args((Char));
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
+Type t; /* to list vs */
+List vs; {
+ switch (whatIs(t)) {
+ case AP : return offsetTyvarsIn(fun(t),
+ offsetTyvarsIn(arg(t),vs));
+
+ case OFFSET : if (cellIsMember(t,vs)) {
+ return vs;
+ } else {
+ return cons(t,vs);
+ }
+ case QUAL : return offsetTyvarsIn(snd(t),vs);
+
+ case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs);
+ /* slightly inaccurate, but won't matter here */
+
+ case EXIST :
+ case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs);
+
+ default : return vs;
+ }
+}
+
+static Type stateVar = NIL;
+static Type alphaVar = NIL;
+static Type betaVar = NIL;
+static Int nextVar = 0;
+
+static Void clearTyVars( void )
+{
+ stateVar = NIL;
+ alphaVar = NIL;
+ betaVar = NIL;
+ nextVar = 0;
+}
+
+static Type mkStateVar( void )
+{
+ if (isNull(stateVar)) {
+ stateVar = mkOffset(nextVar++);
+ }
+ return stateVar;
+}
+
+static Type mkAlphaVar( void )
+{
+ if (isNull(alphaVar)) {
+ alphaVar = mkOffset(nextVar++);
+ }
+ return alphaVar;
+}
+
+static Type mkBetaVar( void )
+{
+ if (isNull(betaVar)) {
+ betaVar = mkOffset(nextVar++);
+ }
+ return betaVar;
+}
+
+static Type local basicType(k)
+Char k; {
+ switch (k) {
+ case CHAR_REP:
+ return typeChar;
+ case INT_REP:
+ return typeInt;
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ return typeInt64;
+#endif
+#ifdef PROVIDE_INTEGER
+ case INTEGER_REP:
+ return typeInteger;
+#endif
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ return typeAddr;
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ return typeWord;
+#endif
+ case FLOAT_REP:
+ return typeFloat;
+ case DOUBLE_REP:
+ return typeDouble;
+#ifdef PROVIDE_ARRAY
+ case ARR_REP: return ap(typePrimArray,mkAlphaVar());
+ case BARR_REP: return typePrimByteArray;
+ case REF_REP: return ap2(typeRef,mkStateVar(),mkAlphaVar());
+ case MUTARR_REP: return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
+ case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar());
+#endif
+#ifdef PROVIDE_STABLE
+ case STABLE_REP:
+ return ap(typeStable,mkAlphaVar());
+#endif
+#ifdef PROVIDE_WEAK
+ case WEAK_REP:
+ return ap(typeWeak,mkAlphaVar());
+ case IO_REP:
+ return ap(typeIO,typeUnit);
+#endif
+#ifdef PROVIDE_FOREIGN
+ case FOREIGN_REP:
+ return typeForeign;
+#endif
+#ifdef PROVIDE_CONCURRENT
+ case THREADID_REP:
+ return typeThreadId;
+ case MVAR_REP:
+ return ap(typeMVar,mkAlphaVar());
+#endif
+ case BOOL_REP:
+ return typeBool;
+ case HANDLER_REP:
+ return fn(typeException,mkAlphaVar());
+ case ERROR_REP:
+ return typeException;
+ case ALPHA_REP:
+ return mkAlphaVar(); /* polymorphic */
+ case BETA_REP:
+ return mkBetaVar(); /* polymorphic */
+ default:
+ printf("Kind: '%c'\n",k);
+ internal("basicType");
+ }
+}
+
+/* Generate type of primop based on list of arg types and result types:
+ *
+ * eg primType "II" "II" = Int -> Int -> (Int,Int)
+ *
+ */
+Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
+{
+ List rs = NIL;
+ List as = NIL;
+ List tvars = NIL; /* for polymorphic types */
+ Type r;
+
+ clearTyVars();
+
+ /* build result types */
+ for(; *r_kinds; ++r_kinds) {
+ rs = cons(basicType(*r_kinds),rs);
+ }
+ /* Construct tuple of results */
+ if (length(rs) == 0) {
+ r = typeUnit;
+ } else if (length(rs) == 1) {
+ r = hd(rs);
+ } else {
+ r = mkTuple(length(rs));
+ for(rs = rev(rs); nonNull(rs); rs=tl(rs)) {
+ r = ap(r,hd(rs));
+ }
+ }
+ /* Construct list of arguments */
+ for(; *a_kinds; ++a_kinds) {
+ as = cons(basicType(*a_kinds),as);
+ }
+ /* Apply any monad magic */
+ if (monad == MONAD_IO) {
+ r = ap(typeIO,r);
+ } else if (monad == MONAD_ST) {
+ r = ap2(typeST,mkStateVar(),r);
+ }
+ /* glue it all together */
+ for(; nonNull(as); as=tl(as)) {
+ r = fn(hd(as),r);
+ }
+ tvars = offsetTyvarsIn(r,NIL);
+ if (nonNull(tvars)) {
+ assert(length(tvars) == nextVar);
+ r = mkPolyType(simpleKind(length(tvars)),r);
+ }
+#if DEBUG_CODE
+ if (debugCode) {
+ printType(stdout,r); printf("\n");
+ }
+#endif
+ return r;
+}
+
+/* forall a1 .. am. TC a1 ... am -> Int */
+Type conToTagType(t)
+Tycon t; {
+ Type ty = t;
+ List tvars = NIL;
+ Int i = 0;
+ for (i=0; i<tycon(t).arity; ++i) {
+ Offset tv = mkOffset(i);
+ ty = ap(ty,tv);
+ tvars = cons(tv,tvars);
+ }
+ ty = fn(ty,typeInt);
+ if (nonNull(tvars)) {
+ ty = mkPolyType(simpleKind(tycon(t).arity),ty);
+ }
+ return ty;
+}
+
+/* forall a1 .. am. Int -> TC a1 ... am */
+Type tagToConType(t)
+Tycon t; {
+ Type ty = t;
+ List tvars = NIL;
+ Int i = 0;
+ for (i=0; i<tycon(t).arity; ++i) {
+ Offset tv = mkOffset(i);
+ ty = ap(ty,tv);
+ tvars = cons(tv,tvars);
+ }
+ ty = fn(typeInt,ty);
+ if (nonNull(tvars)) {
+ ty = mkPolyType(simpleKind(tycon(t).arity),ty);
+ }
+ return ty;
+}
+
+/* --------------------------------------------------------------------------
+ * Type checker control:
+ * ------------------------------------------------------------------------*/
+
+Void mkTypes()
+{
+ arrow = fn(aVar,mkOffset(1));
+ listof = ap(typeList,aVar);
+ predNum = ap(classNum,aVar);
+ predFractional = ap(classFractional,aVar);
+ predIntegral = ap(classIntegral,aVar);
+ predMonad = ap(classMonad,aVar);
+ predMonad0 = ap(classMonad0,aVar);
+}
+
+Void typeChecker(what)
+Int what; {
+ switch (what) {
+ case RESET : tcMode = EXPRESSION;
+ preds = NIL;
+ pendingBtyvs = NIL;
+ emptyAssumption();
+ break;
+
+ case MARK : mark(defnBounds);
+ mark(varsBounds);
+ mark(depends);
+ mark(pendingBtyvs);
+ mark(skolVars);
+ mark(dummyVar);
+ mark(preds);
+ mark(stdDefaults);
+ mark(arrow);
+ mark(boundPair);
+ mark(listof);
+ mark(typeVarToVar);
+ mark(predNum);
+ mark(predFractional);
+ mark(predIntegral);
+ mark(starToStar);
+ mark(predMonad);
+ mark(predMonad0);
+ break;
+
+ case INSTALL : typeChecker(RESET);
+ dummyVar = inventVar();
+ starToStar = simpleKind(1);
+ typeVarToVar = fn(aVar,aVar);
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+extern Type typeCheckExp Args((Bool));
+extern Void typeCheckDefns Args((Void));
+extern Cell provePred Args((Kinds,List,Cell));
+extern List simpleContext Args((List,Int));
+extern Cell rhsExpr Args((Cell));
+extern Int rhsLine Args((Cell));
+extern List offsetTyvarsIn Args((Type,List));
+extern Type primType Args((Int/*AsmMonad*/,String,String));
+extern Type conToTagType Args((Tycon));
+extern Type tagToConType Args((Tycon));
+extern Void mkTypes Args((Void));
+
--- /dev/null
+/* --------------------------------------------------------------------------
+ * Version number
+ * ------------------------------------------------------------------------*/
+
+/* Define this as a 13 character string uniquely identifying the current
+ * version.
+ * Major releases from Nottingham/Yale are of the form "<month><year>"
+ * Minor releases from Nottingham/Yale are of the form "[Beta YYMMDD]"
+ * Anyone else should use a different format to avoid confusion.
+ */
+#define MAJOR_RELEASE 0
+
+#if MAJOR_RELEASE
+#define HUGS_VERSION "January 1998 "
+#else
+#define HUGS_VERSION "STG prototype"
+#endif
+
\begin{code}
module Addr
- ( module PrelAddr
+ ( Addr
+
+ , module Addr
+#ifndef __HUGS__
, module Word
, module Int
- , module Addr
-
+ , module PrelAddr
+#endif
+
-- (non-standard) coercions
, addrToInt -- :: Addr -> Int
, intToAddr -- :: Int -> Addr
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+#else
import PrelAddr
-import PrelCCall ( Word(..) )
import PrelBase
+import PrelIOBase ( IO(..) )
import Word ( indexWord8OffAddr, indexWord16OffAddr
, indexWord32OffAddr, indexWord64OffAddr
, readWord8OffAddr, readWord16OffAddr
, writeInt8OffAddr, writeInt16OffAddr
, writeInt32OffAddr, writeInt64OffAddr
)
-import PrelIOBase ( IO(..), IOResult(..) )
-
-#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( ForeignObj(..), StablePtr(..) )
#endif
\end{code}
\begin{code}
addrToInt :: Addr -> Int
-addrToInt (A# a#) = I# (addr2Int# a#)
-
intToAddr :: Int -> Addr
+
+#ifdef __HUGS__
+addrToInt = primAddrToInt
+intToAddr = primIntToAddr
+#else
+addrToInt (A# a#) = I# (addr2Int# a#)
intToAddr (I# i#) = A# (int2Addr# i#)
+#endif
\end{code}
Indexing immutable memory:
indexFloatOffAddr :: Addr -> Int -> Float
indexDoubleOffAddr :: Addr -> Int -> Double
+#ifdef __HUGS__
+indexCharOffAddr = primIndexCharOffAddr
+indexIntOffAddr = primIndexIntOffAddr
+indexWordOffAddr = primIndexWordOffAddr
+indexAddrOffAddr = primIndexAddrOffAddr
+indexFloatOffAddr = primIndexFloatOffAddr
+indexDoubleOffAddr = primIndexDoubleOffAddr
+#else
indexCharOffAddr (A# addr#) n
= case n of { I# n# ->
case indexCharOffAddr# addr# n# of { r# ->
= case n of { I# n# ->
case indexDoubleOffAddr# addr# n# of { r# ->
(D# r#)}}
+#endif
\end{code}
Indexing mutable memory:
\begin{code}
readCharOffAddr :: Addr -> Int -> IO Char
-readCharOffAddr a i = _casm_ `` %r=(StgChar)(((StgChar*)%0)[(StgInt)%1]); '' a i
-
-readIntOffAddr :: Addr -> Int -> IO Int
-readIntOffAddr a i = _casm_ `` %r=(StgInt)(((StgInt*)%0)[(StgInt)%1]); '' a i
-
-readStablePtrOffAddr :: Addr -> Int -> IO (StablePtr a)
-readStablePtrOffAddr a i = _casm_ `` %r=(StgStablePtr)(((StgStablePtr*)%0)[(StgInt)%1]); '' a i
-
+readIntOffAddr :: Addr -> Int -> IO Int
readWordOffAddr :: Addr -> Int -> IO Word
-readWordOffAddr a i = _casm_ `` %r=(StgWord)(((StgWord*)%0)[(StgInt)%1]); '' a i
-
readAddrOffAddr :: Addr -> Int -> IO Addr
-readAddrOffAddr a i = _casm_ `` %r=(StgAddr)(((StgAddr*)%0)[(StgInt)%1]); '' a i
-
-readFloatOffAddr :: Addr -> Int -> IO Float
-readFloatOffAddr a i = _casm_ `` %r=(StgFloat)(((StgFloat*)%0)[(StgInt)%1]); '' a i
-
+readFloatOffAddr :: Addr -> Int -> IO Float
readDoubleOffAddr :: Addr -> Int -> IO Double
+
+#ifdef __HUGS__
+readCharOffAddr = primReadCharOffAddr
+readIntOffAddr = primReadIntOffAddr
+readWordOffAddr = primReadWordOffAddr
+readAddrOffAddr = primReadAddrOffAddr
+readFloatOffAddr = primReadFloatOffAddr
+readDoubleOffAddr = primReadDoubleOffAddr
+#else
+readCharOffAddr a i = _casm_ `` %r=(StgChar)(((StgChar*)%0)[(StgInt)%1]); '' a i
+readIntOffAddr a i = _casm_ `` %r=(StgInt)(((StgInt*)%0)[(StgInt)%1]); '' a i
+readWordOffAddr a i = _casm_ `` %r=(StgWord)(((StgWord*)%0)[(StgInt)%1]); '' a i
+readAddrOffAddr a i = _casm_ `` %r=(StgAddr)(((StgAddr*)%0)[(StgInt)%1]); '' a i
+readFloatOffAddr a i = _casm_ `` %r=(StgFloat)(((StgFloat*)%0)[(StgInt)%1]); '' a i
readDoubleOffAddr a i = _casm_ `` %r=(StgDouble)(((StgDouble*)%0)[(StgInt)%1]); '' a i
+#endif
\end{code}
\begin{code}
writeCharOffAddr :: Addr -> Int -> Char -> IO ()
+writeIntOffAddr :: Addr -> Int -> Int -> IO ()
+writeWordOffAddr :: Addr -> Int -> Word -> IO ()
+writeAddrOffAddr :: Addr -> Int -> Addr -> IO ()
+writeFloatOffAddr :: Addr -> Int -> Float -> IO ()
+writeDoubleOffAddr :: Addr -> Int -> Double -> IO ()
+
+#ifdef __HUGS__
+writeCharOffAddr = primWriteCharOffAddr
+writeIntOffAddr = primWriteIntOffAddr
+writeWordOffAddr = primWriteWordOffAddr
+writeAddrOffAddr = primWriteAddrOffAddr
+writeFloatOffAddr = primWriteFloatOffAddr
+writeDoubleOffAddr = primWriteDoubleOffAddr
+#else
writeCharOffAddr (A# a#) (I# i#) (C# c#) = IO $ \ s# ->
- case (writeCharOffAddr# a# i# c# s#) of s2# -> IOok s2# ()
+ case (writeCharOffAddr# a# i# c# s#) of s2# -> (# s2#, () #)
-writeIntOffAddr :: Addr -> Int -> Int -> IO ()
writeIntOffAddr (A# a#) (I# i#) (I# e#) = IO $ \ s# ->
- case (writeIntOffAddr# a# i# e# s#) of s2# -> IOok s2# ()
+ case (writeIntOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-writeStablePtrOffAddr :: Addr -> Int -> StablePtr a -> IO ()
-writeStablePtrOffAddr (A# a#) (I# i#) (StablePtr e#) = IO $ \ s# ->
- case (writeStablePtrOffAddr# a# i# e# s#) of s2# -> IOok s2# ()
-
-writeWordOffAddr :: Addr -> Int -> Word -> IO ()
writeWordOffAddr (A# a#) (I# i#) (W# e#) = IO $ \ s# ->
- case (writeWordOffAddr# a# i# e# s#) of s2# -> IOok s2# ()
+ case (writeWordOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-writeAddrOffAddr :: Addr -> Int -> Addr -> IO ()
writeAddrOffAddr (A# a#) (I# i#) (A# e#) = IO $ \ s# ->
- case (writeAddrOffAddr# a# i# e# s#) of s2# -> IOok s2# ()
-
-#ifndef __PARALLEL_HASKELL__
-writeForeignObjOffAddr :: Addr -> Int -> ForeignObj -> IO ()
-writeForeignObjOffAddr (A# a#) (I# i#) (ForeignObj e#) = IO $ \ s# ->
- case (writeForeignObjOffAddr# a# i# e# s#) of s2# -> IOok s2# ()
-#endif
+ case (writeAddrOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-writeFloatOffAddr :: Addr -> Int -> Float -> IO ()
writeFloatOffAddr (A# a#) (I# i#) (F# e#) = IO $ \ s# ->
- case (writeFloatOffAddr# a# i# e# s#) of s2# -> IOok s2# ()
+ case (writeFloatOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
-writeDoubleOffAddr :: Addr -> Int -> Double -> IO ()
writeDoubleOffAddr (A# a#) (I# i#) (D# e#) = IO $ \ s# ->
- case (writeDoubleOffAddr# a# i# e# s#) of s2# -> IOok s2# ()
-
+ case (writeDoubleOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
+#endif
\end{code}
module Bits where
+#ifdef __HUGS__
+import PreludeBuiltin
+#else
import PrelBase
+#endif
+--ADR: The fixity for .|. conflicts with that for .|. in Fran.
+-- Removing all fixities is a fairly safe fix; fixing the "one fixity
+-- per symbol per program" limitation in Hugs would take a lot longer.
+#ifndef __HUGS__
infixl 8 `shift`, `rotate`
infixl 7 .&.
infixl 6 `xor`
infixl 5 .|.
+#endif
class Bits a where
(.&.), (.|.), xor :: a -> a -> a
{- BEGIN_FOR_GHC
import GlaExts
- END_FOR_GHC -}
-
--- the following type imports are only needed in order to define
--- Typeable instances locally.
-import IO ( Handle )
-import Array ( Array )
-import Complex ( Complex )
-import Foreign ( ForeignObj, StablePtr )
-{- BEGIN_FOR_GHC
-import PrelConc ( MVar )
- END_FOR_GHC -}
-{- BEGIN_FOR_HUGS -}
-import -- fool mkdependHS
- Concurrent ( MVar )
-{- END_FOR_HUGS -}
-import Word ( Word8, Word16, Word32, Word64 )
-import Int ( Int8, Int16, Int32 )
-{- BEGIN_FOR_GHC
-import Int ( Int64 )
+import PrelDynamic
END_FOR_GHC -}
import IOExts
)
{- BEGIN_FOR_HUGS -}
-primitive unsafeCoerce "primUnsafeCoerce" :: a -> b
+import
+ PreludeBuiltin
+
+unsafeCoerce = primUnsafeCoerce
{- END_FOR_HUGS -}
{- BEGIN_FOR_GHC
the dynamic value along with its type representation:
\begin{code}
-data Dynamic = Dynamic TypeRep Obj
-
-data Obj = Obj
- -- dummy type to hold the dynamically typed value.
-
-- the instance just prints the type representation.
instance Show Dynamic where
showsPrec _ (Dynamic t _) =
(Abstract) universal datatype:
\begin{code}
-data TypeRep
- = App TyCon [TypeRep]
- | Fun TypeRep TypeRep
- deriving ( Eq )
-
--- type constructors are
-data TyCon = TyCon Int String
-
instance Show TypeRep where
showsPrec p (App tycon tys) =
case tys of
isTupleTyCon (TyCon _ (',':_)) = True
isTupleTyCon _ = False
-instance Eq TyCon where
- (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-
instance Show TyCon where
showsPrec d (TyCon _ s) = showString s
instance Typeable Ordering where
typeOf _ = mkAppTy orderingTc []
-instance (Typeable ix, Typeable a) => Typeable (Array ix a) where
- typeOf a = mkAppTy arrayTc [typeOf (ix a), typeOf (elt a)]
- where
- ix :: Array ix a -> ix
- ix = undefined
-
- elt :: Array ix a -> a
- elt = undefined
-
-instance (Typeable a) => Typeable (Complex a) where
- typeOf c = mkAppTy complexTc [typeOf (v c)]
- where
- v :: Complex a -> a
- v = undefined
-
-instance Typeable Handle where
- typeOf _ = mkAppTy handleTc []
-
instance (Typeable a, Typeable b) => Typeable (a,b) where
typeOf tu = mkAppTy tup2Tc [typeOf (fst tu), typeOf (snd tu)]
where
tup5Tc = mkTyCon ",,,,"
--- Hugs/GHC extension lib types:
-instance Typeable Addr where
- typeOf _ = mkAppTy addrTc []
-
-instance Typeable a => Typeable (StablePtr a) where
- typeOf s = mkAppTy stablePtrTc [typeOf (t s)]
- where
- t :: StablePtr a -> a
- t = undefined
-
-instance Typeable a => Typeable (MVar a) where
- typeOf m = mkAppTy mvarTc [typeOf (t m)]
- where
- t :: MVar a -> a
- t = undefined
-
-instance (Typeable s, Typeable a) => Typeable (ST s a) where
- typeOf st = mkAppTy stTc [typeOf (s st), typeOf (a st)]
- where
- s :: ST s a -> s
- s = undefined
-
- a :: ST s a -> a
- a = undefined
-
-instance Typeable ForeignObj where
- typeOf _ = mkAppTy foreignObjTc []
-
-instance Typeable Int8 where
- typeOf _ = mkAppTy int8Tc []
-
-instance Typeable Int16 where
- typeOf _ = mkAppTy int16Tc []
-
-instance Typeable Int32 where
- typeOf _ = mkAppTy int32Tc []
-
-{- BEGIN_FOR_GHC
-instance Typeable Int64 where
- typeOf _ = mkAppTy int64Tc []
- END_FOR_GHC -}
-
-instance Typeable Word8 where
- typeOf _ = mkAppTy word8Tc []
-
-instance Typeable Word16 where
- typeOf _ = mkAppTy word16Tc []
-
-instance Typeable Word32 where
- typeOf _ = mkAppTy word32Tc []
-
-instance Typeable Word64 where
- typeOf _ = mkAppTy word64Tc []
-
-{- BEGIN_FOR_GHC
-instance Typeable Word where
- typeOf _ = mkAppTy wordTc []
-
-instance Typeable a => Typeable (ByteArray a) where
- typeOf b = mkAppTy byteArrayTc [typeOf (t b)]
- where
- t :: ByteArray t -> t
- t = undefined
-
-instance (Typeable s, Typeable a) => Typeable (MutableByteArray s a) where
- typeOf mb = mkAppTy byteArrayTc [typeOf (s mb), typeOf (a mb)]
- where
- s :: MutableByteArray s a -> s
- s = undefined
-
- a :: MutableByteArray s a -> a
- a = undefined
-
- END_FOR_GHC -}
-
\end{code}
@TyCon@s are provided for the following:
\end{code}
+\begin{code}
+test1 = toDyn (1::Int)
+test2 = toDyn ((+) :: Int -> Int -> Int)
+test3 = dynApp test2 test1
+test4 = dynApp test3 test1
+
+test5, test6,test7 :: Int
+test5 = fromDyn test4 0
+test6 = fromDyn test1 0
+test7 = fromDyn test2 0
+
+test8 = toDyn (mkAppTy listTc)
+test9 :: Float
+test9 = fromDyn test8 0
+
+printf :: String -> [Dynamic] -> IO ()
+printf str args = putStr (decode str args)
+ where
+ decode [] [] = []
+ decode ('%':'n':cs) (d:ds) =
+ (\ v -> show v++decode cs ds) (fromDyn d (0::Int))
+ decode ('%':'c':cs) (d:ds) =
+ (\ v -> show v++decode cs ds) (fromDyn d ('\0'))
+ decode ('%':'b':cs) (d:ds) =
+ (\ v -> show v++decode cs ds) (fromDyn d (False::Bool))
+ decode (x:xs) ds = x:decode xs ds
+
+test10 :: IO ()
+test10 = printf "%n = %c, that much is %b\n" [toDyn (3::Int),toDyn 'a', toDyn False]
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Exception.lhs,v 1.2 1998/12/02 13:26:30 simonm Exp $
+%
+% (c) The GRAP/AQUA Project, Glasgow University, 1998
+%
+
+The External API for exceptions. The functions provided in this
+module allow catching of exceptions in the IO monad.
+
+\begin{code}
+module Exception (
+
+ Exception(..), -- instance Show
+ ArithError(..), -- instance Show
+
+ -- Throwing exceptions
+
+ throw, -- :: Exception -> a
+
+ -- Catching exceptions: The IO interface
+
+ catchException, -- :: IO a -> (Exception -> IO a) -> IO a
+ catch, -- :: IO a -> (IOError -> IO a) -> IO a
+
+ catchArith, -- :: IO a -> (ArithError -> IO a) -> IO a
+ catchError, -- :: IO a -> (String -> IO a) -> IO a
+
+ getException, -- :: a -> IO (Maybe Exception)
+ getExceptionIO, -- :: IO a -> IO (Either Exception a)
+
+ throwDyn, -- :: Typeable exception => exception -> b
+ catchDyn, -- :: Typeable exception =>
+ -- IO a -> (exception -> IO a) -> IO a
+
+ ) where
+
+#ifdef __HUGS__
+import PreludeBuiltin hiding (catch)
+import Prelude hiding (catch)
+#else
+import Prelude hiding (catch)
+import PrelGHC (catch#)
+import PrelException hiding (catch)
+#endif
+
+import Dynamic
+\end{code}
+
+-----------------------------------------------------------------------------
+Catch certain types of exception.
+
+The following family of functions provide exception handling functions
+for particular kinds of exceptions; all non-matching exceptions being
+re-raised.
+
+\begin{code}
+catchIO = Prelude.catch
+#ifdef __HUGS__
+catch = PreludeBuiltin.catchException
+#else
+catch = PrelException.catchException
+#endif
+
+catchArith :: IO a -> (ArithError -> IO a) -> IO a
+catchArith m k = catch m handler
+ where handler (ArithException err) = k err
+ handler other = throw other
+
+catchError :: IO a -> (String -> IO a) -> IO a
+catchError m k = catch m handler
+ where handler (ErrorCall err) = k err
+ handler other = throw other
+\end{code}
+
+-----------------------------------------------------------------------------
+Dynamic exception types. Since one of the possible kinds of exception
+is a dynamically typed value, we can effectively have polymorphic
+exceptions.
+
+throwDyn will raise any value as an exception, provided it is in the
+Typeable class (see Dynamic.lhs).
+
+catchDyn will catch any exception of a given type (determined by the
+handler function). Any raised exceptions that don't match are
+re-raised.
+
+\begin{code}
+throwDyn :: Typeable exception => exception -> b
+throwDyn exception = throw (DynException (toDyn exception))
+
+catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
+catchDyn m k = catchException m handle
+ where handle ex = case ex of
+ (DynException dyn) ->
+ case fromDynamic dyn of
+ Just exception -> k exception
+ Nothing -> throw ex
+ other -> throw ex
+\end{code}
+
+-----------------------------------------------------------------------------
+Some Useful Functions
+
+\begin{code}
+#ifdef __HUGS__
+getException :: a -> IO (Maybe Exception)
+getException a = primCatch' (case primForce a of { () -> return Nothing}) (\e -> return (Just e))
+#else
+getException :: a -> IO (Maybe Exception)
+getException a = catch# (a `seq` return Nothing) (\e -> return (Just e))
+#endif
+
+getExceptionIO :: IO a -> IO (Either Exception a)
+getExceptionIO m = catchException (m >>= \ r -> return (Right r))
+ (\ e -> return (Left e))
+\end{code}
module Foreign
(
ForeignObj -- abstract, instance of: Eq
- , makeForeignObj -- :: Addr{-obj-} -> Addr{-finaliser-} -> IO ForeignObj
+ , makeForeignObj -- :: Addr{-obj-} -> IO ForeignObj
, writeForeignObj -- :: ForeignObj -> Addr{-new obj-} -> IO ()
+ , addForeignFinaliser -- :: ForeignObj -> IO () -> IO ()
, foreignObjToAddr -- :: ForeignObj -> IO Addr
-- the coercion from a foreign obj. to an addr. is unsafe,
-- and should not be used unless absolutely necessary.
, makeStablePtr -- :: a -> IO (StablePtr a)
, deRefStablePtr -- :: StablePtr a -> IO a
, freeStablePtr -- :: StablePtr a -> IO ()
-
- , indexCharOffForeignObj
- , indexAddrOffForeignObj
- , indexIntOffForeignObj
- , indexFloatOffForeignObj
- , indexDoubleOffForeignObj
- , readCharOffForeignObj
- , readAddrOffForeignObj
- , readIntOffForeignObj
- , readFloatOffForeignObj
- , readDoubleOffForeignObj
- , writeCharOffForeignObj
- , writeAddrOffForeignObj
- , writeIntOffForeignObj
- , writeFloatOffForeignObj
- , writeDoubleOffForeignObj
-
- , indexWord8OffForeignObj
- , indexWord16OffForeignObj
- , indexWord32OffForeignObj
- , indexWord64OffForeignObj
- , readWord8OffForeignObj
- , readWord16OffForeignObj
- , readWord32OffForeignObj
- , readWord64OffForeignObj
- , writeWord8OffForeignObj
- , writeWord16OffForeignObj
- , writeWord32OffForeignObj
- , writeWord64OffForeignObj
-
- , indexInt8OffForeignObj
- , indexInt16OffForeignObj
- , indexInt32OffForeignObj
- , indexInt64OffForeignObj
- , readInt8OffForeignObj
- , readInt16OffForeignObj
- , readInt32OffForeignObj
- , readInt64OffForeignObj
- , writeInt8OffForeignObj
- , writeInt16OffForeignObj
- , writeInt32OffForeignObj
- , writeInt64OffForeignObj
-
) where
import PrelForeign
indexAddrOffForeignObj#, indexFloatOffForeignObj#,
indexDoubleOffForeignObj#
)
-import PrelAddr ( Addr(..) )
-import PrelCCall ( Word(..) )
+import PrelAddr ( Addr(..), Word(..) )
+import PrelWeak ( addForeignFinaliser )
import Word
(
indexWord8OffForeignObj
, writeInt32OffForeignObj
, writeInt64OffForeignObj
)
-import PrelIOBase ( IO(..), IOResult(..) )
+import PrelIOBase ( IO(..) )
\end{code}
\begin{code}
- A Haskell port of GNU's getopt library
-
- Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996; last change: Jul. 1998
-
- Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't
- already know it, you probably don't want to hear about it...) and the recognition of
- long options with a single dash (e.g. '-help' is recognised as '--help', as long as
- there is no short option 'h').
-
- Other differences between GNU's getopt and this implementation:
- * To enforce a coherent description of options and arguments, there are explanation
- fields in the option/argument descriptor.
- * Error messages are now more informative, but no longer POSIX compliant... :-(
-
- And a final Haskell advertisement: The GNU C implementation uses well over 1100 lines,
- we need only 199 here, including a 46 line example! :-)
+A Haskell port of GNU's getopt library
+
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation: * To
+enforce a coherent description of options and arguments, there are
+explanation fields in the option/argument descriptor. * Error
+messages are now more informative, but no longer POSIX
+compliant... :-( And a final Haskell advertisement: The GNU C
+implementation uses well over 1100 lines, we need only 195 here,
+including a 46 line example! :-)
\begin{code}
-module GetOpt (
- ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt
- ) where
+module GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) where
import List(isPrefixOf)
fmtOpt (Option sos los ad descr) = (sepBy ", " (map (fmtShort ad) sos),
sepBy ", " (map (fmtLong ad) los),
descr)
- where sepBy _ [] = ""
- sepBy _ [x] = x
+ where sepBy sep [] = ""
+ sepBy sep [x] = x
sepBy sep (x:xs) = x ++ sep ++ sepBy sep xs
fmtShort :: ArgDescr a -> Char -> String
-> [OptDescr a] -- option descriptors
-> [String] -- the commandline arguments
-> ([a],[String],[String]) -- (options,non-options,error messages)
-getOpt _ _ [] = ([],[],[])
-getOpt ordering optDescr args = procNextOpt opt ordering
+getOpt _ _ [] = ([],[],[])
+getOpt ordering optDescr (arg:args) = procNextOpt opt ordering
where procNextOpt (Opt o) _ = (o:os,xs,es)
procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[])
procNextOpt (NonOpt x) Permute = (os,x:xs,es)
procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[])
procNextOpt (OptErr e) _ = (os,xs,e:es)
- (opt,rest) = getNext args optDescr
+ (opt,rest) = getNext arg args optDescr
(os,xs,es) = getOpt ordering optDescr rest
-- take a look at the next cmd line arg and decide what to do with it
-getNext :: [String] -> [OptDescr a] -> (OptKind a,[String])
-getNext (('-':'-':[]):rest) _ = (EndOfOpts,rest)
-getNext (('-':'-':xs):rest) optDescr = longOpt xs rest optDescr
-getNext (('-':x:xs) :rest) optDescr = shortOpt x xs rest optDescr
-getNext (a :rest) _ = (NonOpt a,rest)
-getNext [] _ = error "getNext: impossible"
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
+getNext a rest _ = (NonOpt a,rest)
-- handle long option
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
ads = [ ad | Option _ _ ad _ <- options ]
optStr = ("--"++opt)
- long (_:_:_) _ rest1 = (errAmbig options optStr,rest1)
- long [NoArg a ] [] rest1 = (Opt a,rest1)
- long [NoArg _ ] ('=':_) rest1 = (errNoArg optStr,rest1)
- long [ReqArg _ d] [] [] = (errReq d optStr,[])
- long [ReqArg f _] [] (r:rest1) = (Opt (f r),rest1)
- long [ReqArg f _] ('=':ys) rest1 = (Opt (f ys),rest1)
- long [OptArg f _] [] rest1 = (Opt (f Nothing),rest1)
- long [OptArg f _] ('=':ys) rest1 = (Opt (f (Just ys)),rest1)
- long [_] (_ :_) _ = error "long: impossible"
- long [] _ rest1 = (errUnrec optStr,rest1)
+ long (_:_:_) _ rest = (errAmbig options optStr,rest)
+ long [NoArg a ] [] rest = (Opt a,rest)
+ long [NoArg a ] ('=':xs) rest = (errNoArg optStr,rest)
+ long [ReqArg f d] [] [] = (errReq d optStr,[])
+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)
+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
+ long _ _ rest = (errUnrec optStr,rest)
-- handle short option
shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
ads = [ ad | Option _ _ ad _ <- options ]
optStr = '-':[x]
- short (_:_:_) _ rest1 = (errAmbig options optStr,rest1)
- short (NoArg a :_) [] rest1 = (Opt a,rest1)
- short (NoArg a :_) ys rest1 = (Opt a,('-':ys):rest1)
- short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
- short (ReqArg f _:_) [] (r:rest1) = (Opt (f r),rest1)
- short (ReqArg f _:_) ys rest1 = (Opt (f ys),rest1)
- short (OptArg f _:_) [] rest1 = (Opt (f Nothing),rest1)
- short (OptArg f _:_) ys rest1 = (Opt (f (Just ys)),rest1)
- short [] [] rest1 = (errUnrec optStr,rest1)
- short [] ys rest1 = (errUnrec optStr,('-':ys):rest1)
+ short (_:_:_) _ rest = (errAmbig options optStr,rest)
+ short (NoArg a :_) [] rest = (Opt a,rest)
+ short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
+ short (ReqArg f d:_) [] [] = (errReq d optStr,[])
+ short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
+ short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
+ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
+ short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
+ short [] [] rest = (errUnrec optStr,rest)
+ short [] xs rest = (errUnrec optStr,('-':xs):rest)
-- miscellaneous error formatting
errNoArg :: String -> OptKind a
errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
-\end{code}
{-
-----------------------------------------------------------------------------------------
-- -n USER --name=USER only dump USER's files
-----------------------------------------------------------------------------------------
-}
+\end{code}
import PrelGHC
import PrelBase
-import PrelAddr ( Addr(..) )
+import PrelAddr ( Addr(..), Word(..) )
import PrelST
import IOExts
import PrelIOBase
import ByteArray
import MutableArray
import Monad
-import PrelCCall ( Word(..) )
type PrimIO a = IO a
primIOToIO io = io
, readIOArray
, writeIOArray
, freezeIOArray
+ , thawIOArray
+#ifdef __HUGS__
+#else
, openFileEx
, IOModeEx(..)
, hGetEcho
, hIsTerminalDevice
, hConnectTo
-
+#endif
, trace
+#ifdef __HUGS__
+#else
, performGC
+#endif
- , reallyUnsafePtrEq
+ , unsafePtrEq
, unsafeIOToST
) where
\end{code}
\begin{code}
+#ifdef __HUGS__
+import PreludeBuiltin
+import ST
+#else
import PrelBase
import PrelIOBase
import PrelHandle ( openFileEx, IOModeEx(..),
import PrelST
import PrelArr
import PrelGHC
-import Ix
-import IO
import PrelHandle
import PrelErr
+import IO ( hPutStr, hPutChar )
+#endif
+import Ix
-reallyUnsafePtrEq :: a -> a -> Bool
-reallyUnsafePtrEq a b =
+unsafePtrEq :: a -> a -> Bool
+
+#ifdef __HUGS__
+unsafePtrEq = primReallyUnsafePtrEquality
+#else
+unsafePtrEq a b =
case reallyUnsafePtrEquality# a b of
0# -> False
_ -> True
+#endif
\end{code}
\begin{code}
+newIORef :: a -> IO (IORef a)
+readIORef :: IORef a -> IO a
+writeIORef :: IORef a -> a -> IO ()
+
+#ifdef __HUGS__
+type IORef a = STRef RealWorld a
+newIORef = newSTRef
+readIORef = readSTRef
+writeIORef = writeSTRef
+#else
newtype IORef a = IORef (MutableVar RealWorld a)
deriving Eq
-newIORef :: a -> IO (IORef a)
newIORef v = stToIO (newVar v) >>= \ var -> return (IORef var)
-
-readIORef :: IORef a -> IO a
-readIORef (IORef var) = stToIO (readVar var)
-
-writeIORef :: IORef a -> a -> IO ()
+readIORef (IORef var) = stToIO (readVar var)
writeIORef (IORef var) v = stToIO (writeVar var v)
+#endif
\end{code}
\begin{code}
-newtype IOArray ix elt = IOArray (MutableArray RealWorld ix elt)
- deriving Eq
-
newIOArray :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
boundsIOArray :: Ix ix => IOArray ix elt -> (ix, ix)
readIOArray :: Ix ix => IOArray ix elt -> ix -> IO elt
writeIOArray :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
freezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
+thawIOArray :: Ix ix => Array ix elt -> IO (IOArray ix elt)
+
+#ifdef __HUGS__
+type IOArray ix elt = STArray RealWorld ix elt
+newIOArray = newSTArray
+boundsIOArray = boundsSTArray
+readIOArray = readSTArray
+writeIOArray = writeSTArray
+freezeIOArray = freezeSTArray
+thawIOArray = thawSTArray
+#else
+newtype IOArray ix elt = IOArray (MutableArray RealWorld ix elt)
+ deriving Eq
newIOArray ixs elt =
stToIO (newArray ixs elt) >>= \arr ->
writeIOArray (IOArray arr) ix elt = stToIO (writeArray arr ix elt)
freezeIOArray (IOArray arr) = stToIO (freezeArray arr)
+
+thawIOArray arr = do
+ marr <- stToIO (thawArray arr)
+ return (IOArray marr)
+#endif
\end{code}
\begin{code}
{-# NOINLINE trace #-}
trace :: String -> a -> a
+#ifdef __HUGS__
+trace string expr = unsafePerformIO $ do
+ putStrLn string
+ return expr
+#else
trace string expr = unsafePerformIO $ do
fd <- getHandleFd stderr
- hPutStrLn stderr string
+ hPutStr stderr string
+ hPutChar stderr '\n'
_ccall_ PostTraceHook fd
return expr
-
+#endif
\end{code}
\begin{code}
unsafeIOToST :: IO a -> ST s a
+#ifdef __HUGS__
+unsafeIOToST = primUnsafeCoerce
+#else
unsafeIOToST (IO io) = ST $ \ s ->
case ((unsafeCoerce# io) s) of
- IOok new_s a -> unsafeCoerce# (STret new_s a)
- IOfail new_s e -> error ("I/O Error (unsafeIOToST): " ++ showsPrec 0 e "\n")
+ (# new_s, a #) -> unsafeCoerce# (STret new_s a)
+-- IOfail new_s e -> error ("I/O Error (unsafeIOToST): " ++ showsPrec 0 e "\n")
+#endif
\end{code}
Not something you want to call normally, but useful
the heap or make sure you've got room enough
\begin{code}
+#ifdef __HUGS__
+#else
performGC :: IO ()
-performGC = _ccall_GC_ StgPerformGarbageCollection
+performGC = _ccall_GC_ performGC
+#endif
\end{code}
+
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+#else
import GlaExts
-import Ix
-import Bits
import PrelGHC
import CCall
+import PrelForeign
+import PrelAddr ( Int64(..), Word64(..) )
+#endif
+import Ix
+import Bits
import Numeric ( readDec )
import Word ( Word32 )
-import PrelForeign
-----------------------------------------------------------------------------
-- The "official" coercion functions
\begin{code}
#if WORD_SIZE_IN_BYTES == 8
-data Int64 = I64# Int#
+--data Int64 = I64# Int#
int32ToInt64 :: Int32 -> Int64
int32ToInt64 (I32# i#) = I64# i#
int64ToInt32 (I64# i#) = I32# (int64ToInt# i#)
int64ToInteger :: Int64 -> Integer
-int64ToInteger (I64# x#) = int64ToInteger# x#
+int64ToInteger (I64# x#) =
+ case int64ToInteger# x# of
+ (# a#, s#, p# #) -> J# a# s# p#
integerToInt64 :: Integer -> Int64
integerToInt64 (J# a# s# d#) = I64# (integerToInt64# a# s# d#)
k_a new_s
{-# NOINLINE runST #-}
-runST :: (All s => ST s a) -> a
+runST :: (forall s. ST s a) -> a
runST st = case st of ST st -> let (r,_) = st (PrelST.S# realWorld#) in r
\end{code}
unsafeFreezeSTArray (STArray arr) = strictToLazyST (unsafeFreezeArray arr)
strictToLazyST :: PrelST.ST s a -> ST s a
-strictToLazyST (PrelST.ST m) = ST $ \s ->
+strictToLazyST m = ST $ \s ->
let
- pr = case s of { PrelST.S# s# -> m s# }
+ pr = case s of { PrelST.S# s# -> PrelST.liftST m s# }
r = case pr of { PrelST.STret s2# r -> r }
s' = case pr of { PrelST.STret s2# r -> PrelST.S# s2# }
in
lazyToStrictST :: ST s a -> PrelST.ST s a
lazyToStrictST (ST m) = PrelST.ST $ \s ->
- case (m (PrelST.S# s)) of (a, PrelST.S# s') -> PrelST.STret s' a
+ case (m (PrelST.S# s)) of (a, PrelST.S# s') -> (# s', a #)
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
SRC_HC_OPTS += -hisuf $(way_)hi
endif
-Int_HC_OPTS += -H10m -fno-prune-tydecls
-Word_HC_OPTS += -H10m -fno-prune-tydecls
+Int_HC_OPTS += -H14m -fno-prune-tydecls
+Word_HC_OPTS += -H12m
Foreign_HC_OPTS += -fno-prune-tydecls
NativeInfo_HC_OPTS += -fno-prune-tydecls
Dynamic_HC_OPTS += $(MAGIC_HSCPP_OPTS)
sizeofByteArray, -- :: Ix ix => ByteArray ix -> Int
sizeofMutableByteArray, -- :: Ix ix => MutableByteArray s ix -> Int
+ indexStablePtrArray, -- :: Ix ix => ByteArray ix -> ix -> (StablePtr a)
+
{-
readWord8Array, -- :: Ix ix => MutableByteArray s ix -> Word8
readWord16Array, -- :: Ix ix => MutableByteArray s ix -> Word16
) where
import PrelArr
+import PrelArrExtra
import PrelBase ( sizeofMutableByteArray#, sizeofByteArray#
, Int(..), Int#, (+#), (==#)
, StablePtr#, MutableByteArray#, State#
- , unsafeFreezeByteArray#
+ , unsafeFreezeByteArray#, ByteArray#
, newStablePtrArray#, readStablePtrArray#
, indexStablePtrArray#, writeStablePtrArray#
)
newStablePtrArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
newStablePtrArray ixs = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newStablePtrArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray ixs barr#) }}
+ case (newStablePtrArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, (MutableByteArray ixs barr#) #) }}
readStablePtrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s (StablePtr a)
readStablePtrArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readStablePtrArray# barr# n# s# of { StateAndStablePtr# s2# r# ->
- STret s2# (StablePtr r#) }}
+ case readStablePtrArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2# , (StablePtr r#) #) }}
indexStablePtrArray :: Ix ix => ByteArray ix -> ix -> (StablePtr a)
indexStablePtrArray (ByteArray ixs barr#) n
writeStablePtrArray (MutableByteArray ixs barr#) n (StablePtr sp#) = ST $ \ s# ->
case (index ixs n) of { I# n# ->
case writeStablePtrArray# barr# n# sp# s# of { s2# ->
- STret s2# () }}
+ (# s2# , () #) }}
freezeStablePtrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
freezeStablePtrArray (MutableByteArray ixs arr#) = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }}
+ case freeze arr# n# s# of { (# s2# , frozen# #) ->
+ (# s2# , ByteArray ixs frozen# #) }}
where
freeze :: MutableByteArray# s -- the thing
-> Int# -- size of thing to be frozen
-> State# s -- the Universe and everything
- -> StateAndByteArray# s
+ -> (# State# s, ByteArray# #)
freeze arr# n# s#
- = case (newStablePtrArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
+ = case (newStablePtrArray# n# s#) of { (# s2# , newarr1# #) ->
+ case copy 0# n# arr# newarr1# s2# of { (# s3# , newarr2# #) ->
unsafeFreezeByteArray# newarr2# s3#
}}
where
copy :: Int# -> Int#
-> MutableByteArray# s -> MutableByteArray# s
-> State# s
- -> StateAndMutableByteArray# s
+ -> (# State# s , MutableByteArray# s #)
copy cur# end# from# to# s#
| cur# ==# end#
- = StateAndMutableByteArray# s# to#
+ = (# s# , to# #)
| otherwise
- = case (readStablePtrArray# from# cur# s#) of { StateAndStablePtr# s1# ele ->
+ = case (readStablePtrArray# from# cur# s#) of { (# s1# , ele #) ->
case (writeStablePtrArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
}}
| n# ># (bytes# -# 1#) -> fail (userError "readWord8Array: index out of bounds "++show n)
| otherwise -> IO $ \ s# ->
case readCharArray# barr# n# s# of
- StateAndChar# s2# r# -> IOok s2# (W8# (int2Word# (ord# r#)))
+ (# s2# , r# #) -> (# s2# , W8# (int2Word# (ord# r#)) #)
readWord16Array (MutableByteArray ixs arr#) n@(I# n#) =
case sizeofMutableByteArray# arr# of
| (2# *# n#) ># (bytes# -# 1#) -> fail (userError "readWord16Array: index out of bounds "++show n)
| otherwise -> IO $ \ s# ->
case readWordArray# barr# n# s# of
- StateAndInt# s2# w# -> IOok s2# (wordToWord16 (W# w#))
+ (# s2# , w# #) -> (# s2# , wordToWord16 (W# w#) #)
readWord32Array (MutableByteArray ixs arr#) n@(I# n#) =
case sizeofMutableByteArray# arr# of
| (4# *# n#) ># (bytes# -# 1#) -> fail (userError "readWord32Array: index out of bounds "++show n)
| otherwise -> IO $ \ s# ->
case readWordArray# barr# n# s# of
- StateAndInt# s2# w# -> IOok s2# (wordToWord32 (W# w#))
+ (# s2# , w# #) -> (# s2# , wordToWord32 (W# w#) #)
end{code}
\begin{code}
module NumExts
+
(
doubleToFloat -- :: Double -> Float
, floatToDouble -- :: Double -> Float
, showHex -- :: Integral a => a -> ShowS
, showOct -- :: Integral a => a -> ShowS
- , showIntAtBase -- :: Integral a => a -> (a -> Char) -> a -> ShowS
) where
import Char (ord, chr)
+#ifdef __HUGS__
+import PreludeBuiltin
+ord_0 = ord '0'
+#else
import PrelBase (ord_0)
import GlaExts
+#endif
\end{code}
\begin{code}
doubleToFloat :: Double -> Float
-doubleToFloat (D# d#) = F# (double2Float# d#)
-
floatToDouble :: Float -> Double
+
+#ifdef __HUGS__
+doubleToFloat = primDoubleToFloat
+floatToDouble = primFloatToDouble
+#else
+doubleToFloat (D# d#) = F# (double2Float# d#)
floatToDouble (F# f#) = D# (float2Double# f#)
+#endif
+#ifdef __HUGS__
+showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS
+showIntAtBase base toChr n r
+ | n < 0 = error ("NumExts.showIntAtBase: applied to negative number " ++ show n)
+ | otherwise =
+ case quotRem n base of { (n', d) ->
+ let c = toChr d in
+ seq c $ -- stricter than necessary
+ let
+ r' = c : r
+ in
+ if n' == 0 then r' else showIntAtBase base toChr n' r'
+ }
+#else
showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS
showIntAtBase base toChr n r
| n < 0 = error ("NumExts.showIntAtBase: applied to negative number " ++ show n)
in
if n' == 0 then r' else showIntAtBase base toChr n' r'
}}
+#endif
showHex :: Integral a => a -> ShowS
showHex n r =
ST,
- runST, -- :: (All s => ST s a) -> a
+ runST, -- :: (forall s. ST s a) -> a
fixST, -- :: (a -> ST s a) -> ST s a
unsafeInterleaveST,
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+#define MutableVar Ref
+#define readVar primReadRef
+#define writeVar primWriteRef
+#define newVar primNewRef
+#else
import PrelArr
import PrelST
import PrelBase ( Eq(..), Int, Bool, ($), ()(..) )
+#endif
import Monad
import Ix
%*********************************************************
\begin{code}
-newtype STArray s ix elt = STArray (MutableArray s ix elt)
- deriving Eq
-
newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
writeSTArray :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
readSTArray :: Ix ix => STArray s ix elt -> ix -> ST s elt
freezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
+#ifdef __HUGS__
+data STArray s ix elt = STArray (ix,ix) (PrimMutableArray s elt)
+ deriving Eq
+
+newSTArray ixs elt = do
+ { arr <- primNewArray (rangeSize ixs) elt
+ ; return (STArray ixs arr)
+ }
+
+boundsSTArray (STArray ixs arr) = ixs
+readSTArray (STArray ixs arr) ix = primReadArray arr (index ixs ix)
+writeSTArray (STArray ixs arr) ix elt = primWriteArray arr (index ixs ix) elt
+freezeSTArray (STArray ixs arr) = do
+ { arr' <- primFreezeArray arr
+ ; return (Array ixs arr')
+ }
+
+unsafeFreezeSTArray (STArray ixs arr) = do
+ { arr' <- primUnsafeFreezeArray arr
+ ; return (Array ixs arr')
+ }
+
+thawSTArray (Array ixs arr) = do
+ { arr' <- primThawArray arr
+ ; return (STArray ixs arr')
+ }
+
+primFreezeArray :: PrimMutableArray s a -> ST s (PrimArray a)
+primFreezeArray arr = do
+ { let n = primSizeMutableArray arr
+ ; arr' <- primNewArray n arrEleBottom
+ ; mapM_ (copy arr arr') [0..n-1]
+ ; primUnsafeFreezeArray arr'
+ }
+ where
+ copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
+ arrEleBottom = error "primFreezeArray: panic"
+
+primThawArray :: PrimArray a -> ST s (PrimMutableArray s a)
+primThawArray arr = do
+ { let n = primSizeArray arr
+ ; arr' <- primNewArray n arrEleBottom
+ ; mapM_ (copy arr arr') [0..n-1]
+ ; return arr'
+ }
+ where
+ copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
+ arrEleBottom = error "primFreezeArray: panic"
+#else
+newtype STArray s ix elt = STArray (MutableArray s ix elt)
+ deriving Eq
+
newSTArray ixs elt =
newArray ixs elt >>= \arr ->
return (STArray arr)
freezeSTArray (STArray arr) = freezeArray arr
unsafeFreezeSTArray (STArray arr) = unsafeFreezeArray arr
+#endif
\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1998
+%
+
+\section[Weak]{Module @PrelWeak@}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module Weak (
+ Weak, -- abstract
+ -- instance Eq (Weak v)
+
+ mkWeak, -- :: k -> v -> IO () -> IO (Weak v)
+ deRefWeak, -- :: Weak v -> IO (Maybe v)
+ -- finalise -- :: Weak v -> IO ()
+ -- replaceFinaliser -- :: Weak v -> IO () -> IO ()
+
+ mkWeakPtr, -- :: k -> IO () -> IO (Weak k)
+ mkWeakPair, -- :: k -> v -> IO () -> IO (Weak (k,v))
+ addFinaliser, -- :: key -> IO () -> IO ()
+ addForeignFinaliser -- :: ForeignObj -> IO () -> IO ()
+ ) where
+
+import PrelWeak
+import Foreign
+\end{code}
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+#else
import GlaExts
-import Ix
-import Bits
import CCall
-import Numeric (readDec, showInt)
import PrelForeign
import PrelIOBase
+import PrelAddr
+#endif
+import Ix
+import Bits
+import Numeric (readDec, showInt)
-----------------------------------------------------------------------------
-- The "official" coercion functions
mod (W8# x) (W8# y) = W8# (x `remWord#` y)
quotRem (W8# x) (W8# y) = (W8# (x `quotWord#` y), W8# (x `remWord#` y))
divMod (W8# x) (W8# y) = (W8# (x `quotWord#` y), W8# (x `remWord#` y))
- toInteger (W8# x) = word2Integer# x
+ toInteger (W8# x) = word2Integer x
toInt x = word8ToInt x
instance Ix Word8 where
pow2# :: Int# -> Int#
pow2# x# = word2Int# (shiftL# (int2Word# 1#) x#)
+word2Integer w = case word2Integer# w of
+ (# a, s, d #) -> J# a s d
+
pow2_64# :: Int# -> Int64#
pow2_64# x# = word64ToInt64# (shiftL64# (wordToWord64# (int2Word# 1#)) x#)
mod (W16# x) (W16# y) = W16# (x `remWord#` y)
quotRem (W16# x) (W16# y) = (W16# (x `quotWord#` y), W16# (x `remWord#` y))
divMod (W16# x) (W16# y) = (W16# (x `quotWord#` y), W16# (x `remWord#` y))
- toInteger (W16# x) = word2Integer# x
+ toInteger (W16# x) = word2Integer x
toInt x = word16ToInt x
instance Ix Word16 where
#if WORD_SIZE_IN_BYTES == 8
intToWord32# i# = (int2Word# i#) `and#` (int2Word# 0xffffffff)
wordToWord32# w# = w# `and#` (int2Word# 0xffffffff)
+wordToWord64# w# = w#
#else
intToWord32# i# = int2Word# i#
wordToWord32# w# = w#
mod x y = remWord32 x y
quotRem a b = (a `quotWord32` b, a `remWord32` b)
divMod x y = quotRem x y
- toInteger (W32# x) = word2Integer# x
+ toInteger (W32# x) = word2Integer x
toInt (W32# x) = I# (word2Int# x)
{-# INLINE quotWord32 #-}
instance Enum Word32 where
toEnum = intToWord32
fromEnum = word32ToInt -- lossy, don't use.
- enumFrom w = eft32 w 1
- enumFromTo w1 w2 = eftt32 w1 1 (> w2)
- enumFromThen w1 w2 = eftt32 w1 (w2 - w1) (>last)
- where
+ enumFrom w = [w .. maxBound]
+ enumFromTo w1 w2
+ | w1 > w2 = []
+ | otherwise = eft32 w1 w2
+
+ enumFromThen w1 w2 = [w1,w2 .. last]
+ where
last
| w1 < w2 = maxBound::Word32
| otherwise = minBound
-eftt32 :: Word32 -> Word32 -> (Word32->Bool) -> [Word32]
-eftt32 now step done = go now
+ enumFromThenTo w1 w2 wend = eftt32 w1 stepWith
+ where
+ diff1 = w2 - w1
+ diff2 = w1 - w2
+
+ increasing = w2 > w1
+
+ stepWith :: Word32 -> Maybe Word32
+ stepWith x
+ | increasing && x > nxt = Nothing --oflow.
+ | wend <= x = Nothing
+ | otherwise = Just nxt
+ where
+ nxt
+ | increasing = x + diff1
+ | otherwise = x - diff2
+
+eftt32 :: Word32 -> (Word32 -> Maybe Word32) -> [Word32]
+eftt32 now stepper = go now
where
- go now
- | done now = []
- | otherwise = now : go (now+step)
+ go now =
+ case stepper now of
+ Nothing -> [now]
+ Just v -> now : go v
eft32 :: Word32 -> Word32 -> [Word32]
-eft32 now step = go now
+eft32 now last = go now
where
go x
- | x == maxBound = [x]
- | otherwise = x:go (x+step)
+ | x == last = [x]
+ | otherwise = x:go (x+1)
instance Read Word32 where
readsPrec p = readDec
\begin{code}
#if WORD_SIZE_IN_BYTES == 8
-data Word64 = W64# Word#
+--data Word64 = W64# Word#
word32ToWord64 :: Word32 -> Word64
word32ToWord64 (W32 w#) = W64# w#
word64ToWord32 (W64# w#) = W32# (word64ToWord# w#)
word64ToInteger :: Word64 -> Integer
-word64ToInteger (W64# w#) = word64ToInteger# w#
+word64ToInteger (W64# w#) =
+ case word64ToInteger# w# of
+ (# a#, s#, p# #) -> J# a# s# p#
word64ToInt :: Word64 -> Int
word64ToInt w =
\begin{code}
readWord8OffAddr :: Addr -> Int -> IO Word8
-readWord8OffAddr a i = _casm_ `` %r=(StgWord8)(((StgWord8*)%0)[(StgInt)%1]); '' a i
+readWord8OffAddr a i = _casm_ `` %r=(StgNat8)(((StgNat8*)%0)[(StgInt)%1]); '' a i
readWord16OffAddr :: Addr -> Int -> IO Word16
-readWord16OffAddr a i = _casm_ `` %r=(StgWord16)(((StgWord16*)%0)[(StgInt)%1]); '' a i
+readWord16OffAddr a i = _casm_ `` %r=(StgNat16)(((StgNat16*)%0)[(StgInt)%1]); '' a i
readWord32OffAddr :: Addr -> Int -> IO Word32
-readWord32OffAddr a i = _casm_ `` %r=(StgWord32)(((StgWord32*)%0)[(StgInt)%1]); '' a i
+readWord32OffAddr a i = _casm_ `` %r=(StgNat32)(((StgNat32*)%0)[(StgInt)%1]); '' a i
readWord64OffAddr :: Addr -> Int -> IO Word64
#if WORD_SIZE_IN_BYTES==8
readWord64OffAddr a i = _casm_ `` %r=(StgWord)(((StgWord*)%0)[(StgInt)%1]); '' a i
#else
-readWord64OffAddr a i = _casm_ `` %r=(StgWord64)(((StgWord64*)%0)[(StgInt)%1]); '' a i
+readWord64OffAddr a i = _casm_ `` %r=(StgNat64)(((StgNat64*)%0)[(StgInt)%1]); '' a i
#endif
#ifndef __PARALLEL_HASKELL__
readWord8OffForeignObj :: ForeignObj -> Int -> IO Word8
-readWord8OffForeignObj fo i = _casm_ `` %r=(StgWord8)(((StgWord8*)%0)[(StgInt)%1]); '' fo i
+readWord8OffForeignObj fo i = _casm_ `` %r=(StgNat8)(((StgNat8*)%0)[(StgInt)%1]); '' fo i
readWord16OffForeignObj :: ForeignObj -> Int -> IO Word16
-readWord16OffForeignObj fo i = _casm_ `` %r=(StgWord16)(((StgWord16*)%0)[(StgInt)%1]); '' fo i
+readWord16OffForeignObj fo i = _casm_ `` %r=(StgNat16)(((StgNat16*)%0)[(StgInt)%1]); '' fo i
readWord32OffForeignObj :: ForeignObj -> Int -> IO Word32
-readWord32OffForeignObj fo i = _casm_ `` %r=(StgWord32)(((StgWord32*)%0)[(StgInt)%1]); '' fo i
+readWord32OffForeignObj fo i = _casm_ `` %r=(StgNat32)(((StgNat32*)%0)[(StgInt)%1]); '' fo i
readWord64OffForeignObj :: ForeignObj -> Int -> IO Word64
#if WORD_SIZE_IN_BYTES==8
readWord64OffForeignObj fo i = _casm_ `` %r=(StgWord)(((StgWord*)%0)[(StgInt)%1]); '' fo i
#else
-readWord64OffForeignObj fo i = _casm_ `` %r=(StgWord64)(((StgWord64*)%0)[(StgInt)%1]); '' fo i
+readWord64OffForeignObj fo i = _casm_ `` %r=(StgNat64)(((StgNat64*)%0)[(StgInt)%1]); '' fo i
#endif
#endif
\begin{code}
writeWord8OffAddr :: Addr -> Int -> Word8 -> IO ()
writeWord8OffAddr (A# a#) (I# i#) (W8# w#) = IO $ \ s# ->
- case (writeCharOffAddr# a# i# (chr# (word2Int# w#)) s#) of s2# -> IOok s2# ()
+ case (writeCharOffAddr# a# i# (chr# (word2Int# w#)) s#) of s2# -> (# s2#, () #)
writeWord16OffAddr :: Addr -> Int -> Word16 -> IO ()
-writeWord16OffAddr a i e = _casm_ `` (((StgWord16*)%0)[(StgInt)%1])=(StgWord16)%2; '' a i e
+writeWord16OffAddr a i e = _casm_ `` (((StgNat16*)%0)[(StgInt)%1])=(StgNat16)%2; '' a i e
writeWord32OffAddr :: Addr -> Int -> Word32 -> IO ()
writeWord32OffAddr (A# a#) i@(I# i#) (W32# w#) = IO $ \ s# ->
- case (writeWordOffAddr# a# i'# w# s#) of s2# -> IOok s2# ()
+ case (writeWordOffAddr# a# i'# w# s#) of s2# -> (# s2#, () #)
where
-- adjust index to be in Word units, not Word32 ones.
(I# i'#)
writeWord64OffAddr :: Addr -> Int -> Word64 -> IO ()
#if WORD_SIZE_IN_BYTES==8
writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# ->
- case (writeWordOffAddr# a# i# w# s#) of s2# -> IOok s2# ()
+ case (writeWordOffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
#else
writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# ->
- case (writeWord64OffAddr# a# i# w# s#) of s2# -> IOok s2# ()
+ case (writeWord64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
#endif
#ifndef __PARALLEL_HASKELL__
writeWord8OffForeignObj :: ForeignObj -> Int -> Word8 -> IO ()
-writeWord8OffForeignObj fo i w = _casm_ `` (((StgWord16*)%0)[(StgInt)%1])=(StgWord16)%2; '' fo i w
+writeWord8OffForeignObj fo i w = _casm_ `` (((StgNat16*)%0)[(StgInt)%1])=(StgNat16)%2; '' fo i w
writeWord16OffForeignObj :: ForeignObj -> Int -> Word16 -> IO ()
-writeWord16OffForeignObj fo i w = _casm_ `` (((StgWord16*)%0)[(StgInt)%1])=(StgWord16)%2; '' fo i w
+writeWord16OffForeignObj fo i w = _casm_ `` (((StgNat16*)%0)[(StgInt)%1])=(StgNat16)%2; '' fo i w
writeWord32OffForeignObj :: ForeignObj -> Int -> Word32 -> IO ()
-writeWord32OffForeignObj fo i w = _casm_ `` (((StgWord16*)%0)[(StgInt)%1])=(StgWord16)%2; '' fo i' w
+writeWord32OffForeignObj fo i w = _casm_ `` (((StgNat16*)%0)[(StgInt)%1])=(StgNat16)%2; '' fo i' w
where
-- adjust index to be in Word units, not Word32 ones.
i'
#endif
writeWord64OffForeignObj :: ForeignObj -> Int -> Word64 -> IO ()
-#if WORD_SIZE_IN_BYTES==8
+# if WORD_SIZE_IN_BYTES==8
writeWord64OffForeignObj fo i e = _casm_ `` (((StgWord*)%0)[(StgInt)%1])=(StgWord)%2; '' fo i e
-#else
-writeWord64OffForeignObj fo i e = _casm_ `` (((StgWord64*)%0)[(StgInt)%1])=(StgWord64)%2; '' fo i e
-#endif
+# else
+writeWord64OffForeignObj fo i e = _casm_ `` (((StgNat64*)%0)[(StgInt)%1])=(StgNat64)%2; '' fo i e
+# endif
#endif
%
\section[BSD]{Misc BSD bindings}
-The @BSD@ module defines Haskell bindings to network programming
-functionality that is only provided by BSD-style APIs.
+The @BSD@ module defines Haskell bindings to functionality
+provided by BSD Unix derivatives. Currently this covers
+network programming functionality and symbolic links.
+(OK, so the latter is pretty much supported by most *nixes
+today, but it was BSD that introduced them.)
\begin{code}
-{-# OPTIONS -#include "cbits/ghcSockets.h" #-}
+{-# OPTIONS -#include "cbits/ghcSockets.h" -#include "stgio.h" #-}
#include "config.h"
NetworkName,
NetworkAddr,
- NetworkEntry(..),
+ NetworkEntry(..)
#ifndef cygwin32_TARGET_OS
- getNetworkByName, -- :: NetworkName -> IO NetworkEntry
- getNetworkByAddr, -- :: NetworkAddr -> Family -> IO NetworkEntry
- setNetworkEntry, -- :: Bool -> IO ()
- getNetworkEntry, -- :: IO NetworkEntry
- endNetworkEntry, -- :: IO ()
- getNetworkEntries -- :: Bool -> IO [NetworkEntry]
+ , getNetworkByName -- :: NetworkName -> IO NetworkEntry
+ , getNetworkByAddr -- :: NetworkAddr -> Family -> IO NetworkEntry
+ , setNetworkEntry -- :: Bool -> IO ()
+ , getNetworkEntry -- :: IO NetworkEntry
+ , endNetworkEntry -- :: IO ()
+ , getNetworkEntries -- :: Bool -> IO [NetworkEntry]
#endif
+
+#ifdef HAVE_SYMLINK
+ , symlink -- :: String -> String -> IO ()
+#endif
+#ifdef HAVE_READLINK
+ , readlink -- :: String -> IO String
+#endif
+
) where
import Foreign
import Addr
-import CString ( unpackCStringIO, unpackCStringBA, unvectorize )
+import CString ( unpackCStringIO, unpackCStringBA, unvectorize, unpackNBytesBA )
import SocketPrim
\end{code}
getHostName = do
ptr <- stToIO (newCharArray (0,256))
rc <- _casm_ ``%r=gethostname(%0, 256);'' ptr
- ba <- stToIO (unsafeFreezeByteArray ptr)
if rc == -1
then fail (userError "getHostName: unable to determine host name")
else do
+ ba <- stToIO (unsafeFreezeByteArray ptr)
return (unpackCStringBA ba)
\end{code}
\end{code}
+
+%***************************************************************************
+%* *
+\subsection[BSD-symlink]{Symbolic links}
+%* *
+%***************************************************************************
+
+
+\begin{code}
+#ifdef HAVE_SYMLINK
+symlink :: String -> String -> IO ()
+symlink actual_path sym_path = do
+ rc <- _ccall_ symlink actual_path sym_path
+ if rc == 0 then
+ return ()
+ else do
+ _ccall_ convertErrno
+ cstr <- _ccall_ getErrStr__
+ estr <- unpackCStringIO cstr
+ fail (userError ("BSD.symlink: " ++ estr))
+#endif
+
+#ifdef HAVE_READLINK
+readlink :: String -> IO String
+readlink sym = do
+ mbuf <- stToIO (newCharArray (0, path_max))
+ buf <- stToIO (unsafeFreezeByteArray mbuf)
+ rc <- _ccall_ readlink sym buf (path_max + 1)
+ if rc /= -1 then
+ return (unpackNBytesBA buf rc)
+ else do
+ _ccall_ convertErrno
+ cstr <- _ccall_ getErrStr__
+ estr <- unpackCStringIO cstr
+ fail (userError ("BSD.readlink: " ++ estr))
+ where
+ path_max = (``PATH_MAX''::Int)
+#endif
+
+\end{code}
-}
\begin{code}
+{-# OPTIONS -#include "cbits/ByteOps.h" #-}
+
module ByteOps (
longToBytes,
intToBytes,
import PrelPack
import GlaExts
import Addr
-import PrelIOBase ( IO(..), IOResult(..))
-import PrelArr ( StateAndMutableByteArray#(..),
- StateAndByteArray#(..)
- )
+import PrelIOBase ( IO(..) )
\end{code}
allocChars :: Int -> IO (MutableByteArray RealWorld Int)
allocChars (I# size#) = IO $ \ s# ->
case newCharArray# size# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray (I# 1#, I# size#) barr#)
+ (# s2#, barr# #) ->
+ (# s2#, (MutableByteArray (I# 1#, I# size#) barr#) #)
allocWords :: Int -> IO (MutableByteArray RealWorld Int)
allocWords (I# size#) = IO $ \ s# ->
case newIntArray# size# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray (I# 1#, I# size#) barr#)
+ (# s2#, barr# #) ->
+ (# s2#, (MutableByteArray (I# 1#, I# size#) barr#) #)
-- Freeze these index-free mutable arrays
freeze :: MutableByteArray RealWorld Int -> IO (ByteArray Int)
freeze (MutableByteArray ixs arr#) = IO $ \ s# ->
case unsafeFreezeByteArray# arr# s# of
- StateAndByteArray# s2# frozen# ->
- IOok s2# (ByteArray ixs frozen#)
+ (# s2#, frozen# #) ->
+ (# s2#, (ByteArray ixs frozen#) #)
-- Copy a null-terminated string from outside the heap to
-- Haskellized nonsense inside the heap
-# $Id: Makefile,v 1.9 1998/08/11 21:40:34 sof Exp $
+# $Id: Makefile,v 1.10 1998/12/02 13:26:38 simonm Exp $
#
# Makefile for miscellaneous libraries.
#
#
# Specific flags
#
-BSD_HC_OPTS += -optc-DNON_POSIX_SOURCE
-Socket_HC_OPTS += -I../std/cbits -syslib posix -optc-DNON_POSIX_SOURCE
-SocketPrim_HC_OPTS += -I../std/cbits -H10m -optc-DNON_POSIX_SOURCE
+BSD_HC_OPTS += -I../std/cbits -optc-DNON_POSIX_SOURCE
+Socket_HC_OPTS += -I../std/cbits -optc-DNON_POSIX_SOURCE
+SocketPrim_HC_OPTS += -I../std/cbits -H10m -optc-DNON_POSIX_SOURCE
+PackedString_HC_OPTS += -H12m
#-----------------------------------------------------------------------------
# Dependency generation
Glorious hacking (all the hard work) by Bryan O'Sullivan.
\begin{code}
+{-# OPTIONS -#include "cbits/PackedString.h" #-}
+
module PackedString (
PackedString, -- abstract
)
import Addr
-import PrelArr ( StateAndMutableByteArray#(..) , StateAndByteArray#(..) )
import PrelST
import ST
import IOExts ( unsafePerformIO )
import GlaExts
import ST
import Ix
+import Weak ( addForeignFinaliser )
import PrelIOBase -- IOError, Handle representation
import PrelHandle
import Foreign
deriving ( Eq )
instance Show PortNumber where
- showsPrec p (PNum pn) = showsPrec p pn_host
- where
- pn_host :: Int
- pn_host = unsafePerformIO (_casm_ ``%r=(int)ntohs((int)%0); '' pn)
-
+ showsPrec p pn = showsPrec p (ntohs pn)
mkPortNumber :: Int -> PortNumber
mkPortNumber v = unsafePerformIO $ do
po <- _casm_ ``%r=(int)htons((int)%0); '' v
return (PNum po)
+ntohs :: PortNumber -> Int
+ntohs (PNum po) = unsafePerformIO (_casm_ ``%r=(int)ntohs((int)%0); '' po)
+
+instance Num PortNumber where
+ fromInt i = mkPortNumber i
+ fromInteger i = fromInt (fromInteger i)
+ -- for completeness.
+ (+) x y = mkPortNumber (ntohs x + ntohs y)
+ (-) x y = mkPortNumber (ntohs x - ntohs y)
+ negate x = mkPortNumber (-ntohs x)
+ (*) x y = mkPortNumber (ntohs x * ntohs y)
+ abs n = mkPortNumber (abs (ntohs n))
+ signum n = mkPortNumber (signum (ntohs n))
+
data SockAddr -- C Names
#ifndef cygwin32_TARGET_OS
= SockAddrUnix -- struct sockaddr_un
#endif
-#if freebsd_TARGET_OS
+#if freebsd2_TARGET_OS || freebsd3_TARGET_OS
data Family =
AF_UNSPEC -- unspecified
-- Alpha running OSF or a SPARC with SunOS, rather than Solaris.
#if osf1_TARGET_OS || osf3_TARGET_OS || sunos4_TARGET_OS || hpux_TARGET_OS || \
- aix_TARGET_OS || freebsd_TARGET_OS
+ aix_TARGET_OS || freebsd2_TARGET_OS || freebsd3_TARGET_OS
data SocketType =
Stream
| Datagram
socketToHandle (MkSocket fd family stype protocol status) m = do
fo <- _ccall_ openFd fd file_mode flush_on_close
- fo <- makeForeignObj fo (``&freeFileObject'' :: Addr)
+ fo <- makeForeignObj fo
+ addForeignFinaliser fo (freeFileObject fo)
mkBuffer__ fo 0 -- not buffered
hndl <- newHandle (Handle__ fo htype NoBuffering socket_str)
return hndl
\begin{code}
#endif /* 0 */
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ByteOps.h"
#if __STDC__
/* need the ANSI arg decl, so "short" and "float" args dont get promoted */
#define X2BYTES(type) \
I_ \
-CAT2(type,2bytes__)(type in, unsigned char *arr)\
+type##2bytes(type in, unsigned char *arr) \
{ \
union { \
type i; \
#else /* not STDC */
#define X2BYTES(type) \
I_ \
-CAT2(type,2bytes__)(in, arr) \
- type in; \
- unsigned char *arr; \
+type##2bytes(type in, unsigned char *arr) \
{ \
union { \
type i; \
#define BYTES2X(ctype,htype) \
I_ \
-CAT3(bytes2,ctype,__)(P_ in, htype *out) \
+bytes2##ctype##__(P_ in, htype *out) \
{ \
union { \
ctype i; \
return(sizeof (ctype)); \
}
-static STG_INLINE
-void
-assign_flt(W_ p_dest[], StgFloat src)
-{
- float_thing y;
- y.f = src;
- *p_dest = y.fu;
-}
-
-
-static STG_INLINE
-void
-assign_dbl(W_ p_dest[], StgDouble src)
-{
- double_thing y;
- y.d = src;
- p_dest[0] = y.du.dhi;
- p_dest[1] = y.du.dlo;
-}
-
#define BYTES2FX(ctype,htype,assign_fx) \
I_ \
-CAT3(bytes2,ctype,__)(P_ in, htype *out) \
+bytes2##ctype##__(P_ in, htype *out) \
{ \
union { \
ctype i; \
for (k = 0; k < sizeof(ctype); k++) \
u.cs[k] = arr[k]; \
\
- assign_fx(out, (htype) u.i); \
+ assign_fx((P_)out, (htype) u.i); \
\
return(sizeof (ctype)); \
}
BYTES2X(int,I_)
BYTES2X(short,I_)
-BYTES2FX(float,StgFloat,assign_flt)
-BYTES2FX(double,StgDouble,assign_dbl)
+BYTES2FX(float,StgFloat,ASSIGN_FLT)
+BYTES2FX(double,StgDouble,ASSIGN_DBL)
/* "Native" support */
/* sigh again: without these some (notably "float") willnae work */
-I_ long2bytes__ PROTO((long, unsigned char *));
-I_ int2bytes__ PROTO((int, unsigned char *));
-I_ short2bytes__ PROTO((short, unsigned char *));
-I_ float2bytes__ PROTO((float, unsigned char *));
-I_ double2bytes__ PROTO((double, unsigned char *));
+I_ long2bytes__ (long, unsigned char *);
+I_ int2bytes__ (int, unsigned char *);
+I_ short2bytes__ (short, unsigned char *);
+I_ float2bytes__ (float, unsigned char *);
+I_ double2bytes__ (double, unsigned char *);
-I_ bytes2long__ PROTO((P_, I_ *));
-I_ bytes2int__ PROTO((P_, I_ *));
-I_ bytes2short__ PROTO((P_, I_ *));
-I_ bytes2float__ PROTO((P_, StgFloat *));
-I_ bytes2double__ PROTO((P_, StgDouble *));
+I_ bytes2long__ (P_, I_ *);
+I_ bytes2int__ (P_, I_ *);
+I_ bytes2short__ (P_, I_ *);
+I_ bytes2float__ (P_, StgFloat *);
+I_ bytes2double__ (P_, StgDouble *);
#endif
C_SRCS=$(wildcard *.c)
# Remove Readline.lhs if readline.h isn't available.
-ifneq "$(GhcLibsWithReadline)" "YES"
+ifneq "$(HAVE_READLINE)" "YES"
C_SRCS := $(filter-out ghcReadline.c,$(C_SRCS))
endif
SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
-SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR)
+SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR) -I$(GHC_LIB_DIR)/std/cbits
LIBRARY=libHSmisc_cbits.a
LIBOBJS=$(C_OBJS)
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: PackedString.c,v 1.2 1998/12/02 13:26:41 simonm Exp $
+ *
+ * PackedString C bits
+ *
+ * (c) The GHC Team 1998
+ * -------------------------------------------------------------------------- */
+
+#include "Rts.h"
+
+StgInt
+byteArrayHasNUL__ (StgByteArray ba, StgInt len)
+{
+ StgInt i;
+
+ for (i = 0; i < len; i++) {
+ if (*(ba + i) == '\0') {
+ return(1); /* true */
+ }
+ }
+
+ return(0); /* false */
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: PackedString.h,v 1.2 1998/12/02 13:26:42 simonm Exp $
+ *
+ * PackedString C bits
+ *
+ * (c) The GHC Team 1998
+ * -------------------------------------------------------------------------- */
+
+extern StgInt byteArrayHasNUL__ (StgByteArray ba, StgInt len);
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
acceptSocket(I_ sockfd, A_ peer, A_ addrlen)
while ((fd = accept((int)sockfd, (struct sockaddr *)peer, (int *)addrlen)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address not in writeable part of user address space";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor not a socket";
+ break;
+ case GHC_EOPNOTSUPP:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not of type that supports listen";
+ break;
+ case GHC_EWOULDBLOCK:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "No sockets are present to be accepted";
+ break;
+ }
return -1;
}
}
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
bindSocket(I_ sockfd, A_ myaddr, I_ addrlen, I_ isUnixDomain)
while ((rc = bind((int)sockfd, (struct sockaddr *)myaddr, (int)addrlen)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ if (isUnixDomain != 0)
+ ghc_errstr = "For a component of path prefix of path name";
+ else
+ ghc_errstr = "Requested address protected, cannot bind socket";
+ break;
+ case GHC_EISCONN:
+ case GHC_EADDRINUSE:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "Address already in use";
+ break;
+ case GHC_EADDRNOTAVAIL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Address not available from local machine";
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid socket file descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address not in valid part of user address space";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Specified size of structure not equal valid address for family";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Descriptor for file, not a socket";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Could not make directory entry or alloc inode";
+ break;
+ case GHC_EISDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "A null path name was given";
+ break;
+ case GHC_ELOOP:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Too many symbolic links encountered";
+ break;
+ case GHC_ENAMETOOLONG:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Max length of path name exceeded";
+ break;
+ case GHC_ENOENT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix does not exist";
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix is not a directory";
+ break;
+ case GHC_EROFS:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "The inode would reside on read only file system";
+ break;
+ }
return -1;
}
}
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
-connectSocket(sockfd, servaddr, addrlen, isUnixDomain)
-StgInt sockfd;
-StgAddr servaddr;
-StgInt addrlen;
-StgInt isUnixDomain;
+connectSocket(I_ sockfd, A_ servaddr, I_ addrlen, I_ isUnixDomain)
{
int rc;
while ((rc = connect((int)sockfd, (struct sockaddr *)servaddr, (int)addrlen)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ if (isUnixDomain != 0)
+ ghc_errstr = "For a component of path prefix of path name";
+ else
+ ghc_errstr = "Requested address protected, cannot bind socket";
+ break;
+ case GHC_EISCONN:
+ case GHC_EADDRINUSE:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "Address already in use";
+ break;
+ case GHC_EADDRNOTAVAIL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Address not available from local machine";
+ break;
+ case GHC_EAFNOSUPPORT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address cannot be used with socket";
+ break;
+ case GHC_EINPROGRESS:
+ case GHC_EALREADY:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "Non-blocking socket, previous connection attempt not completed";
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid socket file descriptor";
+ break;
+ case GHC_ECONNREFUSED:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Connection rejected";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address not in valid part of process address space";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Specified size of structure not equal valid address for family";
+ break;
+ break;
+ case GHC_ENETUNREACH:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Network not reachable from host";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Descriptor for file, not a socket";
+ break;
+ case GHC_ETIMEDOUT:
+ ghc_errtype = ERR_TIMEEXPIRED;
+ ghc_errstr = "Connection attempt timed out";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Could not make directory entry or alloc inode";
+ break;
+ case GHC_EISDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "A null path name was given";
+ break;
+ case GHC_ELOOP:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Too many symbolic links encountered";
+ break;
+ case GHC_ENAMETOOLONG:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Max length of path name exceeded";
+ break;
+ case GHC_ENOENT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix does not exist";
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix is not a directory";
+ break;
+ case GHC_EPROTOTYPE:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "File referred to is a socket of differing type";
+ break;
+ }
return -1;
}
}
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
createSocket(I_ family, I_ type, I_ protocol)
if ((fd = socket((int)family, (int)type, (int)protocol)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
- return -1;
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "cannot create socket";
+ break;
+ case GHC_EMFILE:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Too many open files";
+ break;
+ case GHC_ENFILE:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "System file table overflow";
+ break;
+ case GHC_EPROTONOSUPPORT:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "Protocol type not supported";
+ break;
+ case GHC_EPROTOTYPE:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Protocol wrong type for socket";
+ break;
+ }
+ return (StgInt)-1;
}
}
- return fd;
+ return (StgInt)fd;
}
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
getPeerName(I_ sockfd, A_ peer, A_ namelen)
while ((name = getpeername((int) sockfd, (struct sockaddr *) peer, (int *) namelen)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data not in writeable part of user address space";
+ break;
+ case GHC_ENOBUFS:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Insuffcient resources";
+ break;
+ case GHC_ENOTCONN:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not connected";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor is not a socket";
+ break;
+ }
return -1;
}
}
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
getSockName(I_ sockfd, A_ peer, A_ namelen)
while ((name = getsockname((int) sockfd, (struct sockaddr *) peer, (int *) namelen)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data not in writeable part of user address space";
+ break;
+ case GHC_ENOBUFS:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Insuffcient resources";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor is not a socket";
+ break;
+ }
return -1;
}
}
#include "config.h"
#if HAVE_READLINE_READLINE_H
-#include "readline/readline.h"
+#include <readline/readline.h>
+#include <readline/history.h>
#endif
/* For some reason the following 3 aren't defined in readline.h */
/* Our C Hackery stuff for Callbacks */
typedef I_ KeyCode;
extern StgStablePtr cbackList;
-I_ genericRlCback PROTO((I_, I_));
+I_ genericRlCback (I_, I_);
extern StgStablePtr haskellRlEntry;
extern I_ current_narg, rl_return;
extern KeyCode current_kc;
#include <netinet/in.h>
#include <arpa/inet.h>
#include <stdio.h>
+#include <limits.h>
#ifdef HAVE_STDLIB_H
# include <stdlib.h>
#endif
/* acceptSocket.lc */
-StgInt acceptSocket PROTO((StgInt, StgAddr, StgAddr));
+StgInt acceptSocket (StgInt, StgAddr, StgAddr);
/* bindSocket.lc */
-StgInt bindSocket PROTO((StgInt, StgAddr, StgInt, StgInt));
+StgInt bindSocket (StgInt, StgAddr, StgInt, StgInt);
/* connectSocket.lc */
-StgInt connectSocket PROTO((StgInt, StgAddr, StgInt, StgInt));
+StgInt connectSocket (StgInt, StgAddr, StgInt, StgInt);
/* createSocket.lc */
-StgInt createSocket PROTO((StgInt, StgInt, StgInt));
+StgInt createSocket (StgInt, StgInt, StgInt);
/* getSockName.lc */
-StgInt getSockName PROTO((StgInt, StgAddr, StgAddr));
+StgInt getSockName (StgInt, StgAddr, StgAddr);
/* getPeerName.lc */
-StgInt getPeerName PROTO((StgInt, StgAddr, StgAddr));
+StgInt getPeerName (StgInt, StgAddr, StgAddr);
/* listenSocket.lc */
-StgInt listenSocket PROTO((StgInt, StgInt));
+StgInt listenSocket (StgInt, StgInt);
/* shutdownSocket.lc */
-StgInt shutdownSocket PROTO((StgInt, StgInt));
+StgInt shutdownSocket (StgInt, StgInt);
/* readDescriptor.lc */
-StgInt readDescriptor PROTO((StgInt, StgAddr, StgInt));
+StgInt readDescriptor (StgInt, StgAddr, StgInt);
/* recvFrom.c */
-StgInt recvFrom__ PROTO((StgInt, StgAddr, StgInt, StgAddr));
+StgInt recvFrom__ (StgInt, StgAddr, StgInt, StgAddr);
/* sendTo.c */
-StgInt sendTo__ PROTO((StgInt, StgAddr, StgInt, StgAddr, StgInt));
+StgInt sendTo__ (StgInt, StgAddr, StgInt, StgAddr, StgInt);
/* socketOpt.c */
-StgInt getSocketOption__ PROTO((StgInt, StgInt));
-StgInt setSocketOption__ PROTO((StgInt, StgInt, StgInt));
+StgInt getSocketOption__ (StgInt, StgInt);
+StgInt setSocketOption__ (StgInt, StgInt, StgInt);
/* writeDescriptor.lc */
-StgInt writeDescriptor PROTO((StgInt, StgAddr, StgInt));
+StgInt writeDescriptor (StgInt, StgAddr, StgInt);
#endif /* !GHC_SOCKETS_H */
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
listenSocket(I_ sockfd, I_ backlog)
while ((rc = listen((int) sockfd, (int) backlog)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid descriptor";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor not a socket";
+ break;
+ case GHC_EOPNOTSUPP:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not of type that supports listen";
+ break;
+ }
return -1;
}
}
* will fill a supplied 16-byte array with the digest.
*/
+#include <string.h>
+
typedef unsigned long word32;
typedef unsigned char byte;
t = 64 - (t & 0x3f); /* Space available in ctx->in (at least 1) */
if ((unsigned)t > len) {
- bcopy(buf, (byte *)ctx->in + 64 - (unsigned)t, len);
+ memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, len);
return;
}
/* First chunk is an odd size */
- bcopy(buf,(byte *)ctx->in + 64 - (unsigned)t, (unsigned)t);
+ memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, (unsigned)t);
byteSwap(ctx->in, 16);
MD5Transform(ctx->buf, ctx->in);
buf += (unsigned)t;
/* Process data in 64-byte chunks */
while (len >= 64) {
- bcopy(buf, ctx->in, 64);
+ memcpy(ctx->in, buf, 64);
byteSwap(ctx->in, 16);
MD5Transform(ctx->buf, ctx->in);
buf += 64;
}
/* Handle any remaining bytes of data. */
- bcopy(buf, ctx->in, len);
+ memcpy(ctx->in, buf, len);
}
/*
count = 56 - 1 - count;
if (count < 0) { /* Padding forces an extra block */
- bzero(p, count+8);
+ memset(p, 0, count+8);
byteSwap(ctx->in, 16);
MD5Transform(ctx->buf, ctx->in);
p = (byte *)ctx->in;
count = 56;
}
- bzero(p, count+8);
+ memset(p, 0, count+8);
byteSwap(ctx->in, 14);
/* Append length in bits and transform */
MD5Transform(ctx->buf, ctx->in);
byteSwap(ctx->buf, 4);
- bcopy(ctx->buf, digest, 16);
- bzero(ctx,sizeof(ctx));
+ memcpy(digest, ctx->buf, 16);
+ memset(ctx,0,sizeof(ctx));
}
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
readDescriptor(I_ fd, A_ buf, I_ nbytes)
while ((sucked = read((int) fd, (char *) buf, (int) nbytes)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EBADMSG:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Message waiting to be read is not a data message";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data buffer not in writeable part of user address space";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Seek pointer associated with descriptor negative";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "I/O error occurred while writing to file system";
+ break;
+ case GHC_EISDIR:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Descriptor refers to a directory";
+ break;
+ case GHC_EAGAIN:
+ case GHC_EWOULDBLOCK:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "No data could be written immediately";
+ break;
+ }
return -1;
}
}
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\subsection[recvFrom.lc]{recvFrom run-time support}
-
-\begin{code}
-#endif
+/* -----------------------------------------------------------------------------
+ * $Id: recvFrom.c,v 1.3 1998/12/02 13:26:46 simonm Exp $
+ *
+ * recvFrom run-time support
+ *
+ * (c) The GHC Team 1998
+ * -------------------------------------------------------------------------- */
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
-recvFrom__(fd, buf, nbytes, from)
-StgInt fd;
-StgAddr buf;
-StgInt nbytes;
-StgAddr from;
+recvFrom__(StgInt fd, StgAddr buf, StgInt nbytes, StgAddr from)
{
StgInt count;
int sz;
-#if 0
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\subsection[sendTo.c]{sendTo run-time support}
-
-\begin{code}
-#endif
+/* -----------------------------------------------------------------------------
+ * $Id: sendTo.c,v 1.3 1998/12/02 13:26:46 simonm Exp $
+ *
+ * sendTo run-time support
+ *
+ * (c) The GHC Team 1998
+ * -------------------------------------------------------------------------- */
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
-sendTo__(fd, buf, nbytes, to, sz)
-StgInt fd;
-StgAddr buf;
-StgInt nbytes;
-StgAddr to;
-StgInt sz;
+sendTo__(StgInt fd, StgAddr buf, StgInt nbytes, StgAddr to, StgInt sz)
{
StgInt count;
int flags = 0;
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
shutdownSocket(I_ sockfd, I_ how)
while ((rc = shutdown((int) sockfd, (int) how)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_ENOTCONN:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not connected";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor is not a socket";
+ break;
+ }
return -1;
}
}
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
getSocketOption__ (fd, opt)
#endif
#define NON_POSIX_SOURCE
-#include "rtsdefs.h"
+#include "Rts.h"
#include "ghcSockets.h"
+#include "stgio.h"
StgInt
writeDescriptor(I_ fd, A_ buf, I_ nbytes)
while ((dumped = write((int) fd, (char *) buf, (int) nbytes)) < 0) {
if (errno != EINTR) {
cvtErrno();
- stdErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EDQUOT:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Disk quota exhausted";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data not in writeable part of user address space";
+ break;
+ case GHC_EFBIG:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Maximum process or system file size exceeded";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Seek pointer associated with descriptor negative";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "I/O error occurred while writing to file system";
+ break;
+ case GHC_ENOSPC:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "No space left on device";
+ break;
+ case GHC_ENXIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Hangup occurred";
+ break;
+ case GHC_EPIPE:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Write to not read pipe/unconnected socket caught";
+ break;
+ case GHC_ERANGE:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Too much or too little written to descriptor";
+ break;
+ case GHC_EAGAIN:
+ case GHC_EWOULDBLOCK:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "No data could be written immediately";
+ break;
+ }
return -1;
}
}
-# $Id: Makefile,v 1.4 1998/04/16 12:50:44 sof Exp $
+#
+# $Id: Makefile,v 1.5 1998/12/02 13:26:49 simonm Exp $
#
# Makefile for POSIX library
#
PosixTTY_HC_OPTS ='-\#include"cbits/libposix.h"' -monly-2-regs
Posix_HC_OPTS ='-\#include"cbits/libposix.h"'
+# sigh.
+../misc/PackedString_HC_OPTS += -H8m
+
#-----------------------------------------------------------------------------
# Dependency generation
import GlaExts
import PrelIOBase
-import PrelHandle (readHandle, writeHandle, newHandle, getBMode__, getHandleFd )
+import PrelHandle (newHandle, getBMode__, getHandleFd,
+ freeFileObject, freeStdFileObject )
import IO
import Addr
import Foreign
+import Weak ( addForeignFinaliser )
import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO )
import PosixUtil
(or as a result of) program termination.
-}
#ifndef __PARALLEL_HASKELL__
- fo <-
- (if fd == stdInput || fd == stdOutput || fd == stdError then
- makeForeignObj fo (``&freeStdFile''::Addr)
- else
- makeForeignObj fo (``&freeFileObject''::Addr))
+ fo <- makeForeignObj fo
+ if fd == stdInput || fd == stdOutput || fd == stdError then
+ addForeignFinaliser fo (freeStdFileObject fo)
+ else
+ addForeignFinaliser fo (freeFileObject fo)
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
addSignal :: Signal -> SignalSet -> SignalSet
addSignal int oldset = unsafePerformPrimIO $ do
bytes <- allocChars sigSetSize
- _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
- (void) sigaddset((sigset_t *)%0, %2);''
- bytes oldset int
+ _ccall_ stg_sigaddset bytes oldset int
freeze bytes
inSignalSet :: Signal -> SignalSet -> Bool
deleteSignal :: Signal -> SignalSet -> SignalSet
deleteSignal int oldset = unsafePerformPrimIO $ do
bytes <- allocChars sigSetSize
- _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
- (void) sigdelset((sigset_t *)%0, %2);''
- bytes oldset int
+ _ccall_ stg_sigdelset bytes oldset int
freeze bytes
installHandler :: Signal
import GlaExts
import PrelIOBase -- IOError representation
-
\end{code}
First, all of the major Posix data types, to avoid any recursive dependencies
/*
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
-%
-\subsection[env.lc]{Environment Handling for LibPosix}
-
-Many useful environment functions are not necessarily provided by libc.
-To get around this problem, we introduce our own. The first time that
-you modify your environment, we copy the environment wholesale into
-malloc'ed locations, so that subsequent modifications can do proper
-memory management. The $environ$ variable is updated with a pointer
-to the current environment so that the normal $getenv$ and $exec*$ functions
-should continue to work properly.
-
-\begin{code}
-*/
-
-#include "rtsdefs.h"
+ * (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
+ *
+ * \subsection[env.lc]{Environment Handling for LibPosix}
+ *
+ * Many useful environment functions are not necessarily provided by libc.
+ * To get around this problem, we introduce our own. The first time that
+ * you modify your environment, we copy the environment wholesale into
+ * malloc'ed locations, so that subsequent modifications can do proper
+ * memory management. The $environ$ variable is updated with a pointer
+ * to the current environment so that the normal $getenv$ and $exec*$ functions
+ * should continue to work properly.
+ */
+
+#include "Rts.h"
#include "libposix.h"
/* Switch this on once we've moved the environment to the malloc arena */
#define NON_POSIX_SOURCE
#endif
-#include "rtsdefs.h"
+#include "Rts.h"
#include "libposix.h"
/*
#define _POSIX_VDISABLE '\0' /* Just a guess...but it works for Suns */
#endif
-/* For PosixIO only (finaliser for (FILE *) contained in Handles) */
-extern void freeStdFile PROTO((StgForeignObj));
-extern void freeFile PROTO((StgForeignObj));
-
extern I_ nocldstop;
-char *strDup PROTO((const char *));
-int setenviron PROTO((char **));
-int copyenv (STG_NO_ARGS);
-int _setenv PROTO((char *));
-int delenv PROTO((char *));
-int execvpe PROTO((char *, char **, char **));
+char *strDup (const char *);
+int setenviron (char **);
+int copyenv (void);
+int _setenv (char *);
+int delenv (char *);
+int execvpe (char *, char **, char **);
+void stg_sigaddset(sigset_t *newset, sigset_t *oldset, int signum);
+void stg_sigdelset(sigset_t *newset, sigset_t *oldset, int signum);
#define LIBPOSIX_H
#endif
--- /dev/null
+/*
+ * (c) Juan Quintela, Universidade da Corunha 1998
+ *
+ * wrappers for signal funcions
+ *
+ * sigset_t is a struct in some UNIXes (LINUX/glibc for instance)
+ * and it is not posible to do the inline (_casm_). These functions
+ * aren't inline because it causes gcc to run out of registers on x86.
+ *
+ */
+
+#include "Rts.h"
+#include "libposix.h"
+
+void
+stg_sigaddset(sigset_t *newset, sigset_t *oldset, int signum)
+{
+ *newset = *oldset;
+ sigaddset(newset, signum);
+}
+
+void
+stg_sigdelset(sigset_t *newset, sigset_t *oldset, int signum)
+{
+ *newset = *oldset;
+ sigdelset(newset, signum);
+}
import Ix
import PrelList
-import PrelRead
+--import PrelRead
import PrelArr -- Most of the hard work is done here
import PrelBase
shows (assocs a) )
showList = showList__ (showsPrec 0)
+{-
instance (Ix a, Read a, Read b) => Read (Array a b) where
readsPrec p = readParen (p > 9)
(\r -> [(array b as, u) | ("array",s) <- lex r,
(b,t) <- reads s,
(as,u) <- reads t ])
readList = readList__ (readsPrec 0)
+-}
\end{code}
cpuTimePrecision -- :: Integer
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+#else
import PrelBase
-import PrelArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray )
+import PrelArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray )
import PrelMaybe
import PrelNum
+import PrelNumExtra
import PrelAddr
import PrelIOBase
-import IO
import PrelST
+#endif
+import IO ( fail )
import Ratio
+#ifdef __HUGS__
+#define cat2(x,y) x/**/y
+#define CCALL(fun) cat2(prim_,fun)
+#define stToIO id
+#define sizeof_int64 8
+#else
+#define CCALL(fun) _ccall_ fun
+#define const_BUFSIZ ``BUFSIZ''
+#define primPackString
+#endif
+
\end{code}
Computation @getCPUTime@ returns the number of picoseconds CPU time
used by the current program. The precision of this result is
implementation-dependent.
-The @cpuTimePrecision@ constant is the resolution (in picoseconds!) of
-the number of
+The @cpuTimePrecision@ constant is the smallest measurable difference
+in CPU time that the implementation can record, and is given as an
+integral number of picoseconds.
\begin{code}
+#ifdef __HUGS__
+
+getCPUTime :: IO Integer
+getCPUTime = do
+ marr <- primNewByteArray (sizeof_int * 4)
+ ptr <- CCALL(getCPUTime) marr
+ if (ptr /= nullAddr) then do
+ x0 <- primReadIntArray marr 0
+ x1 <- primReadIntArray marr 1
+ x2 <- primReadIntArray marr 2
+ x3 <- primReadIntArray marr 3
+ return ((fromIntegral x0 * 1000000000 + fromIntegral x1 +
+ fromIntegral x2 * 1000000000 + fromIntegral x3)
+ * 1000)
+ else
+ fail (IOError Nothing UnsupportedOperation "getCPUTime"
+ "can't get CPU time")
+
+#else
+
getCPUTime :: IO Integer
getCPUTime =
stToIO (newIntArray (0,3)) >>= \ marr ->
_ccall_ getCPUTime barr >>= \ ptr ->
if (ptr::Addr) /= ``NULL'' then
return ((fromIntegral (I# (indexIntArray# frozen# 0#)) * 1000000000 +
- fromIntegral (I# (indexIntArray# frozen# 1#)) +
- fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 +
- fromIntegral (I# (indexIntArray# frozen# 3#))) * 1000)
+ fromIntegral (I# (indexIntArray# frozen# 1#)) +
+ fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 +
+ fromIntegral (I# (indexIntArray# frozen# 3#))) * 1000)
else
fail (IOError Nothing UnsupportedOperation "getCPUTime"
"can't get CPU time")
+#endif
+
cpuTimePrecision :: Integer
cpuTimePrecision = round ((1000000000000::Integer) %
- fromInt (unsafePerformIO (_ccall_ clockTicks )))
+ fromInt (unsafePerformIO (CCALL(clockTicks) )))
\end{code}
+\begin{code}
+#ifdef __HUGS__
+sizeof_int = 4
+
+foreign import stdcall "libHS_cbits.so" "getCPUTime" prim_getCPUTime :: Bytes -> IO Addr
+foreign import stdcall "libHS_cbits.so" "clockTicks" prim_clockTicks :: IO Int
+#endif
+\end{code}
import PrelBase
import PrelRead (readLitChar)
-import PrelErr ( error )
+import {-# SOURCE #-} PrelErr ( error )
\end{code}
doesDirectoryExist,
getPermissions,
setPermissions,
+#ifndef __HUGS__
getModificationTime
+#endif
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+#else
import PrelBase
import PrelIOBase
+import PrelHandle
import PrelST
import PrelArr
import PrelPack ( unpackNBytesST )
-import PrelCCall ( Word(..) )
import PrelAddr
import Time ( ClockTime(..) )
+#endif
\end{code}
doesDirectoryExist :: FilePath -> IO Bool
getPermissions :: FilePath -> IO Permissions
setPermissions :: FilePath -> Permissions -> IO ()
+#ifndef __HUGS__
getModificationTime :: FilePath -> IO ClockTime
+#endif
\end{code}
+\begin{code}
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "createDirectory" primCreateDirectory :: CString -> IO Int
+foreign import stdcall "libHS_cbits.so" "removeDirectory" primRemoveDirectory :: CString -> IO Int
+foreign import stdcall "libHS_cbits.so" "removeFile" primRemoveFile :: CString -> IO Int
+foreign import stdcall "libHS_cbits.so" "renameDirectory" primRenameDirectory :: CString -> CString -> IO Int
+foreign import stdcall "libHS_cbits.so" "renameFile" primRenameFile :: CString -> CString -> IO Int
+foreign import stdcall "libHS_cbits.so" "openDir__" primOpenDir :: CString -> IO Addr
+foreign import stdcall "libHS_cbits.so" "readDir__" primReadDir :: Addr -> IO Addr
+foreign import stdcall "libHS_cbits.so" "get_dirent_d_name" primGetDirentDName :: Addr -> IO Addr
+foreign import stdcall "libHS_cbits.so" "setCurrentDirectory" primSetCurrentDirectory :: CString -> IO Int
+foreign import stdcall "libHS_cbits.so" "getCurrentDirectory" primGetCurrentDirectory :: IO Addr
+foreign import stdcall "libc.so.6" "free" primFree :: Addr -> IO ()
+foreign import stdcall "libc.so.6" "malloc" primMalloc :: Word -> IO Addr
+foreign import stdcall "libc.so.6" "chmod" primChmod :: CString -> Word -> IO Int
+#endif
+\end{code}
%*********************************************************
%* *
\end{itemize}
\begin{code}
+
createDirectory path = do
+#ifdef __HUGS__
+ rc <- primCreateDirectory (primPackString path)
+#else
rc <- _ccall_ createDirectory path
+#endif
if rc == 0 then return () else
constructErrorAndFailWithInfo "createDirectory" path
\end{code}
\begin{code}
removeDirectory path = do
+#ifdef __HUGS__
+ rc <- primRemoveDirectory (primPackString path)
+#else
rc <- _ccall_ removeDirectory path
+#endif
if rc == 0 then
return ()
else
\begin{code}
removeFile path = do
+#ifdef __HUGS__
+ rc <- primRemoveFile (primPackString path)
+#else
rc <- _ccall_ removeFile path
+#endif
if rc == 0 then
return ()
else
\begin{code}
renameDirectory opath npath = do
+#ifdef __HUGS__
+ rc <- primRenameDirectory (primPackString opath) (primPackString npath)
+#else
rc <- _ccall_ renameDirectory opath npath
+#endif
if rc == 0 then
return ()
else
\begin{code}
renameFile opath npath = do
+#ifdef __HUGS__
+ rc <- primRenameFile (primPackString opath) (primPackString npath)
+#else
rc <- _ccall_ renameFile opath npath
+#endif
if rc == 0 then
return ()
else
\begin{code}
--getDirectoryContents :: FilePath -> IO [FilePath]
+#ifdef __HUGS__
+getDirectoryContents path = do
+ dir <- primOpenDir (primPackString path)
+ if dir == nullAddr
+ then constructErrorAndFailWithInfo "getDirectoryContents" path
+ else loop dir
+ where
+ loop :: Addr -> IO [String]
+ loop dir = do
+ dirent_ptr <- primReadDir dir
+ if dirent_ptr == nullAddr
+ then do
+ -- readDir__ implicitly performs closedir() when the
+ -- end is reached.
+ return []
+ else do
+ str <- primGetDirentDName dirent_ptr
+ entry <- primUnpackCString str
+ entries <- loop dir
+ return (entry:entries)
+#else
getDirectoryContents path = do
dir <- _ccall_ openDir__ path
if dir == ``NULL''
entry <- stToIO (unpackNBytesST str len)
entries <- loop dir
return (entry:entries)
+#endif
\end{code}
If the operating system has a notion of current directories,
\begin{code}
getCurrentDirectory = do
+#ifdef __HUGS__
+ str <- primGetCurrentDirectory
+#else
str <- _ccall_ getCurrentDirectory
- if str /= ``NULL''
+#endif
+ if str /= nullAddr
then do
+#ifdef __HUGS__
+ pwd <- primUnpackCString str
+ primFree str
+#else
+ -- don't use unpackCString (see getDirectoryContents above)
len <- _ccall_ strlen str
- pwd <- stToIO (unpackNBytesST str len)
- _ccall_ free str
+ pwd <- stToIO (unpackNBytesST str len)
+ _ccall_ free str
+#endif
return pwd
else
constructErrorAndFail "getCurrentDirectory"
\begin{code}
setCurrentDirectory path = do
+#ifdef __HUGS__
+ rc <- primSetCurrentDirectory (primPackString path)
+#else
rc <- _ccall_ setCurrentDirectory path
+#endif
if rc == 0
then return ()
else constructErrorAndFailWithInfo "setCurrentDirectory" path
\begin{code}
--doesFileExist :: FilePath -> IO Bool
+#ifdef __HUGS__
+foreign import stdcall "libc.so.6" "access" primAccess :: PrimByteArray -> Int -> IO Int
+foreign import stdcall "libHS_cbits.so" "const_F_OK" const_F_OK :: Int
+
+doesFileExist name = do
+ rc <- primAccess (primPackString name) const_F_OK
+ return (rc == 0)
+#else
doesFileExist name = do
rc <- _ccall_ access name (``F_OK''::Int)
return (rc == 0)
+#endif
--doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name =
`catch`
(\ _ -> return False)
+#ifndef __HUGS__
--getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
getFileStatus name >>= \ st ->
modificationTime st
+#endif
--getPermissions :: FilePath -> IO Permissions
getPermissions name =
)
--setPermissions :: FilePath -> Permissions -> IO ()
+#ifdef __HUGS__
+setPermissions name (Permissions r w e s) = do
+ let
+ read = if r then ownerReadMode else emptyFileMode
+ write = if w then ownerWriteMode else emptyFileMode
+ exec = if e || s then ownerExecuteMode else emptyFileMode
+
+ mode = read `unionFileMode` (write `unionFileMode` exec)
+
+ rc <- primChmod (primPackString name) mode
+ if rc == 0
+ then return ()
+ else fail (IOError Nothing SystemError "setPermissions" "insufficient permissions")
+#else
setPermissions name (Permissions r w e s) = do
let
read# = case (if r then ownerReadMode else ``0'') of { W# x# -> x# }
if rc == 0
then return ()
else fail (IOError Nothing SystemError "setPermissions" "insufficient permissions")
-
+#endif
\end{code}
(Sigh)..copied from Posix.Files to avoid dep. on posix library
\begin{code}
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "sizeof_stat" sizeof_stat :: Int
+foreign import stdcall "libHS_cbits.so" "prim_stat" primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int
+
+type FileStatus = PrimByteArray
+
+getFileStatus :: FilePath -> IO FileStatus
+getFileStatus name = do
+ bytes <- primNewByteArray sizeof_stat
+ rc <- primStat (primPackString name) bytes
+ if rc == 0
+ then primUnsafeFreezeByteArray bytes
+ else fail (IOError Nothing SystemError "getFileStatus" "")
+#else
type FileStatus = ByteArray Int
getFileStatus :: FilePath -> IO FileStatus
where
malloc1 = IO $ \ s# ->
case newIntArray# 1# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bnds barr#)
+ (# s2#, barr# #) -> (# s2#, MutableByteArray bnds barr# #)
bnds = (0,1)
-- The C routine fills in an unsigned word. We don't have `unsigned2Integer#,'
cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# ->
case readIntArray# arr# 0# s# of
- StateAndInt# s2# r# ->
+ (# s2#, r# #) ->
if r# ==# 0# then
- IOok s2# 0
+ (# s2#, 0 #)
else
case unsafeFreezeByteArray# arr# s2# of
- StateAndByteArray# s3# frozen# ->
- IOok s3# (J# 1# 1# frozen#)
+ (# s3#, frozen# #) ->
+ (# s3#, J# 1# 1# frozen# #)
+#endif
+
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "get_stat_st_mode" fileMode :: FileStatus -> FileMode
+foreign import stdcall "libHS_cbits.so" "prim_S_ISDIR" prim_S_ISDIR :: FileMode -> Int
+foreign import stdcall "libHS_cbits.so" "prim_S_ISREG" prim_S_ISREG :: FileMode -> Int
+
+isDirectory :: FileStatus -> Bool
+isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0
+isRegularFile :: FileStatus -> Bool
+isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0
+#else
isDirectory :: FileStatus -> Bool
isDirectory stat = unsafePerformIO $ do
rc <- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat
isRegularFile stat = unsafePerformIO $ do
rc <- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat
return (rc /= 0)
+#endif
\end{code}
\begin{code}
type FileMode = Word
-ownerReadMode :: FileMode
-ownerReadMode = ``S_IRUSR''
-ownerWriteMode :: FileMode
-ownerWriteMode = ``S_IWUSR''
+#ifdef __HUGS__
+emptyFileMode :: FileMode
+unionFileMode :: FileMode -> FileMode -> FileMode
+intersectFileMode :: FileMode -> FileMode -> FileMode
+
+foreign import stdcall "libHS_cbits.so" "const_S_IRUSR" ownerReadMode :: FileMode
+foreign import stdcall "libHS_cbits.so" "const_S_IWUSR" ownerWriteMode :: FileMode
+foreign import stdcall "libHS_cbits.so" "const_S_IXUSR" ownerExecuteMode :: FileMode
+
+emptyFileMode = primIntToWord 0
+unionFileMode = primOrWord
+intersectFileMode = primAndWord
+#else
+ownerReadMode :: FileMode
+ownerReadMode = ``S_IRUSR''
+
+ownerWriteMode :: FileMode
+ownerWriteMode = ``S_IWUSR''
ownerExecuteMode :: FileMode
ownerExecuteMode = ``S_IXUSR''
intersectFileMode :: FileMode -> FileMode -> FileMode
intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#)
-fileMode :: FileStatus -> FileMode
+fileMode :: FileStatus -> FileMode
fileMode stat = unsafePerformIO (
_casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat)
+#endif
\end{code}
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+#ifndef BODY /* Hugs just includes this in PreludeBuiltin so no header needed */
module IO (
Handle, -- abstract, instance of: Eq, Show.
HandlePosn(..), -- abstract, instance of: Eq, Show.
-- extensions
hPutBuf,
+#ifndef __HUGS__
hPutBufBA,
+#endif
slurpFile
) where
+#ifdef __HUGS__
+
+import PreludeBuiltin
+
+#else
+
+--import PrelST
import PrelBase
import PrelIOBase
import PrelAddr ( Addr(..), nullAddr )
import PrelArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
+import PrelException ( fail, catch )
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( ForeignObj )
import Char ( ord, chr )
+#endif /* ndef __HUGS__ */
+#endif /* ndef BODY */
+
+#ifndef HEAD
+
+#ifdef __HUGS__
+#define cat2(x,y) x/**/y
+#define CCALL(fun) cat2(prim_,fun)
+#define __CONCURRENT_HASKELL__
+#define stToIO id
+#define unpackNBytesAccST primUnpackCStringAcc
+#else
+#define CCALL(fun) _ccall_ fun
+#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
+#define ref_freeFileObject (``&freeFileObject''::Addr)
+#define const_BUFSIZ ``BUFSIZ''
+#endif
+
\end{code}
Standard instances for @Handle@:
hReady h = hWaitForInput h 0
hWaitForInput :: Handle -> Int -> IO Bool
-hWaitForInput handle msecs = do
- handle_ <- wantReadableHandle "hWaitForInput" handle
- rc <- _ccall_ inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
+hWaitForInput handle msecs =
+ wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
+ rc <- CCALL(inputReady) (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
writeHandle handle handle_
case rc of
0 -> return False
\begin{code}
hGetChar :: Handle -> IO Char
-hGetChar handle = do
- handle_ <- wantReadableHandle "hGetChar" handle
+hGetChar handle =
+ wantReadableHandle "hGetChar" handle $ \ handle_ -> do
let fo = haFO__ handle_
- intc <- mayBlock fo (_ccall_ fileGetc fo) -- ConcHask: UNSAFE, may block
+ intc <- mayBlock fo (CCALL(fileGetc) fo) -- ConcHask: UNSAFE, may block
writeHandle handle handle_
if intc /= (-1)
then return (chr intc)
\begin{code}
hLookAhead :: Handle -> IO Char
hLookAhead handle = do
- handle_ <- wantReadableHandle "hLookAhead" handle
+ wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
let fo = haFO__ handle_
- intc <- mayBlock fo (_ccall_ fileLookAhead fo) -- ConcHask: UNSAFE, may block
+ intc <- mayBlock fo (CCALL(fileLookAhead) fo) -- ConcHask: UNSAFE, may block
writeHandle handle handle_
if intc /= (-1)
then return (chr intc)
\begin{code}
hGetContents :: Handle -> IO String
-hGetContents handle = do
- handle_ <- wantReadableHandle "hGetContents" handle
+hGetContents handle =
+ wantReadableHandle "hGetContents" handle $ \ handle_ -> do
{-
To avoid introducing an extra layer of buffering here,
we provide three lazy read methods, based on character,
#endif
lazyReadBlock handle fo = do
- buf <- _ccall_ getBufStart fo (0::Int)
- bytes <- mayBlock fo (_ccall_ readBlock fo) -- ConcHask: UNSAFE, may block.
+ buf <- CCALL(getBufStart) fo (0::Int)
+ bytes <- mayBlock fo (CCALL(readBlock) fo) -- ConcHask: UNSAFE, may block.
case bytes of
-3 -> -- buffering has been turned off, use lazyReadChar instead
lazyReadChar handle fo
-2 -> return ""
- -1 -> do -- an error occurred, close the handle
- handle_ <- readHandle handle
- _ccall_ closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
+ -1 -> -- an error occurred, close the handle
+ withHandle handle $ \ handle_ -> do
+ CCALL(closeFile) (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
writeHandle handle (handle_ { haType__ = ClosedHandle,
haFO__ = nullFile__ })
return ""
stToIO (unpackNBytesAccST buf bytes more)
lazyReadLine handle fo = do
- bytes <- mayBlock fo (_ccall_ readLine fo) -- ConcHask: UNSAFE, may block.
+ bytes <- mayBlock fo (CCALL(readLine) fo) -- ConcHask: UNSAFE, may block.
case bytes of
-3 -> -- buffering has been turned off, use lazyReadChar instead
lazyReadChar handle fo
-2 -> return "" -- handle closed by someone else, stop reading.
- -1 -> do -- an error occurred, close the handle
- handle_ <- readHandle handle
- _ccall_ closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
+ -1 -> -- an error occurred, close the handle
+ withHandle handle $ \ handle_ -> do
+ CCALL(closeFile) (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
writeHandle handle (handle_ { haType__ = ClosedHandle,
haFO__ = nullFile__ })
return ""
_ -> do
more <- unsafeInterleaveIO (lazyReadLine handle fo)
- buf <- _ccall_ getBufStart fo bytes -- ConcHask: won't block
+ buf <- CCALL(getBufStart) fo bytes -- ConcHask: won't block
stToIO (unpackNBytesAccST buf bytes more)
lazyReadChar handle fo = do
- char <- mayBlock fo (_ccall_ readChar fo) -- ConcHask: UNSAFE, may block.
+ char <- mayBlock fo (CCALL(readChar) fo) -- ConcHask: UNSAFE, may block.
case char of
-4 -> -- buffering is now block-buffered, use lazyReadBlock instead
lazyReadBlock handle fo
-3 -> -- buffering is now line-buffered, use lazyReadLine instead
lazyReadLine handle fo
-2 -> return ""
- -1 -> do -- error, silently close handle.
- handle_ <- readHandle handle
- _ccall_ closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
+ -1 -> -- error, silently close handle.
+ withHandle handle $ \ handle_ -> do
+ CCALL(closeFile) (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
writeHandle handle (handle_{ haType__ = ClosedHandle,
haFO__ = nullFile__ })
return ""
\begin{code}
hPutChar :: Handle -> Char -> IO ()
-hPutChar handle c = do
- handle_ <- wantWriteableHandle "hPutChar" handle
+hPutChar handle c =
+ wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
let fo = haFO__ handle_
- flushConnectedHandle fo
- rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block.
writeHandle handle handle_
if rc == 0
then return ()
\begin{code}
hPutStr :: Handle -> String -> IO ()
-hPutStr handle str = do
- handle_ <- wantWriteableHandle "hPutStr" handle
+hPutStr handle str =
+ wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
let fo = haFO__ handle_
- flushConnectedHandle fo
case haBufferMode__ handle_ of
LineBuffering -> do
- buf <- _ccall_ getWriteableBuf fo
- pos <- _ccall_ getBufWPtr fo
- bsz <- _ccall_ getBufSize fo
+ buf <- CCALL(getWriteableBuf) fo
+ pos <- CCALL(getBufWPtr) fo
+ bsz <- CCALL(getBufSize) fo
writeLines fo buf bsz pos str
BlockBuffering _ -> do
- buf <- _ccall_ getWriteableBuf fo
- pos <- _ccall_ getBufWPtr fo
- bsz <- _ccall_ getBufSize fo
+ buf <- CCALL(getWriteableBuf) fo
+ pos <- CCALL(getBufWPtr) fo
+ bsz <- CCALL(getBufSize) fo
writeBlocks fo buf bsz pos str
NoBuffering -> do
writeChars fo str
before passing the external write routine a pointer to the buffer.
\begin{code}
+#ifdef __HUGS__
+
+#ifdef __CONCURRENT_HASKELL__
+/* See comment in shoveString below for explanation */
+#warning delayed update of buffer disnae work with killThread
+#endif
#ifndef __PARALLEL_HASKELL__
writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
#else
writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
#endif
+writeLines obj buf bufLen initPos s =
+ let
+ shoveString :: Int -> [Char] -> IO ()
+ shoveString n ls =
+ case ls of
+ [] ->
+ if n == 0 then
+ CCALL(setBufWPtr) obj (0::Int)
+ else do
+ {-
+ At the end of a buffer write, update the buffer position
+ in the underlying file object, so that if the handle
+ is subsequently dropped by the program, the whole
+ buffer will be properly flushed.
+
+ There's one case where this delayed up-date of the buffer
+ position can go wrong: if a thread is killed, it might be
+ in the middle of filling up a buffer, with the result that
+ the partial buffer update is lost upon finalisation. Not
+ that killing of threads is supported at the moment.
+
+ -}
+ CCALL(setBufWPtr) obj n
+
+ (x:xs) -> do
+ primWriteCharOffAddr buf n x
+ {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
+ if n == bufLen || x == '\n'
+ then do
+ rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block.
+ if rc == 0
+ then shoveString 0 xs
+ else constructErrorAndFail "writeLines"
+ else
+ shoveString (n + 1) xs
+ in
+ shoveString initPos s
+#else /* ndef __HUGS__ */
+#ifndef __PARALLEL_HASKELL__
+writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
+#else
+writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
+#endif
writeLines obj buf bf@(I# bufLen) (I# initPos#) s =
let
write_char :: Addr -> Int# -> Char# -> IO ()
write_char (A# buf) n# c# =
IO $ \ s# ->
- case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# ()
+ case (writeCharOffAddr# buf n# c# s#) of s2# -> (# s2#, () #)
shoveString :: Int# -> [Char] -> IO ()
shoveString n ls =
case ls of
[] ->
if n ==# 0# then
- _ccall_ setBufWPtr obj (0::Int)
+ CCALL(setBufWPtr) obj (0::Int)
else do
{-
At the end of a buffer write, update the buffer position
that killing of threads is supported at the moment.
-}
- _ccall_ setBufWPtr obj (I# n)
+ CCALL(setBufWPtr) obj (I# n)
((C# x):xs) -> do
write_char buf n x
{- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
if n ==# bufLen || x `eqChar#` '\n'#
then do
- rc <- mayBlock obj (_ccall_ writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
if rc == 0
then shoveString 0# xs
else constructErrorAndFail "writeLines"
shoveString (n +# 1#) xs
in
shoveString initPos# s
+#endif /* ndef __HUGS__ */
+#ifdef __HUGS__
+#ifndef __PARALLEL_HASKELL__
+writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
+#else
+writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
+#endif
+writeBlocks obj buf bufLen initPos s =
+ let
+ shoveString :: Int -> [Char] -> IO ()
+ shoveString n ls =
+ case ls of
+ [] ->
+ if n == 0 then
+ CCALL(setBufWPtr) obj (0::Int)
+ else do
+ {-
+ At the end of a buffer write, update the buffer position
+ in the underlying file object, so that if the handle
+ is subsequently dropped by the program, the whole
+ buffer will be properly flushed.
+
+ There's one case where this delayed up-date of the buffer
+ position can go wrong: if a thread is killed, it might be
+ in the middle of filling up a buffer, with the result that
+ the partial buffer update is lost upon finalisation. However,
+ by the time killThread is supported, Haskell finalisers are also
+ likely to be in, which means the 'IOFileObject' hack can go
+ alltogether.
+
+ -}
+ CCALL(setBufWPtr) obj n
+
+ (x:xs) -> do
+ primWriteCharOffAddr buf n x
+ if n == bufLen
+ then do
+ rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block.
+ if rc == 0
+ then shoveString 0 xs
+ else constructErrorAndFail "writeChunks"
+ else
+ shoveString (n + 1) xs
+ in
+ shoveString initPos s
+#else /* ndef __HUGS__ */
#ifndef __PARALLEL_HASKELL__
writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
#else
write_char :: Addr -> Int# -> Char# -> IO ()
write_char (A# buf) n# c# =
IO $ \ s# ->
- case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# ()
+ case (writeCharOffAddr# buf n# c# s#) of s2# -> (# s2#, () #)
shoveString :: Int# -> [Char] -> IO ()
shoveString n ls =
case ls of
[] ->
if n ==# 0# then
- _ccall_ setBufWPtr obj (0::Int)
+ CCALL(setBufWPtr) obj (0::Int)
else do
{-
At the end of a buffer write, update the buffer position
alltogether.
-}
- _ccall_ setBufWPtr obj (I# n)
+ CCALL(setBufWPtr) obj (I# n)
((C# x):xs) -> do
write_char buf n x
if n ==# bufLen
then do
- rc <- mayBlock obj (_ccall_ writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
if rc == 0
then shoveString 0# xs
else constructErrorAndFail "writeChunks"
shoveString (n +# 1#) xs
in
shoveString initPos# s
+#endif /* ndef __HUGS__ */
#ifndef __PARALLEL_HASKELL__
writeChars :: ForeignObj -> String -> IO ()
#endif
writeChars fo "" = return ()
writeChars fo (c:cs) = do
- rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block.
if rc == 0
then writeChars fo cs
else constructErrorAndFail "writeChars"
\begin{code}
hPrint :: Show a => Handle -> a -> IO ()
-hPrint hdl = hPutStr hdl . show
+hPrint hdl = hPutStrLn hdl . show
\end{code}
Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
readLn = do l <- getLine
r <- readIO l
return r
+
+#endif /* ndef HEAD */
+
\end{code}
range (c,c') = [c..c']
index b@(c,c') ci
| inRange b ci = fromEnum ci - fromEnum c
- | otherwise = error (showString "Ix{Char}.index: Index " .
- showParen True (showsPrec 0 ci) .
- showString " out of range " $
- showParen True (showsPrec 0 b) "")
+ | otherwise = indexCharError ci b
inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
where i = fromEnum ci
range (m,n) = [m..n]
index b@(m,n) i
| inRange b i = i - m
- | otherwise = error (showString "Ix{Int}.index: Index " .
- showParen True (showsPrec 0 i) .
- showString " out of range " $
- showParen True (showsPrec 0 b) "")
+ | otherwise = indexIntError i b
inRange (m,n) i = m <= i && i <= n
+-- abstract these errors from the relevant index functions so that
+-- the guts of the function will be small enough to inline.
+
+{-# NOINLINE indexCharError #-}
+indexCharError :: Char -> (Char,Char) -> a
+indexCharError ci b
+ = error (showString "Ix{Char}.index: Index " .
+ showParen True (showsPrec 0 ci) .
+ showString " out of range " $
+ showParen True (showsPrec 0 b) "")
+
+{-# NOINLINE indexIntError #-}
+indexIntError :: Int -> (Int,Int) -> a
+indexIntError i b
+ = error (showString "Ix{Int}.index: Index " .
+ showParen True (showsPrec 0 i) .
+ showString " out of range " $
+ showParen True (showsPrec 0 b) "")
+
-- Integer instance is in PrelNum
----------------------------------------------------------------------
----------------------------------------------------------------------
instance (Ix a, Ix b) => Ix (a, b) where -- as derived
- {-# INLINE range #-}
+ {- INLINE range #-}
range ((l1,l2),(u1,u2)) =
[ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ]
- {-# INLINE index #-}
+ {- INLINE index #-}
index ((l1,l2),(u1,u2)) (i1,i2) =
index (l1,u1) i1 * rangeSize (l2,u2) + index (l2,u2) i2
- {-# INLINE inRange #-}
+ {- INLINE inRange #-}
inRange ((l1,l2),(u1,u2)) (i1,i2) =
inRange (l1,u1) i1 && inRange (l2,u2) i2
in the range for an @Ix@ pair:
\begin{code}
+{-# SPECIALISE rangeSize :: (Int,Int) -> Int #-}
rangeSize :: (Ix a) => (a,a) -> Int
rangeSize b@(l,h)
| l > h = 0
-- external reference to Main.main
---------------------------------------------------------------------------
-_interface_ Main 1
-_exports_
-Main main ;
-_declarations_
-1 main _:_ PrelIOBase.IO PrelBase.();;
+__interface Main 1 where
+__export Main main ;
+1 main :: PrelIOBase.IO PrelBase.();
#
LIBRARY = libHS$(_way).a
-HS_SRCS = $(wildcard *.lhs)
+HS_SRCS = $(wildcard *.lhs)
HS_OBJS = $(HS_SRCS:.lhs=.$(way_)o)
LIBOBJS = $(HS_OBJS)
HS_IFACES= $(HS_SRCS:.lhs=.$(way_)hi) PrelGHC.$(way_)hi
endif
# per-module flags
-PrelArr_HC_OPTS += -monly-2-regs
-Directory_HC_OPTS += -monly-3-regs
-Time_HC_OPTS += -monly-3-regs -H16m
+PrelArrExtra_HC_OPTS += -monly-2-regs
+Directory_HC_OPTS += -monly-3-regs
+Time_HC_OPTS += -monly-3-regs
-# Far too much heap is needed to compile PrelNum with -O at the
+# Far too much heap is needed to compile PrelNumExtra with -O at the
# moment, but there you go..
-PrelNum_HC_OPTS += -H30m
+PrelNumExtra_HC_OPTS += -H30m -K2m
-PrelBase_HC_OPTS += -H12m
-PrelRead_HC_OPTS += -H13m
+PrelBase_HC_OPTS += -H10m
+PrelRead_HC_OPTS += -H16m
PrelTup_HC_OPTS += -H12m
+PrelNum_HC_OPTS += -H12m
PrelArr_HC_OPTS += -H8m
-PrelHandle_HC_OPTS += -H12m
-Time_HC_OPTS += -H8m
+PrelHandle_HC_OPTS += -H14m
+Time_HC_OPTS += -H18m
Complex_HC_OPTS += -H10m
IO_HC_OPTS += -H12m
PrelMain_HC_OPTS += -fno-prune-tydecls # avoids an apparent bug; ToDo
INSTALL_DATAS += $(HS_IFACES)
include $(TOP)/mk/target.mk
-
-glaExts/PackedString_HC_OPTS += -monly-3-regs
-concurrent/Parallel_HC_OPTS += -fglasgow-exts
-glaExts/Int_HC_OPTS += -H8m
-glaExts/Word_HC_OPTS += -H8m
module Maybe
(
- Maybe(..),
- isJust, fromJust,
- fromMaybe,
- listToMaybe, maybeToList,
- catMaybes,
- mapMaybe,
- unfoldr
+ Maybe(..), -- non-standard
+ -- instance of: Eq, Ord, Show, Read,
+ -- Functor, Monad, MonadZero, MonadPlus
+
+ maybe, -- :: b -> (a -> b) -> Maybe a -> b
+
+ isJust, -- :: Maybe a -> Bool
+ fromJust, -- :: Maybe a -> a
+ fromMaybe, -- :: a -> Maybe a -> a
+ listToMaybe, -- :: [a] -> Maybe a
+ maybeToList, -- :: Maybe a -> [a]
+ catMaybes, -- :: [Maybe a] -> [a]
+ mapMaybe, -- :: (a -> Maybe b) -> [a] -> [b]
+ unfoldr -- :: (a -> Maybe (b,a)) -> a -> (a,[b])
+
) where
import PrelErr ( error )
listToMaybe [] = Nothing
listToMaybe (a:_) = Just a
+{- OLD, NOT EXPORTED:
findMaybe :: (a -> Bool) -> [a] -> Maybe a
findMaybe p = listToMaybe . filter p
+-}
catMaybes :: [Maybe a] -> [a]
catMaybes ls = [x | Just x <- ls]
Nothing -> rs
Just r -> r:rs
---OLD: mapMaybe f = catMaybes . map f
--- new version is potentially more space efficient
-
--- Not exported
+{- OLD, NOT EXPORTED:
joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
joinMaybe f m1 m2 =
case m1 of
Nothing -> m2
Just v1 -> case m2 of {Nothing -> m1; Just v2 -> Just (f v1 v2)}
-
-{- OLD: Note: stricter than the above.
-joinMaybe _ Nothing Nothing = Nothing
-joinMaybe _ (Just g) Nothing = Just g
-joinMaybe _ Nothing (Just g) = Just g
-joinMaybe f (Just g) (Just h) = Just (f g h)
-}
\end{code}
\begin{verbatim}
- unfoldr f' (foldr f z xs) == (xs,z)
+ unfoldr f' (foldr f z xs) == (z,xs)
if the following holds:
\end{verbatim}
\begin{code}
-unfoldr :: (a -> Maybe (b, a)) -> a -> ([b],a)
+unfoldr :: (a -> Maybe (b, a)) -> a -> (a,[b])
unfoldr f x =
case f x of
- Just (y,x') -> let (ys,x'') = unfoldr f x' in (y:ys,x'')
- Nothing -> ([],x)
+ Just (y,x') -> let (x'',ys) = unfoldr f x' in (x'',y:ys)
+ Nothing -> (x,[])
\end{code}
import PrelMaybe
import PrelArr
import PrelNum
+import PrelNumExtra
import PrelRead
import PrelErr ( error )
module PrelAddr (
Addr(..)
+ , Word(..)
, nullAddr -- :: Addr
, plusAddr -- :: Addr -> Int -> Addr
, indexAddrOffAddr -- :: Addr -> Int -> Addr
+ , Word64(..)
+ , Int64(..)
) where
import PrelGHC
import PrelBase
-import PrelST
import PrelCCall
\end{code}
\begin{code}
data Addr = A# Addr# deriving (Eq, Ord)
+data Word = W# Word# deriving (Eq, Ord)
instance Show Addr where
showsPrec p (A# a) = showsPrec p (I# (addr2Int# a))
instance CCallable Addr#
instance CReturnable Addr
+instance CCallable Word
+instance CCallable Word#
+instance CReturnable Word
+
+#if WORD_SIZE_IN_BYTES == 8
+data Word64 = W64# Word#
+data Int64 = I64# Int#
+#else
+data Word64 = W64# Word64# --deriving (Eq, Ord) -- Glasgow extension
+data Int64 = I64# Int64# --deriving (Eq, Ord) -- Glasgow extension
+
+instance CCallable Word64#
+instance CCallable Int64#
+#endif
+
+instance CCallable Word64
+instance CReturnable Word64
+
+instance CCallable Int64
+instance CReturnable Int64
+
indexAddrOffAddr :: Addr -> Int -> Addr
indexAddrOffAddr (A# addr#) n
= case n of { I# n# ->
instance CCallable (ByteArray ix)
instance CCallable ByteArray#
--- A one-element mutable array:
-type MutableVar s a = MutableArray s Int a
+data MutableVar s a = MutableVar (MutVar# s a)
+
+instance Eq (MutableVar s a) where
+ MutableVar v1# == MutableVar v2#
+ = sameMutVar# v1# v2#
-- just pointer equality on arrays:
instance Eq (MutableArray s ix elt) where
writeVar :: MutableVar s a -> a -> ST s ()
newVar init = ST $ \ s# ->
- case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
- STret s2# (MutableArray vAR_IXS arr#) }
- where
- vAR_IXS = error "newVar: Shouldn't access `bounds' of a MutableVar\n"
+ case (newMutVar# init s#) of { (# s2#, var# #) ->
+ (# s2#, MutableVar var# #) }
-readVar (MutableArray _ var#) = ST $ \ s# ->
- case readArray# var# 0# s# of { StateAndPtr# s2# r ->
- STret s2# r }
+readVar (MutableVar var#) = ST $ \ s# -> readMutVar# var# s#
-writeVar (MutableArray _ var#) val = ST $ \ s# ->
- case writeArray# var# 0# val s# of { s2# ->
- STret s2# () }
+writeVar (MutableVar var#) val = ST $ \ s# ->
+ case writeMutVar# var# val s# of { s2# ->
+ (# s2#, () #) }
\end{code}
%*********************************************************
= let n# = case (index bounds i) of { I# x -> x } -- index fails if out of range
in
case (indexArray# arr# n#) of
- Lift v -> v
+ (# _, v #) -> v
#ifdef USE_FOLDR_BUILD
{-# INLINE array #-}
array ixs@(ix_start, ix_end) ivs =
runST ( ST $ \ s ->
case (newArray ixs arrEleBottom) of { ST new_array_thing ->
- case (new_array_thing s) of { STret s# arr@(MutableArray _ arr#) ->
+ case (new_array_thing s) of { (# s#, arr@(MutableArray _ arr#) #) ->
let
fill_in s# [] = s#
fill_in s# ((i,v):ivs) =
newArray ixs init = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newArray# n# init s#) of { StateAndMutableArray# s2# arr# ->
- STret s2# (MutableArray ixs arr#) }}
+ case (newArray# n# init s#) of { (# s2#, arr# #) ->
+ (# s2#, MutableArray ixs arr# #) }}
newCharArray ixs = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray ixs barr#) }}
+ case (newCharArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray ixs barr# #) }}
newIntArray ixs = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray ixs barr#) }}
+ case (newIntArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray ixs barr# #) }}
newWordArray ixs = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newWordArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray ixs barr#) }}
+ case (newWordArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray ixs barr# #) }}
newAddrArray ixs = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray ixs barr#) }}
+ case (newAddrArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray ixs barr# #) }}
newFloatArray ixs = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newFloatArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray ixs barr#) }}
+ case (newFloatArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray ixs barr# #) }}
newDoubleArray ixs = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray ixs barr#) }}
+ case (newDoubleArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray ixs barr# #) }}
boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix)
boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix)
readArray (MutableArray ixs arr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readArray# arr# n# s# of { StateAndPtr# s2# r ->
- STret s2# r }}
+ case readArray# arr# n# s# of { (# s2#, r #) ->
+ (# s2#, r #) }}
readCharArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readCharArray# barr# n# s# of { StateAndChar# s2# r# ->
- STret s2# (C# r#) }}
+ case readCharArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, C# r# #) }}
readIntArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readIntArray# barr# n# s# of { StateAndInt# s2# r# ->
- STret s2# (I# r#) }}
+ case readIntArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, I# r# #) }}
readWordArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readWordArray# barr# n# s# of { StateAndWord# s2# r# ->
- STret s2# (W# r#) }}
+ case readWordArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, W# r# #) }}
readAddrArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readAddrArray# barr# n# s# of { StateAndAddr# s2# r# ->
- STret s2# (A# r#) }}
+ case readAddrArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, A# r# #) }}
readFloatArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readFloatArray# barr# n# s# of { StateAndFloat# s2# r# ->
- STret s2# (F# r#) }}
+ case readFloatArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, F# r# #) }}
readDoubleArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
case (index ixs n) of { I# n# ->
- case readDoubleArray# barr# n# s# of { StateAndDouble# s2# r# ->
- STret s2# (D# r#) }}
+ case readDoubleArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, D# r# #) }}
--Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
indexCharArray :: Ix ix => ByteArray ix -> ix -> Char
writeArray (MutableArray ixs arr#) n ele = ST $ \ s# ->
case index ixs n of { I# n# ->
case writeArray# arr# n# ele s# of { s2# ->
- STret s2# () }}
+ (# s2#, () #) }}
writeCharArray (MutableByteArray ixs barr#) n (C# ele) = ST $ \ s# ->
case (index ixs n) of { I# n# ->
case writeCharArray# barr# n# ele s# of { s2# ->
- STret s2# () }}
+ (# s2#, () #) }}
writeIntArray (MutableByteArray ixs barr#) n (I# ele) = ST $ \ s# ->
case (index ixs n) of { I# n# ->
case writeIntArray# barr# n# ele s# of { s2# ->
- STret s2# () }}
+ (# s2#, () #) }}
writeWordArray (MutableByteArray ixs barr#) n (W# ele) = ST $ \ s# ->
case (index ixs n) of { I# n# ->
case writeWordArray# barr# n# ele s# of { s2# ->
- STret s2# () }}
+ (# s2#, () #) }}
writeAddrArray (MutableByteArray ixs barr#) n (A# ele) = ST $ \ s# ->
case (index ixs n) of { I# n# ->
case writeAddrArray# barr# n# ele s# of { s2# ->
- STret s2# () }}
+ (# s2#, () #) }}
writeFloatArray (MutableByteArray ixs barr#) n (F# ele) = ST $ \ s# ->
case (index ixs n) of { I# n# ->
case writeFloatArray# barr# n# ele s# of { s2# ->
- STret s2# () }}
+ (# s2#, () #) }}
writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ s# ->
case (index ixs n) of { I# n# ->
case writeDoubleArray# barr# n# ele s# of { s2# ->
- STret s2# () }}
+ (# s2#, () #) }}
\end{code}
%*********************************************************
\begin{code}
+{-
freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
freezeWordArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-freezeFloatArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-freezeDoubleArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
{-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt),
MutableArray s IPr elt -> ST s (Array IPr elt)
#-}
{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-}
-
+-}
freezeArray (MutableArray ixs arr#) = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndArray# s2# frozen# ->
- STret s2# (Array ixs frozen#) }}
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, Array ixs frozen# #) }}
where
freeze :: MutableArray# s ele -- the thing
-> Int# -- size of thing to be frozen
-> State# s -- the Universe and everything
- -> StateAndArray# s ele
-
+ -> (# State# s, Array# ele #)
freeze arr# n# s#
- = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableArray# s3# newarr2# ->
+ = case newArray# n# init s# of { (# s2#, newarr1# #) ->
+ case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) ->
unsafeFreezeArray# newarr2# s3#
}}
where
init = error "freezeArray: element not copied"
copy :: Int# -> Int#
- -> MutableArray# s ele -> MutableArray# s ele
+ -> MutableArray# s ele
+ -> MutableArray# s ele
-> State# s
- -> StateAndMutableArray# s ele
+ -> (# State# s, MutableArray# s ele #)
copy cur# end# from# to# s#
| cur# ==# end#
- = StateAndMutableArray# s# to#
+ = (# s#, to# #)
| otherwise
- = case readArray# from# cur# s# of { StateAndPtr# s1# ele ->
+ = case readArray# from# cur# s# of { (# s1#, ele #) ->
case writeArray# to# cur# ele s1# of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
}}
freezeCharArray (MutableByteArray ixs arr#) = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }}
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray ixs frozen# #) }}
where
freeze :: MutableByteArray# s -- the thing
-> Int# -- size of thing to be frozen
-> State# s -- the Universe and everything
- -> StateAndByteArray# s
+ -> (# State# s, ByteArray# #)
freeze arr# n# s#
- = case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
+ = case (newCharArray# n# s#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) ->
unsafeFreezeByteArray# newarr2# s3#
}}
where
copy :: Int# -> Int#
-> MutableByteArray# s -> MutableByteArray# s
-> State# s
- -> StateAndMutableByteArray# s
+ -> (# State# s, MutableByteArray# s #)
copy cur# end# from# to# s#
| cur# ==# end#
- = StateAndMutableByteArray# s# to#
+ = (# s#, to# #)
| otherwise
- = case (readCharArray# from# cur# s#) of { StateAndChar# s1# ele ->
+ = case (readCharArray# from# cur# s#) of { (# s1#, ele #) ->
case (writeCharArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
}}
freezeIntArray (MutableByteArray ixs arr#) = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }}
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray ixs frozen# #) }}
where
freeze :: MutableByteArray# s -- the thing
-> Int# -- size of thing to be frozen
-> State# s -- the Universe and everything
- -> StateAndByteArray# s
+ -> (# State# s, ByteArray# #)
freeze arr# n# s#
- = case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
+ = case (newIntArray# n# s#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) ->
unsafeFreezeByteArray# newarr2# s3#
}}
where
copy :: Int# -> Int#
-> MutableByteArray# s -> MutableByteArray# s
-> State# s
- -> StateAndMutableByteArray# s
+ -> (# State# s, MutableByteArray# s #)
copy cur# end# from# to# s#
| cur# ==# end#
- = StateAndMutableByteArray# s# to#
+ = (# s#, to# #)
| otherwise
- = case (readIntArray# from# cur# s#) of { StateAndInt# s1# ele ->
+ = case (readIntArray# from# cur# s#) of { (# s1#, ele #) ->
case (writeIntArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
}}
freezeWordArray (MutableByteArray ixs arr#) = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }}
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray ixs frozen# #) }}
where
freeze :: MutableByteArray# s -- the thing
-> Int# -- size of thing to be frozen
-> State# s -- the Universe and everything
- -> StateAndByteArray# s
+ -> (# State# s, ByteArray# #)
freeze arr# n# s#
- = case (newWordArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
+ = case (newWordArray# n# s#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) ->
unsafeFreezeByteArray# newarr2# s3#
}}
where
copy :: Int# -> Int#
-> MutableByteArray# s -> MutableByteArray# s
-> State# s
- -> StateAndMutableByteArray# s
+ -> (# State# s, MutableByteArray# s #)
copy cur# end# from# to# s#
| cur# ==# end#
- = StateAndMutableByteArray# s# to#
+ = (# s#, to# #)
| otherwise
- = case (readWordArray# from# cur# s#) of { StateAndWord# s1# ele ->
+ = case (readWordArray# from# cur# s#) of { (# s1#, ele #) ->
case (writeWordArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
}}
freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }}
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray ixs frozen# #) }}
where
freeze :: MutableByteArray# s -- the thing
-> Int# -- size of thing to be frozen
-> State# s -- the Universe and everything
- -> StateAndByteArray# s
+ -> (# State# s, ByteArray# #)
freeze arr# n# s#
- = case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
+ = case (newAddrArray# n# s#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) ->
unsafeFreezeByteArray# newarr2# s3#
}}
where
copy :: Int# -> Int#
-> MutableByteArray# s -> MutableByteArray# s
-> State# s
- -> StateAndMutableByteArray# s
+ -> (# State# s, MutableByteArray# s #)
copy cur# end# from# to# s#
| cur# ==# end#
- = StateAndMutableByteArray# s# to#
+ = (# s#, to# #)
| otherwise
- = case (readAddrArray# from# cur# s#) of { StateAndAddr# s1# ele ->
+ = case (readAddrArray# from# cur# s#) of { (# s1#, ele #) ->
case (writeAddrArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
}}
-freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ s# ->
- case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }}
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndByteArray# s
-
- freeze arr# end# s#
- = case (newFloatArray# end# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> StateAndMutableByteArray# s
-
- copy cur# from# to# s#
- | cur# ==# end#
- = StateAndMutableByteArray# s# to#
- | otherwise
- = case (readFloatArray# from# cur# s#) of { StateAndFloat# s1# ele ->
- case (writeFloatArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) from# to# s2#
- }}
-
-freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ s# ->
- case rangeSize ixs of { I# n# ->
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }}
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndByteArray# s
-
- freeze arr# n# s#
- = case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> StateAndMutableByteArray# s
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableByteArray# s# to#
- | otherwise
- = case (readDoubleArray# from# cur# s#) of { StateAndDouble# s1# ele ->
- case (writeDoubleArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-
unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
#-}
unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ s# ->
- case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
- STret s2# (Array ixs frozen#) }
+ case unsafeFreezeArray# arr# s# of { (# s2#, frozen# #) ->
+ (# s2#, Array ixs frozen# #) }
unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray ixs frozen#) }
+ case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray ixs frozen# #) }
--This takes a immutable array, and copies it into a mutable array, in a
thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt)
thawArray (Array ixs arr#) = ST $ \ s# ->
case rangeSize ixs of { I# n# ->
- case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# ->
- STret s2# (MutableArray ixs thawed#)}}
+ case thaw arr# n# s# of { (# s2#, thawed# #) ->
+ (# s2#, MutableArray ixs thawed# #)}}
where
thaw :: Array# ele -- the thing
-> Int# -- size of thing to be thawed
-> State# s -- the Universe and everything
- -> StateAndMutableArray# s ele
+ -> (# State# s, MutableArray# s ele #)
thaw arr# n# s#
- = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# ->
+ = case newArray# n# init s# of { (# s2#, newarr1# #) ->
copy 0# n# arr# newarr1# s2# }
where
init = error "thawArray: element not copied"
-> Array# ele
-> MutableArray# s ele
-> State# s
- -> StateAndMutableArray# s ele
+ -> (# State# s, MutableArray# s ele #)
copy cur# end# from# to# s#
| cur# ==# end#
- = StateAndMutableArray# s# to#
+ = (# s#, to# #)
| otherwise
- = case indexArray# from# cur# of { Lift ele ->
+ = case indexArray# from# cur# of { (# _, ele #) ->
case writeArray# to# cur# ele s# of { s1# ->
copy (cur# +# 1#) end# from# to# s1#
}}
-\end{code}
-%*********************************************************
-%* *
-\subsection{Ghastly return types}
-%* *
-%*********************************************************
-
-\begin{code}
-data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt)
-data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt)
-data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray#
-data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s)
\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+\section[PrelArrExtra]{Module @PrelArrExtra@}
+
+The following functions should be in PrelArr, but need -monly-2-regs
+to compile. So as not to compile the whole of PrelArr with
+-monly-2-regs, the culprits have been moved out into a separate
+module.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module PrelArrExtra where
+
+import Ix
+import PrelArr
+import PrelST
+import PrelBase
+import PrelGHC
+
+freezeFloatArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
+freezeDoubleArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
+
+freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ s# ->
+ case rangeSize ixs of { I# n# ->
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray ixs frozen# #) }}
+ where
+ freeze :: MutableByteArray# s -- the thing
+ -> Int# -- size of thing to be frozen
+ -> State# s -- the Universe and everything
+ -> (# State# s, ByteArray# #)
+
+ freeze arr# end# s#
+ = case (newFloatArray# end# s#) of { (# s2#, newarr1# #) ->
+ case copy 0# arr# newarr1# s2# of { (# s3#, newarr2# #) ->
+ unsafeFreezeByteArray# newarr2# s3#
+ }}
+ where
+ copy :: Int#
+ -> MutableByteArray# s -> MutableByteArray# s
+ -> State# s
+ -> (# State# s, MutableByteArray# s #)
+
+ copy cur# from# to# s#
+ | cur# ==# end#
+ = (# s#, to# #)
+ | otherwise
+ = case (readFloatArray# from# cur# s#) of { (# s1#, ele #) ->
+ case (writeFloatArray# to# cur# ele s1#) of { s2# ->
+ copy (cur# +# 1#) from# to# s2#
+ }}
+
+freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ s# ->
+ case rangeSize ixs of { I# n# ->
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray ixs frozen# #) }}
+ where
+ freeze :: MutableByteArray# s -- the thing
+ -> Int# -- size of thing to be frozen
+ -> State# s -- the Universe and everything
+ -> (# State# s, ByteArray# #)
+
+ freeze arr# n# s#
+ = case (newDoubleArray# n# s#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) ->
+ unsafeFreezeByteArray# newarr2# s3#
+ }}
+ where
+ copy :: Int# -> Int#
+ -> MutableByteArray# s -> MutableByteArray# s
+ -> State# s
+ -> (# State# s, MutableByteArray# s #)
+
+ copy cur# end# from# to# s#
+ | cur# ==# end#
+ = (# s#, to# #)
+ | otherwise
+ = case (readDoubleArray# from# cur# s#) of { (# s1#, ele #) ->
+ case (writeDoubleArray# to# cur# ele s1#) of { s2# ->
+ copy (cur# +# 1#) end# from# to# s2#
+ }}
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRAP/AQUA Project, Glasgow University, 1992-1996
%
\section[PrelBase]{Module @PrelBase@}
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-module PrelBase(
+module PrelBase
+ (
module PrelBase,
module PrelGHC -- Re-export PrelGHC, to avoid lots of people
-- having to import it explicitly
- ) where
+ )
+ where
import {-# SOURCE #-} PrelErr ( error )
import PrelGHC
\begin{code}
{-
+data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
+ -- to avoid weird names like con2tag_[]#
+instance Functor [] where
+ map f [] = []
+ map f (x:xs) = f x : [] -- map f xs
+
+class Functor f where
+ map :: (a -> b) -> f a -> f b
+
class Eval a
+
data Bool = False | True
data Int = I# Int#
data Double = D# Double#
-- (avoids weird-named functions, e.g., con2tag_()#
data Maybe a = Nothing | Just a
-data Ordering = LT | EQ | GT deriving( Eq )
+data Ordering = LT | EQ | GT deriving( Eq, Ord )
type String = [Char]
data Char = C# Char#
-data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
- -- to avoid weird names like con2tag_[]#
-------------- Stage 2 -----------------------
class Bounded a where
minBound, maxBound :: a
+-- Leave this in for now; to make it easier to silently
+-- discard Evals from Haskell 1.4 contexts
class Eval a
\end{code}
enumFromThenTo n n' m
= map toEnum [fromEnum n, fromEnum n' .. fromEnum m]
-class (Eq a, Show a, Eval a) => Num a where
+class (Eq a, Show a) => Num a where
(+), (-), (*) :: a -> a -> a
negate :: a -> a
abs, signum :: a -> a
fromInt :: Int -> a -- partain: Glasgow extension
x - y = x + negate y
- fromInt (I# i#) = fromInteger (int2Integer# i#)
+ fromInt (I# i#) = fromInteger (case int2Integer# i# of
+ (# a, s, d #) -> J# a s d)
-- Go via the standard class-op if the
-- non-standard one ain't provided
\end{code}
%* *
%*********************************************************
-Just the type declarations. If we don't actually use any @Integers@ we'd
-rather not link the @Integer@ module at all; and the default-decl stuff
-in the renamer tends to slurp in @Double@ regardless.
-
\begin{code}
data Float = F# Float#
data Double = D# Double#
data Integer = J# Int# Int# ByteArray#
-\end{code}
+instance Eq Integer where
+ (J# a1 s1 d1) == (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) ==# 0#
+
+ (J# a1 s1 d1) /= (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0#
+\end{code}
%*********************************************************
%* *
%*********************************************************
\begin{code}
--- The current implementation of seq# cannot handle function types,
--- so we leave this instance out rather than make false promises.
---
--- instance Eval (a -> b)
-
instance Show (a -> b) where
showsPrec p f = showString "<<function>>"
showList ls = showList__ (showsPrec 0) ls
ltInt (I# x) (I# y) = x <# y
leInt (I# x) (I# y) = x <=# y
\end{code}
+
+Convenient boxed Integer PrimOps. These are 'thin-air' Ids, so
+it's nice to have them in PrelBase.
+
+\begin{code}
+{-# INLINE int2Integer #-}
+{-# INLINE addr2Integer #-}
+int2Integer i = case int2Integer# i of (# a, s, d #) -> J# a s d
+addr2Integer s = case addr2Integer# s of (# a, s, d #) -> J# a s d
+
+integer_0, integer_1, integer_2, integer_m1 :: Integer
+integer_0 = int2Integer 0#
+integer_1 = int2Integer 1#
+integer_2 = int2Integer 2#
+integer_m1 = int2Integer (negateInt# 1#)
+\end{code}
module PrelCCall (
CCallable(..),
- CReturnable(..),
-
- Word(..),
- Word64(..),
- Int64(..)
+ CReturnable(..)
) where
import PrelBase
instance CCallable Double#
instance CReturnable Double
-data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension
-
-instance CCallable Word
-instance CCallable Word#
-instance CReturnable Word
-
-
-data Word64 = W64# Word64# --deriving (Eq, Ord) -- Glasgow extension
-data Int64 = I64# Int64# --deriving (Eq, Ord) -- Glasgow extension
-
-instance CCallable Word64
-instance CCallable Word64#
-instance CReturnable Word64
-
-instance CCallable Int64
-instance CCallable Int64#
-instance CReturnable Int64
-
instance CReturnable () -- Why, exactly?
\end{code}
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-module PrelConc(
+
+module PrelConc (
+
+ -- Thread Ids
+ ThreadId,
+
-- Forking and suchlike
- ST, forkST,
- IO, forkIO,
- par, fork,
- threadDelay, threadWaitRead, threadWaitWrite,
+ forkIO,
+ killThread,
+ seq, par, fork,
+ {-threadDelay, threadWaitRead, threadWaitWrite, -}
- -- MVars
+ -- MVars
MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
) where
import PrelBase
import {-# SOURCE #-} PrelErr ( parError )
-import PrelST ( ST(..), STret(..), StateAndPtr#(..) )
-import PrelIOBase ( IO(..), IOResult(..), MVar(..) )
+import PrelST ( ST(..), STret(..), liftST )
+import PrelIOBase ( IO(..), MVar(..), liftIO, unsafePerformIO )
+import PrelErr ( parError )
import PrelBase ( Int(..) )
-import PrelGHC ( fork#, delay#, waitRead#, waitWrite#,
- SynchVar#, newSynchVar#, takeMVar#, putMVar#,
- State#, RealWorld, par#
- )
+import PrelErr ( seqError )
infixr 0 `par`, `fork`
\end{code}
-
-
%************************************************************************
%* *
-\subsection{@par@, and @fork@}
+\subsection{@ThreadId@, @par@, and @fork@}
%* *
%************************************************************************
\begin{code}
-forkST :: ST s a -> ST s a
-
-forkST (ST action) = ST $ \ s ->
- let d@(STret _ r) = action s in
- d `fork` STret s r
-
-forkIO :: IO () -> IO ()
-forkIO (IO action) = IO $ \ s -> (action s) `fork` IOok s ()
-
-par, fork :: Eval a => a -> b -> b
+data ThreadId = ThreadId ThreadId#
+-- ToDo: data ThreadId = ThreadId (WeakPair ThreadId# ())
+-- But since ThreadId# is unlifted, the WeakPair type must use open
+-- type variables.
+
+forkIO :: IO () -> IO ThreadId
+forkIO action = IO $ \ s ->
+ case (fork# action s) of (# s, id #) -> (# s, ThreadId id #)
+
+killThread :: ThreadId -> IO ()
+killThread (ThreadId id) = IO $ \ s ->
+ case (killThread# id s) of s -> (# s, () #)
+
+-- "seq" is defined a bit wierdly (see below)
+--
+-- The reason for the strange "0# -> parError" case is that
+-- it fools the compiler into thinking that seq is non-strict in
+-- its second argument (even if it inlines seq at the call site).
+-- If it thinks seq is strict in "y", then it often evaluates
+-- "y" before "x", which is totally wrong.
+--
+-- Just before converting from Core to STG there's a bit of magic
+-- that recognises the seq# and eliminates the duff case.
+
+{-# INLINE seq #-}
+seq :: a -> b -> b
+seq x y = case (seq# x) of { 0# -> seqError; _ -> y }
+
+par, fork :: a -> b -> b
{-# INLINE par #-}
{-# INLINE fork #-}
-
#if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__)
-par x y = case (par# x) of { 0# -> parError; _ -> y }
+par x y = case (par# x) of { 0# -> parError; _ -> y }
#else
par x y = y
#endif
-#if defined(__CONCURRENT_HASKELL__) || defined (__GRANSIM__)
-fork x y = case (fork# x) of { 0# -> parError; _ -> y }
-#else
-fork x y = y
-#endif
-
-runOrBlockIO m = m -- ?????
+fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
\end{code}
newEmptyMVar :: IO (MVar a)
newEmptyMVar = IO $ \ s# ->
- case newSynchVar# s# of
- StateAndSynchVar# s2# svar# -> IOok s2# (MVar svar#)
+ case newMVar# s# of
+ (# s2#, svar# #) -> (# s2#, MVar svar# #)
takeMVar :: MVar a -> IO a
-takeMVar (MVar mvar#) = IO $ \ s# ->
- case takeMVar# mvar# s# of
- StateAndPtr# s2# r -> IOok s2# r
+takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
putMVar :: MVar a -> a -> IO ()
putMVar (MVar mvar#) x = IO $ \ s# ->
case putMVar# mvar# x s# of
- s2# -> IOok s2# ()
+ s2# -> (# s2#, () #)
newMVar :: a -> IO (MVar a)
@threadWaitWrite@ is similar, but for writing on a file descriptor.
\begin{code}
+{- Not yet -- SDM
threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
threadDelay (I# x#) = IO $ \ s# ->
case delay# x# s# of
- s2# -> IOok s2# ()
+ s2# -> (# s2#, () #)
threadWaitRead (I# x#) = IO $ \ s# ->
case waitRead# x# s# of
- s2# -> IOok s2# ()
+ s2# -> (# s2#, () #)
threadWaitWrite (I# x#) = IO $ \ s# ->
case waitWrite# x# s# of
- s2# -> IOok s2# ()
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Ghastly return types}
-%* *
-%*********************************************************
-
-\begin{code}
-data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt)
+ s2# -> (# s2#, () #)
+-}
\end{code}
--- /dev/null
+%
+% (c) AQUA Project, Glasgow University, 1998
+%
+
+The Dynamic type is used in the Exception type, so we have to have
+Dynamic visible here. The rest of the operations on Dynamics are
+available in exts/Dynamic.lhs.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#ifndef __HUGS__
+module PrelDynamic where
+
+import PrelBase
+#endif
+
+data Dynamic = Dynamic TypeRep Obj
+
+data Obj = Obj
+ -- dummy type to hold the dynamically typed value.
+
+data TypeRep
+ = App TyCon [TypeRep]
+ | Fun TypeRep TypeRep
+ deriving ( Eq )
+
+-- type constructors are
+data TyCon = TyCon Int String
+
+instance Eq TyCon where
+ (TyCon t1 _) == (TyCon t2 _) = t1 == t2
+\end{code}
-- because it's wired into the compiler
---------------------------------------------------------------------------
-_interface_ PrelErr 1
-_exports_
-PrelErr error parError;
+__interface PrelErr 1 where
+__export PrelErr error parError;
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
module PrelErr
-
(
irrefutPatError
, noMethodBindingError
, seqError -- :: a
, error -- :: String -> a
- , ioError -- :: String -> a
, assertError -- :: String -> Bool -> a -> a
) where
import PrelBase
-import PrelIOBase ( IO(..), catch )
-import PrelHandle
+import PrelIOBase ( IO(..) )
+--import PrelHandle ( catch )
import PrelAddr
import PrelList ( span )
+import PrelException
import PrelPack ( packString )
import PrelArr ( ByteArray(..) )
%*********************************************************
\begin{code}
+{-
errorIO :: IO () -> a
errorIO (IO io)
_ -> bottom
where
bottom = bottom -- Never evaluated
-
-ioError :: String -> a
-ioError s = error__ ``&IOErrorHdrHook'' s
+-}
+--ioError :: String -> a
+--ioError s = error__ ``&IOErrorHdrHook'' s
-- error stops execution and displays an error message
error :: String -> a
-error s = error__ ``&ErrorHdrHook'' s
-
+error s = throw (ErrorCall s)
+--error s = error__ ``&ErrorHdrHook'' s
+{-
-- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
-- but the former does exactly the same as the latter, so I nuked it.
-- SLPJ Jan 97
error__ msg_hdr s
#ifdef __PARALLEL_HASKELL__
= errorIO (do
- (hFlush stdout) `catch` (\ _ -> return ())
+ (hFlush stdout) `catchException` (\ _ -> return ())
let bs@(ByteArray (_,len) _) = packString s
_ccall_ writeErrString__ msg_hdr bs len
_ccall_ stg_exit (1::Int)
)
#else
= errorIO ( do
- (hFlush stdout) `catch` (\ _ -> return ())
+ (hFlush stdout) `catchException` (\ _ -> return ())
-- Note: there's potential for trouble here in a
-- a concurrent setting if an error is flagged after the
-- lock on the stdout handle. (I don't see a possibility
)
#endif {- !parallel -}
+-}
\end{code}
%*********************************************************
\begin{code}
irrefutPatError
, noMethodBindingError
- --, noExplicitMethodError
, nonExhaustiveGuardsError
, patError
, recSelError
, recConError
, recUpdError :: String -> a
---noDefaultMethodError s = error ("noDefaultMethodError:"++s)
---noExplicitMethodError s = error ("No default method for class operation "++s)
-noMethodBindingError s = error (untangle s "No instance nor default method for class operation")
-irrefutPatError s = error (untangle s "Irrefutable pattern failed for pattern")
-nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
-recSelError s = error (untangle s "Missing field in record selection:")
-recConError s = error (untangle s "Missing field in record construction:")
-recUpdError s = error (untangle s "Record to doesn't contain field(s) to be updated")
-patError s = patError__ (untangle s "Non-exhaustive patterns in")
+noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
+irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
+patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+recSelError s = throw (RecSelError (untangle s "Missing field in record selection:"))
+recConError s = throw (RecConError (untangle s "Missing field in record construction:"))
+recUpdError s = throw (RecUpdError (untangle s "Record to doesn't contain field(s) to be updated"))
+
assertError :: String -> Bool -> a -> a
assertError str pred v
--- /dev/null
+---------------------------------------------------------------------------
+-- PrelException.hi-boot
+--
+-- This hand-written interface file is the initial bootstrap version
+-- for PrelException.hi.
+---------------------------------------------------------------------------
+
+__interface PrelErr 1 where
+__export PrelException fail catch;
+1 fail :: __forall [a] => PrelIOBase.IOError -> PrelIOBase.IO a ;
+1 catch :: __forall [a] => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ;
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: PrelException.lhs,v 1.2 1998/12/02 13:27:01 simonm Exp $
+%
+% (c) The GRAP/AQUA Project, Glasgow University, 1998
+%
+
+Exceptions and exception-handling functions.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#ifndef __HUGS__
+module PrelException where
+
+import PrelBase
+import PrelIOBase
+import PrelST ( STret(..) )
+import PrelDynamic
+import PrelGHC
+#endif
+\end{code}
+
+-----------------------------------------------------------------------------
+Exception datatype and operations.
+
+\begin{code}
+data Exception
+ = IOException IOError -- IO exceptions (from 'fail')
+ | ArithException ArithError -- Arithmetic exceptions
+ | ErrorCall String -- Calls to 'error'
+ | NoMethodError String -- A non-existent method was invoked
+ | PatternMatchFail String -- A pattern match failed
+ | NonExhaustiveGuards String -- A guard match failed
+ | RecSelError String -- Selecting a non-existent field
+ | RecConError String -- Field missing in record construction
+ | RecUpdError String -- Record doesn't contain updated field
+ | AssertionFailed String -- Assertions
+ | DynException Dynamic -- Dynamic exceptions
+ | ExternalException ExtError -- External exceptions
+
+data ArithError
+ = Overflow
+ | Underflow
+ | LossOfPrecision
+ | DivideByZero
+ | Denormal
+ deriving (Eq, Ord)
+
+data ExtError
+ = StackOverflow
+ | HeapOverflow
+ | ThreadKilled
+ deriving (Eq, Ord)
+
+instance Show ArithError where
+ showsPrec _ Overflow = showString "arithmetic overflow"
+ showsPrec _ Underflow = showString "arithmetic underflow"
+ showsPrec _ LossOfPrecision = showString "loss of precision"
+ showsPrec _ DivideByZero = showString "divide by zero"
+ showsPrec _ Denormal = showString "denormal"
+
+instance Show ExtError where
+ showsPrec _ StackOverflow = showString "stack overflow"
+ showsPrec _ HeapOverflow = showString "heap overflow"
+ showsPrec _ ThreadKilled = showString "thread killed"
+
+instance Show Exception where
+ showsPrec _ (IOException err) = shows err
+ showsPrec _ (ArithException err) = shows err
+ showsPrec _ (ErrorCall err) = showString err
+ showsPrec _ (NoMethodError err) = showString err
+ showsPrec _ (PatternMatchFail err) = showString err
+ showsPrec _ (NonExhaustiveGuards err) = showString err
+ showsPrec _ (RecSelError err) = showString err
+ showsPrec _ (RecConError err) = showString err
+ showsPrec _ (RecUpdError err) = showString err
+ showsPrec _ (AssertionFailed err) = showString err
+ showsPrec _ (DynException err) = showString "unknown exception"
+
+-- Primitives:
+
+throw :: Exception -> a
+
+#ifdef __HUGS__
+throw = primRaise
+#else
+throw exception = raise# exception
+#endif
+\end{code}
+
+catch handles the passing around of the state in the IO monad; if we
+don't actually apply (and hence run) an IO computation, we don't get
+any exceptions! Hence a large mantrap to watch out for is
+
+ catch# (m :: IO ()) (handler :: NDSet Exception -> IO ())
+
+since the computation 'm' won't actually be performed in the context
+of the 'catch#'. In fact, don't use catch# at all.
+
+\begin{code}
+catchException :: IO a -> (Exception -> IO a) -> IO a
+#ifdef __HUGS__
+catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s)
+#else
+catchException m k = IO $ \s -> case catch# (liftIO m s) (\exs -> liftIO (k exs) s)
+ of STret s r -> (# s, r #)
+#endif
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch m k = catchException m handler
+ where handler (IOException err) = k err
+ handler other = throw other
+\end{code}
+
+Why is this stuff here? To avoid recursive module dependencies of
+course.
+
+\begin{code}
+fail :: IOError -> IO a
+fail err = throw (IOException err)
+\end{code}
+
#ifndef __PARALLEL_HASKELL__
ForeignObj(..),
makeForeignObj,
+ writeForeignObj
#endif
- StateAndForeignObj#(..)
) where
import PrelIOBase
--instance CCallable ForeignObj
--instance CCallable ForeignObj#
+makeForeignObj :: Addr -> IO ForeignObj
+makeForeignObj (A# obj) = IO ( \ s# ->
+ case makeForeignObj# obj s# of
+ (# s1#, fo# #) -> (# s1#, ForeignObj fo# #) )
+
eqForeignObj :: ForeignObj -> ForeignObj -> Bool
--makeForeignObj :: Addr -> Addr -> IO ForeignObj
writeForeignObj :: ForeignObj -> Addr -> IO ()
-{- derived op - attaching a free() finaliser to a malloc() allocated reference. -}
-makeMallocPtr :: Addr -> IO ForeignObj
-
-{-
---makeForeignObj :: Addr -> Addr -> IO ForeignObj
-makeForeignObj (A# obj) (A# finaliser) = IO ( \ s# ->
- case makeForeignObj# obj finaliser s# of
- StateAndForeignObj# s1# fo# -> IOok s1# (ForeignObj fo#))
--}
-
writeForeignObj (ForeignObj fo#) (A# datum#) = IO ( \ s# ->
- case writeForeignObj# fo# datum# s# of { s1# -> IOok s1# () } )
-
-makeMallocPtr a = makeForeignObj a (``&free''::Addr)
+ case writeForeignObj# fo# datum# s# of { s1# -> (# s1#, () #) } )
eqForeignObj mp1 mp2
= unsafePerformIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
makeStablePtr f = IO $ \ rw1# ->
case makeStablePtr# f rw1# of
- StateAndStablePtr# rw2# sp# -> IOok rw2# (StablePtr sp#)
+ (# rw2#, sp# #) -> (# rw2#, StablePtr sp# #)
deRefStablePtr (StablePtr sp#) = IO $ \ rw1# ->
- case deRefStablePtr# sp# rw1# of
- StateAndPtr# rw2# a -> IOok rw2# a
+ deRefStablePtr# sp# rw1#
freeStablePtr sp = _ccall_ freeStablePointer sp
eqStablePtr :: StablePtr a -> StablePtr b -> Bool
-eqStablePtr s1 s2
- = unsafePerformIO (_ccall_ eqStablePtr s1 s2) /= (0::Int)
+eqStablePtr (StablePtr sp1#) (StablePtr sp2#) =
+ case eqStablePtr# sp1# sp2# of
+ 0# -> False
+ _ -> True
instance Eq (StablePtr a) where
p == q = eqStablePtr p q
%*********************************************************
%* *
-\subsection{Ghastly return types}
+\subsection{Unpacking Foreigns}
%* *
%*********************************************************
+Primitives for converting Foreigns pointing to external
+sequence of bytes into a list of @Char@s (a renamed version
+of the code above).
+
\begin{code}
#ifndef __PARALLEL_HASKELL__
-data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
+unpackCStringFO :: ForeignObj -> [Char]
+unpackCStringFO (ForeignObj fo#) = unpackCStringFO# fo#
+
+unpackCStringFO# :: ForeignObj# -> [Char]
+unpackCStringFO# fo {- ptr. to NUL terminated string-}
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffForeignObj# fo nh
+
+unpackNBytesFO :: ForeignObj -> Int -> [Char]
+unpackNBytesFO (ForeignObj fo) (I# l) = unpackNBytesFO# fo l
+
+unpackNBytesFO# :: ForeignObj# -> Int# -> [Char]
+ -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
+unpackNBytesFO# fo len
+ = unpack 0#
+ where
+ unpack i
+ | i >=# len = []
+ | otherwise = C# ch : unpack (i +# 1#)
+ where
+ ch = indexCharOffForeignObj# fo i
#endif
---data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj#
\end{code}
-- primitive operations and types that GHC knows about.
---------------------------------------------------------------------------
-_interface_ PrelGHC 2 0
-_exports_
-PrelGHC
+__interface PrelGHC 2 0 where
+
+__export PrelGHC
+
->
All -- Pseudo class used for universal quantification
-- Magical assert thingy
assert
--- I/O primitives
+ -- I/O primitives
RealWorld
realWorld#
State#
+ -- Concurrency primitives
+ ThreadId#
fork#
- delay#
+ killThread#
+ delay#
+ waitRead#
+ waitWrite#
+
+ -- MVars
+ MVar#
+ sameMVar#
+ newMVar#
+ takeMVar#
+ putMVar#
+
+ -- Parallel
seq#
par#
parGlobal#
parAtRel#
parAtForNow#
- SynchVar#
- sameMVar#
- newSynchVar#
- takeMVar#
- putMVar#
- waitRead#
- waitWrite#
-
- errorIO#
-
+ -- Character Type
Char#
gtChar#
geChar#
ord#
chr#
+ -- Int Type
Int#
>#
>=#
leAddr#
int2Addr#
addr2Int#
-
+ addr2Integer#
+
Float#
gtFloat#
geFloat#
sizeofByteArray#
sizeofMutableByteArray#
+ MutVar#
+ newMutVar#
+ readMutVar#
+ writeMutVar#
+ sameMutVar#
+
+ catch#
+ raise#
+
+ Weak#
+ mkWeak#
+ deRefWeak#
+
ForeignObj#
makeForeignObj#
writeForeignObj#
-
+
StablePtr#
makeStablePtr#
deRefStablePtr#
+ eqStablePtr#
reallyUnsafePtrEquality#
unsafeCoerce#
;
-_declarations_
-
1 class CCallable a :: ** ;
1 class CReturnable a :: ** ;
-1 assert _:_ _forall_ [a] => PrelBase.Bool -> a -> a ;;
+1 assert :: __forall [a] => PrelBase.Bool -> a -> a ;
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "error.h"
-
+#include "cbits/error.h"
+#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelHandle where
import PrelBase
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
+import PrelException ( Exception(..), throw, catch, fail, catchException )
import PrelMaybe ( Maybe(..) )
import PrelAddr ( Addr, nullAddr )
import PrelBounded () -- get at Bounded Int instance.
import PrelNum ( toInteger )
+import PrelWeak ( addForeignFinaliser )
+#if __CONCURRENT_HASKELL__
+import PrelConc
+#endif
import Ix
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj )
+import PrelForeign ( makeForeignObj, writeForeignObj )
#endif
-import PrelConc -- concurrent only
-\end{code}
+#endif /* ndef(__HUGS__) */
+
+#ifdef __HUGS__
+#define cat2(x,y) x/**/y
+#define CCALL(fun) cat2(prim_,fun)
+#define __CONCURRENT_HASKELL__
+#define stToIO id
+#define sizeof_int64 8
+#else
+#define CCALL(fun) _ccall_ fun
+#define const_BUFSIZ ``BUFSIZ''
+#define primPackString
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT ForeignObj
+#else
+#define FILE_OBJECT Addr
+#endif
+#endif
+\end{code}
%*********************************************************
%* *
\begin{code}
{-# INLINE newHandle #-}
-{-# INLINE readHandle #-}
+{-# INLINE withHandle #-}
{-# INLINE writeHandle #-}
-newHandle :: Handle__ -> IO Handle
-readHandle :: Handle -> IO Handle__
-writeHandle :: Handle -> Handle__ -> IO ()
+newHandle :: Handle__ -> IO Handle
+withHandle :: Handle -> (Handle__ -> IO a) -> IO a
+writeHandle :: Handle -> Handle__ -> IO ()
#if defined(__CONCURRENT_HASKELL__)
newHandle hc = newMVar hc >>= \ h ->
return (Handle h)
-readHandle (Handle h) = takeMVar h
+ -- withHandle grabs the handle lock, performs
+ -- some operation over it, making sure that we
+ -- unlock & reset the handle state should an
+ -- exception occur while performing said op.
+withHandle (Handle h) act = do
+ h_ <- takeMVar h
+ v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
+ return v
+
writeHandle (Handle h) hc = putMVar h hc
-
#else
-- Use ordinary MutableVars for non-concurrent Haskell
newHandle hc = stToIO (newVar hc >>= \ h ->
return (Handle h))
-readHandle (Handle h) = stToIO (readVar h)
+ -- of questionable value to install this exception
+ -- handler, but let's do it in the non-concurrent
+ -- case too, for now.
+withHandle (Handle h) act = do
+ h_ <- stToIO (readVar h)
+ v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex)
+ return v
+
writeHandle (Handle h) hc = stToIO (writeVar h hc)
+#endif
+
+\end{code}
+
+nullFile__ is only used for closed handles, plugging it in as a null
+file object reference.
+\begin{code}
+nullFile__ :: FILE_OBJECT
+nullFile__ =
+#ifndef __PARALLEL_HASKELL__
+ unsafePerformIO (makeForeignObj nullAddr)
+#else
+ nullAddr
#endif
+
+mkClosedHandle__ :: Handle__
+mkClosedHandle__ =
+ Handle__
+ nullFile__
+ ClosedHandle
+ NoBuffering
+ "closed file"
+
+mkErrorHandle__ :: IOError -> Handle__
+mkErrorHandle__ ioe =
+ Handle__
+ nullFile__
+ (ErrorHandle ioe)
+ NoBuffering
+ "error handle"
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Handle Finalisers}
+%* *
+%*********************************************************
+
+\begin{code}
+#ifndef __HUGS__
+freeStdFileObject :: ForeignObj -> IO ()
+freeStdFileObject fo = CCALL(freeStdFileObject) fo
+
+freeFileObject :: ForeignObj -> IO ()
+freeFileObject fo = CCALL(freeFileObject) fo
+#else
+foreign import stdcall "./libHS_cbits.dll" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO ()
+foreign import stdcall "./libHS_cbits.dll" "freeFileObject" freeFileObject :: ForeignObj -> IO ()
+#endif
\end{code}
%*********************************************************
stdin, stdout, stderr :: Handle
stdout = unsafePerformIO (do
- rc <- _ccall_ getLock 1 1 -- ConcHask: SAFE, won't block
+ rc <- CCALL(getLock) 1 1 -- ConcHask: SAFE, won't block
case rc of
0 -> newHandle (mkClosedHandle__)
1 -> do
#ifndef __CONCURRENT_HASKELL__
- fo <- _ccall_ openStdFile 1 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block
+ fo <- CCALL(openStdFile) 1 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block
#else
- fo <- _ccall_ openStdFile 1 (1{-flush on close-} + 128{-don't block on I/O-})
+ fo <- CCALL(openStdFile) 1 (1{-flush on close-} + 128{-don't block on I/O-})
0{-writeable-} -- ConcHask: SAFE, won't block
#endif
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
+ fo <- makeForeignObj fo
+ addForeignFinaliser fo (freeStdFileObject fo)
#endif
+
+#ifdef __HUGS__
+/* I dont care what the Haskell report says, in an interactive system,
+ * stdout should be unbuffered by default.
+ */
+ let bm = NoBuffering
+#else
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
+#endif
newHandle (Handle__ fo WriteHandle bm "stdout")
_ -> do ioError <- constructError "stdout"
newHandle (mkErrorHandle__ ioError)
)
stdin = unsafePerformIO (do
- rc <- _ccall_ getLock 0 0 -- ConcHask: SAFE, won't block
+ rc <- CCALL(getLock) 0 0 -- ConcHask: SAFE, won't block
case rc of
0 -> newHandle (mkClosedHandle__)
1 -> do
#ifndef __CONCURRENT_HASKELL__
- fo <- _ccall_ openStdFile 0 0{-don't flush on close -} 1{-readable-} -- ConcHask: SAFE, won't block
+ fo <- CCALL(openStdFile) 0 0{-don't flush on close -} 1{-readable-} -- ConcHask: SAFE, won't block
#else
- fo <- _ccall_ openStdFile 0 (0{-flush on close-} + 128{-don't block on I/O-})
+ fo <- CCALL(openStdFile) 0 (0{-flush on close-} + 128{-don't block on I/O-})
1{-readable-} -- ConcHask: SAFE, won't block
#endif
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
+ fo <- makeForeignObj fo
+ addForeignFinaliser fo (freeStdFileObject fo)
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
stderr = unsafePerformIO (do
- rc <- _ccall_ getLock 2 1 -- ConcHask: SAFE, won't block
+ rc <- CCALL(getLock) 2 1 -- ConcHask: SAFE, won't block
case rc of
0 -> newHandle (mkClosedHandle__)
1 -> do
#ifndef __CONCURRENT_HASKELL__
- fo <- _ccall_ openStdFile 2 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block
+ fo <- CCALL(openStdFile) 2 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block
#else
- fo <- _ccall_ openStdFile 2 (1{-flush on close-} + 128{-don't block on I/O-})
+ fo <- CCALL(openStdFile) 2 (1{-flush on close-} + 128{-don't block on I/O-})
0{-writeable-} -- ConcHask: SAFE, won't block
#endif
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
+ fo <- makeForeignObj fo
+ addForeignFinaliser fo (freeStdFileObject fo)
#endif
- hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
- -- when stderr and stdout are both connected to a terminal, ensure
- -- that anything buffered on stdout is flushed prior to writing on stderr.
- --
- hConnectTo stdout hdl
- return hdl
+ newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
_ -> do ioError <- constructError "stderr"
newHandle (mkErrorHandle__ ioError)
)
openFileEx :: FilePath -> IOModeEx -> IO Handle
openFileEx f m = do
- fo <- _ccall_ openFile f file_mode binary flush_on_close -- ConcHask: SAFE, won't block
+ fo <- CCALL(openFile) (primPackString f) file_mode binary file_flags -- ConcHask: SAFE, won't block
if fo /= nullAddr then do
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo ((``&freeFileObject'')::Addr)
+ fo <- makeForeignObj fo
+ addForeignFinaliser fo (freeFileObject fo)
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
TextMode imo -> (imo, 0)
#ifndef __CONCURRENT_HASKELL__
- file_mode = file_mode'
+ file_flags = file_flags'
#else
- file_mode = file_mode' + 128{-Don't block on I/O-}
+ file_flags = file_flags' + 128{-Don't block on I/O-}
#endif
- (flush_on_close, file_mode') =
+ (file_flags', file_mode) =
case imo of
AppendMode -> (1, 0)
WriteMode -> (1, 1)
\begin{code}
hClose :: Handle -> IO ()
-hClose handle = do
- handle_ <- readHandle handle
+hClose handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
writeHandle handle handle_
ioe_closedHandle "hClose" handle
_ -> do
- rc <- _ccall_ closeFile (haFO__ handle_) 1{-flush if you can-} -- ConcHask: SAFE, won't block
+ rc <- CCALL(closeFile) (haFO__ handle_) 1{-flush if you can-} -- ConcHask: SAFE, won't block
{- We explicitly close a file object so that we can be told
if there were any errors. Note that after @hClose@
has been performed, the ForeignObj embedded in the Handle
\begin{code}
hFileSize :: Handle -> IO Integer
-hFileSize handle = do
- handle_ <- readHandle handle
+hFileSize handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
SemiClosedHandle -> do
writeHandle handle handle_
ioe_closedHandle "hFileSize" handle
+#ifdef __HUGS__
+ other -> do
+ mem <- primNewByteArray sizeof_int64
+ rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
+ if rc == 0 then do
+ result <- primReadInt64Array mem 0
+ return (primInt64ToInteger result)
+ else
+ constructErrorAndFail "hFileSize"
+#else
other ->
-- HACK! We build a unique MP_INT of the right shape to hold
-- a single unsigned word, and we let the C routine
-- For some reason, this fails to typecheck if converted to a do
-- expression --SDM
_casm_ ``%r = 1;'' >>= \(I# hack#) ->
- case int2Integer# hack# of
+ case int2Integer hack# of
result@(J# _ _ d#) -> do
- rc <- _ccall_ fileSize (haFO__ handle_) d# -- ConcHask: SAFE, won't block
+ rc <- CCALL(fileSize) (haFO__ handle_) d# -- ConcHask: SAFE, won't block
writeHandle handle handle_
if rc == 0 then
return result
else
constructErrorAndFail "hFileSize"
+#endif
\end{code}
For a readable handle {\em hdl}, @hIsEOF hdl@ returns
\begin{code}
hIsEOF :: Handle -> IO Bool
-hIsEOF handle = do
- handle_ <- wantReadableHandle "hIsEOF" handle
+hIsEOF handle =
+ wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ fileEOF fo) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (CCALL(fileEOF) fo) -- ConcHask: UNSAFE, may block
writeHandle handle handle_
case rc of
0 -> return False
InvalidArgument
"hSetBuffering"
("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified.
- _ -> do
- handle_ <- readHandle handle
+ _ ->
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
of semi-closed handles to change [sof 6/98]
-}
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ setBuffering fo bsize) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (CCALL(setBuffering) fo bsize) -- ConcHask: UNSAFE, may block
if rc == 0
then do
writeHandle handle (handle_{ haBufferMode__ = mode })
\begin{code}
hFlush :: Handle -> IO ()
-hFlush handle = do
- handle_ <- wantWriteableHandle "hFlush" handle
+hFlush handle =
+ wantWriteableHandle "hFlush" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ flushFile fo) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (CCALL(flushFile) fo) -- ConcHask: UNSAFE, may block
writeHandle handle handle_
if rc == 0 then
return ()
\begin{code}
hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle = do
- handle_ <- wantSeekableHandle "hGetPosn" handle
- posn <- _ccall_ getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block
+hGetPosn handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+ posn <- CCALL(getFilePosn) (haFO__ handle_) -- ConcHask: SAFE, won't block
writeHandle handle handle_
if posn /= -1 then
return (HandlePosn handle posn)
constructErrorAndFail "hGetPosn"
hSetPosn :: HandlePosn -> IO ()
-hSetPosn (HandlePosn handle posn) = do
- handle_ <- wantSeekableHandle "hSetPosn" handle -- not as silly as it looks: the handle may have been closed in the meantime.
+hSetPosn (HandlePosn handle posn) =
+ wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- not as silly as it looks: the handle may have been closed in the meantime.
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ setFilePosn fo posn) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (CCALL(setFilePosn) fo posn) -- ConcHask: UNSAFE, may block
writeHandle handle handle_
if rc == 0 then
return ()
\begin{code}
hSeek :: Handle -> SeekMode -> Integer -> IO ()
-hSeek handle mode offset@(J# _ s# d#) = do
- handle_ <- wantSeekableHandle "hSeek" handle
+#ifdef __HUGS__
+hSeek handle mode offset =
+ wantSeekableHandle "hSeek" handle $ \ handle_ -> do
+ let fo = haFO__ handle_
+ rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
+#else
+hSeek handle mode offset@(J# _ s# d#) =
+ wantSeekableHandle "hSeek" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ seekFile fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
+#endif
writeHandle handle handle_
if rc == 0 then
return ()
\begin{code}
hIsOpen :: Handle -> IO Bool
-hIsOpen handle = do
- handle_ <- readHandle handle
+hIsOpen handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
return True
hIsClosed :: Handle -> IO Bool
-hIsClosed handle = do
- handle_ <- readHandle handle
+hIsClosed handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
-}
hIsReadable :: Handle -> IO Bool
-hIsReadable handle = do
- handle_ <- readHandle handle
+hIsReadable handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
isReadable _ = False
hIsWritable :: Handle -> IO Bool
-hIsWritable handle = do
- handle_ <- readHandle handle
+hIsWritable handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
getBMode__ :: Addr -> IO (BufferMode, Int)
#endif
getBMode__ fo = do
- rc <- _ccall_ getBufferMode fo -- ConcHask: SAFE, won't block
+ rc <- CCALL(getBufferMode) fo -- ConcHask: SAFE, won't block
case (rc::Int) of
0 -> return (NoBuffering, 0)
-1 -> return (LineBuffering, default_buffer_size)
n -> return (BlockBuffering (Just n), n)
where
default_buffer_size :: Int
- default_buffer_size = (``BUFSIZ'' - 1)
+ default_buffer_size = (const_BUFSIZ - 1)
\end{code}
Querying how a handle buffers its data:
\begin{code}
hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering handle = do
- handle_ <- readHandle handle
+hGetBuffering handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
\begin{code}
hIsSeekable :: Handle -> IO Bool
-hIsSeekable handle = do
- handle_ <- readHandle handle
+hIsSeekable handle =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
writeHandle handle handle_
return False
other -> do
- rc <- _ccall_ seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block
+ rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block
writeHandle handle handle_
case rc of
0 -> return False
\begin{code}
hSetEcho :: Handle -> Bool -> IO ()
-hSetEcho hdl on = do
- isT <- hIsTerminalDevice hdl
+hSetEcho handle on = do
+ isT <- hIsTerminalDevice handle
if not isT
then return ()
- else do
- handle_ <- readHandle hdl
+ else
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle hdl handle_
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle hdl handle_
- ioe_closedHandle "hSetEcho" hdl
+ writeHandle handle handle_
+ ioe_closedHandle "hSetEcho" handle
other -> do
- rc <- _ccall_ setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
- writeHandle hdl handle_
+ rc <- CCALL(setTerminalEcho) (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
if rc /= -1
then return ()
else constructErrorAndFail "hSetEcho"
hGetEcho :: Handle -> IO Bool
-hGetEcho hdl = do
- isT <- hIsTerminalDevice hdl
+hGetEcho handle = do
+ isT <- hIsTerminalDevice handle
if not isT
then return False
- else do
- handle_ <- readHandle hdl
+ else
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle hdl handle_
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle hdl handle_
- ioe_closedHandle "hGetEcho" hdl
+ writeHandle handle handle_
+ ioe_closedHandle "hGetEcho" handle
other -> do
- rc <- _ccall_ getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle hdl handle_
+ rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
case rc of
1 -> return True
0 -> return False
_ -> constructErrorAndFail "hSetEcho"
hIsTerminalDevice :: Handle -> IO Bool
-hIsTerminalDevice hdl = do
- handle_ <- readHandle hdl
+hIsTerminalDevice handle = do
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
- writeHandle hdl handle_
+ writeHandle handle handle_
fail ioError
ClosedHandle -> do
- writeHandle hdl handle_
- ioe_closedHandle "hIsTerminalDevice" hdl
+ writeHandle handle handle_
+ ioe_closedHandle "hIsTerminalDevice" handle
other -> do
- rc <- _ccall_ isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle hdl handle_
+ rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ writeHandle handle handle_
case rc of
1 -> return True
0 -> return False
hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
-hConnectHdl_ hW hR is_tty = do
- hW_ <- wantRWHandle "hConnectTo" hW
- hR_ <- wantRWHandle "hConnectTo" hR
- _ccall_ setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
+hConnectHdl_ hW hR is_tty =
+ wantWriteableHandle "hConnectTo" hW $ \ hW_ -> do
+ wantReadableHandle "hConnectTo" hR $ \ hR_ -> do
+ CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
writeHandle hR hR_
writeHandle hW hW_
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
-#else
-#define FILE_OBJECT Addr
-#endif
-
-flushConnectedHandle :: FILE_OBJECT -> IO ()
-flushConnectedHandle fo = _ccall_ flushConnectedHandle fo
\end{code}
As an extension, we also allow characters to be pushed back.
\begin{code}
hUngetChar :: Handle -> Char -> IO ()
-hUngetChar handle c = do
- handle_ <- wantReadableHandle "hLookAhead" handle
- rc <- _ccall_ ungetChar (haFO__ handle_) c -- ConcHask: SAFE, won't block
+hUngetChar handle c =
+ wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
+ rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block
writeHandle handle handle_
if rc == (-1)
then constructErrorAndFail "hUngetChar"
-- in one go, read file into an externally allocated buffer.
slurpFile :: FilePath -> IO (Addr, Int)
slurpFile fname = do
- hdl <- openFile fname ReadMode
- sz <- hFileSize hdl
+ handle <- openFile fname ReadMode
+ sz <- hFileSize handle
if sz > toInteger (maxBound::Int) then
fail (userError "slurpFile: file too big")
else do
let sz_i = fromInteger sz
- chunk <- _ccall_ allocMemory__ (sz_i::Int)
+ chunk <- CCALL(allocMemory__) (sz_i::Int)
if chunk == nullAddr
then do
- hClose hdl
+ hClose handle
constructErrorAndFail "slurpFile"
- else do
- handle_ <- readHandle hdl
+ else
+ withHandle handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ readChunk fo chunk sz_i) -- ConcHask: UNSAFE, may block.
- writeHandle hdl handle_
- hClose hdl
+ rc <- mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block.
+ writeHandle handle handle_
+ hClose handle
if rc < 0
then constructErrorAndFail "slurpFile"
else return (chunk, rc)
+#ifndef __HUGS__ /* Hugs' Prelude doesn't need this */
hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int
hFillBufBA handle buf sz
| sz <= 0 = fail (IOError (Just handle)
InvalidArgument
"hFillBufBA"
("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
- | otherwise = do
- handle_ <- wantReadableHandle "hFillBufBA" handle
+ | otherwise =
+ wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ readChunk fo buf sz) -- ConcHask: UNSAFE, may block.
+#ifdef __HUGS__
+ rc <- mayBlock fo (CCALL(readChunkBA) fo buf sz) -- ConcHask: UNSAFE, may block.
+#else
+ rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
+#endif
writeHandle handle handle_
if rc >= 0
then return rc
else constructErrorAndFail "hFillBufBA"
+#endif
hFillBuf :: Handle -> Addr -> Int -> IO Int
hFillBuf handle buf sz
InvalidArgument
"hFillBuf"
("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified.
- | otherwise = do
- handle_ <- wantReadableHandle "hFillBuf" handle
+ | otherwise =
+ wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ readChunk fo buf sz) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
writeHandle handle handle_
if rc >= 0
then return rc
\begin{code}
hPutBuf :: Handle -> Addr -> Int -> IO ()
-hPutBuf handle buf len = do
- handle_ <- wantWriteableHandle "hPutBuf" handle
+hPutBuf handle buf len =
+ wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ writeBuf fo buf len) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block.
writeHandle handle handle_
if rc == 0
then return ()
else constructErrorAndFail "hPutBuf"
+#ifndef __HUGS__ /* Another one Hugs doesn't provide */
hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
-hPutBufBA handle buf len = do
- handle_ <- wantWriteableHandle "hPutBufBA" handle
+hPutBufBA handle buf len =
+ wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (_ccall_ writeBufBA fo buf len) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block.
writeHandle handle handle_
if rc == 0
then return ()
else constructErrorAndFail "hPutBuf"
+#endif
\end{code}
Sometimes it's useful to get at the file descriptor that
\begin{code}
getHandleFd :: Handle -> IO Int
getHandleFd handle = do
- handle_ <- readHandle handle
+ withHandle handle $ \ handle_ -> do
case (haType__ handle_) of
ErrorHandle ioError -> do
writeHandle handle handle_
writeHandle handle handle_
ioe_closedHandle "getHandleFd" handle
_ -> do
- fd <- _ccall_ getFileFd (haFO__ handle_)
+ fd <- CCALL(getFileFd) (haFO__ handle_)
writeHandle handle handle_
return fd
\end{code}
if it isn't:
\begin{code}
-wantReadableHandle :: String -> Handle -> IO Handle__
-wantReadableHandle fun handle = do
- handle_ <- readHandle handle
+wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantReadableHandle fun handle act =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
WriteHandle -> do
writeHandle handle handle_
fail not_readable_error
- other -> return handle_
+ other -> act handle_
where
not_readable_error =
IOError (Just handle) IllegalOperation fun
("handle is not open for reading")
-wantWriteableHandle :: String -> Handle -> IO Handle__
-wantWriteableHandle fun handle = do
- handle_ <- readHandle handle
+wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantWriteableHandle fun handle act =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
ReadHandle -> do
writeHandle handle handle_
fail not_writeable_error
- other -> return handle_
+ other -> act handle_
where
not_writeable_error =
IOError (Just handle) IllegalOperation fun
("handle is not open for writing")
--- either R or W.
-wantRWHandle :: String -> Handle -> IO Handle__
-wantRWHandle fun handle = do
- handle_ <- readHandle handle
- case haType__ handle_ of
- ErrorHandle ioError -> do
- writeHandle handle handle_
- fail ioError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- SemiClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle fun handle
- other -> return handle_
- where
- not_readable_error =
- IOError (Just handle) IllegalOperation fun
- ("handle is not open for reading or writing")
-
-wantSeekableHandle :: String -> Handle -> IO Handle__
-wantSeekableHandle fun handle = do
- handle_ <- readHandle handle
+wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantSeekableHandle fun handle act =
+ withHandle handle $ \ handle_ -> do
case haType__ handle_ of
ErrorHandle ioError -> do
writeHandle handle handle_
AppendHandle -> do
writeHandle handle handle_
fail not_seekable_error
- _ -> return handle_
+ _ -> act handle_
where
not_seekable_error =
IOError (Just handle)
mayBlock :: Addr -> IO Int -> IO Int
#endif
-#ifndef __CONCURRENT_HASKELL__
+#ifndef notyet /*__CONCURRENT_HASKELL__*/
mayBlock _ act = act
#else
mayBlock fo act = do
rc <- act
case rc of
-5 -> do -- (possibly blocking) read
- fd <- _ccall_ getFileFd fo
+ fd <- CCALL(getFileFd) fo
threadWaitRead fd
- _ccall_ clearNonBlockingIOFlag__ fo -- force read to happen this time.
+ CCALL(clearNonBlockingIOFlag__) fo -- force read to happen this time.
mayBlock fo act -- input available, re-try
-6 -> do -- (possibly blocking) write
- fd <- _ccall_ getFileFd fo
+ fd <- CCALL(getFileFd) fo
threadWaitWrite fd
- _ccall_ clearNonBlockingIOFlag__ fo -- force write to happen this time.
+ CCALL(clearNonBlockingIOFlag__) fo -- force write to happen this time.
mayBlock fo act -- output possible
-7 -> do -- (possibly blocking) write on connected handle
- fd <- _ccall_ getConnFileFd fo
+ fd <- CCALL(getConnFileFd) fo
threadWaitWrite fd
- _ccall_ clearConnNonBlockingIOFlag__ fo -- force write to happen this time.
+ CCALL(clearConnNonBlockingIOFlag__) fo -- force write to happen this time.
mayBlock fo act -- output possible
_ -> do
- _ccall_ setNonBlockingIOFlag__ fo -- reset file object.
- _ccall_ setConnNonBlockingIOFlag__ fo -- reset (connected) file object.
+ CCALL(setNonBlockingIOFlag__) fo -- reset file object.
+ CCALL(setConnNonBlockingIOFlag__) fo -- reset (connected) file object.
return rc
#endif
+
+#ifdef __HUGS__
+threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
+
+-- Hugs does actually have the primops needed to implement these
+-- but, like GHC, the primops don't actually do anything...
+threadDelay _ = return ()
+threadWaitRead _ = return ()
+threadWaitWrite _ = return ()
+#endif
+
+\end{code}
+
+
+\begin{code}
+#ifdef __HUGS__
+type FD = Int
+type Exclusive = Int -- really Bool
+type How = Int
+type Binary = Int
+type OpenStdFlags = Int
+type OpenFlags = Int
+type Readable = Int -- really Bool
+type Flush = Int -- really Bool
+type RC = Int -- standard return code
+
+type IOFileAddr = Addr -- as returned from functions
+type CString = PrimByteArray
+type Bytes = PrimMutableByteArray RealWorld
+
+#ifndef __PARALLEL_HASKELL__
+type FILE_OBJ = ForeignObj -- as passed into functions
+#else
+type FILE_OBJ = Addr
+#endif
+
+foreign import stdcall "libHS_cbits.so" "setBuf" prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
+foreign import stdcall "libHS_cbits.so" "getBufSize" prim_getBufSize :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "inputReady" prim_inputReady :: FILE_OBJ -> Int -> IO RC
+foreign import stdcall "libHS_cbits.so" "fileGetc" prim_fileGetc :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "fileLookAhead" prim_fileLookAhead :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "readBlock" prim_readBlock :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "readLine" prim_readLine :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "readChar" prim_readChar :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "writeFileObject" prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
+foreign import stdcall "libHS_cbits.so" "filePutc" prim_filePutc :: FILE_OBJ -> Char -> IO RC
+foreign import stdcall "libHS_cbits.so" "getBufStart" prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
+foreign import stdcall "libHS_cbits.so" "getWriteableBuf" prim_getWriteableBuf :: FILE_OBJ -> IO Addr
+foreign import stdcall "libHS_cbits.so" "getBufWPtr" prim_getBufWPtr :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "setBufWPtr" prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
+foreign import stdcall "libHS_cbits.so" "closeFile" prim_closeFile :: FILE_OBJ -> Flush -> IO RC
+foreign import stdcall "libHS_cbits.so" "fileEOF" prim_fileEOF :: FILE_OBJ -> IO RC
+foreign import stdcall "libHS_cbits.so" "setBuffering" prim_setBuffering :: FILE_OBJ -> Int -> IO RC
+foreign import stdcall "libHS_cbits.so" "flushFile" prim_flushFile :: FILE_OBJ -> IO RC
+foreign import stdcall "libHS_cbits.so" "getBufferMode" prim_getBufferMode :: FILE_OBJ -> IO RC
+foreign import stdcall "libHS_cbits.so" "seekFile_int64" prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
+foreign import stdcall "libHS_cbits.so" "seekFileP" prim_seekFileP :: FILE_OBJ -> IO RC
+foreign import stdcall "libHS_cbits.so" "setTerminalEcho" prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
+foreign import stdcall "libHS_cbits.so" "getTerminalEcho" prim_getTerminalEcho :: FILE_OBJ -> IO RC
+foreign import stdcall "libHS_cbits.so" "isTerminalDevice" prim_isTerminalDevice :: FILE_OBJ -> IO RC
+foreign import stdcall "libHS_cbits.so" "setConnectedTo" prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
+foreign import stdcall "libHS_cbits.so" "ungetChar" prim_ungetChar :: FILE_OBJ -> Char -> IO RC
+foreign import stdcall "libHS_cbits.so" "readChunk" prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
+foreign import stdcall "libHS_cbits.so" "writeBuf" prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
+foreign import stdcall "libHS_cbits.so" "getFileFd" prim_getFileFd :: FILE_OBJ -> IO FD
+foreign import stdcall "libHS_cbits.so" "fileSize_int64" prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
+foreign import stdcall "libHS_cbits.so" "getFilePosn" prim_getFilePosn :: FILE_OBJ -> IO Int
+foreign import stdcall "libHS_cbits.so" "setFilePosn" prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
+foreign import stdcall "libHS_cbits.so" "getConnFileFd" prim_getConnFileFd :: FILE_OBJ -> IO FD
+foreign import stdcall "libHS_cbits.so" "allocMemory__" prim_allocMemory__ :: Int -> IO Addr
+foreign import stdcall "libHS_cbits.so" "getLock" prim_getLock :: FD -> Exclusive -> IO RC
+foreign import stdcall "libHS_cbits.so" "openStdFile" prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
+foreign import stdcall "libHS_cbits.so" "openFile" prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
+foreign import stdcall "libHS_cbits.so" "freeFileObject" prim_freeFileObject :: FILE_OBJ -> IO ()
+foreign import stdcall "libHS_cbits.so" "freeStdFileObject" prim_freeStdFileObject :: FILE_OBJ -> IO ()
+foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" const_BUFSIZ :: Int
+
+foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "getErrStr__" prim_getErrStr__ :: IO Addr
+foreign import stdcall "libHS_cbits.so" "getErrNo__" prim_getErrNo__ :: IO Int
+foreign import stdcall "libHS_cbits.so" "getErrType__" prim_getErrType__ :: IO Int
+
+#endif
\end{code}
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% -----------------------------------------------------------------------------
+% $Id: PrelIOBase.lhs,v 1.6 1998/12/02 13:27:03 simonm Exp $
+%
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[PrelIOBase]{Module @PrelIOBase@}
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "error.h"
+#include "cbits/error.h"
+#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelIOBase where
import {-# SOURCE #-} PrelErr ( error )
+
+import PrelST
import PrelBase
-import PrelST ( ST(..), STret(..), StateAndPtr#(..) )
+import {-# SOURCE #-} PrelException ( fail )
+import PrelST ( ST(..), STret(..) )
import PrelMaybe ( Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
import PrelPack ( unpackCString )
import PrelArr ( MutableVar, readVar )
+#endif
+
+#ifdef __HUGS__
+#define cat2(x,y) x/**/y
+#define CCALL(fun) cat2(prim_,fun)
+#define __CONCURRENT_HASKELL__
+#define stToIO id
+#define unpackCString primUnpackString
+#else
+#define CCALL(fun) _ccall_ fun
+#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
+#endif
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT ForeignObj
+#else
+#define FILE_OBJECT Addr
+#endif
\end{code}
%*********************************************************
%* *
%*********************************************************
-IO is no longer built on top of PrimIO (which used to be a specialised
-version of the ST monad), instead it is now has its own type. This is
-purely for efficiency purposes, since we get to remove several levels
-of lifting in the type of the monad.
+The IO Monad is just an instance of the ST monad, where the state is
+the real world. We use the exception mechanism (in PrelException) to
+implement IO exceptions.
\begin{code}
-newtype IO a = IO (State# RealWorld -> IOResult a)
+#ifndef __HUGS__
+newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
-{-# INLINE unIO #-}
unIO (IO a) = a
-data IOResult a = IOok (State# RealWorld) a
- | IOfail (State# RealWorld) IOError
-
instance Functor IO where
map f x = x >>= (return . f)
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = m >>= \ _ -> k
- return x = IO $ \ s -> IOok s x
+ return x = IO $ \ s -> (# s, x #)
- (IO m) >>= k =
- IO $ \s ->
- case m s of
- IOfail new_s err -> IOfail new_s err
- IOok new_s a -> unIO (k a) new_s
+ m >>= k = bindIO m k
-fixIO :: (a -> IO a) -> IO a
-- not required but worth having around
+fixIO :: (a -> IO a) -> IO a
+fixIO m = stToIO (fixST (ioToST . m))
-fixIO k = IO $ \ s ->
- let
- (IO k_loop) = k loop
- result = k_loop s
- IOok _ loop = result
- in
- result
+liftIO :: IO a -> State# RealWorld -> STret RealWorld a
+liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
+
+bindIO :: IO a -> (a -> IO b) -> IO b
+bindIO (IO m) k = IO ( \ s ->
+ case m s of
+ (# new_s, a #) -> unIO (k a) new_s
+ )
+
+#endif
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Coercions to @ST@}
+%* *
+%*********************************************************
+
+\begin{code}
+#ifdef __HUGS__
+/* Hugs doesn't distinguish these types so no coercion required) */
+#else
+stToIO :: ST RealWorld a -> IO a
+stToIO (ST m) = (IO m)
+
+ioToST :: IO a -> ST RealWorld a
+ioToST (IO m) = (ST m)
+#endif
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Utility functions}
+%* *
+%*********************************************************
-fail :: IOError -> IO a
-fail err = IO $ \ s -> IOfail s err
+I'm not sure why this little function is here...
+
+\begin{code}
+--fputs :: Addr{-FILE*-} -> String -> IO Bool
userError :: String -> IOError
userError str = IOError Nothing (UserError Nothing) "" str
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch (IO m) k = IO $ \ s ->
- case m s of
- IOok new_s a -> IOok new_s a
- IOfail new_s e -> unIO (k e) new_s
-
-instance Show (IO a) where
- showsPrec p f = showString "<<IO action>>"
- showList = showList__ (showsPrec 0)
+{-
+fputs stream (c : cs)
+ = CCALL(filePutc) stream c >>
+ fputs stream cs
+-}
\end{code}
%*********************************************************
%* *
-\subsection{Coercions to @ST@}
+\subsection{Unsafe @IO@ operations}
%* *
%*********************************************************
\begin{code}
-stToIO :: ST RealWorld a -> IO a
-stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r
-
-ioToST :: IO a -> ST RealWorld a
-ioToST (IO io) = ST $ \ s ->
- case (io s) of
- IOok new_s a -> STret new_s a
- IOfail new_s e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
+#ifndef __HUGS__
+{-# NOINLINE unsafePerformIO #-}
+unsafePerformIO :: IO a -> a
+unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
+
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST
+#endif
\end{code}
%*********************************************************
Showing @IOError@s
\begin{code}
+#ifdef __HUGS__
+-- For now we give a fairly uninformative error message which just happens to
+-- be like the ones that Hugs used to give.
+instance Show IOError where
+ showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
+#else
instance Show IOError where
showsPrec p (IOError hdl iot loc s) =
showsPrec p iot .
Nothing -> id
Just h -> showString "Handle: " . showsPrec p h
-
+#endif
\end{code}
The @String@ part of an @IOError@ is platform-dependent. However, to
constructErrorMsg :: String -> Maybe String -> IO IOError
constructErrorMsg call_site reason =
- _ccall_ getErrType__ >>= \ (I# errtype#) ->
- _ccall_ getErrStr__ >>= \ str ->
+ CCALL(getErrType__) >>= \ errtype ->
+ CCALL(getErrStr__) >>= \ str ->
let
iot =
- case errtype# of
- ERR_ALREADYEXISTS# -> AlreadyExists
- ERR_HARDWAREFAULT# -> HardwareFault
- ERR_ILLEGALOPERATION# -> IllegalOperation
- ERR_INAPPROPRIATETYPE# -> InappropriateType
- ERR_INTERRUPTED# -> Interrupted
- ERR_INVALIDARGUMENT# -> InvalidArgument
- ERR_NOSUCHTHING# -> NoSuchThing
- ERR_OTHERERROR# -> OtherError
- ERR_PERMISSIONDENIED# -> PermissionDenied
- ERR_PROTOCOLERROR# -> ProtocolError
- ERR_RESOURCEBUSY# -> ResourceBusy
- ERR_RESOURCEEXHAUSTED# -> ResourceExhausted
- ERR_RESOURCEVANISHED# -> ResourceVanished
- ERR_SYSTEMERROR# -> SystemError
- ERR_TIMEEXPIRED# -> TimeExpired
- ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints
- ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation
- ERR_EOF# -> EOF
+ case errtype of
+ ERR_ALREADYEXISTS -> AlreadyExists
+ ERR_HARDWAREFAULT -> HardwareFault
+ ERR_ILLEGALOPERATION -> IllegalOperation
+ ERR_INAPPROPRIATETYPE -> InappropriateType
+ ERR_INTERRUPTED -> Interrupted
+ ERR_INVALIDARGUMENT -> InvalidArgument
+ ERR_NOSUCHTHING -> NoSuchThing
+ ERR_OTHERERROR -> OtherError
+ ERR_PERMISSIONDENIED -> PermissionDenied
+ ERR_PROTOCOLERROR -> ProtocolError
+ ERR_RESOURCEBUSY -> ResourceBusy
+ ERR_RESOURCEEXHAUSTED -> ResourceExhausted
+ ERR_RESOURCEVANISHED -> ResourceVanished
+ ERR_SYSTEMERROR -> SystemError
+ ERR_TIMEEXPIRED -> TimeExpired
+ ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints
+ ERR_UNSUPPORTEDOPERATION -> UnsupportedOperation
+ ERR_EOF -> EOF
_ -> OtherError
msg =
unpackCString str ++
(case iot of
- OtherError -> "(error code: " ++ show (I# errtype#) ++ ")"
+ OtherError -> "(error code: " ++ show errtype ++ ")"
_ -> "") ++
(case reason of
Nothing -> ""
\begin{code}
+#ifndef __HUGS__
{-
Sigh, the MVar ops in ConcBase depend on IO, the IO
representation here depend on MVars for handles (when
the definition of MVars go here:
-}
-data MVar a = MVar (SynchVar# RealWorld a)
+data MVar a = MVar (MVar# RealWorld a)
{-
Double sigh - ForeignObj is needed here too to break a cycle.
data ForeignObj = ForeignObj ForeignObj# -- another one
instance CCallable ForeignObj
instance CCallable ForeignObj#
-
-makeForeignObj :: Addr -> Addr -> IO ForeignObj
-makeForeignObj (A# obj) (A# finaliser) = IO ( \ s# ->
- case makeForeignObj# obj finaliser s# of
- StateAndForeignObj# s1# fo# -> IOok s1# (ForeignObj fo#))
-
-data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj#
-
+#endif /* ndef __HUGS__ */
#if defined(__CONCURRENT_HASKELL__)
newtype Handle = Handle (MVar Handle__)
newtype Handle = Handle (MutableVar RealWorld Handle__)
#endif
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
-#else
-#define FILE_OBJECT Addr
-#endif
-
{-
A Handle is represented by (a reference to) a record
containing the state of the I/O port/device. We record
Note: when a Handle is garbage collected, we want to flush its buffer
and close the OS file handle, so as to free up a (precious) resource.
-
-This means that the finaliser for the handle needs to have access to
-the buffer and the OS file handle. The current implementation of foreign
-objects requires that the finaliser is implemented in C, so to
-arrange for this to happen, openFile() returns a pointer to a structure
-big enough to hold the OS file handle and a pointer to the buffer.
-This pointer is then wrapped up inside a ForeignObj, and finalised
-as desired.
-
-}
data Handle__
= Handle__ {
{-
Internally, we classify handles as being one
of the following:
-
-}
data Handle__Type
= ErrorHandle IOError
showsPrec p (Handle h) =
let
#if defined(__CONCURRENT_HASKELL__)
+#ifdef __HUGS__
+ hdl_ = unsafePerformIO (primTakeMVar h)
+#else
-- (Big) SIGH: unfolded defn of takeMVar to avoid
-- an (oh-so) unfortunate module loop with PrelConc.
hdl_ = unsafePerformIO (IO $ \ s# ->
case h of { MVar h# ->
- case takeMVar# h# s# of { StateAndPtr# s2# r ->
- IOok s2# r }})
+ case takeMVar# h# s# of { (# s2# , r #) ->
+ (# s2#, r #) }})
+#endif
#else
hdl_ = unsafePerformIO (stToIO (readVar h))
#endif
BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def)
where
def :: Int
- def = unsafePerformIO (_ccall_ getBufSize fo)
-
-
-{-
- nullFile__ is only used for closed handles, plugging it in as
- a null file object reference.
--}
-nullFile__ :: FILE_OBJECT
-nullFile__ =
-#ifndef __PARALLEL_HASKELL__
- unsafePerformIO (makeForeignObj nullAddr nullAddr{-i.e., don't finalise-})
-#else
- nullAddr
-#endif
-
-
-mkClosedHandle__ :: Handle__
-mkClosedHandle__ =
- Handle__
- nullFile__
- ClosedHandle
- NoBuffering
- "closed file"
-
-mkErrorHandle__ :: IOError -> Handle__
-mkErrorHandle__ ioe =
- Handle__
- nullFile__
- (ErrorHandle ioe)
- NoBuffering
- "error handle"
+ def = unsafePerformIO (CCALL(getBufSize) fo)
mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
mkBuffer__ fo sz_in_bytes = do
case sz_in_bytes of
0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer.
_ -> do
- chunk <- _ccall_ allocMemory__ sz_in_bytes
+ chunk <- CCALL(allocMemory__) sz_in_bytes
if chunk == nullAddr
then fail (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
else return chunk
- _ccall_ setBuf fo chunk sz_in_bytes
+ CCALL(setBuf) fo chunk sz_in_bytes
\end{code}
{- Read instance defined in IO. -}
\end{code}
-
-%*********************************************************
-%* *
-\subsection{Unsafe @IO@ operations}
-%* *
-%*********************************************************
-
-\begin{code}
-{-# NOINLINE unsafePerformIO #-}
-unsafePerformIO :: IO a -> a
-unsafePerformIO (IO m)
- = case m realWorld# of
- IOok _ r -> r
- IOfail _ e -> error ("unsafePerformIO: I/O error: " ++ show e ++ "\n")
-
-{-# NOINLINE unsafeInterleaveIO #-}
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO (IO m) = IO ( \ s ->
- let
- IOok _ r = m s
- in
- IOok s r)
-
-\end{code}
head (x:_) = x
head [] = errorEmptyList "head"
+tail :: [a] -> [a]
+tail (_:xs) = xs
+tail [] = errorEmptyList "tail"
+
last :: [a] -> a
+#ifdef USE_REPORT_PRELUDE
last [x] = x
last (_:xs) = last xs
last [] = errorEmptyList "last"
-
-tail :: [a] -> [a]
-tail (_:xs) = xs
-tail [] = errorEmptyList "tail"
+#else
+-- eliminate repeated cases
+last [] = errorEmptyList "last"
+last (x:xs) = last' x xs
+ where last' x [] = x
+ last' _ (x:xs) = last' x xs
+#endif
init :: [a] -> [a]
+#ifdef USE_REPORT_PRELUDE
init [x] = []
init (x:xs) = x : init xs
init [] = errorEmptyList "init"
+#else
+-- eliminate repeated cases
+init [] = errorEmptyList "init"
+init (x:xs) = init' x xs
+ where init' x [] = []
+ init' x (y:xs) = x : init' y xs
+#endif
null :: [a] -> Bool
null [] = True
-- here's a more efficient version
unlines [] = []
unlines (l:ls) = l ++ '\n' : unlines ls
-
#endif
unwords :: [String] -> String
\section[PrelMain]{Module @PrelMain@}
\begin{code}
+{-# OPTIONS -#include "cbits/stgio.h" #-}
+
module PrelMain( mainIO ) where
import Prelude
import {-# SOURCE #-} qualified Main -- for type of "Main.main"
-import PrelErr ( ioError )
+import IO ( hFlush, hPutStr, stdout, stderr )
+import PrelAddr ( Addr )
+import PrelException
+import PrelPack ( packString )
+import PrelArr ( ByteArray(..) )
\end{code}
\begin{code}
mainIO :: IO () -- It must be of type (IO t) because that's what
-- the RTS expects. GHC doesn't check this, so
-- make sure this type signature stays!
-mainIO = catch Main.main (\err -> ioError (showsPrec 0 err "\n"))
+mainIO = catchException Main.main handler
+
+-- make sure we handle errors while reporting the error!
+-- (e.g. evaluating the string passed to 'error' might generate
+-- another error, etc.)
+
+handler :: Exception -> IO ()
+handler err = catchException (real_handler err) handler
+
+real_handler :: Exception -> IO ()
+real_handler ex =
+ case ex of
+ ErrorCall s -> reportError s
+ other -> hPutStr stderr (showsPrec 0 other "\n") >>
+ _ccall_ stg_exit (1::Int)
+
+-- calls to 'error' are treated slightly differently...
+
+reportError :: String -> IO ()
+reportError str = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ let bs@(ByteArray (_,len) _) = packString str
+ _ccall_ writeErrString__ (``&ErrorHdrHook''::Addr) bs len
+ _ccall_ stg_exit (1::Int)
+
\end{code}
\section[PrelNum]{Module @PrelNum@}
-Numeric part of the prelude.
-
-It's rather big!
-
\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/floatExtreme.h" #-}
-{-# OPTIONS -H20m #-}
+{-# OPTIONS -fno-implicit-prelude #-}
-#include "../includes/ieee-flpt.h"
-
-\end{code}
-
-\begin{code}
module PrelNum where
import PrelBase
-import PrelGHC
-import {-# SOURCE #-} PrelErr ( error )
-import PrelList
-import PrelMaybe
-
-import PrelArr ( Array, array, (!) )
-import PrelIOBase ( unsafePerformIO )
-import Ix ( Ix(..) )
-import PrelCCall () -- we need the definitions of CCallable and
- -- CReturnable for the _ccall_s herein.
-
+import Ix
+import {-# SOURCE #-} PrelErr
infixr 8 ^, ^^, **
-infixl 7 /, %, `quot`, `rem`, `div`, `mod`
+infixl 7 %, /, `quot`, `rem`, `div`, `mod`
\end{code}
-
%*********************************************************
%* *
\subsection{Standard numeric classes}
%*********************************************************
%* *
-\subsection{Overloaded numeric functions}
-%* *
-%*********************************************************
-
-\begin{code}
-even, odd :: (Integral a) => a -> Bool
-even n = n `rem` 2 == 0
-odd = not . even
-
-{-# SPECIALISE gcd ::
- Int -> Int -> Int,
- Integer -> Integer -> Integer #-}
-gcd :: (Integral a) => a -> a -> a
-gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
-gcd x y = gcd' (abs x) (abs y)
- where gcd' x 0 = x
- gcd' x y = gcd' y (x `rem` y)
-
-{-# SPECIALISE lcm ::
- Int -> Int -> Int,
- Integer -> Integer -> Integer #-}
-lcm :: (Integral a) => a -> a -> a
-lcm _ 0 = 0
-lcm 0 _ = 0
-lcm x y = abs ((x `quot` (gcd x y)) * y)
-
-{-# SPECIALISE (^) ::
- Integer -> Integer -> Integer,
- Integer -> Int -> Integer,
- Int -> Int -> Int #-}
-(^) :: (Num a, Integral b) => a -> b -> a
-x ^ 0 = 1
-x ^ n | n > 0 = f x (n-1) x
- where f _ 0 y = y
- f x n y = g x n where
- g x n | even n = g (x*x) (n `quot` 2)
- | otherwise = f x (n-1) (x*y)
-_ ^ _ = error "Prelude.^: negative exponent"
-
-{-# SPECIALISE (^^) ::
- Double -> Int -> Double,
- Rational -> Int -> Rational #-}
-(^^) :: (Fractional a, Integral b) => a -> b -> a
-x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
-
-{-# SPECIALIZE fromIntegral ::
- Int -> Rational,
- Integer -> Rational,
- Int -> Int,
- Int -> Integer,
- Int -> Float,
- Int -> Double,
- Integer -> Int,
- Integer -> Integer,
- Integer -> Float,
- Integer -> Double #-}
-fromIntegral :: (Integral a, Num b) => a -> b
-fromIntegral = fromInteger . toInteger
-
-{-# SPECIALIZE fromRealFrac ::
- Double -> Rational,
- Rational -> Double,
- Float -> Rational,
- Rational -> Float,
- Rational -> Rational,
- Double -> Double,
- Double -> Float,
- Float -> Float,
- Float -> Double #-}
-fromRealFrac :: (RealFrac a, Fractional b) => a -> b
-fromRealFrac = fromRational . toRational
-
-atan2 :: (RealFloat a) => a -> a -> a
-atan2 y x = case (signum y, signum x) of
- ( 0, 1) -> 0
- ( 1, 0) -> pi/2
- ( 0,-1) -> pi
- (-1, 0) -> (negate pi)/2
- ( _, 1) -> atan (y/x)
- ( _,-1) -> atan (y/x) + pi
- ( 0, 0) -> error "Prelude.atan2: atan2 of origin"
-\end{code}
-
-
-%*********************************************************
-%* *
\subsection{Instances for @Int@}
%* *
%*********************************************************
then a `remInt` b
else error "Integral.Int.rem{PreludeCore}: divide by 0\n"
- n `div` d
- | n > 0 && d < 0 = mk_neg (quotInt (n-d-1) d)
- | n < 0 && d > 0 = mk_neg (quotInt (n-d+1) d)
- | otherwise = quotInt n d
- where
- {-
- - the result of (integral) division is
- defined as being truncated towards
- negative infinity. (see Sec 6.3.2 of
- the Haskell 1.4 report.)
-
- - in the case of Int, if either nominator or
- denominator is negative, we adjust the nominator
- to account for the above property before
- computing the quotient.
-
- - in the case of Int, the adjustment of the
- nominator runs the risk of overflowing. If
- we make the assumption that arithmetic is
- modulo word size, and adjust the final result
- to account for this.
- -}
-
- mk_neg r
- | r <= 0 = r
- | otherwise = -(r+1)
-
+ x `div` y = if x > 0 && y < 0 then quotInt (x-y-1) y
+ else if x < 0 && y > 0 then quotInt (x-y+1) y
+ else quotInt x y
x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then
if r/=0 then r+y else 0
else
divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y)
-- Stricter. Sorry if you don't like it. (WDP 94/10)
- toInteger (I# n#) = int2Integer# n# -- give back a full-blown Integer
+--OLD: even x = eqInt (x `mod` 2) 0
+--OLD: odd x = neInt (x `mod` 2) 0
+
+ toInteger (I# i) = int2Integer i -- give back a full-blown Integer
toInt x = x
\end{code}
-
%*********************************************************
%* *
-\subsection{Type @Integer@}
+\subsection{Instances for @Integer@}
%* *
%*********************************************************
-These types are used to return from integer primops
-
\begin{code}
-data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray#
-data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray#
-\end{code}
-
-Instances
-
-\begin{code}
-instance Eq Integer where
- (J# a1 s1 d1) == (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) ==# 0#
-
- (J# a1 s1 d1) /= (J# a2 s2 d2)
- = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0#
-
instance Ord Integer where
(J# a1 s1 d1) <= (J# a2 s2 d2)
= (cmpInteger# a1 s1 d1 a2 s2 d2) <=# 0#
instance Num Integer where
(+) (J# a1 s1 d1) (J# a2 s2 d2)
- = plusInteger# a1 s1 d1 a2 s2 d2
+ = case plusInteger# a1 s1 d1 a2 s2 d2 of (# a, s, d #) -> J# a s d
(-) (J# a1 s1 d1) (J# a2 s2 d2)
- = minusInteger# a1 s1 d1 a2 s2 d2
+ = case minusInteger# a1 s1 d1 a2 s2 d2 of (# a, s, d #) -> J# a s d
- negate (J# a s d) = negateInteger# a s d
+ negate (J# a s d)
+ = case negateInteger# a s d of (# a, s, d #) -> J# a s d
(*) (J# a1 s1 d1) (J# a2 s2 d2)
- = timesInteger# a1 s1 d1 a2 s2 d2
+ = case timesInteger# a1 s1 d1 a2 s2 d2 of (# a, s, d #) -> J# a s d
-- ORIG: abs n = if n >= 0 then n else -n
= case 0 of { J# a2 s2 d2 ->
if (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0#
then n
- else negateInteger# a1 s1 d1
+ else case negateInteger# a1 s1 d1 of (# a, s, d #) -> J# a s d
}
signum n@(J# a1 s1 d1)
fromInteger x = x
- fromInt (I# n#) = int2Integer# n# -- gives back a full-blown Integer
+ fromInt (I# i) = int2Integer i
instance Real Integer where
toRational x = x % 1
instance Integral Integer where
quotRem (J# a1 s1 d1) (J# a2 s2 d2)
= case (quotRemInteger# a1 s1 d1 a2 s2 d2) of
- Return2GMPs a3 s3 d3 a4 s4 d4
+ (# a3, s3, d3, a4, s4, d4 #)
-> (J# a3 s3 d3, J# a4 s4 d4)
{- USING THE UNDERLYING "GMP" CODE IS DUBIOUS FOR NOW:
| otherwise = error "Integer.index: Index out of range."
inRange (m,n) i = m <= i && i <= n
-integer_0, integer_1, integer_2, integer_m1 :: Integer
-integer_0 = int2Integer# 0#
-integer_1 = int2Integer# 1#
-integer_2 = int2Integer# 2#
-integer_m1 = int2Integer# (negateInt# 1#)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Type @Float@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Eq Float where
- (F# x) == (F# y) = x `eqFloat#` y
-
-instance Ord Float where
- (F# x) `compare` (F# y) | x `ltFloat#` y = LT
- | x `eqFloat#` y = EQ
- | otherwise = GT
-
- (F# x) < (F# y) = x `ltFloat#` y
- (F# x) <= (F# y) = x `leFloat#` y
- (F# x) >= (F# y) = x `geFloat#` y
- (F# x) > (F# y) = x `gtFloat#` y
-
-instance Num Float where
- (+) x y = plusFloat x y
- (-) x y = minusFloat x y
- negate x = negateFloat x
- (*) x y = timesFloat x y
- abs x | x >= 0.0 = x
- | otherwise = negateFloat x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
- fromInteger n = encodeFloat n 0
- fromInt i = int2Float i
-
-instance Real Float where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Float where
- (/) x y = divideFloat x y
- fromRational x = fromRat x
- recip x = 1.0 / x
-
-instance Floating Float where
- pi = 3.141592653589793238
- exp x = expFloat x
- log x = logFloat x
- sqrt x = sqrtFloat x
- sin x = sinFloat x
- cos x = cosFloat x
- tan x = tanFloat x
- asin x = asinFloat x
- acos x = acosFloat x
- atan x = atanFloat x
- sinh x = sinhFloat x
- cosh x = coshFloat x
- tanh x = tanhFloat x
- (**) x y = powerFloat x y
- logBase x y = log y / log x
-
- asinh x = log (x + sqrt (1.0+x*x))
- acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
- atanh x = log ((x+1.0) / sqrt (1.0-x*x))
-
-instance RealFrac Float where
-
- {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
- {-# SPECIALIZE truncate :: Float -> Int #-}
- {-# SPECIALIZE round :: Float -> Int #-}
- {-# SPECIALIZE ceiling :: Float -> Int #-}
- {-# SPECIALIZE floor :: Float -> Int #-}
-
- {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
- {-# SPECIALIZE truncate :: Float -> Integer #-}
- {-# SPECIALIZE round :: Float -> Integer #-}
- {-# SPECIALIZE ceiling :: Float -> Integer #-}
- {-# SPECIALIZE floor :: Float -> Integer #-}
-
- properFraction x
- = case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
- }
-
- truncate x = case properFraction x of
- (n,_) -> n
-
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
-
- ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
-
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
-
-instance RealFloat Float where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = FLT_MANT_DIG -- ditto
- floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
-
- decodeFloat (F# f#)
- = case decodeFloat# f# of
- ReturnIntAndGMP exp# a# s# d# ->
- (J# a# s# d#, I# exp#)
-
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
-
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
-
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
-
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatInfinite x) {- ditto! -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ...
- isIEEE x = True
-
-instance Show Float where
- showsPrec x = showSigned showFloat x
- showList = showList__ (showsPrec 0)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Type @Double@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance Eq Double where
- (D# x) == (D# y) = x ==## y
-
-instance Ord Double where
- (D# x) `compare` (D# y) | x <## y = LT
- | x ==## y = EQ
- | otherwise = GT
-
- (D# x) < (D# y) = x <## y
- (D# x) <= (D# y) = x <=## y
- (D# x) >= (D# y) = x >=## y
- (D# x) > (D# y) = x >## y
-
-instance Num Double where
- (+) x y = plusDouble x y
- (-) x y = minusDouble x y
- negate x = negateDouble x
- (*) x y = timesDouble x y
- abs x | x >= 0.0 = x
- | otherwise = negateDouble x
- signum x | x == 0.0 = 0
- | x > 0.0 = 1
- | otherwise = negate 1
- fromInteger n = encodeFloat n 0
- fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
-
-instance Real Double where
- toRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Double where
- (/) x y = divideDouble x y
- fromRational x = fromRat x
- recip x = 1.0 / x
-
-instance Floating Double where
- pi = 3.141592653589793238
- exp x = expDouble x
- log x = logDouble x
- sqrt x = sqrtDouble x
- sin x = sinDouble x
- cos x = cosDouble x
- tan x = tanDouble x
- asin x = asinDouble x
- acos x = acosDouble x
- atan x = atanDouble x
- sinh x = sinhDouble x
- cosh x = coshDouble x
- tanh x = tanhDouble x
- (**) x y = powerDouble x y
- logBase x y = log y / log x
-
- asinh x = log (x + sqrt (1.0+x*x))
- acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
- atanh x = log ((x+1.0) / sqrt (1.0-x*x))
-
-instance RealFrac Double where
-
- {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Int #-}
- {-# SPECIALIZE round :: Double -> Int #-}
- {-# SPECIALIZE ceiling :: Double -> Int #-}
- {-# SPECIALIZE floor :: Double -> Int #-}
-
- {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Integer #-}
- {-# SPECIALIZE round :: Double -> Integer #-}
- {-# SPECIALIZE ceiling :: Double -> Integer #-}
- {-# SPECIALIZE floor :: Double -> Integer #-}
-
-#if defined(__UNBOXED_INSTANCES__)
- {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Int# #-}
- {-# SPECIALIZE round :: Double -> Int# #-}
- {-# SPECIALIZE ceiling :: Double -> Int# #-}
- {-# SPECIALIZE floor :: Double -> Int# #-}
-#endif
-
- properFraction x
- = case (decodeFloat x) of { (m,n) ->
- let b = floatRadix x in
- if n >= 0 then
- (fromInteger m * fromInteger b ^ n, 0.0)
- else
- case (quotRem m (b^(negate n))) of { (w,r) ->
- (fromInteger w, encodeFloat r n)
- }
- }
-
- truncate x = case properFraction x of
- (n,_) -> n
-
- round x = case properFraction x of
- (n,r) -> let
- m = if r < 0.0 then n - 1 else n + 1
- half_down = abs r - 0.5
- in
- case (compare half_down 0.0) of
- LT -> n
- EQ -> if even n then n else m
- GT -> m
-
- ceiling x = case properFraction x of
- (n,r) -> if r > 0.0 then n + 1 else n
-
- floor x = case properFraction x of
- (n,r) -> if r < 0.0 then n - 1 else n
-
-instance RealFloat Double where
- floatRadix _ = FLT_RADIX -- from float.h
- floatDigits _ = DBL_MANT_DIG -- ditto
- floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
-
- decodeFloat (D# d#)
- = case decodeDouble# d# of
- ReturnIntAndGMP exp# a# s# d# ->
- (J# a# s# d#, I# exp#)
-
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# }
-
- exponent x = case decodeFloat x of
- (m,n) -> if m == 0 then 0 else n + floatDigits x
-
- significand x = case decodeFloat x of
- (m,_) -> encodeFloat m (negate (floatDigits x))
-
- scaleFloat k x = case decodeFloat x of
- (m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleInfinite x) {- ditto -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNegativeZero x) -- ...
- isIEEE x = True
-
-instance Show Double where
- showsPrec x = showSigned showFloat x
- showList = showList__ (showsPrec 0)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Common code for @Float@ and @Double@}
-%* *
-%*********************************************************
+showSignedInteger :: Int -> Integer -> ShowS
+showSignedInteger p n r
+ = -- from HBC version; support code follows
+ if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
-The @Enum@ instances for Floats and Doubles are slightly unusual.
-The @toEnum@ function truncates numbers to Int. The definitions
-of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic
-series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat
-dubious. This example may have either 10 or 11 elements, depending on
-how 0.1 is represented.
+jtos :: Integer -> String
+jtos n
+ = if n < 0 then
+ '-' : jtos' (-n) []
+ else
+ jtos' n []
-NOTE: The instances for Float and Double do not make use of the default
-methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being
-a `non-lossy' conversion to and from Ints. Instead we make use of the
-1.2 default methods (back in the days when Enum had Ord as a superclass)
-for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.)
+jtos' :: Integer -> String -> String
+jtos' n cs
+ = if n < 10 then
+ chr (fromInteger (n + ord_0)) : cs
+ else
+ jtos' q (chr (toInt r + (ord_0::Int)) : cs)
+ where
+ (q,r) = n `quotRem` 10
-\begin{code}
-instance Enum Float where
- toEnum = fromIntegral
- fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-instance Enum Double where
- toEnum = fromIntegral
- fromEnum = fromInteger . truncate -- may overflow
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-numericEnumFrom :: (Real a) => a -> [a]
-numericEnumFromThen :: (Real a) => a -> a -> [a]
-numericEnumFromThenTo :: (Real a) => a -> a -> a -> [a]
-numericEnumFrom = iterate (+1)
-numericEnumFromThen n m = iterate (+(m-n)) n
-numericEnumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
- (numericEnumFromThen n m)
\end{code}
-
%*********************************************************
%* *
\subsection{The @Ratio@ and @Rational@ types}
%*********************************************************
\begin{code}
-data (Eval a, Integral a) => Ratio a = !a :% !a deriving (Eq)
+data (Integral a) => Ratio a = !a :% !a deriving (Eq)
type Rational = Ratio Integer
-\end{code}
-\begin{code}
{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
-
(%) :: (Integral a) => a -> a -> Ratio a
numerator, denominator :: (Integral a) => Ratio a -> a
-approxRational :: (RealFrac a) => a -> a -> Rational
-
\end{code}
\tr{reduce} is a subsidiary function used only in this module .
denominator (x:%y) = y
\end{code}
-
-@approxRational@, applied to two real fractional numbers x and epsilon,
-returns the simplest rational number within epsilon of x. A rational
-number n%d in reduced form is said to be simpler than another n'%d' if
-abs n <= abs n' && d <= d'. Any real interval contains a unique
-simplest rational; here, for simplicity, we assume a closed rational
-interval. If such an interval includes at least one whole number, then
-the simplest rational is the absolutely least whole number. Otherwise,
-the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
-and abs r' < d', and the simplest rational is q%1 + the reciprocal of
-the simplest rational between d'%r' and d%r.
-
-\begin{code}
-approxRational x eps = simplest (x-eps) (x+eps)
- where simplest x y | y < x = simplest y x
- | x == y = xr
- | x > 0 = simplest' n d n' d'
- | y < 0 = - simplest' (-n') d' (-n) d
- | otherwise = 0 :% 1
- where xr = toRational x
- n = numerator xr
- d = denominator xr
- nd' = toRational y
- n' = numerator nd'
- d' = denominator nd'
-
- simplest' n d n' d' -- assumes 0 < n%d < n'%d'
- | r == 0 = q :% 1
- | q /= q' = (q+1) :% 1
- | otherwise = (q*n''+d'') :% n''
- where (q,r) = quotRem n d
- (q',r') = quotRem n' d'
- nd'' = simplest' d' r' d r
- n'' = numerator nd''
- d'' = denominator nd''
-\end{code}
-
-
-\begin{code}
-instance (Integral a) => Ord (Ratio a) where
- (x:%y) <= (x':%y') = x * y' <= x' * y
- (x:%y) < (x':%y') = x * y' < x' * y
-
-instance (Integral a) => Num (Ratio a) where
- (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
- (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
- (x:%y) * (x':%y') = reduce (x * x') (y * y')
- negate (x:%y) = (-x) :% y
- abs (x:%y) = abs x :% y
- signum (x:%y) = signum x :% 1
- fromInteger x = fromInteger x :% 1
-
-instance (Integral a) => Real (Ratio a) where
- toRational (x:%y) = toInteger x :% toInteger y
-
-instance (Integral a) => Fractional (Ratio a) where
- (x:%y) / (x':%y') = (x*y') % (y*x')
- recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
- fromRational (x:%y) = fromInteger x :% fromInteger y
-
-instance (Integral a) => RealFrac (Ratio a) where
- properFraction (x:%y) = (fromIntegral q, r:%y)
- where (q,r) = quotRem x y
-
-instance (Integral a) => Enum (Ratio a) where
- enumFrom = iterate ((+)1)
- enumFromThen n m = iterate ((+)(m-n)) n
- toEnum n = fromIntegral n :% 1
- fromEnum = fromInteger . truncate
-
-instance (Integral a) => Show (Ratio a) where
- showsPrec p (x:%y) = showParen (p > ratio_prec)
- (shows x . showString " % " . shows y)
-
--- defn. also used by the Read (Ratio a) instance PrelRead.
-ratio_prec :: Int
-ratio_prec = 7
-
-\end{code}
-
-\begin{code}
---Exported from std library Numeric, defined here to
---avoid mut. rec. between PrelNum and Numeric.
-showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
-showSigned showPos p x
- | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x))
- | otherwise = showPos x
-
-showSignedInteger :: Int -> Integer -> ShowS
-showSignedInteger p n r
- = -- from HBC version; support code follows
- if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
-
-jtos :: Integer -> String
-jtos n
- | n < 0 = '-' : jtos' (-n) []
- | otherwise = jtos' n []
-
-jtos' :: Integer -> String -> String
-jtos' n cs
- | n < 10 = chr (fromInteger (n + ord_0)) : cs
- | otherwise = jtos' q (chr (toInt r + (ord_0::Int)) : cs)
- where
- (q,r) = n `quotRem` 10
-
-showFloat x = showString (formatRealFloat FFGeneric Nothing x)
-
--- These are the format types. This type is not exported.
-
-data FFFormat = FFExponent | FFFixed | FFGeneric --no need: deriving (Eq, Ord, Show)
-
-formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
-formatRealFloat fmt decs x = s
- where
- base = 10
- base_i = toInteger base
-
- s
- | isNaN x = "NaN"
- | isInfinite x = (\ str -> if x < 0 then '-':str else str) "Infinity"
- | x < 0 || isNegativeZero x = '-' : doFmt fmt (floatToDigits base_i (-x))
- | otherwise = doFmt fmt (floatToDigits base_i x)
-
- doFmt fmt (is, e) =
- let ds = map intToDigit is in
- case fmt of
- FFGeneric ->
- doFmt (if e <0 || e > 7 then FFExponent else FFFixed)
- (is,e)
- FFExponent ->
- case decs of
- Nothing ->
- let e' = if e==0 then 0 else e-1 in
- (case ds of
- [d] -> d : ".0e"
- (d:ds) -> d : '.' : ds ++ "e") ++ show e'
- Just dec ->
- let dec' = max dec 1 in
- case is of
- [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
- _ ->
- let
- (ei,is') = roundTo base (dec'+1) is
- d:ds = map intToDigit (if ei > 0 then init is' else is')
- in
- d:'.':ds ++ 'e':show (e-1+ei)
- FFFixed ->
- let
- mk0 ls = case ls of { "" -> "0" ; _ -> ls}
- in
- case decs of
- Nothing ->
- let
- f 0 s ds = mk0 (reverse s) ++ '.':mk0 ds
- f n s "" = f (n-1) ('0':s) ""
- f n s (d:ds) = f (n-1) (d:s) ds
- in
- f e "" ds
- Just dec ->
- let dec' = max dec 1 in
- if e >= 0 then
- let
- (ei,is') = roundTo base (dec' + e) is
- (ls,rs) = splitAt (e+ei) (map intToDigit is')
- in
- mk0 ls ++ (if null rs then "" else '.':rs)
- else
- let
- (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)
- d:ds = map intToDigit (if ei > 0 then is' else 0:is')
- in
- d : '.' : ds
-
-
-roundTo :: Int -> Int -> [Int] -> (Int,[Int])
-roundTo base d is =
- let
- v = f d is
- in
- case v of
- (0,is) -> v
- (1,is) -> (1, 1:is)
- where
- b2 = base `div` 2
-
- f n [] = (0, replicate n 0)
- f 0 (i:_) = (if i>=b2 then 1 else 0, [])
- f d (i:is) =
- let
- (c,ds) = f (d-1) is
- i' = c + i
- in
- if i' == base then (1,0:ds) else (0,i':ds)
-
---
--- Based on "Printing Floating-Point Numbers Quickly and Accurately"
--- by R.G. Burger and R.K. Dybvig in PLDI 96.
--- This version uses a much slower logarithm estimator. It should be improved.
-
--- This function returns a list of digits (Ints in [0..base-1]) and an
--- exponent.
---floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
-floatToDigits _ 0 = ([0], 0)
-floatToDigits base x =
- let
- (f0, e0) = decodeFloat x
- (minExp0, _) = floatRange x
- p = floatDigits x
- b = floatRadix x
- minExp = minExp0 - p -- the real minimum exponent
- -- Haskell requires that f be adjusted so denormalized numbers
- -- will have an impossibly low exponent. Adjust for this.
- (f, e) =
- let n = minExp - e0 in
- if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
- (r, s, mUp, mDn) =
- if e >= 0 then
- let be = b^ e in
- if f == b^(p-1) then
- (f*be*b*2, 2*b, be*b, b)
- else
- (f*be*2, 2, be, be)
- else
- if e > minExp && f == b^(p-1) then
- (f*b*2, b^(-e+1)*2, b, 1)
- else
- (f*2, b^(-e)*2, 1, 1)
- k =
- let
- k0 =
- if b == 2 && base == 10 then
- -- logBase 10 2 is slightly bigger than 3/10 so
- -- the following will err on the low side. Ignoring
- -- the fraction will make it err even more.
- -- Haskell promises that p-1 <= logBase b f < p.
- (p - 1 + e0) * 3 `div` 10
- else
- ceiling ((log (fromInteger (f+1)) + fromInt e * log (fromInteger b)) /
- log (fromInteger base))
-
- fixup n =
- if n >= 0 then
- if r + mUp <= expt base n * s then n else fixup (n+1)
- else
- if expt base (-n) * (r + mUp) <= s then n else fixup (n+1)
- in
- fixup k0
-
- gen ds rn sN mUpN mDnN =
- let
- (dn, rn') = (rn * base) `divMod` sN
- mUpN' = mUpN * base
- mDnN' = mDnN * base
- in
- case (rn' < mDnN', rn' + mUpN' > sN) of
- (True, False) -> dn : ds
- (False, True) -> dn+1 : ds
- (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
- (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
-
- rds =
- if k >= 0 then
- gen [] r (s * expt base k) mUp mDn
- else
- let bk = expt base (-k) in
- gen [] (r * bk) s (mUp * bk) (mDn * bk)
- in
- (map toInt (reverse rds), k)
-
-\end{code}
-
-@showRational@ converts a Rational to a string that looks like a
-floating point number, but without converting to any floating type
-(because of the possible overflow).
-
-From/by Lennart, 94/09/26
+%*********************************************************
+%* *
+\subsection{Overloaded numeric functions}
+%* *
+%*********************************************************
\begin{code}
-showRational :: Int -> Rational -> String
-showRational n r =
- if r == 0 then
- "0.0"
- else
- let (r', e) = normalize r
- in prR n r' e
-
-startExpExp = 4 :: Int
-
--- make sure 1 <= r < 10
-normalize :: Rational -> (Rational, Int)
-normalize r = if r < 1 then
- case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1)
- else
- norm startExpExp r 0
- where norm :: Int -> Rational -> Int -> (Rational, Int)
- -- Invariant: r*10^e == original r
- norm 0 r e = (r, e)
- norm ee r e =
- let n = 10^ee
- tn = 10^n
- in if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
-
-drop0 "" = ""
-drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
-
-prR :: Int -> Rational -> Int -> String
-prR n r e | r < 1 = prR n (r*10) (e-1) -- final adjustment
-prR n r e | r >= 10 = prR n (r/10) (e+1)
-prR n r e0 =
- let s = show ((round (r * 10^n))::Integer)
- e = e0+1
- in if e > 0 && e < 8 then
- take e s ++ "." ++ drop0 (drop e s)
- else if e <= 0 && e > -3 then
- "0." ++ take (-e) (repeat '0') ++ drop0 s
- else
- head s : "."++ drop0 (tail s) ++ "e" ++ show e0
-\end{code}
-
-
-[In response to a request for documentation of how fromRational works,
-Joe Fasel writes:] A quite reasonable request! This code was added to
-the Prelude just before the 1.2 release, when Lennart, working with an
-early version of hbi, noticed that (read . show) was not the identity
-for floating-point numbers. (There was a one-bit error about half the
-time.) The original version of the conversion function was in fact
-simply a floating-point divide, as you suggest above. The new version
-is, I grant you, somewhat denser.
-
-Unfortunately, Joe's code doesn't work! Here's an example:
-
-main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")
-
-This program prints
- 0.0000000000000000
-instead of
- 1.8217369128763981e-300
-
-Lennart's code follows, and it works...
-
-\begin{pseudocode}
-{-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
-fromRat :: (RealFloat a) => Rational -> a
-fromRat x = x'
- where x' = f e
-
--- If the exponent of the nearest floating-point number to x
--- is e, then the significand is the integer nearest xb^(-e),
--- where b is the floating-point radix. We start with a good
--- guess for e, and if it is correct, the exponent of the
--- floating-point number we construct will again be e. If
--- not, one more iteration is needed.
-
- f e = if e' == e then y else f e'
- where y = encodeFloat (round (x * (1 % b)^^e)) e
- (_,e') = decodeFloat y
- b = floatRadix x'
+even, odd :: (Integral a) => a -> Bool
+even n = n `rem` 2 == 0
+odd = not . even
--- We obtain a trial exponent by doing a floating-point
--- division of x's numerator by its denominator. The
--- result of this division may not itself be the ultimate
--- result, because of an accumulation of three rounding
--- errors.
+{-# SPECIALISE gcd ::
+ Int -> Int -> Int,
+ Integer -> Integer -> Integer #-}
+gcd :: (Integral a) => a -> a -> a
+gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' x 0 = x
+ gcd' x y = gcd' y (x `rem` y)
- (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
- / fromInteger (denominator x))
-\end{pseudocode}
+{-# SPECIALISE lcm ::
+ Int -> Int -> Int,
+ Integer -> Integer -> Integer #-}
+lcm :: (Integral a) => a -> a -> a
+lcm _ 0 = 0
+lcm 0 _ = 0
+lcm x y = abs ((x `quot` (gcd x y)) * y)
-Now, here's Lennart's code.
+{-# SPECIALISE (^) ::
+ Integer -> Integer -> Integer,
+ Integer -> Int -> Integer,
+ Int -> Int -> Int #-}
+(^) :: (Num a, Integral b) => a -> b -> a
+x ^ 0 = 1
+x ^ n | n > 0 = f x (n-1) x
+ where f _ 0 y = y
+ f x n y = g x n where
+ g x n | even n = g (x*x) (n `quot` 2)
+ | otherwise = f x (n-1) (x*y)
+_ ^ _ = error "Prelude.^: negative exponent"
-\begin{code}
-{-# SPECIALISE fromRat ::
- Rational -> Double,
- Rational -> Float #-}
-
---fromRat :: (RealFloat a) => Rational -> a
-fromRat x
- | x == 0 = encodeFloat 0 0 -- Handle exceptional cases
- | x < 0 = - fromRat' (-x) -- first.
- | otherwise = fromRat' x
-
--- Conversion process:
--- Scale the rational number by the RealFloat base until
--- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
--- Then round the rational to an Integer and encode it with the exponent
--- that we got from the scaling.
--- To speed up the scaling process we compute the log2 of the number to get
--- a first guess of the exponent.
-
-fromRat' :: (RealFloat a) => Rational -> a
-fromRat' x = r
- where b = floatRadix r
- p = floatDigits r
-
- (minExp0, _) = floatRange r
-
- minExp = minExp0 - p -- the real minimum exponent
-
- xMin = toRational (expt b (p-1))
- xMax = toRational (expt b p)
-
- p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
- f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
- (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
-
- r = encodeFloat (round x') p'
-
--- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
-scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
-scaleRat b minExp xMin xMax p x
- | p <= minExp = (x, p)
- | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b)
- | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b)
- | otherwise = (x, p)
-
--- Exponentiation with a cache for the most common numbers.
-minExpt = 0::Int
-maxExpt = 1100::Int
-
-expt :: Integer -> Int -> Integer
-expt base n
- | base == 2 && n >= minExpt && n <= maxExpt = expts!n
- | otherwise = base^n
-
-expts :: Array Int Integer
-expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
-
--- Compute the (floor of the) log of i in base b.
--- Simplest way would be just divide i by b until it's smaller then b, but that would
--- be very slow! We are just slightly more clever.
-integerLogBase :: Integer -> Integer -> Int
-integerLogBase b i
- | i < b = 0
- | otherwise = doDiv (i `div` (b^l)) l
- where
- -- Try squaring the base first to cut down the number of divisions.
- l = 2 * integerLogBase (b*b) i
-
- doDiv :: Integer -> Int -> Int
- doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
+{- SPECIALISE (^^) ::
+ Double -> Int -> Double,
+ Rational -> Int -> Rational #-}
+(^^) :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
+atan2 :: (RealFloat a) => a -> a -> a
+atan2 y x = case (signum y, signum x) of
+ ( 0, 1) -> 0
+ ( 1, 0) -> pi/2
+ ( 0,-1) -> pi
+ (-1, 0) -> (negate pi)/2
+ ( _, 1) -> atan (y/x)
+ ( _,-1) -> atan (y/x) + pi
+ ( 0, 0) -> error "Prelude.atan2: atan2 of origin"
\end{code}
-%*********************************************************
-%* *
-\subsection{Numeric primops}
-%* *
-%*********************************************************
-
-Definitions of the boxed PrimOps; these will be
-used in the case of partial applications, etc.
-
-\begin{code}
-plusFloat (F# x) (F# y) = F# (plusFloat# x y)
-minusFloat (F# x) (F# y) = F# (minusFloat# x y)
-timesFloat (F# x) (F# y) = F# (timesFloat# x y)
-divideFloat (F# x) (F# y) = F# (divideFloat# x y)
-negateFloat (F# x) = F# (negateFloat# x)
-
-gtFloat (F# x) (F# y) = gtFloat# x y
-geFloat (F# x) (F# y) = geFloat# x y
-eqFloat (F# x) (F# y) = eqFloat# x y
-neFloat (F# x) (F# y) = neFloat# x y
-ltFloat (F# x) (F# y) = ltFloat# x y
-leFloat (F# x) (F# y) = leFloat# x y
-
-float2Int (F# x) = I# (float2Int# x)
-int2Float (I# x) = F# (int2Float# x)
-
-expFloat (F# x) = F# (expFloat# x)
-logFloat (F# x) = F# (logFloat# x)
-sqrtFloat (F# x) = F# (sqrtFloat# x)
-sinFloat (F# x) = F# (sinFloat# x)
-cosFloat (F# x) = F# (cosFloat# x)
-tanFloat (F# x) = F# (tanFloat# x)
-asinFloat (F# x) = F# (asinFloat# x)
-acosFloat (F# x) = F# (acosFloat# x)
-atanFloat (F# x) = F# (atanFloat# x)
-sinhFloat (F# x) = F# (sinhFloat# x)
-coshFloat (F# x) = F# (coshFloat# x)
-tanhFloat (F# x) = F# (tanhFloat# x)
-
-powerFloat (F# x) (F# y) = F# (powerFloat# x y)
-
--- definitions of the boxed PrimOps; these will be
--- used in the case of partial applications, etc.
-
-plusDouble (D# x) (D# y) = D# (x +## y)
-minusDouble (D# x) (D# y) = D# (x -## y)
-timesDouble (D# x) (D# y) = D# (x *## y)
-divideDouble (D# x) (D# y) = D# (x /## y)
-negateDouble (D# x) = D# (negateDouble# x)
-
-gtDouble (D# x) (D# y) = x >## y
-geDouble (D# x) (D# y) = x >=## y
-eqDouble (D# x) (D# y) = x ==## y
-neDouble (D# x) (D# y) = x /=## y
-ltDouble (D# x) (D# y) = x <## y
-leDouble (D# x) (D# y) = x <=## y
-
-double2Int (D# x) = I# (double2Int# x)
-int2Double (I# x) = D# (int2Double# x)
-double2Float (D# x) = F# (double2Float# x)
-float2Double (F# x) = D# (float2Double# x)
-
-expDouble (D# x) = D# (expDouble# x)
-logDouble (D# x) = D# (logDouble# x)
-sqrtDouble (D# x) = D# (sqrtDouble# x)
-sinDouble (D# x) = D# (sinDouble# x)
-cosDouble (D# x) = D# (cosDouble# x)
-tanDouble (D# x) = D# (tanDouble# x)
-asinDouble (D# x) = D# (asinDouble# x)
-acosDouble (D# x) = D# (acosDouble# x)
-atanDouble (D# x) = D# (atanDouble# x)
-sinhDouble (D# x) = D# (sinhDouble# x)
-coshDouble (D# x) = D# (coshDouble# x)
-tanhDouble (D# x) = D# (tanhDouble# x)
-
-powerDouble (D# x) (D# y) = D# (x **## y)
-\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelNumExtra]{Module @PrelNumExtra@}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -H20m #-}
+
+#include "../includes/ieee-flpt.h"
+
+\end{code}
+
+\begin{code}
+module PrelNumExtra where
+
+import PrelBase
+import PrelGHC
+import PrelNum
+import {-# SOURCE #-} PrelErr ( error )
+import PrelList
+import PrelMaybe
+
+import PrelArr ( Array, array, (!) )
+import PrelIOBase ( unsafePerformIO )
+import Ix ( Ix(..) )
+import PrelCCall () -- we need the definitions of CCallable and
+ -- CReturnable for the _ccall_s herein.
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type @Float@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Eq Float where
+ (F# x) == (F# y) = x `eqFloat#` y
+
+instance Ord Float where
+ (F# x) `compare` (F# y) | x `ltFloat#` y = LT
+ | x `eqFloat#` y = EQ
+ | otherwise = GT
+
+ (F# x) < (F# y) = x `ltFloat#` y
+ (F# x) <= (F# y) = x `leFloat#` y
+ (F# x) >= (F# y) = x `geFloat#` y
+ (F# x) > (F# y) = x `gtFloat#` y
+
+instance Num Float where
+ (+) x y = plusFloat x y
+ (-) x y = minusFloat x y
+ negate x = negateFloat x
+ (*) x y = timesFloat x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateFloat x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
+ fromInteger n = encodeFloat n 0
+ fromInt i = int2Float i
+
+instance Real Float where
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Float where
+ (/) x y = divideFloat x y
+ fromRational x = fromRat x
+ recip x = 1.0 / x
+
+instance Floating Float where
+ pi = 3.141592653589793238
+ exp x = expFloat x
+ log x = logFloat x
+ sqrt x = sqrtFloat x
+ sin x = sinFloat x
+ cos x = cosFloat x
+ tan x = tanFloat x
+ asin x = asinFloat x
+ acos x = acosFloat x
+ atan x = atanFloat x
+ sinh x = sinhFloat x
+ cosh x = coshFloat x
+ tanh x = tanhFloat x
+ (**) x y = powerFloat x y
+ logBase x y = log y / log x
+
+ asinh x = log (x + sqrt (1.0+x*x))
+ acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
+ atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+
+instance RealFrac Float where
+
+ {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
+ {-# SPECIALIZE truncate :: Float -> Int #-}
+ {-# SPECIALIZE round :: Float -> Int #-}
+ {-# SPECIALIZE ceiling :: Float -> Int #-}
+ {-# SPECIALIZE floor :: Float -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
+ {-# SPECIALIZE truncate :: Float -> Integer #-}
+ {-# SPECIALIZE round :: Float -> Integer #-}
+ {-# SPECIALIZE ceiling :: Float -> Integer #-}
+ {-# SPECIALIZE floor :: Float -> Integer #-}
+
+ properFraction x
+ = case (decodeFloat x) of { (m,n) ->
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
+ }
+
+ truncate x = case properFraction x of
+ (n,_) -> n
+
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
+
+ ceiling x = case properFraction x of
+ (n,r) -> if r > 0.0 then n + 1 else n
+
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
+
+instance RealFloat Float where
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = FLT_MANT_DIG -- ditto
+ floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
+
+ decodeFloat (F# f#)
+ = case decodeFloat# f# of
+ (# exp#, a#, s#, d# #) -> (J# a# s# d#, I# exp#)
+
+ encodeFloat (J# a# s# d#) (I# e#)
+ = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
+
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
+
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
+ isNaN x =
+ (0::Int) /= unsafePerformIO (_ccall_ isFloatNaN x) {- a _pure_function! -}
+ isInfinite x =
+ (0::Int) /= unsafePerformIO (_ccall_ isFloatInfinite x) {- ditto! -}
+ isDenormalized x =
+ (0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- ..
+ isNegativeZero x =
+ (0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ...
+ isIEEE x = True
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type @Double@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Show Float where
+ showsPrec x = showSigned showFloat x
+ showList = showList__ (showsPrec 0)
+
+instance Eq Double where
+ (D# x) == (D# y) = x ==## y
+
+instance Ord Double where
+ (D# x) `compare` (D# y) | x <## y = LT
+ | x ==## y = EQ
+ | otherwise = GT
+
+ (D# x) < (D# y) = x <## y
+ (D# x) <= (D# y) = x <=## y
+ (D# x) >= (D# y) = x >=## y
+ (D# x) > (D# y) = x >## y
+
+instance Num Double where
+ (+) x y = plusDouble x y
+ (-) x y = minusDouble x y
+ negate x = negateDouble x
+ (*) x y = timesDouble x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateDouble x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
+ fromInteger n = encodeFloat n 0
+ fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
+
+instance Real Double where
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Double where
+ (/) x y = divideDouble x y
+ fromRational x = fromRat x
+ recip x = 1.0 / x
+
+instance Floating Double where
+ pi = 3.141592653589793238
+ exp x = expDouble x
+ log x = logDouble x
+ sqrt x = sqrtDouble x
+ sin x = sinDouble x
+ cos x = cosDouble x
+ tan x = tanDouble x
+ asin x = asinDouble x
+ acos x = acosDouble x
+ atan x = atanDouble x
+ sinh x = sinhDouble x
+ cosh x = coshDouble x
+ tanh x = tanhDouble x
+ (**) x y = powerDouble x y
+ logBase x y = log y / log x
+
+ asinh x = log (x + sqrt (1.0+x*x))
+ acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
+ atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+
+instance RealFrac Double where
+
+ {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Int #-}
+ {-# SPECIALIZE round :: Double -> Int #-}
+ {-# SPECIALIZE ceiling :: Double -> Int #-}
+ {-# SPECIALIZE floor :: Double -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Integer #-}
+ {-# SPECIALIZE round :: Double -> Integer #-}
+ {-# SPECIALIZE ceiling :: Double -> Integer #-}
+ {-# SPECIALIZE floor :: Double -> Integer #-}
+
+#if defined(__UNBOXED_INSTANCES__)
+ {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Int# #-}
+ {-# SPECIALIZE round :: Double -> Int# #-}
+ {-# SPECIALIZE ceiling :: Double -> Int# #-}
+ {-# SPECIALIZE floor :: Double -> Int# #-}
+#endif
+
+ properFraction x
+ = case (decodeFloat x) of { (m,n) ->
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
+ }
+
+ truncate x = case properFraction x of
+ (n,_) -> n
+
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
+
+ ceiling x = case properFraction x of
+ (n,r) -> if r > 0.0 then n + 1 else n
+
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
+
+instance RealFloat Double where
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = DBL_MANT_DIG -- ditto
+ floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
+
+ decodeFloat (D# d#)
+ = case decodeDouble# d# of
+ (# exp#, a#, s#, d# #) -> (J# a# s# d#, I# exp#)
+
+ encodeFloat (J# a# s# d#) (I# e#)
+ = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# }
+
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
+
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
+ isNaN x =
+ (0::Int) /= unsafePerformIO (_ccall_ isDoubleNaN x) {- a _pure_function! -}
+ isInfinite x =
+ (0::Int) /= unsafePerformIO (_ccall_ isDoubleInfinite x) {- ditto -}
+ isDenormalized x =
+ (0::Int) /= unsafePerformIO (_ccall_ isDoubleDenormalized x) -- ..
+ isNegativeZero x =
+ (0::Int) /= unsafePerformIO (_ccall_ isDoubleNegativeZero x) -- ...
+ isIEEE x = True
+
+instance Show Double where
+ showsPrec x = showSigned showFloat x
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Coercions}
+%* *
+%*********************************************************
+
+\begin{code}
+{- SPECIALIZE fromIntegral ::
+ Int -> Rational,
+ Integer -> Rational,
+ Int -> Int,
+ Int -> Integer,
+ Int -> Float,
+ Int -> Double,
+ Integer -> Int,
+ Integer -> Integer,
+ Integer -> Float,
+ Integer -> Double #-}
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+{- SPECIALIZE fromRealFrac ::
+ Double -> Rational,
+ Rational -> Double,
+ Float -> Rational,
+ Rational -> Float,
+ Rational -> Rational,
+ Double -> Double,
+ Double -> Float,
+ Float -> Float,
+ Float -> Double #-}
+fromRealFrac :: (RealFrac a, Fractional b) => a -> b
+fromRealFrac = fromRational . toRational
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Common code for @Float@ and @Double@}
+%* *
+%*********************************************************
+
+The @Enum@ instances for Floats and Doubles are slightly unusual.
+The @toEnum@ function truncates numbers to Int. The definitions
+of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic
+series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat
+dubious. This example may have either 10 or 11 elements, depending on
+how 0.1 is represented.
+
+NOTE: The instances for Float and Double do not make use of the default
+methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being
+a `non-lossy' conversion to and from Ints. Instead we make use of the
+1.2 default methods (back in the days when Enum had Ord as a superclass)
+for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.)
+
+\begin{code}
+instance Enum Float where
+ toEnum = fromIntegral
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+instance Enum Double where
+ toEnum = fromIntegral
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+numericEnumFrom :: (Real a) => a -> [a]
+numericEnumFromThen :: (Real a) => a -> a -> [a]
+numericEnumFromThenTo :: (Real a) => a -> a -> a -> [a]
+numericEnumFrom = iterate (+1)
+numericEnumFromThen n m = iterate (+(m-n)) n
+numericEnumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
+ (numericEnumFromThen n m)
+\end{code}
+
+@approxRational@, applied to two real fractional numbers x and epsilon,
+returns the simplest rational number within epsilon of x. A rational
+number n%d in reduced form is said to be simpler than another n'%d' if
+abs n <= abs n' && d <= d'. Any real interval contains a unique
+simplest rational; here, for simplicity, we assume a closed rational
+interval. If such an interval includes at least one whole number, then
+the simplest rational is the absolutely least whole number. Otherwise,
+the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
+and abs r' < d', and the simplest rational is q%1 + the reciprocal of
+the simplest rational between d'%r' and d%r.
+
+\begin{code}
+approxRational :: (RealFrac a) => a -> a -> Rational
+approxRational x eps = simplest (x-eps) (x+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr = toRational x
+ n = numerator xr
+ d = denominator xr
+ nd' = toRational y
+ n' = numerator nd'
+ d' = denominator nd'
+
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ nd'' = simplest' d' r' d r
+ n'' = numerator nd''
+ d'' = denominator nd''
+\end{code}
+
+
+\begin{code}
+instance (Integral a) => Ord (Ratio a) where
+ (x:%y) <= (x':%y') = x * y' <= x' * y
+ (x:%y) < (x':%y') = x * y' < x' * y
+
+instance (Integral a) => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x * x') (y * y')
+ negate (x:%y) = (-x) :% y
+ abs (x:%y) = abs x :% y
+ signum (x:%y) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+
+instance (Integral a) => Real (Ratio a) where
+ toRational (x:%y) = toInteger x :% toInteger y
+
+instance (Integral a) => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
+ fromRational (x:%y) = fromInteger x :% fromInteger y
+
+instance (Integral a) => RealFrac (Ratio a) where
+ properFraction (x:%y) = (fromIntegral q, r:%y)
+ where (q,r) = quotRem x y
+
+instance (Integral a) => Enum (Ratio a) where
+ enumFrom = iterate ((+)1)
+ enumFromThen n m = iterate ((+)(m-n)) n
+ toEnum n = fromIntegral n :% 1
+ fromEnum = fromInteger . truncate
+
+ratio_prec :: Int
+ratio_prec = 7
+
+instance (Integral a) => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > ratio_prec)
+ (shows x . showString " % " . shows y)
+\end{code}
+
+@showRational@ converts a Rational to a string that looks like a
+floating point number, but without converting to any floating type
+(because of the possible overflow).
+
+From/by Lennart, 94/09/26
+
+\begin{code}
+showRational :: Int -> Rational -> String
+showRational n r =
+ if r == 0 then
+ "0.0"
+ else
+ let (r', e) = normalize r
+ in prR n r' e
+
+startExpExp = 4 :: Int
+
+-- make sure 1 <= r < 10
+normalize :: Rational -> (Rational, Int)
+normalize r = if r < 1 then
+ case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1)
+ else
+ norm startExpExp r 0
+ where norm :: Int -> Rational -> Int -> (Rational, Int)
+ -- Invariant: r*10^e == original r
+ norm 0 r e = (r, e)
+ norm ee r e =
+ let n = 10^ee
+ tn = 10^n
+ in if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
+
+drop0 "" = ""
+drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
+
+prR :: Int -> Rational -> Int -> String
+prR n r e | r < 1 = prR n (r*10) (e-1) -- final adjustment
+prR n r e | r >= 10 = prR n (r/10) (e+1)
+prR n r e0 =
+ let s = show ((round (r * 10^n))::Integer)
+ e = e0+1
+ in if e > 0 && e < 8 then
+ take e s ++ "." ++ drop0 (drop e s)
+ else if e <= 0 && e > -3 then
+ "0." ++ take (-e) (repeat '0') ++ drop0 s
+ else
+ head s : "."++ drop0 (tail s) ++ "e" ++ show e0
+\end{code}
+
+[In response to a request for documentation of how fromRational works,
+Joe Fasel writes:] A quite reasonable request! This code was added to
+the Prelude just before the 1.2 release, when Lennart, working with an
+early version of hbi, noticed that (read . show) was not the identity
+for floating-point numbers. (There was a one-bit error about half the
+time.) The original version of the conversion function was in fact
+simply a floating-point divide, as you suggest above. The new version
+is, I grant you, somewhat denser.
+
+Unfortunately, Joe's code doesn't work! Here's an example:
+
+main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")
+
+This program prints
+ 0.0000000000000000
+instead of
+ 1.8217369128763981e-300
+
+Lennart's code follows, and it works...
+
+\begin{pseudocode}
+{-# SPECIALISE fromRat ::
+ Rational -> Double,
+ Rational -> Float #-}
+fromRat :: (RealFloat a) => Rational -> a
+fromRat x = x'
+ where x' = f e
+
+-- If the exponent of the nearest floating-point number to x
+-- is e, then the significand is the integer nearest xb^(-e),
+-- where b is the floating-point radix. We start with a good
+-- guess for e, and if it is correct, the exponent of the
+-- floating-point number we construct will again be e. If
+-- not, one more iteration is needed.
+
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1 % b)^^e)) e
+ (_,e') = decodeFloat y
+ b = floatRadix x'
+
+-- We obtain a trial exponent by doing a floating-point
+-- division of x's numerator by its denominator. The
+-- result of this division may not itself be the ultimate
+-- result, because of an accumulation of three rounding
+-- errors.
+
+ (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
+\end{pseudocode}
+
+Now, here's Lennart's code.
+
+\begin{code}
+--fromRat :: (RealFloat a) => Rational -> a
+fromRat x =
+ if x == 0 then encodeFloat 0 0 -- Handle exceptional cases
+ else if x < 0 then - fromRat' (-x) -- first.
+ else fromRat' x
+
+-- Conversion process:
+-- Scale the rational number by the RealFloat base until
+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
+-- Then round the rational to an Integer and encode it with the exponent
+-- that we got from the scaling.
+-- To speed up the scaling process we compute the log2 of the number to get
+-- a first guess of the exponent.
+
+fromRat' :: (RealFloat a) => Rational -> a
+fromRat' x = r
+ where b = floatRadix r
+ p = floatDigits r
+ (minExp0, _) = floatRange r
+ minExp = minExp0 - p -- the real minimum exponent
+ xMin = toRational (expt b (p-1))
+ xMax = toRational (expt b p)
+ p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
+ f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+ (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+ r = encodeFloat (round x') p'
+
+-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
+scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
+scaleRat b minExp xMin xMax p x =
+ if p <= minExp then
+ (x, p)
+ else if x >= xMax then
+ scaleRat b minExp xMin xMax (p+1) (x/b)
+ else if x < xMin then
+ scaleRat b minExp xMin xMax (p-1) (x*b)
+ else
+ (x, p)
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
+expt :: Integer -> Int -> Integer
+expt base n =
+ if base == 2 && n >= minExpt && n <= maxExpt then
+ expts!n
+ else
+ base^n
+expts :: Array Int Integer
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+
+-- Compute the (floor of the) log of i in base b.
+-- Simplest way would be just divide i by b until it's smaller then b, but that would
+-- be very slow! We are just slightly more clever.
+integerLogBase :: Integer -> Integer -> Int
+integerLogBase b i =
+ if i < b then
+ 0
+ else
+ -- Try squaring the base first to cut down the number of divisions.
+ let l = 2 * integerLogBase (b*b) i
+ doDiv :: Integer -> Int -> Int
+ doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
+ in doDiv (i `div` (b^l)) l
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Printing out numbers}
+%* *
+%*********************************************************
+
+\begin{code}
+--Exported from std library Numeric, defined here to
+--avoid mut. rec. between PrelNum and Numeric.
+showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x = if x < 0 then showParen (p > 6)
+ (showChar '-' . showPos (-x))
+ else showPos x
+
+showFloat x = showString (formatRealFloat FFGeneric Nothing x)
+
+-- These are the format types. This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric --no need: deriving (Eq, Ord, Show)
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x = s
+ where
+ base = 10
+ s = if isNaN x
+ then "NaN"
+ else
+ if isInfinite x then
+ if x < 0 then "-Infinity" else "Infinity"
+ else
+ if x < 0 || isNegativeZero x then
+ '-':doFmt fmt (floatToDigits (toInteger base) (-x))
+ else
+ doFmt fmt (floatToDigits (toInteger base) x)
+
+ doFmt fmt (is, e) =
+ let ds = map intToDigit is in
+ case fmt of
+ FFGeneric ->
+ doFmt (if e <0 || e > 7 then FFExponent else FFFixed)
+ (is,e)
+ FFExponent ->
+ case decs of
+ Nothing ->
+ let e' = if e==0 then 0 else e-1 in
+ (case ds of
+ [d] -> d : ".0e"
+ (d:ds) -> d : '.' : ds ++ "e") ++ show e'
+ Just dec ->
+ let dec' = max dec 1 in
+ case is of
+ [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
+ _ ->
+ let
+ (ei,is') = roundTo base (dec'+1) is
+ d:ds = map intToDigit (if ei > 0 then init is' else is')
+ in
+ d:'.':ds ++ 'e':show (e-1+ei)
+ FFFixed ->
+ let
+ mk0 ls = case ls of { "" -> "0" ; _ -> ls}
+ in
+ case decs of
+ Nothing ->
+ let
+ f 0 s ds = mk0 (reverse s) ++ '.':mk0 ds
+ f n s "" = f (n-1) ('0':s) ""
+ f n s (d:ds) = f (n-1) (d:s) ds
+ in
+ f e "" ds
+ Just dec ->
+ let dec' = max dec 1 in
+ if e >= 0 then
+ let
+ (ei,is') = roundTo base (dec' + e) is
+ (ls,rs) = splitAt (e+ei) (map intToDigit is')
+ in
+ mk0 ls ++ (if null rs then "" else '.':rs)
+ else
+ let
+ (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)
+ d:ds = map intToDigit (if ei > 0 then is' else 0:is')
+ in
+ d : '.' : ds
+
+
+roundTo :: Int -> Int -> [Int] -> (Int,[Int])
+roundTo base d is =
+ let
+ v = f d is
+ in
+ case v of
+ (0,is) -> v
+ (1,is) -> (1, 1:is)
+ where
+ b2 = base `div` 2
+
+ f n [] = (0, replicate n 0)
+ f 0 (i:_) = (if i>=b2 then 1 else 0, [])
+ f d (i:is) =
+ let
+ (c,ds) = f (d-1) is
+ i' = c + i
+ in
+ if i' == base then (1,0:ds) else (0,i':ds)
+
+--
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R.K. Dybvig in PLDI 96.
+-- This version uses a much slower logarithm estimator. It should be improved.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+--floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
+floatToDigits _ 0 = ([0], 0)
+floatToDigits base x =
+ let
+ (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange x
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (f, e) =
+ let n = minExp - e0 in
+ if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+ (r, s, mUp, mDn) =
+ if e >= 0 then
+ let be = b^ e in
+ if f == b^(p-1) then
+ (f*be*b*2, 2*b, be*b, b)
+ else
+ (f*be*2, 2, be, be)
+ else
+ if e > minExp && f == b^(p-1) then
+ (f*b*2, b^(-e+1)*2, b, 1)
+ else
+ (f*2, b^(-e)*2, 1, 1)
+ k =
+ let
+ k0 =
+ if b == 2 && base == 10 then
+ -- logBase 10 2 is slightly bigger than 3/10 so
+ -- the following will err on the low side. Ignoring
+ -- the fraction will make it err even more.
+ -- Haskell promises that p-1 <= logBase b f < p.
+ (p - 1 + e0) * 3 `div` 10
+ else
+ ceiling ((log (fromInteger (f+1)) +
+ fromInt e * log (fromInteger b)) /
+ fromInt e * log (fromInteger b))
+
+ fixup n =
+ if n >= 0 then
+ if r + mUp <= expt base n * s then n else fixup (n+1)
+ else
+ if expt base (-n) * (r + mUp) <= s then n else fixup (n+1)
+ in
+ fixup k0
+
+ gen ds rn sN mUpN mDnN =
+ let
+ (dn, rn') = (rn * base) `divMod` sN
+ mUpN' = mUpN * base
+ mDnN' = mDnN * base
+ in
+ case (rn' < mDnN', rn' + mUpN' > sN) of
+ (True, False) -> dn : ds
+ (False, True) -> dn+1 : ds
+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+
+ rds =
+ if k >= 0 then
+ gen [] r (s * expt base k) mUp mDn
+ else
+ let bk = expt base (-k) in
+ gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ in
+ (map toInt (reverse rds), k)
+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Numeric primops}
+%* *
+%*********************************************************
+
+Definitions of the boxed PrimOps; these will be
+used in the case of partial applications, etc.
+
+\begin{code}
+plusFloat (F# x) (F# y) = F# (plusFloat# x y)
+minusFloat (F# x) (F# y) = F# (minusFloat# x y)
+timesFloat (F# x) (F# y) = F# (timesFloat# x y)
+divideFloat (F# x) (F# y) = F# (divideFloat# x y)
+negateFloat (F# x) = F# (negateFloat# x)
+
+gtFloat (F# x) (F# y) = gtFloat# x y
+geFloat (F# x) (F# y) = geFloat# x y
+eqFloat (F# x) (F# y) = eqFloat# x y
+neFloat (F# x) (F# y) = neFloat# x y
+ltFloat (F# x) (F# y) = ltFloat# x y
+leFloat (F# x) (F# y) = leFloat# x y
+
+float2Int (F# x) = I# (float2Int# x)
+int2Float (I# x) = F# (int2Float# x)
+
+expFloat (F# x) = F# (expFloat# x)
+logFloat (F# x) = F# (logFloat# x)
+sqrtFloat (F# x) = F# (sqrtFloat# x)
+sinFloat (F# x) = F# (sinFloat# x)
+cosFloat (F# x) = F# (cosFloat# x)
+tanFloat (F# x) = F# (tanFloat# x)
+asinFloat (F# x) = F# (asinFloat# x)
+acosFloat (F# x) = F# (acosFloat# x)
+atanFloat (F# x) = F# (atanFloat# x)
+sinhFloat (F# x) = F# (sinhFloat# x)
+coshFloat (F# x) = F# (coshFloat# x)
+tanhFloat (F# x) = F# (tanhFloat# x)
+
+powerFloat (F# x) (F# y) = F# (powerFloat# x y)
+
+-- definitions of the boxed PrimOps; these will be
+-- used in the case of partial applications, etc.
+
+plusDouble (D# x) (D# y) = D# (x +## y)
+minusDouble (D# x) (D# y) = D# (x -## y)
+timesDouble (D# x) (D# y) = D# (x *## y)
+divideDouble (D# x) (D# y) = D# (x /## y)
+negateDouble (D# x) = D# (negateDouble# x)
+
+gtDouble (D# x) (D# y) = x >## y
+geDouble (D# x) (D# y) = x >=## y
+eqDouble (D# x) (D# y) = x ==## y
+neDouble (D# x) (D# y) = x /=## y
+ltDouble (D# x) (D# y) = x <## y
+leDouble (D# x) (D# y) = x <=## y
+
+double2Int (D# x) = I# (double2Int# x)
+int2Double (I# x) = D# (int2Double# x)
+double2Float (D# x) = F# (double2Float# x)
+float2Double (F# x) = D# (float2Double# x)
+
+expDouble (D# x) = D# (expDouble# x)
+logDouble (D# x) = D# (logDouble# x)
+sqrtDouble (D# x) = D# (sqrtDouble# x)
+sinDouble (D# x) = D# (sinDouble# x)
+cosDouble (D# x) = D# (cosDouble# x)
+tanDouble (D# x) = D# (tanDouble# x)
+asinDouble (D# x) = D# (asinDouble# x)
+acosDouble (D# x) = D# (acosDouble# x)
+atanDouble (D# x) = D# (atanDouble# x)
+sinhDouble (D# x) = D# (sinhDouble# x)
+coshDouble (D# x) = D# (coshDouble# x)
+tanhDouble (D# x) = D# (tanhDouble# x)
+
+powerDouble (D# x) (D# y) = D# (x **## y)
+\end{code}
--- /dev/null
+---------------------------------------------------------------------------
+-- PrelPack.hi-boot
+--
+-- This hand-written interface file is the initial bootstrap version
+-- for PrelPack.hi.
+-- It's needed for the 'thin-air' Ids, when compiling PrelBase, and
+-- other Prelude files that precede PrelPack
+---------------------------------------------------------------------------
+
+__interface PrelPack 1 where
+__export PrelPack packCString# unpackCString# unpackNBytes# unpackAppendCString# unpackFoldrCString#;
+
+1 packCString# :: [PrelBase.Char] -> PrelGHC.ByteArray# ;
+1 unpackCString# :: PrelGHC.Addr# -> [PrelBase.Char] ;
+1 unpackNBytes# :: PrelGHC.Addr# -> PrelGHC.Int# -> [PrelBase.Char] ;
+1 unpackAppendCString# :: PrelGHC.Addr# -> [PrelBase.Char] -> [PrelBase.Char] ;
+1 unpackFoldrCString# :: __forall [a] => PrelGHC.Addr# -> (PrelBase.Char -> a -> a) -> a -> a ;
+
write_ps_array, -- MutableByteArray s Int -> Int# -> Char# -> ST s ()
freeze_ps_array -- MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
-
)
where
= unpackNBytesBA# bytes len#
where
len# = case max 0 (min i len) of I# v# -> v#
- len | u > l = 0
+ len | l > u = 0
| otherwise = u-l+1
unpackNBytesBA# :: ByteArray# -> Int# -> [Char]
freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
new_ps_array size = ST $ \ s ->
- case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray bot barr#) }
+ case (newCharArray# size s) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bot barr# #) }
where
bot = error "new_ps_array"
write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
- STret s2# () }
+ (# s2#, () #) }
-- same as unsafeFreezeByteArray
freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray (0,I# len#) frozen#) }
+ case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray (0,I# len#) frozen# #) }
\end{code}
import {-# SOURCE #-} PrelErr ( error )
import PrelNum
+import PrelNumExtra
import PrelList
import PrelTup
import PrelMaybe
import Monad
-- needed for readIO.
-import PrelIOBase ( IO, fail, userError )
-
+import PrelIOBase ( IO, userError )
+import PrelException ( fail )
\end{code}
%*********************************************************
too many people got bitten by space leaks when it was lazy.
\begin{code}
-newtype ST s a = ST (State# s -> STret s a)
-
-data STret s a = STret (State# s) a
+newtype ST s a = ST (State# s -> (# State# s, a #))
instance Functor (ST s) where
map f (ST m) = ST $ \ s ->
- case (m s) of { STret new_s r ->
- STret new_s (f r) }
+ case (m s) of { (# new_s, r #) ->
+ (# new_s, f r #) }
instance Monad (ST s) where
{-# INLINE return #-}
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
- return x = ST $ \ s -> STret s x
+ return x = ST $ \ s -> (# s, x #)
m >> k = m >>= \ _ -> k
(ST m) >>= k
= ST $ \ s ->
- case (m s) of { STret new_s r ->
+ case (m s) of { (# new_s, r #) ->
case (k r) of { ST k2 ->
(k2 new_s) }}
+data STret s a = STret (State# s) a
+-- liftST is useful when we want a lifted result from an ST computation. See
+-- fixST below.
+liftST :: ST s a -> State# s -> STret s a
+liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r
fixST :: (a -> ST s a) -> ST s a
fixST k = ST $ \ s ->
- let (ST k_r) = k r
- ans = k_r s
+ let ans = liftST (k r) s
STret _ r = ans
in
- ans
+ case ans of STret s' r -> (# s', r #)
{-# NOINLINE unsafeInterleaveST #-}
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST (ST m) = ST ( \ s ->
let
- STret _ r = m s
+ r = case m s of (# _, res #) -> res
in
- STret s r)
+ (# s, r #)
+ )
+instance Show (ST s a) where
+ showsPrec p f = showString "<<ST action>>"
+ showList = showList__ (showsPrec 0)
\end{code}
Definition of runST
\begin{code}
{-# NOINLINE runST #-}
-runST :: (All s => ST s a) -> a
+runST :: (forall s. ST s a) -> a
runST st =
case st of
ST m -> case m realWorld# of
- STret _ r -> r
+ (# _, r #) -> r
\end{code}
%*********************************************************
\begin{code}
data State s = S# (State# s)
-data StateAndPtr# s elt = StateAndPtr# (State# s) elt
-
-data StateAndChar# s = StateAndChar# (State# s) Char#
-data StateAndInt# s = StateAndInt# (State# s) Int#
-data StateAndWord# s = StateAndWord# (State# s) Word#
-data StateAndFloat# s = StateAndFloat# (State# s) Float#
-data StateAndDouble# s = StateAndDouble# (State# s) Double#
-data StateAndAddr# s = StateAndAddr# (State# s) Addr#
-
-data StateAndInt64# s = StateAndInt64# (State# s) Int64#
-data StateAndWord64# s = StateAndWord64# (State# s) Word64#
\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1998
+%
+
+\section[PrelWeak]{Module @PrelWeak@}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module PrelWeak where
+
+import PrelGHC
+import PrelMaybe
+import PrelBase
+import PrelIOBase
+import PrelForeign
+
+data Weak v = Weak (Weak# v)
+
+mkWeak :: k -- key
+ -> v -- value
+ -> IO () -- finaliser
+ -> IO (Weak v) -- weak pointer
+
+mkWeak key val finaliser = IO $ \s ->
+ case mkWeak# key val finaliser s of { (# s, w #) ->
+ (# s, Weak w #) }
+
+deRefWeak :: Weak v -> IO (Maybe v)
+deRefWeak (Weak w) = IO $ \s ->
+ case deRefWeak# w s of
+ (# s, flag, w #) -> case flag of
+ 0# -> (# s, Nothing #)
+ _ -> (# s, Just w #)
+
+mkWeakPtr :: k -> IO () -> IO (Weak k)
+mkWeakPtr key finaliser = mkWeak key key finaliser
+
+mkWeakPair :: k -> v -> IO () -> IO (Weak (k,v))
+mkWeakPair key val finaliser = mkWeak key (key,val) finaliser
+
+addFinaliser :: key -> IO () -> IO ()
+addFinaliser key finaliser = do
+ mkWeakPtr key finaliser -- throw it away
+ return ()
+
+addForeignFinaliser :: ForeignObj -> IO () -> IO ()
+addForeignFinaliser (ForeignObj fo) finaliser = addFinaliser fo finaliser
+
+{-
+finalise :: Weak v -> IO ()
+finalise (Weak w) = finaliseWeak# w
+
+instance Eq (Weak v) where
+ (Weak w1) == (Weak w2) = w1 `sameWeak#` w2
+-}
+
+\end{code}
import PrelList
import PrelRead
import PrelNum
+import PrelNumExtra
import PrelTup
import PrelMaybe
import PrelEither
import PrelBounded
+import PrelConc
import Monad
import Maybe
-import PrelErr ( error, seqError )
-import IO ( IO, FilePath, IOError,
- fail, userError, catch,
- putChar, putStr, putStrLn, print,
- getChar, getLine, getContents, interact,
- readFile, writeFile, appendFile, readIO, readLn
- )
-
-{- Declared elsewhere:
-PrelBase: infixr 9 .
-PrelNum: infixr 8 ^, ^^, **
-PrelBase: infixl *
-PrelNum: infixl 7 /, %, `quot`, `rem`, `div`, `mod`
-PrelBase: infixl 6 +, -
-PrelBase: infixr 5 :, ++
-PrelBase: infix 4 ==, /=, <. <=, >=, >
-PrelBase: infixr 3 &&
-PrelBase: infixr 2 ||
-PrelBase: infixl >>, >>=
-PrelBase: infixr $
--}
-infixr 0 `seq`
-
+import PrelErr ( error )
+import IO
-- These can't conveniently be defined in PrelBase because they use numbers,
-- or I/O, so here's a convenient place to do them.
-strict :: Eval a => (a -> b) -> a -> b
+strict :: (a -> b) -> a -> b
strict f x = x `seq` f x
-
--- "seq" is defined a bit wierdly (see below)
---
--- The reason for the strange "0# -> parError" case is that
--- it fools the compiler into thinking that seq is non-strict in
--- its second argument (even if it inlines seq at the call site).
--- If it thinks seq is strict in "y", then it often evaluates
--- "y" before "x", which is totally wrong.
---
--- Just before converting from Core to STG there's a bit of magic
--- that recognises the seq# and eliminates the duff case.
-
-{-# INLINE seq #-}
-seq :: Eval a => a -> b -> b
-seq x y = case (seq# x) of { 0# -> seqError; _ -> y }
-
-- It is expected that compilers will recognize this and insert error
-- messages which are more appropriate to the context in which undefined
-- appears.
randomIO lh = do
ct <- getCPUTime
(TOD sec _) <- getClockTime
- return (random lh (sec * 12345 + ct))
+ return (random lh (toInteger sec * 12345 + ct))
random :: (Integer, Integer) -> Integer -> [Integer]
random (l, h) s =
) where
import PrelNum
+import PrelNumExtra
\end{code}
\section[System]{Module @System@}
\begin{code}
+{-# OPTIONS -#include "cbits/stgio.h" #-}
module System (
ExitCode(ExitSuccess,ExitFailure),
getArgs, getProgName, getEnv, system, exitWith
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+
+indexAddrOffAddr = primIndexAddrOffAddr
+
+unpackCString = unsafeUnpackCString
+
+#else
import Prelude
import PrelAddr
import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo )
import PrelPack ( unpackCString )
+#endif
\end{code}
line arguments (not including the program name).
\begin{code}
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "get_prog_argv" primArgv :: Addr
+foreign import stdcall "libHS_cbits.so" "get_prog_argc" primArgc :: Int
+
+getArgs = return (unpackArgv primArgv primArgc)
+#else
getArgs = return (unpackArgv ``prog_argv'' (``prog_argc''::Int))
+#endif
\end{code}
Computation $getProgName$ returns the name of the program
as it was invoked.
\begin{code}
+#ifdef __HUGS__
+getProgName = return (unpackProgName primArgv)
+#else
getProgName = return (unpackProgName ``prog_argv'')
+#endif
\end{code}
Computation $getEnv var$ returns the value
\end{itemize}
\begin{code}
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "getenv" primGetEnv :: PrimByteArray -> IO Addr
+
+getEnv name = do
+ litstring <- primGetEnv (primPackString name)
+ if litstring /= nullAddr
+ then primUnpackCString litstring
+ else fail (IOError Nothing NoSuchThing "getEnv"
+ ("environment variable: " ++ name))
+#else
getEnv name = do
litstring <- _ccall_ getenv name
if litstring /= ``NULL''
then return (unpackCString litstring)
else fail (IOError Nothing NoSuchThing "getEnv"
("environment variable: " ++ name))
+#endif
\end{code}
Computation $system cmd$ returns the exit code
\end{itemize}
\begin{code}
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "systemCmd" primSystem :: PrimByteArray -> IO Int
system "" = fail (IOError Nothing InvalidArgument "system" "null command")
system cmd = do
- status <- _ccall_ systemCmd cmd
+ status <- primSystem (primPackString cmd)
case status of
0 -> return ExitSuccess
-1 -> constructErrorAndFailWithInfo "system" cmd
n -> return (ExitFailure n)
+#else
+system "" = fail (IOError Nothing InvalidArgument "system" "null command")
+system cmd = do
+ status <- _ccall_ systemCmd cmd
+ case status of
+ 0 -> return ExitSuccess
+ -1 -> constructErrorAndFailWithInfo "system" cmd
+ n -> return (ExitFailure n)
+#endif
\end{code}
Computation $exitWith code$ terminates the
Before it terminates, any open or semi-closed handles are first closed.
\begin{code}
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "exit" primExit :: Int -> IO ()
+
+exitWith ExitSuccess = do
+ primExit 0
+ fail (IOError Nothing OtherError "exitWith" "exit should not return")
+
+exitWith (ExitFailure n)
+ | n == 0 = fail (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0")
+ | otherwise = do
+ primExit n
+ fail (IOError Nothing OtherError "exitWith" "exit should not return")
+#else
exitWith ExitSuccess = do
- _ccall_ EXIT (0::Int)
+ _ccall_ exit (0::Int)
fail (IOError Nothing OtherError "exitWith" "exit should not return")
exitWith (ExitFailure n)
| n == 0 = fail (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0")
| otherwise = do
- _ccall_ EXIT n
+ _ccall_ exit n
fail (IOError Nothing OtherError "exitWith" "exit should not return")
+#endif
\end{code}
) where
+#ifdef __HUGS__
+import PreludeBuiltin
+#else
import PrelBase
import PrelIOBase
+import PrelHandle
import PrelArr
import PrelST
import PrelAddr
import PrelPack ( unpackCString )
+#endif
import Ix
import Char ( intToDigit )
external calendar time @CalendarTime@.
\begin{code}
+#ifdef __HUGS__
+-- I believe Int64 is more than big enough.
+-- In fact, I think one of Int32 or Word32 would do. - ADR
+data ClockTime = TOD Int64 Int64 deriving (Eq, Ord)
+#else
data ClockTime = TOD Integer Integer deriving (Eq, Ord)
+#endif
\end{code}
When a @ClockTime@ is shown, it is converted to a string of the form
we use the C library routines based on 32 bit integers.
\begin{code}
+#ifdef __HUGS__
+#warning Show ClockTime is bogus
+instance Show ClockTime
+#else
instance Show ClockTime where
showsPrec p (TOD sec@(J# a# s# d#) nsec) =
showString $ unsafePerformIO $ do
- buf <- allocChars 32
+ buf <- allocChars 38 -- exactly enough for error message
str <- _ccall_ showTime (I# s#) d# buf
return (unpackCString str)
showList = showList__ (showsPrec 0)
+#endif
\end{code}
ctHour :: Int,
ctMin :: Int,
ctSec :: Int,
+#ifdef __HUGS__
+ ctPicosec :: Int64,
+#else
ctPicosec :: Integer,
+#endif
ctWDay :: Day,
ctYDay :: Int,
ctTZName :: String,
tdHour :: Int,
tdMin :: Int,
tdSec :: Int,
+#ifdef __HUGS__
+ tdPicosec :: Int64 -- not standard
+#else
tdPicosec :: Integer -- not standard
+#endif
}
deriving (Eq,Ord,Read,Show)
\end{code}
@getClockTime@ returns the current time in its internal representation.
\begin{code}
+#ifdef __HUGS__
+getClockTime :: IO ClockTime
+getClockTime = do
+ i1 <- malloc1
+ i2 <- malloc1
+ rc <- prim_getClockTime i1 i2
+ if rc == 0
+ then do
+ sec <- cvtUnsigned i1
+ nsec <- cvtUnsigned i2
+ return (TOD sec (nsec * 1000))
+ else
+ constructErrorAndFail "getClockTime"
+ where
+ malloc1 = primNewByteArray sizeof_int64
+ cvtUnsigned arr = primReadInt64Array arr 0
+#else
getClockTime :: IO ClockTime
getClockTime = do
i1 <- malloc1
where
malloc1 = IO $ \ s# ->
case newIntArray# 1# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bottom barr#)
+ (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bottom barr# #)
-- The C routine fills in an unsigned word. We don't have
-- `unsigned2Integer#,' so we freeze the data bits and use them
cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# ->
case readIntArray# arr# 0# s# of
- StateAndInt# s2# r# ->
+ (# s2#, r# #) ->
if r# ==# 0#
- then IOok s2# 0
+ then (# s2#, 0 #)
else case unsafeFreezeByteArray# arr# s2# of
- StateAndByteArray# s3# frozen# ->
- IOok s3# (J# 1# 1# frozen#)
-
+ (# s3#, frozen# #) ->
+ (# s3#, J# 1# 1# frozen# #)
+#endif
\end{code}
@addToClockTime@ {\em d} {\em t} adds a time difference {\em d} and a
\begin{code}
+#ifdef __HUGS__
+addToClockTime :: TimeDiff -> ClockTime -> ClockTime
+addToClockTime (TimeDiff year mon day hour min sec psec)
+ (TOD c_sec c_psec) = unsafePerformIO $ do
+ res <- allocWords sizeof_int64
+ rc <- prim_toClockSec year mon day hour min sec 0 res
+ if rc /= 0
+ then do
+ diff_sec <- primReadInt64Array res 0
+ let diff_psec = psec
+ return (TOD (c_sec + diff_sec) (c_psec + diff_psec))
+ else
+ error "Time.addToClockTime: can't perform conversion of TimeDiff"
+#else
addToClockTime :: TimeDiff -> ClockTime -> ClockTime
addToClockTime (TimeDiff year mon day hour min sec psec)
(TOD c_sec c_psec) = unsafePerformIO $ do
res <- allocWords (``sizeof(time_t)'')
ptr <- _ccall_ toClockSec year mon day hour min sec 0 res
let (A# ptr#) = ptr
- if ptr /= nullAddr
+ if ptr /= (``0''::Addr)
then let
- diff_sec = (int2Integer# (indexIntOffAddr# ptr# 0#))
+ diff_sec = (int2Integer (indexIntOffAddr# ptr# 0#))
diff_psec = psec
in
return (TOD (c_sec + diff_sec) (c_psec + diff_psec))
else
error "Time.addToClockTime: can't perform conversion of TimeDiff"
-
+#endif
diffClockTimes :: ClockTime -> ClockTime -> TimeDiff
diffClockTimes tod_a tod_b =
ignored.
\begin{code}
+#ifdef __HUGS__
+toCalendarTime :: ClockTime -> IO CalendarTime
+toCalendarTime (TOD sec psec) = do
+ res <- allocWords sizeof_int64
+ zoneNm <- allocChars 32
+ prim_SETZONE res zoneNm
+ rc <- prim_toLocalTime sec res
+ if rc /= 0
+ then constructErrorAndFail "Time.toCalendarTime: out of range"
+ else do
+ sec <- get_tm_sec res
+ min <- get_tm_min res
+ hour <- get_tm_hour res
+ mday <- get_tm_mday res
+ mon <- get_tm_mon res
+ year <- get_tm_year res
+ wday <- get_tm_wday res
+ yday <- get_tm_yday res
+ isdst <- get_tm_isdst res
+ zone <- prim_ZONE res
+ tz <- prim_GMTOFF res
+ tzname <- primUnpackCString zone
+ return (CalendarTime (1900+year) mon mday hour min sec psec
+ (toEnum wday) yday tzname tz (isdst /= 0))
+
+toUTCTime :: ClockTime -> CalendarTime
+toUTCTime (TOD sec psec) = unsafePerformIO $ do
+ res <- allocWords sizeof_int64
+ zoneNm <- allocChars 32
+ prim_SETZONE res zoneNm
+ rc <- prim_toUTCTime sec res
+ if rc /= 0
+ then error "Time.toUTCTime: out of range"
+ else do
+ sec <- get_tm_sec res
+ min <- get_tm_min res
+ hour <- get_tm_hour res
+ mday <- get_tm_mday res
+ mon <- get_tm_mon res
+ year <- get_tm_year res
+ wday <- get_tm_wday res
+ yday <- get_tm_yday res
+ return (CalendarTime (1900+year) mon mday hour min sec psec
+ (toEnum wday) yday "UTC" 0 False)
+
+toClockTime :: CalendarTime -> ClockTime
+toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz isdst) =
+ if psec < 0 || psec > 999999999999 then
+ error "Time.toClockTime: picoseconds out of range"
+ else if tz < -43200 || tz > 43200 then
+ error "Time.toClockTime: timezone offset out of range"
+ else
+ unsafePerformIO ( do
+ res <- allocWords sizeof_int64
+ rc <- prim_toClockSec year mon mday hour min sec isDst res
+ if rc /= 0
+ then do
+ tm <- primReadInt64Array res 0
+ return (TOD tm psec)
+ else error "Time.toClockTime: can't perform conversion"
+ )
+ where
+ isDst = if isdst then (1::Int) else 0
+#else
toCalendarTime :: ClockTime -> IO CalendarTime
toCalendarTime (TOD sec@(J# a# s# d#) psec) = do
res <- allocWords (``sizeof(struct tm)''::Int)
zoneNm <- allocChars 32
_casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm
tm <- _ccall_ toLocalTime (I# s#) d# res
- if tm == nullAddr
+ if tm == (``NULL''::Addr)
then constructErrorAndFail "Time.toCalendarTime: out of range"
else do
sec <- _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm
ptr <- _ccall_ toClockSec year mon mday hour min sec isDst res
let (A# ptr#) = ptr
if ptr /= ``NULL''
- then return (TOD (int2Integer# (indexIntOffAddr# ptr# 0#)) psec)
+ then return (TOD (int2Integer (indexIntOffAddr# ptr# 0#)) psec)
else error "Time.toClockTime: can't perform conversion"
)
where
isDst = if isdst then (1::Int) else 0
+#endif
bottom :: (Int,Int)
bottom = error "Time.bottom"
-- (copied from PosixUtil, for now)
-- Allocate a mutable array of characters with no indices.
+#ifdef __HUGS__
+allocChars :: Int -> IO (PrimMutableByteArray RealWorld)
+allocChars size = primNewByteArray size
+
+-- Allocate a mutable array of words with no indices
+
+allocWords :: Int -> IO (PrimMutableByteArray RealWorld)
+allocWords size = primNewByteArray size
+#else
allocChars :: Int -> IO (MutableByteArray RealWorld ())
allocChars (I# size#) = IO $ \ s# ->
case newCharArray# size# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bot barr#)
+ (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bot barr# #)
where
bot = error "Time.allocChars"
allocWords :: Int -> IO (MutableByteArray RealWorld ())
allocWords (I# size#) = IO $ \ s# ->
case newIntArray# size# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bot barr#)
+ (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bot barr# #)
where
bot = error "Time.allocWords"
-
+#endif
\end{code}
\begin{code}
c -> [c]
\end{code}
+
+\begin{code}
+#ifdef __HUGS__
+foreign import stdcall "libHS_cbits.so" "get_tm_sec" get_tm_sec :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_min" get_tm_min :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_hour" get_tm_hour :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_mday" get_tm_mday :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_mon" get_tm_mon :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_year" get_tm_year :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_wday" get_tm_wday :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_yday" get_tm_yday :: Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "get_tm_isdst" get_tm_isdst :: Bytes -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "prim_ZONE" prim_ZONE :: Bytes -> IO Addr
+foreign import stdcall "libHS_cbits.so" "prim_GMTOFF" prim_GMTOFF :: Bytes -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "prim_SETZONE" prim_SETZONE :: Bytes -> Bytes -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "sizeof_word" sizeof_word :: Int
+foreign import stdcall "libHS_cbits.so" "sizeof_struct_tm" sizeof_struct_tm :: Int
+foreign import stdcall "libHS_cbits.so" "sizeof_time_t" sizeof_time_t :: Int
+
+-- believed to be at least 1 bit (the sign bit!) bigger than sizeof_time_t
+sizeof_int64 :: Int
+sizeof_int64 = 8
+
+foreign import stdcall "libHS_cbits.so" "prim_getClockTime" prim_getClockTime :: Bytes -> Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "prim_toClockSec" prim_toClockSec :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "prim_toLocalTime" prim_toLocalTime :: Int64 -> Bytes -> IO Int
+foreign import stdcall "libHS_cbits.so" "prim_toUTCTime" prim_toUTCTime :: Int64 -> Bytes -> IO Int
+#endif
+\end{code}
-# $Id: Makefile,v 1.1 1998/02/02 17:34:22 simonm Exp $
+# $Id: Makefile,v 1.2 1998/12/02 13:27:12 simonm Exp $
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
LIBRARY=libHS_cbits.a
INSTALL_LIBS+=$(LIBRARY)
-SRCS= $(wildcard *.lc)
+C_SRCS= $(wildcard *.c)
-C_SRCS = $(SRCS:.lc=.c)
C_OBJS = $(C_SRCS:.c=.o)
LIBOBJS = $(C_OBJS)
-SRC_CC_OPTS = -O -I$(GHC_INCLUDE_DIR)
+SRC_CC_OPTS += -O -I$(GHC_INCLUDE_DIR) $(GhcLibCcOpts)
#
# Compile the files using the Haskell compiler (ghc really).
#
CC=$(HC)
-#
-# Remove the intermediate .c files
-# (the .o's will be removed automatically by default mk setup)
-#
-CLEAN_FILES += $(C_SRCS)
-
SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
include $(TOP)/mk/target.mk
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: allocMem.c,v 1.2 1998/12/02 13:27:13 simonm Exp $
+ *
+ * malloc interface
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgAddr
+allocMemory__(sz)
+StgInt sz;/* bytes*/
+{
+ StgAddr ptr;
+
+ if ( (ptr = malloc(sz*sizeof(char))) == NULL) {
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "malloc failed";
+ return NULL;
+ }
+ return ptr;
+
+}
+++ /dev/null
-%
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\subsection[allocMem.lc]{Allocating memory off heap}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgAddr
-allocMemory__(sz)
-StgInt sz;/* bytes*/
-{
- StgAddr ptr;
-
- if ( (ptr = malloc(sz*sizeof(char))) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "malloc failed";
- return NULL;
- }
- return ptr;
-
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: closeFile.c,v 1.3 1998/12/02 13:27:14 simonm Exp $
+ *
+ * hClose Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgInt __really_close_stdfiles=1;
+
+StgInt
+closeFile(ptr,flush_buf)
+StgForeignPtr ptr;
+StgInt flush_buf;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int rc = 0;
+ int unlocked=1;
+
+ /* Already closed, shouldn't occur. */
+ if ( fo == NULL ) {
+ return 0;
+ }
+
+ if ( flush_buf != 0 && (fo->flags & FILEOBJ_FLUSH) ) {
+ writeFileObject(ptr,fo->bufWPtr);
+ }
+
+ /* If the flush failed, we ignore this and soldier on.. */
+
+ if ( unlockFile(fo->fd) ) {
+ /* If the file has already been unlocked (or an entry
+ for it in the locking tables couldn't be found), could
+ mean two things:
+
+ - we're repeating an hClose on an already
+ closed file (this is likely to be a bug
+ in the implementation of hClose, as this
+ condition should have been caught before
+ we ended up here.)
+
+ - the file wasn't locked in the first place!
+ (file descriptors to non regular files.)
+
+ We proceed with attempting to close the file,
+ but don't flag the error should close() return
+ EBADF
+ */
+ unlocked=0;
+
+ }
+
+ /* Closing file descriptors that refer to standard channels
+ is problematic, so we back off from doing this by default,
+ just closing them at the Handle level. If you insist on
+ closing them, setting the (global) variable
+ __really_close_stdfiles to 0 turns off this behaviour.
+ */
+ if ( (fo->flags & FILEOBJ_STD) && __really_close_stdfiles ) {
+ ;
+
+ } else {
+ /* Regardless of success or otherwise, the fd field gets smashed. */
+ while ( (rc = close(fo->fd)) != 0 ) {
+ /* See above unlockFile() comment */
+ if ( errno != EINTR && (!unlocked && errno != EBADF ) ) {
+ cvtErrno();
+ stdErrno();
+ fo->fd = -1;
+ return rc;
+ }
+ }
+ }
+ fo->fd = -1;
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[closeFile.lc]{hClose Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgInt __really_close_stdfiles=1;
-
-StgInt
-closeFile(ptr,flush_buf)
-StgForeignObj ptr;
-StgInt flush_buf;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
- int unlocked=1;
-
- /* Already closed, shouldn't occur. */
- if ( fo == NULL ) {
- return 0;
- }
-
- if ( flush_buf != 0 && (fo->flags & FILEOBJ_FLUSH) ) {
- writeFileObject(ptr,fo->bufWPtr);
- }
-
- /* If the flush failed, we ignore this and soldier on.. */
-
- if ( unlockFile(fo->fd) ) {
- /* If the file has already been unlocked (or an entry
- for it in the locking tables couldn't be found), could
- mean two things:
-
- - we're repeating an hClose on an already
- closed file (this is likely to be a bug
- in the implementation of hClose, as this
- condition should have been caught before
- we ended up here.)
-
- - the file wasn't locked in the first place!
- (file descriptors to non regular files.)
-
- We proceed with attempting to close the file,
- but don't flag the error should close() return
- EBADF
- */
- unlocked=0;
-
- }
-
- /* Closing file descriptors that refer to standard channels
- is problematic, so we back off from doing this by default,
- just closing them at the Handle level. If you insist on
- closing them, setting the (global) variable
- __really_close_stdfiles to 0 turns off this behaviour.
- */
- if ( (fo->flags & FILEOBJ_STD) && __really_close_stdfiles ) {
- ;
-
- } else {
- /* Regardless of success or otherwise, the fd field gets smashed. */
- while ( (rc = close(fo->fd)) != 0 ) {
- /* See above unlockFile() comment */
- if ( errno != EINTR && (!unlocked && errno != EBADF ) ) {
- cvtErrno();
- stdErrno();
- fo->fd = -1;
- return rc;
- }
- }
- }
- fo->fd = -1;
- return 0;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: createDirectory.c,v 1.3 1998/12/02 13:27:16 simonm Exp $
+ *
+ * createDirectory Runtime Support}
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+StgInt
+createDirectory(path)
+StgByteArray path;
+{
+ int rc;
+ struct stat sb;
+
+ while((rc = mkdir(path, 0777)) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_ENOENT:
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no path to directory";
+ break;
+ case GHC_EEXIST:
+ if (stat(path, &sb) != 0) {
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "cannot stat existing file";
+ }
+ if (S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_ALREADYEXISTS;
+ ghc_errstr = "directory already exists";
+ } else {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "file already exists";
+ }
+ break;
+ }
+ return -1;
+ }
+ }
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[createDirectory.lc]{createDirectory Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-createDirectory(path)
-StgByteArray path;
-{
- int rc;
- struct stat sb;
-
- while((rc = mkdir(path, 0777)) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOENT:
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to directory";
- break;
- case GHC_EEXIST:
- if (stat(path, &sb) != 0) {
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "cannot stat existing file";
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "directory already exists";
- } else {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file already exists";
- }
- break;
- }
- return -1;
- }
- }
- return 0;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1998
+ *
+ * $Id: directoryAux.c,v 1.2 1998/12/02 13:27:17 simonm Exp $
+ *
+ * Support functions for manipulating directories
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_DIRENT_H
+#include <dirent.h>
+#endif
+
+StgAddr
+openDir__(StgByteArray path)
+{
+ struct stat sb;
+ DIR *dir;
+
+ /* Check for an actual directory */
+ while (stat(path, &sb) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return NULL;
+ }
+ }
+ if (!S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "not a directory";
+ return NULL;
+ }
+
+ while ((dir = opendir(path)) == NULL) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return NULL;
+ }
+ }
+ return dir;
+}
+
+StgAddr
+readDir__(StgAddr dir)
+
+{
+ struct dirent *d;
+ while ((d = readdir((DIR*)dir)) == NULL) {
+ if (errno == 0) {
+ (void) closedir((DIR*)dir);
+ return NULL;
+ } else if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ (void) closedir((DIR*)dir);
+ return NULL;
+ }
+ errno = 0;
+ }
+ return d;
+}
+
+StgAddr
+get_dirent_d_name(StgAddr d)
+{
+ return ((struct dirent*)d)->d_name;
+}
+
+StgInt const_F_OK( void ) { return F_OK; }
+
+StgInt sizeof_stat( void ) { return sizeof(struct stat); }
+
+StgInt prim_stat(StgAddr x, StgAddr y)
+{
+ return stat((char*)x, (struct stat*)y);
+}
+
+
+StgWord
+get_stat_st_mode (StgAddr x)
+{
+ return ((struct stat *)x)->st_mode;
+}
+
+
+StgInt64
+get_stat_st_mtime(StgAddr x)
+{
+ return ((struct stat *)x)->st_mtime;
+}
+
+void
+set_stat_st_mtime(StgByteArray p, StgByteArray x)
+{
+ ((unsigned long *)p)[0] = ((struct stat *)x)->st_mtime;
+ return;
+}
+
+StgWord const_S_IRUSR( void ) { return S_IRUSR; }
+StgWord const_S_IWUSR( void ) { return S_IWUSR; }
+StgWord const_S_IXUSR( void ) { return S_IXUSR; }
+
+StgInt
+prim_S_ISDIR( StgWord x )
+{
+ return S_ISDIR(x);
+}
+
+StgInt
+prim_S_ISREG( StgWord x )
+{
+ return S_ISREG(x);
+}
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\subsection[directoryAux.lc]{Support functions for manipulating directories}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_DIRENT_H
-#include <dirent.h>
-#endif
-
-StgAddr
-openDir__(path)
-StgByteArray path;
-{
- struct stat sb;
- DIR *dir;
-
- /* Check for an actual directory */
- while (stat(path, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return NULL;
- }
- }
- if (!S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- return NULL;
- }
-
- while ((dir = opendir(path)) == NULL) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return NULL;
- }
- }
- return dir;
-}
-
-StgAddr
-readDir__(dir)
-StgAddr dir;
-{
- struct dirent *d;
- while ((d = readdir((DIR*)dir)) == NULL) {
- if (errno == 0) {
- (void) closedir((DIR*)dir);
- return NULL;
- } else if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- (void) closedir((DIR*)dir);
- return NULL;
- }
- errno = 0;
- }
- return d;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: echoAux.c,v 1.2 1998/12/02 13:27:18 simonm Exp $
+ *
+ * Support functions for changing echoing
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_TERMIOS_H
+#include <termios.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+StgInt
+setTerminalEcho(ptr, on)
+StgForeignPtr ptr;
+StgInt on;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct termios tios;
+ int fd, rc;
+
+ fd = fo->fd;
+
+ while ( (rc = tcgetattr(fd,&tios)) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+
+ if (on) {
+ tios.c_lflag |= ECHO;
+ } else {
+ tios.c_lflag &= ~ECHO;
+ }
+
+ while ( (rc = tcsetattr(fd,TCSANOW,&tios)) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return 0;
+}
+
+StgInt
+getTerminalEcho(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct termios tios;
+ int fd, rc;
+
+ fd = fo->fd;
+
+ while ( (rc = tcgetattr(fd,&tios)) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return (tios.c_cflag & ECHO ? 1 : 0);
+}
+
+StgInt
+isTerminalDevice(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct termios tios;
+ int fd, rc;
+
+ fd = fo -> fd;
+
+ while ( (rc = tcgetattr(fd,&tios)) == -1) {
+ if (errno == ENOTTY) return 0;
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return 1;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\subsection[echoAux.lc]{Support functions for changing echoing}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_TERMIOS_H
-#include <termios.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-StgInt
-setTerminalEcho(ptr, on)
-StgForeignObj ptr;
-StgInt on;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct termios tios;
- int fd, rc;
-
- fd = fo->fd;
-
- while ( (rc = tcgetattr(fd,&tios)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- if (on) {
- tios.c_lflag |= ECHO;
- } else {
- tios.c_lflag &= ~ECHO;
- }
-
- while ( (rc = tcsetattr(fd,TCSANOW,&tios)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
-
-StgInt
-getTerminalEcho(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct termios tios;
- int fd, rc;
-
- fd = fo->fd;
-
- while ( (rc = tcgetattr(fd,&tios)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return (tios.c_cflag & ECHO ? 1 : 0);
-}
-
-StgInt
-isTerminalDevice(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct termios tios;
- int fd, rc;
-
- fd = fo -> fd;
-
- while ( (rc = tcgetattr(fd,&tios)) == -1) {
- if (errno == ENOTTY) return 0;
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 1;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: errno.c,v 1.3 1998/12/02 13:27:20 simonm Exp $
+ *
+ * GHC Error Number Conversion
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+int ghc_errno = 0;
+int ghc_errtype = 0;
+
+char *ghc_errstr = NULL;
+
+StgAddr
+getErrStr__()
+{ return ((StgAddr)ghc_errstr); }
+
+StgInt
+getErrNo__()
+{ return ((StgInt)ghc_errno); }
+
+StgInt
+getErrType__()
+{ return ((StgInt)ghc_errtype); }
+
+
+/* Collect all of the grotty #ifdef's in one place. */
+
+void cvtErrno(void)
+{
+ switch(errno) {
+#ifdef E2BIG
+ case E2BIG:
+ ghc_errno = GHC_E2BIG;
+ break;
+#endif
+#ifdef EACCES
+ case EACCES:
+ ghc_errno = GHC_EACCES;
+ break;
+#endif
+#ifdef EADDRINUSE
+ case EADDRINUSE:
+ ghc_errno = GHC_EADDRINUSE;
+ break;
+#endif
+#ifdef EADDRNOTAVAIL
+ case EADDRNOTAVAIL:
+ ghc_errno = GHC_EADDRNOTAVAIL;
+ break;
+#endif
+#ifdef EADV
+ case EADV:
+ ghc_errno = GHC_EADV;
+ break;
+#endif
+#ifdef EAFNOSUPPORT
+ case EAFNOSUPPORT:
+ ghc_errno = GHC_EAFNOSUPPORT;
+ break;
+#endif
+#ifdef EAGAIN
+ case EAGAIN:
+ ghc_errno = GHC_EAGAIN;
+ break;
+#endif
+#ifdef EALREADY
+ case EALREADY:
+ ghc_errno = GHC_EALREADY;
+ break;
+#endif
+#ifdef EBADF
+ case EBADF:
+ ghc_errno = GHC_EBADF;
+ break;
+#endif
+#ifdef EBADMSG
+ case EBADMSG:
+ ghc_errno = GHC_EBADMSG;
+ break;
+#endif
+#ifdef EBADRPC
+ case EBADRPC:
+ ghc_errno = GHC_EBADRPC;
+ break;
+#endif
+#ifdef EBUSY
+ case EBUSY:
+ ghc_errno = GHC_EBUSY;
+ break;
+#endif
+#ifdef ECHILD
+ case ECHILD:
+ ghc_errno = GHC_ECHILD;
+ break;
+#endif
+#ifdef ECOMM
+ case ECOMM:
+ ghc_errno = GHC_ECOMM;
+ break;
+#endif
+#ifdef ECONNABORTED
+ case ECONNABORTED:
+ ghc_errno = GHC_ECONNABORTED;
+ break;
+#endif
+#ifdef ECONNREFUSED
+ case ECONNREFUSED:
+ ghc_errno = GHC_ECONNREFUSED;
+ break;
+#endif
+#ifdef ECONNRESET
+ case ECONNRESET:
+ ghc_errno = GHC_ECONNRESET;
+ break;
+#endif
+#ifdef EDEADLK
+ case EDEADLK:
+ ghc_errno = GHC_EDEADLK;
+ break;
+#endif
+#ifdef EDESTADDRREQ
+ case EDESTADDRREQ:
+ ghc_errno = GHC_EDESTADDRREQ;
+ break;
+#endif
+#ifdef EDIRTY
+ case EDIRTY:
+ ghc_errno = GHC_EDIRTY;
+ break;
+#endif
+#ifdef EDOM
+ case EDOM:
+ ghc_errno = GHC_EDOM;
+ break;
+#endif
+#ifdef EDQUOT
+ case EDQUOT:
+ ghc_errno = GHC_EDQUOT;
+ break;
+#endif
+#ifdef EEXIST
+ case EEXIST:
+ ghc_errno = GHC_EEXIST;
+ break;
+#endif
+#ifdef EFAULT
+ case EFAULT:
+ ghc_errno = GHC_EFAULT;
+ break;
+#endif
+#ifdef EFBIG
+ case EFBIG:
+ ghc_errno = GHC_EFBIG;
+ break;
+#endif
+#ifdef EFTYPE
+ case EFTYPE:
+ ghc_errno = GHC_EFTYPE;
+ break;
+#endif
+#ifdef EHOSTDOWN
+ case EHOSTDOWN:
+ ghc_errno = GHC_EHOSTDOWN;
+ break;
+#endif
+#ifdef EHOSTUNREACH
+ case EHOSTUNREACH:
+ ghc_errno = GHC_EHOSTUNREACH;
+ break;
+#endif
+#ifdef EIDRM
+ case EIDRM:
+ ghc_errno = GHC_EIDRM;
+ break;
+#endif
+#ifdef EILSEQ
+ case EILSEQ:
+ ghc_errno = GHC_EILSEQ;
+ break;
+#endif
+#ifdef EINPROGRESS
+ case EINPROGRESS:
+ ghc_errno = GHC_EINPROGRESS;
+ break;
+#endif
+#ifdef EINTR
+ case EINTR:
+ ghc_errno = GHC_EINTR;
+ break;
+#endif
+#ifdef EINVAL
+ case EINVAL:
+ ghc_errno = GHC_EINVAL;
+ break;
+#endif
+#ifdef EIO
+ case EIO:
+ ghc_errno = GHC_EIO;
+ break;
+#endif
+#ifdef EISCONN
+ case EISCONN:
+ ghc_errno = GHC_EISCONN;
+ break;
+#endif
+#ifdef EISDIR
+ case EISDIR:
+ ghc_errno = GHC_EISDIR;
+ break;
+#endif
+#ifdef ELOOP
+ case ELOOP:
+ ghc_errno = GHC_ELOOP;
+ break;
+#endif
+#ifdef EMFILE
+ case EMFILE:
+ ghc_errno = GHC_EMFILE;
+ break;
+#endif
+#ifdef EMLINK
+ case EMLINK:
+ ghc_errno = GHC_EMLINK;
+ break;
+#endif
+#ifdef EMSGSIZE
+ case EMSGSIZE:
+ ghc_errno = GHC_EMSGSIZE;
+ break;
+#endif
+#ifdef EMULTIHOP
+ case EMULTIHOP:
+ ghc_errno = GHC_EMULTIHOP;
+ break;
+#endif
+#ifdef ENAMETOOLONG
+ case ENAMETOOLONG:
+ ghc_errno = GHC_ENAMETOOLONG;
+ break;
+#endif
+#ifdef ENETDOWN
+ case ENETDOWN:
+ ghc_errno = GHC_ENETDOWN;
+ break;
+#endif
+#ifdef ENETRESET
+ case ENETRESET:
+ ghc_errno = GHC_ENETRESET;
+ break;
+#endif
+#ifdef ENETUNREACH
+ case ENETUNREACH:
+ ghc_errno = GHC_ENETUNREACH;
+ break;
+#endif
+#ifdef ENFILE
+ case ENFILE:
+ ghc_errno = GHC_ENFILE;
+ break;
+#endif
+#ifdef ENOBUFS
+ case ENOBUFS:
+ ghc_errno = GHC_ENOBUFS;
+ break;
+#endif
+#ifdef ENODATA
+ case ENODATA:
+ ghc_errno = GHC_ENODATA;
+ break;
+#endif
+#ifdef ENODEV
+ case ENODEV:
+ ghc_errno = GHC_ENODEV;
+ break;
+#endif
+#ifdef ENOENT
+ case ENOENT:
+ ghc_errno = GHC_ENOENT;
+ break;
+#endif
+#ifdef ENOEXEC
+ case ENOEXEC:
+ ghc_errno = GHC_ENOEXEC;
+ break;
+#endif
+#ifdef ENOLCK
+ case ENOLCK:
+ ghc_errno = GHC_ENOLCK;
+ break;
+#endif
+#ifdef ENOLINK
+ case ENOLINK:
+ ghc_errno = GHC_ENOLINK;
+ break;
+#endif
+#ifdef ENOMEM
+ case ENOMEM:
+ ghc_errno = GHC_ENOMEM;
+ break;
+#endif
+#ifdef ENOMSG
+ case ENOMSG:
+ ghc_errno = GHC_ENOMSG;
+ break;
+#endif
+#ifdef ENONET
+ case ENONET:
+ ghc_errno = GHC_ENONET;
+ break;
+#endif
+#ifdef ENOPROTOOPT
+ case ENOPROTOOPT:
+ ghc_errno = GHC_ENOPROTOOPT;
+ break;
+#endif
+#ifdef ENOSPC
+ case ENOSPC:
+ ghc_errno = GHC_ENOSPC;
+ break;
+#endif
+#ifdef ENOSR
+ case ENOSR:
+ ghc_errno = GHC_ENOSR;
+ break;
+#endif
+#ifdef ENOSTR
+ case ENOSTR:
+ ghc_errno = GHC_ENOSTR;
+ break;
+#endif
+#ifdef ENOSYS
+ case ENOSYS:
+ ghc_errno = GHC_ENOSYS;
+ break;
+#endif
+#ifdef ENOTBLK
+ case ENOTBLK:
+ ghc_errno = GHC_ENOTBLK;
+ break;
+#endif
+#ifdef ENOTCONN
+ case ENOTCONN:
+ ghc_errno = GHC_ENOTCONN;
+ break;
+#endif
+#ifdef ENOTDIR
+ case ENOTDIR:
+ ghc_errno = GHC_ENOTDIR;
+ break;
+#endif
+#ifndef aix_TARGET_OS
+/* AIX returns EEXIST where 4.3BSD used ENOTEMPTY.
+ * there is an ENOTEMPTY defined as the same as EEXIST, and
+ * therefore it won't work properly on a case statement.
+ * another option is to define _ALL_SOURCE for aix, which
+ * gives a different number for ENOTEMPTY.
+ * I haven't tried that. -- andre.
+ */
+#ifdef ENOTEMPTY
+ case ENOTEMPTY:
+ ghc_errno = GHC_ENOTEMPTY;
+ break;
+#endif
+#endif
+#ifdef ENOTSOCK
+ case ENOTSOCK:
+ ghc_errno = GHC_ENOTSOCK;
+ break;
+#endif
+#ifdef ENOTTY
+ case ENOTTY:
+ ghc_errno = GHC_ENOTTY;
+ break;
+#endif
+#ifdef ENXIO
+ case ENXIO:
+ ghc_errno = GHC_ENXIO;
+ break;
+#endif
+#ifdef EOPNOTSUPP
+ case EOPNOTSUPP:
+ ghc_errno = GHC_EOPNOTSUPP;
+ break;
+#endif
+#ifdef EPERM
+ case EPERM:
+ ghc_errno = GHC_EPERM;
+ break;
+#endif
+#ifdef EPFNOSUPPORT
+ case EPFNOSUPPORT:
+ ghc_errno = GHC_EPFNOSUPPORT;
+ break;
+#endif
+#ifdef EPIPE
+ case EPIPE:
+ ghc_errno = GHC_EPIPE;
+ break;
+#endif
+#ifdef EPROCLIM
+ case EPROCLIM:
+ ghc_errno = GHC_EPROCLIM;
+ break;
+#endif
+#ifdef EPROCUNAVAIL
+ case EPROCUNAVAIL:
+ ghc_errno = GHC_EPROCUNAVAIL;
+ break;
+#endif
+#ifdef EPROGMISMATCH
+ case EPROGMISMATCH:
+ ghc_errno = GHC_EPROGMISMATCH;
+ break;
+#endif
+#ifdef EPROGUNAVAIL
+ case EPROGUNAVAIL:
+ ghc_errno = GHC_EPROGUNAVAIL;
+ break;
+#endif
+#ifdef EPROTO
+ case EPROTO:
+ ghc_errno = GHC_EPROTO;
+ break;
+#endif
+#ifdef EPROTONOSUPPORT
+ case EPROTONOSUPPORT:
+ ghc_errno = GHC_EPROTONOSUPPORT;
+ break;
+#endif
+#ifdef EPROTOTYPE
+ case EPROTOTYPE:
+ ghc_errno = GHC_EPROTOTYPE;
+ break;
+#endif
+#ifdef ERANGE
+ case ERANGE:
+ ghc_errno = GHC_ERANGE;
+ break;
+#endif
+#ifdef EREMCHG
+ case EREMCHG:
+ ghc_errno = GHC_EREMCHG;
+ break;
+#endif
+#ifdef EREMOTE
+ case EREMOTE:
+ ghc_errno = GHC_EREMOTE;
+ break;
+#endif
+#ifdef EROFS
+ case EROFS:
+ ghc_errno = GHC_EROFS;
+ break;
+#endif
+#ifdef ERPCMISMATCH
+ case ERPCMISMATCH:
+ ghc_errno = GHC_ERPCMISMATCH;
+ break;
+#endif
+#ifdef ERREMOTE
+ case ERREMOTE:
+ ghc_errno = GHC_ERREMOTE;
+ break;
+#endif
+#ifdef ESHUTDOWN
+ case ESHUTDOWN:
+ ghc_errno = GHC_ESHUTDOWN;
+ break;
+#endif
+#ifdef ESOCKTNOSUPPORT
+ case ESOCKTNOSUPPORT:
+ ghc_errno = GHC_ESOCKTNOSUPPORT;
+ break;
+#endif
+#ifdef ESPIPE
+ case ESPIPE:
+ ghc_errno = GHC_ESPIPE;
+ break;
+#endif
+#ifdef ESRCH
+ case ESRCH:
+ ghc_errno = GHC_ESRCH;
+ break;
+#endif
+#ifdef ESRMNT
+ case ESRMNT:
+ ghc_errno = GHC_ESRMNT;
+ break;
+#endif
+#ifdef ESTALE
+ case ESTALE:
+ ghc_errno = GHC_ESTALE;
+ break;
+#endif
+#ifdef ETIME
+ case ETIME:
+ ghc_errno = GHC_ETIME;
+ break;
+#endif
+#ifdef ETIMEDOUT
+ case ETIMEDOUT:
+ ghc_errno = GHC_ETIMEDOUT;
+ break;
+#endif
+#ifdef ETOOMANYREFS
+ case ETOOMANYREFS:
+ ghc_errno = GHC_ETOOMANYREFS;
+ break;
+#endif
+#ifdef ETXTBSY
+ case ETXTBSY:
+ ghc_errno = GHC_ETXTBSY;
+ break;
+#endif
+#ifdef EUSERS
+ case EUSERS:
+ ghc_errno = GHC_EUSERS;
+ break;
+#endif
+#if 0
+#ifdef EWOULDBLOCK
+ case EWOULDBLOCK:
+ ghc_errno = GHC_EWOULDBLOCK;
+ break;
+#endif
+#endif
+#ifdef EXDEV
+ case EXDEV:
+ ghc_errno = GHC_EXDEV;
+ break;
+#endif
+ default:
+ ghc_errno = errno;
+ break;
+ }
+}
+
+void
+stdErrno(void)
+{
+ switch(ghc_errno) {
+ default:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "unexpected error";
+ break;
+ case 0:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "no error";
+ case GHC_E2BIG:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "argument list too long";
+ break;
+ case GHC_EACCES:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "inadequate access permission";
+ break;
+ case GHC_EADDRINUSE:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "address already in use";
+ break;
+ case GHC_EADDRNOTAVAIL:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "address not available";
+ break;
+ case GHC_EADV:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "RFS advertise error";
+ break;
+ case GHC_EAFNOSUPPORT:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "address family not supported by protocol family";
+ break;
+ case GHC_EAGAIN:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "insufficient resources";
+ break;
+ case GHC_EALREADY:
+ ghc_errtype = ERR_ALREADYEXISTS;
+ ghc_errstr = "operation already in progress";
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "internal error (EBADF)";
+ break;
+ case GHC_EBADMSG:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "next message has wrong type";
+ break;
+ case GHC_EBADRPC:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "invalid RPC request or response";
+ break;
+ case GHC_EBUSY:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "device busy";
+ break;
+ case GHC_ECHILD:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no child processes";
+ break;
+ case GHC_ECOMM:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "no virtual circuit could be found";
+ break;
+ case GHC_ECONNABORTED:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "aborted connection";
+ break;
+ case GHC_ECONNREFUSED:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no listener on remote host";
+ break;
+ case GHC_ECONNRESET:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "connection reset by peer";
+ break;
+ case GHC_EDEADLK:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "resource deadlock avoided";
+ break;
+ case GHC_EDESTADDRREQ:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "destination address required";
+ break;
+ case GHC_EDIRTY:
+ ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
+ ghc_errstr = "file system dirty";
+ break;
+ case GHC_EDOM:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "argument too large";
+ break;
+ case GHC_EDQUOT:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "quota exceeded";
+ break;
+ case GHC_EEXIST:
+ ghc_errtype = ERR_ALREADYEXISTS;
+ ghc_errstr = "file already exists";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "internal error (EFAULT)";
+ break;
+ case GHC_EFBIG:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "file too large";
+ break;
+ case GHC_EFTYPE:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "inappropriate NFS file type or format";
+ break;
+ case GHC_EHOSTDOWN:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "destination host down";
+ break;
+ case GHC_EHOSTUNREACH:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "remote host is unreachable";
+ break;
+ case GHC_EIDRM:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "IPC identifier removed";
+ break;
+ case GHC_EILSEQ:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "invalid wide character";
+ break;
+ case GHC_EINPROGRESS:
+ ghc_errtype = ERR_ALREADYEXISTS;
+ ghc_errstr = "operation now in progress";
+ break;
+ case GHC_EINTR:
+ ghc_errtype = ERR_INTERRUPTED;
+ ghc_errstr = "interrupted system call";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "invalid argument";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_HARDWAREFAULT;
+ ghc_errstr = "unknown I/O fault";
+ break;
+ case GHC_EISCONN:
+ ghc_errtype = ERR_ALREADYEXISTS;
+ ghc_errstr = "socket is already connected";
+ break;
+ case GHC_EISDIR:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "file is a directory";
+ break;
+ case GHC_ELOOP:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "too many symbolic links";
+ break;
+ case GHC_EMFILE:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "process file table full";
+ break;
+ case GHC_EMLINK:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "too many links";
+ break;
+ case GHC_EMSGSIZE:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "message too long";
+ break;
+ case GHC_EMULTIHOP:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "multi-hop RFS request";
+ break;
+ case GHC_ENAMETOOLONG:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "filename too long";
+ break;
+ case GHC_ENETDOWN:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "network is down";
+ break;
+ case GHC_ENETRESET:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "remote host rebooted; connection lost";
+ break;
+ case GHC_ENETUNREACH:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "remote network is unreachable";
+ break;
+ case GHC_ENFILE:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "system file table full";
+ break;
+ case GHC_ENOBUFS:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "no buffer space available";
+ break;
+ case GHC_ENODATA:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no message on the stream head read queue";
+ break;
+ case GHC_ENODEV:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no such device";
+ break;
+ case GHC_ENOENT:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no such file or directory";
+ break;
+ case GHC_ENOEXEC:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "not an executable file";
+ break;
+ case GHC_ENOLCK:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "no file locks available";
+ break;
+ case GHC_ENOLINK:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "RFS link has been severed";
+ break;
+ case GHC_ENOMEM:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "not enough virtual memory";
+ break;
+ case GHC_ENOMSG:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no message of desired type";
+ break;
+ case GHC_ENONET:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "host is not on a network";
+ break;
+ case GHC_ENOPROTOOPT:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "operation not supported by protocol";
+ break;
+ case GHC_ENOSPC:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "no space left on device";
+ break;
+ case GHC_ENOSR:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "out of stream resources";
+ break;
+ case GHC_ENOSTR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "not a stream device";
+ break;
+ case GHC_ENOSYS:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "function not implemented";
+ break;
+ case GHC_ENOTBLK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "not a block device";
+ break;
+ case GHC_ENOTCONN:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "socket is not connected";
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "not a directory";
+ break;
+ case GHC_ENOTEMPTY:
+ ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
+ ghc_errstr = "directory not empty";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "not a socket";
+ break;
+ case GHC_ENOTTY:
+ ghc_errtype = ERR_ILLEGALOPERATION;
+ ghc_errstr = "inappropriate ioctl for device";
+ break;
+ case GHC_ENXIO:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no such device or address";
+ break;
+ case GHC_EOPNOTSUPP:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "operation not supported on socket";
+ break;
+ case GHC_EPERM:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "privileged operation";
+ break;
+ case GHC_EPFNOSUPPORT:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "protocol family not supported";
+ break;
+ case GHC_EPIPE:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "broken pipe";
+ break;
+ case GHC_EPROCLIM:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "too many processes";
+ break;
+ case GHC_EPROCUNAVAIL:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "unimplemented RPC procedure";
+ break;
+ case GHC_EPROGMISMATCH:
+ ghc_errtype = ERR_PROTOCOLERROR;
+ ghc_errstr = "unsupported RPC program version";
+ break;
+ case GHC_EPROGUNAVAIL:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "RPC program unavailable";
+ break;
+ case GHC_EPROTO:
+ ghc_errtype = ERR_PROTOCOLERROR;
+ ghc_errstr = "error in streams protocol";
+ break;
+ case GHC_EPROTONOSUPPORT:
+ ghc_errtype = ERR_PROTOCOLERROR;
+ ghc_errstr = "protocol not supported";
+ break;
+ case GHC_EPROTOTYPE:
+ ghc_errtype = ERR_PROTOCOLERROR;
+ ghc_errstr = "wrong protocol for socket";
+ break;
+ case GHC_ERANGE:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "result too large";
+ break;
+ case GHC_EREMCHG:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "remote address changed";
+ break;
+ case GHC_EREMOTE:
+ ghc_errtype = ERR_ILLEGALOPERATION;
+ ghc_errstr = "too many levels of remote in path";
+ break;
+ case GHC_EROFS:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "read-only file system";
+ break;
+ case GHC_ERPCMISMATCH:
+ ghc_errtype = ERR_PROTOCOLERROR;
+ ghc_errstr = "RPC version is wrong";
+ break;
+ case GHC_ERREMOTE:
+ ghc_errtype = ERR_ILLEGALOPERATION;
+ ghc_errstr = "object is remote";
+ break;
+ case GHC_ESHUTDOWN:
+ ghc_errtype = ERR_ILLEGALOPERATION;
+ ghc_errstr = "can't send after socket shutdown";
+ break;
+ case GHC_ESOCKTNOSUPPORT:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "socket type not supported";
+ break;
+ case GHC_ESPIPE:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "can't seek on a pipe";
+ break;
+ case GHC_ESRCH:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no such process";
+ break;
+ case GHC_ESRMNT:
+ ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
+ ghc_errstr = "RFS resources still mounted by remote host(s)";
+ break;
+ case GHC_ESTALE:
+ ghc_errtype = ERR_RESOURCEVANISHED;
+ ghc_errstr = "stale NFS file handle";
+ break;
+ case GHC_ETIME:
+ ghc_errtype = ERR_TIMEEXPIRED;
+ ghc_errstr = "timer expired";
+ break;
+ case GHC_ETIMEDOUT:
+ ghc_errtype = ERR_TIMEEXPIRED;
+ ghc_errstr = "connection timed out";
+ break;
+ case GHC_ETOOMANYREFS:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "too many references; can't splice";
+ break;
+ case GHC_ETXTBSY:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "text file in-use";
+ break;
+ case GHC_EUSERS:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "quota table full";
+ break;
+ case GHC_EWOULDBLOCK:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "operation would block";
+ break;
+ case GHC_EXDEV:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "can't make a cross-device link";
+ break;
+ }
+}
+
+void
+convertErrno(void)
+{
+ cvtErrno();
+ stdErrno();
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[errno.lc]{GHC Error Number Conversion}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-int ghc_errno = 0;
-int ghc_errtype = 0;
-
-char *ghc_errstr = NULL;
-
-StgAddr
-getErrStr__()
-{ return ((StgAddr)ghc_errstr); }
-
-StgInt
-getErrNo__()
-{ return ((StgInt)ghc_errno); }
-
-StgInt
-getErrType__()
-{ return ((StgInt)ghc_errtype); }
-
-
-/* Collect all of the grotty #ifdef's in one place. */
-
-void cvtErrno(STG_NO_ARGS)
-{
- switch(errno) {
-#ifdef E2BIG
- case E2BIG:
- ghc_errno = GHC_E2BIG;
- break;
-#endif
-#ifdef EACCES
- case EACCES:
- ghc_errno = GHC_EACCES;
- break;
-#endif
-#ifdef EADDRINUSE
- case EADDRINUSE:
- ghc_errno = GHC_EADDRINUSE;
- break;
-#endif
-#ifdef EADDRNOTAVAIL
- case EADDRNOTAVAIL:
- ghc_errno = GHC_EADDRNOTAVAIL;
- break;
-#endif
-#ifdef EADV
- case EADV:
- ghc_errno = GHC_EADV;
- break;
-#endif
-#ifdef EAFNOSUPPORT
- case EAFNOSUPPORT:
- ghc_errno = GHC_EAFNOSUPPORT;
- break;
-#endif
-#ifdef EAGAIN
- case EAGAIN:
- ghc_errno = GHC_EAGAIN;
- break;
-#endif
-#ifdef EALREADY
- case EALREADY:
- ghc_errno = GHC_EALREADY;
- break;
-#endif
-#ifdef EBADF
- case EBADF:
- ghc_errno = GHC_EBADF;
- break;
-#endif
-#ifdef EBADMSG
- case EBADMSG:
- ghc_errno = GHC_EBADMSG;
- break;
-#endif
-#ifdef EBADRPC
- case EBADRPC:
- ghc_errno = GHC_EBADRPC;
- break;
-#endif
-#ifdef EBUSY
- case EBUSY:
- ghc_errno = GHC_EBUSY;
- break;
-#endif
-#ifdef ECHILD
- case ECHILD:
- ghc_errno = GHC_ECHILD;
- break;
-#endif
-#ifdef ECOMM
- case ECOMM:
- ghc_errno = GHC_ECOMM;
- break;
-#endif
-#ifdef ECONNABORTED
- case ECONNABORTED:
- ghc_errno = GHC_ECONNABORTED;
- break;
-#endif
-#ifdef ECONNREFUSED
- case ECONNREFUSED:
- ghc_errno = GHC_ECONNREFUSED;
- break;
-#endif
-#ifdef ECONNRESET
- case ECONNRESET:
- ghc_errno = GHC_ECONNRESET;
- break;
-#endif
-#ifdef EDEADLK
- case EDEADLK:
- ghc_errno = GHC_EDEADLK;
- break;
-#endif
-#ifdef EDESTADDRREQ
- case EDESTADDRREQ:
- ghc_errno = GHC_EDESTADDRREQ;
- break;
-#endif
-#ifdef EDIRTY
- case EDIRTY:
- ghc_errno = GHC_EDIRTY;
- break;
-#endif
-#ifdef EDOM
- case EDOM:
- ghc_errno = GHC_EDOM;
- break;
-#endif
-#ifdef EDQUOT
- case EDQUOT:
- ghc_errno = GHC_EDQUOT;
- break;
-#endif
-#ifdef EEXIST
- case EEXIST:
- ghc_errno = GHC_EEXIST;
- break;
-#endif
-#ifdef EFAULT
- case EFAULT:
- ghc_errno = GHC_EFAULT;
- break;
-#endif
-#ifdef EFBIG
- case EFBIG:
- ghc_errno = GHC_EFBIG;
- break;
-#endif
-#ifdef EFTYPE
- case EFTYPE:
- ghc_errno = GHC_EFTYPE;
- break;
-#endif
-#ifdef EHOSTDOWN
- case EHOSTDOWN:
- ghc_errno = GHC_EHOSTDOWN;
- break;
-#endif
-#ifdef EHOSTUNREACH
- case EHOSTUNREACH:
- ghc_errno = GHC_EHOSTUNREACH;
- break;
-#endif
-#ifdef EIDRM
- case EIDRM:
- ghc_errno = GHC_EIDRM;
- break;
-#endif
-#ifdef EILSEQ
- case EILSEQ:
- ghc_errno = GHC_EILSEQ;
- break;
-#endif
-#ifdef EINPROGRESS
- case EINPROGRESS:
- ghc_errno = GHC_EINPROGRESS;
- break;
-#endif
-#ifdef EINTR
- case EINTR:
- ghc_errno = GHC_EINTR;
- break;
-#endif
-#ifdef EINVAL
- case EINVAL:
- ghc_errno = GHC_EINVAL;
- break;
-#endif
-#ifdef EIO
- case EIO:
- ghc_errno = GHC_EIO;
- break;
-#endif
-#ifdef EISCONN
- case EISCONN:
- ghc_errno = GHC_EISCONN;
- break;
-#endif
-#ifdef EISDIR
- case EISDIR:
- ghc_errno = GHC_EISDIR;
- break;
-#endif
-#ifdef ELOOP
- case ELOOP:
- ghc_errno = GHC_ELOOP;
- break;
-#endif
-#ifdef EMFILE
- case EMFILE:
- ghc_errno = GHC_EMFILE;
- break;
-#endif
-#ifdef EMLINK
- case EMLINK:
- ghc_errno = GHC_EMLINK;
- break;
-#endif
-#ifdef EMSGSIZE
- case EMSGSIZE:
- ghc_errno = GHC_EMSGSIZE;
- break;
-#endif
-#ifdef EMULTIHOP
- case EMULTIHOP:
- ghc_errno = GHC_EMULTIHOP;
- break;
-#endif
-#ifdef ENAMETOOLONG
- case ENAMETOOLONG:
- ghc_errno = GHC_ENAMETOOLONG;
- break;
-#endif
-#ifdef ENETDOWN
- case ENETDOWN:
- ghc_errno = GHC_ENETDOWN;
- break;
-#endif
-#ifdef ENETRESET
- case ENETRESET:
- ghc_errno = GHC_ENETRESET;
- break;
-#endif
-#ifdef ENETUNREACH
- case ENETUNREACH:
- ghc_errno = GHC_ENETUNREACH;
- break;
-#endif
-#ifdef ENFILE
- case ENFILE:
- ghc_errno = GHC_ENFILE;
- break;
-#endif
-#ifdef ENOBUFS
- case ENOBUFS:
- ghc_errno = GHC_ENOBUFS;
- break;
-#endif
-#ifdef ENODATA
- case ENODATA:
- ghc_errno = GHC_ENODATA;
- break;
-#endif
-#ifdef ENODEV
- case ENODEV:
- ghc_errno = GHC_ENODEV;
- break;
-#endif
-#ifdef ENOENT
- case ENOENT:
- ghc_errno = GHC_ENOENT;
- break;
-#endif
-#ifdef ENOEXEC
- case ENOEXEC:
- ghc_errno = GHC_ENOEXEC;
- break;
-#endif
-#ifdef ENOLCK
- case ENOLCK:
- ghc_errno = GHC_ENOLCK;
- break;
-#endif
-#ifdef ENOLINK
- case ENOLINK:
- ghc_errno = GHC_ENOLINK;
- break;
-#endif
-#ifdef ENOMEM
- case ENOMEM:
- ghc_errno = GHC_ENOMEM;
- break;
-#endif
-#ifdef ENOMSG
- case ENOMSG:
- ghc_errno = GHC_ENOMSG;
- break;
-#endif
-#ifdef ENONET
- case ENONET:
- ghc_errno = GHC_ENONET;
- break;
-#endif
-#ifdef ENOPROTOOPT
- case ENOPROTOOPT:
- ghc_errno = GHC_ENOPROTOOPT;
- break;
-#endif
-#ifdef ENOSPC
- case ENOSPC:
- ghc_errno = GHC_ENOSPC;
- break;
-#endif
-#ifdef ENOSR
- case ENOSR:
- ghc_errno = GHC_ENOSR;
- break;
-#endif
-#ifdef ENOSTR
- case ENOSTR:
- ghc_errno = GHC_ENOSTR;
- break;
-#endif
-#ifdef ENOSYS
- case ENOSYS:
- ghc_errno = GHC_ENOSYS;
- break;
-#endif
-#ifdef ENOTBLK
- case ENOTBLK:
- ghc_errno = GHC_ENOTBLK;
- break;
-#endif
-#ifdef ENOTCONN
- case ENOTCONN:
- ghc_errno = GHC_ENOTCONN;
- break;
-#endif
-#ifdef ENOTDIR
- case ENOTDIR:
- ghc_errno = GHC_ENOTDIR;
- break;
-#endif
-#ifndef aix_TARGET_OS
-/* AIX returns EEXIST where 4.3BSD used ENOTEMPTY.
- * there is an ENOTEMPTY defined as the same as EEXIST, and
- * therefore it won't work properly on a case statement.
- * another option is to define _ALL_SOURCE for aix, which
- * gives a different number for ENOTEMPTY.
- * I haven't tried that. -- andre.
- */
-#ifdef ENOTEMPTY
- case ENOTEMPTY:
- ghc_errno = GHC_ENOTEMPTY;
- break;
-#endif
-#endif
-#ifdef ENOTSOCK
- case ENOTSOCK:
- ghc_errno = GHC_ENOTSOCK;
- break;
-#endif
-#ifdef ENOTTY
- case ENOTTY:
- ghc_errno = GHC_ENOTTY;
- break;
-#endif
-#ifdef ENXIO
- case ENXIO:
- ghc_errno = GHC_ENXIO;
- break;
-#endif
-#ifdef EOPNOTSUPP
- case EOPNOTSUPP:
- ghc_errno = GHC_EOPNOTSUPP;
- break;
-#endif
-#ifdef EPERM
- case EPERM:
- ghc_errno = GHC_EPERM;
- break;
-#endif
-#ifdef EPFNOSUPPORT
- case EPFNOSUPPORT:
- ghc_errno = GHC_EPFNOSUPPORT;
- break;
-#endif
-#ifdef EPIPE
- case EPIPE:
- ghc_errno = GHC_EPIPE;
- break;
-#endif
-#ifdef EPROCLIM
- case EPROCLIM:
- ghc_errno = GHC_EPROCLIM;
- break;
-#endif
-#ifdef EPROCUNAVAIL
- case EPROCUNAVAIL:
- ghc_errno = GHC_EPROCUNAVAIL;
- break;
-#endif
-#ifdef EPROGMISMATCH
- case EPROGMISMATCH:
- ghc_errno = GHC_EPROGMISMATCH;
- break;
-#endif
-#ifdef EPROGUNAVAIL
- case EPROGUNAVAIL:
- ghc_errno = GHC_EPROGUNAVAIL;
- break;
-#endif
-#ifdef EPROTO
- case EPROTO:
- ghc_errno = GHC_EPROTO;
- break;
-#endif
-#ifdef EPROTONOSUPPORT
- case EPROTONOSUPPORT:
- ghc_errno = GHC_EPROTONOSUPPORT;
- break;
-#endif
-#ifdef EPROTOTYPE
- case EPROTOTYPE:
- ghc_errno = GHC_EPROTOTYPE;
- break;
-#endif
-#ifdef ERANGE
- case ERANGE:
- ghc_errno = GHC_ERANGE;
- break;
-#endif
-#ifdef EREMCHG
- case EREMCHG:
- ghc_errno = GHC_EREMCHG;
- break;
-#endif
-#ifdef EREMOTE
- case EREMOTE:
- ghc_errno = GHC_EREMOTE;
- break;
-#endif
-#ifdef EROFS
- case EROFS:
- ghc_errno = GHC_EROFS;
- break;
-#endif
-#ifdef ERPCMISMATCH
- case ERPCMISMATCH:
- ghc_errno = GHC_ERPCMISMATCH;
- break;
-#endif
-#ifdef ERREMOTE
- case ERREMOTE:
- ghc_errno = GHC_ERREMOTE;
- break;
-#endif
-#ifdef ESHUTDOWN
- case ESHUTDOWN:
- ghc_errno = GHC_ESHUTDOWN;
- break;
-#endif
-#ifdef ESOCKTNOSUPPORT
- case ESOCKTNOSUPPORT:
- ghc_errno = GHC_ESOCKTNOSUPPORT;
- break;
-#endif
-#ifdef ESPIPE
- case ESPIPE:
- ghc_errno = GHC_ESPIPE;
- break;
-#endif
-#ifdef ESRCH
- case ESRCH:
- ghc_errno = GHC_ESRCH;
- break;
-#endif
-#ifdef ESRMNT
- case ESRMNT:
- ghc_errno = GHC_ESRMNT;
- break;
-#endif
-#ifdef ESTALE
- case ESTALE:
- ghc_errno = GHC_ESTALE;
- break;
-#endif
-#ifdef ETIME
- case ETIME:
- ghc_errno = GHC_ETIME;
- break;
-#endif
-#ifdef ETIMEDOUT
- case ETIMEDOUT:
- ghc_errno = GHC_ETIMEDOUT;
- break;
-#endif
-#ifdef ETOOMANYREFS
- case ETOOMANYREFS:
- ghc_errno = GHC_ETOOMANYREFS;
- break;
-#endif
-#ifdef ETXTBSY
- case ETXTBSY:
- ghc_errno = GHC_ETXTBSY;
- break;
-#endif
-#ifdef EUSERS
- case EUSERS:
- ghc_errno = GHC_EUSERS;
- break;
-#endif
-#if 0
-#ifdef EWOULDBLOCK
- case EWOULDBLOCK:
- ghc_errno = GHC_EWOULDBLOCK;
- break;
-#endif
-#endif
-#ifdef EXDEV
- case EXDEV:
- ghc_errno = GHC_EXDEV;
- break;
-#endif
- default:
- ghc_errno = errno;
- break;
- }
-}
-
-void
-stdErrno(STG_NO_ARGS)
-{
- switch(ghc_errno) {
- default:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "unexpected error";
- break;
- case 0:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "no error";
- case GHC_E2BIG:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "argument list too long";
- break;
- case GHC_EACCES:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "inadequate access permission";
- break;
- case GHC_EADDRINUSE:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "address already in use";
- break;
- case GHC_EADDRNOTAVAIL:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "address not available";
- break;
- case GHC_EADV:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "RFS advertise error";
- break;
- case GHC_EAFNOSUPPORT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "address family not supported by protocol family";
- break;
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "insufficient resources";
- break;
- case GHC_EALREADY:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "operation already in progress";
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "internal error (EBADF)";
- break;
- case GHC_EBADMSG:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "next message has wrong type";
- break;
- case GHC_EBADRPC:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "invalid RPC request or response";
- break;
- case GHC_EBUSY:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "device busy";
- break;
- case GHC_ECHILD:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no child processes";
- break;
- case GHC_ECOMM:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "no virtual circuit could be found";
- break;
- case GHC_ECONNABORTED:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "aborted connection";
- break;
- case GHC_ECONNREFUSED:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no listener on remote host";
- break;
- case GHC_ECONNRESET:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "connection reset by peer";
- break;
- case GHC_EDEADLK:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "resource deadlock avoided";
- break;
- case GHC_EDESTADDRREQ:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "destination address required";
- break;
- case GHC_EDIRTY:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "file system dirty";
- break;
- case GHC_EDOM:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "argument too large";
- break;
- case GHC_EDQUOT:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "quota exceeded";
- break;
- case GHC_EEXIST:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "file already exists";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "internal error (EFAULT)";
- break;
- case GHC_EFBIG:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "file too large";
- break;
- case GHC_EFTYPE:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "inappropriate NFS file type or format";
- break;
- case GHC_EHOSTDOWN:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "destination host down";
- break;
- case GHC_EHOSTUNREACH:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "remote host is unreachable";
- break;
- case GHC_EIDRM:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "IPC identifier removed";
- break;
- case GHC_EILSEQ:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "invalid wide character";
- break;
- case GHC_EINPROGRESS:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "operation now in progress";
- break;
- case GHC_EINTR:
- ghc_errtype = ERR_INTERRUPTED;
- ghc_errstr = "interrupted system call";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "invalid argument";
- break;
- case GHC_EIO:
- ghc_errtype = ERR_HARDWAREFAULT;
- ghc_errstr = "unknown I/O fault";
- break;
- case GHC_EISCONN:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "socket is already connected";
- break;
- case GHC_EISDIR:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- break;
- case GHC_ELOOP:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "too many symbolic links";
- break;
- case GHC_EMFILE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "process file table full";
- break;
- case GHC_EMLINK:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "too many links";
- break;
- case GHC_EMSGSIZE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "message too long";
- break;
- case GHC_EMULTIHOP:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "multi-hop RFS request";
- break;
- case GHC_ENAMETOOLONG:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "filename too long";
- break;
- case GHC_ENETDOWN:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "network is down";
- break;
- case GHC_ENETRESET:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "remote host rebooted; connection lost";
- break;
- case GHC_ENETUNREACH:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "remote network is unreachable";
- break;
- case GHC_ENFILE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "system file table full";
- break;
- case GHC_ENOBUFS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "no buffer space available";
- break;
- case GHC_ENODATA:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no message on the stream head read queue";
- break;
- case GHC_ENODEV:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such device";
- break;
- case GHC_ENOENT:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such file or directory";
- break;
- case GHC_ENOEXEC:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not an executable file";
- break;
- case GHC_ENOLCK:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "no file locks available";
- break;
- case GHC_ENOLINK:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "RFS link has been severed";
- break;
- case GHC_ENOMEM:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- break;
- case GHC_ENOMSG:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no message of desired type";
- break;
- case GHC_ENONET:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "host is not on a network";
- break;
- case GHC_ENOPROTOOPT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "operation not supported by protocol";
- break;
- case GHC_ENOSPC:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "no space left on device";
- break;
- case GHC_ENOSR:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "out of stream resources";
- break;
- case GHC_ENOSTR:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not a stream device";
- break;
- case GHC_ENOSYS:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "function not implemented";
- break;
- case GHC_ENOTBLK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not a block device";
- break;
- case GHC_ENOTCONN:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "socket is not connected";
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- break;
- case GHC_ENOTEMPTY:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "directory not empty";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not a socket";
- break;
- case GHC_ENOTTY:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "inappropriate ioctl for device";
- break;
- case GHC_ENXIO:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such device or address";
- break;
- case GHC_EOPNOTSUPP:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "operation not supported on socket";
- break;
- case GHC_EPERM:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "privileged operation";
- break;
- case GHC_EPFNOSUPPORT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "protocol family not supported";
- break;
- case GHC_EPIPE:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "broken pipe";
- break;
- case GHC_EPROCLIM:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "too many processes";
- break;
- case GHC_EPROCUNAVAIL:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "unimplemented RPC procedure";
- break;
- case GHC_EPROGMISMATCH:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "unsupported RPC program version";
- break;
- case GHC_EPROGUNAVAIL:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "RPC program unavailable";
- break;
- case GHC_EPROTO:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "error in streams protocol";
- break;
- case GHC_EPROTONOSUPPORT:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "protocol not supported";
- break;
- case GHC_EPROTOTYPE:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "wrong protocol for socket";
- break;
- case GHC_ERANGE:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "result too large";
- break;
- case GHC_EREMCHG:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "remote address changed";
- break;
- case GHC_EREMOTE:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "too many levels of remote in path";
- break;
- case GHC_EROFS:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "read-only file system";
- break;
- case GHC_ERPCMISMATCH:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "RPC version is wrong";
- break;
- case GHC_ERREMOTE:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "object is remote";
- break;
- case GHC_ESHUTDOWN:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "can't send after socket shutdown";
- break;
- case GHC_ESOCKTNOSUPPORT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "socket type not supported";
- break;
- case GHC_ESPIPE:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't seek on a pipe";
- break;
- case GHC_ESRCH:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such process";
- break;
- case GHC_ESRMNT:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "RFS resources still mounted by remote host(s)";
- break;
- case GHC_ESTALE:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "stale NFS file handle";
- break;
- case GHC_ETIME:
- ghc_errtype = ERR_TIMEEXPIRED;
- ghc_errstr = "timer expired";
- break;
- case GHC_ETIMEDOUT:
- ghc_errtype = ERR_TIMEEXPIRED;
- ghc_errstr = "connection timed out";
- break;
- case GHC_ETOOMANYREFS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "too many references; can't splice";
- break;
- case GHC_ETXTBSY:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "text file in-use";
- break;
- case GHC_EUSERS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "quota table full";
- break;
- case GHC_EWOULDBLOCK:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "operation would block";
- break;
- case GHC_EXDEV:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't make a cross-device link";
- break;
- }
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: error.h,v 1.3 1998/12/02 13:27:21 simonm Exp $
+ *
+ * Error codes used by the IO subsystem.
+ */
+
+#define ERR_ALREADYEXISTS 1
+#define ERR_HARDWAREFAULT 2
+#define ERR_ILLEGALOPERATION 3
+#define ERR_INAPPROPRIATETYPE 4
+#define ERR_INTERRUPTED 5
+#define ERR_INVALIDARGUMENT 6
+#define ERR_NOSUCHTHING 7
+#define ERR_OTHERERROR 8
+#define ERR_PERMISSIONDENIED 9
+#define ERR_PROTOCOLERROR 10
+#define ERR_RESOURCEBUSY 11
+#define ERR_RESOURCEEXHAUSTED 12
+#define ERR_RESOURCEVANISHED 13
+#define ERR_SYSTEMERROR 14
+#define ERR_TIMEEXPIRED 15
+#define ERR_UNSATISFIEDCONSTRAINTS 16
+#define ERR_UNSUPPORTEDOPERATION 17
+#define ERR_USERERROR 18
+#define ERR_EOF 19
+
+#define GHC_E2BIG -1
+#define GHC_EACCES -2
+#define GHC_EADDRINUSE -3
+#define GHC_EADDRNOTAVAIL -4
+#define GHC_EADV -5
+#define GHC_EAFNOSUPPORT -6
+#define GHC_EAGAIN -7
+#define GHC_EAIO -8
+#define GHC_EALREADY -9
+#define GHC_EBADF -10
+#define GHC_EBADMSG -11
+#define GHC_EBADRPC -12
+#define GHC_EBUSY -13
+#define GHC_ECANCELED -14
+#define GHC_ECHILD -15
+#define GHC_ECLONEME -16
+#define GHC_ECOMM -17
+#define GHC_ECONNABORTED -18
+#define GHC_ECONNREFUSED -19
+#define GHC_ECONNRESET -20
+#define GHC_EDEADLK -21
+#define GHC_EDESTADDRREQ -22
+#define GHC_EDIRTY -23
+#define GHC_EDOM -24
+#define GHC_EDOTDOT -25
+#define GHC_EDQUOT -26
+#define GHC_EDUPPKG -27
+#define GHC_EEXIST -28
+#define GHC_EFAIL -29
+#define GHC_EFAULT -30
+#define GHC_EFBIG -31
+#define GHC_EFTYPE -32
+#define GHC_EHOSTDOWN -33
+#define GHC_EHOSTUNREACH -34
+#define GHC_EIDRM -35
+#define GHC_EILSEQ -36
+#define GHC_EINPROG -37
+#define GHC_EINPROGRESS -38
+#define GHC_EINTR -39
+#define GHC_EINVAL -40
+#define GHC_EIO -41
+#define GHC_EISCONN -42
+#define GHC_EISDIR -43
+#define GHC_ELOOP -44
+#define GHC_EMEDIA -45
+#define GHC_EMFILE -46
+#define GHC_EMLINK -47
+#define GHC_EMSGSIZE -48
+#define GHC_EMTIMERS -49
+#define GHC_EMULTIHOP -50
+#define GHC_ENAMETOOLONG -51
+#define GHC_ENETDOWN -52
+#define GHC_ENETRESET -53
+#define GHC_ENETUNREACH -54
+#define GHC_ENFILE -55
+#define GHC_ENOBUFS -56
+#define GHC_ENODATA -57
+#define GHC_ENODEV -58
+#define GHC_ENOENT -59
+#define GHC_ENOEXEC -60
+#define GHC_ENOLCK -61
+#define GHC_ENOLINK -62
+#define GHC_ENOMEM -63
+#define GHC_ENOMSG -64
+#define GHC_ENONET -65
+#define GHC_ENOPKG -66
+#define GHC_ENOPROTOOPT -67
+#define GHC_ENOSPC -68
+#define GHC_ENOSR -69
+#define GHC_ENOSTR -70
+#define GHC_ENOSYM -71
+#define GHC_ENOSYS -72
+#define GHC_ENOTBLK -73
+#define GHC_ENOTCONN -74
+#define GHC_ENOTDIR -75
+#define GHC_ENOTEMPTY -76
+#define GHC_ENOTSOCK -77
+#define GHC_ENOTSUP -78
+#define GHC_ENOTTY -79
+#define GHC_ENXIO -80
+#define GHC_EOPNOTSUPP -81
+#define GHC_EPERM -82
+#define GHC_EPFNOSUPPORT -83
+#define GHC_EPIPE -84
+#define GHC_EPROCLIM -85
+#define GHC_EPROCUNAVAIL -86
+#define GHC_EPROGMISMATCH -87
+#define GHC_EPROGUNAVAIL -88
+#define GHC_EPROTO -89
+#define GHC_EPROTONOSUPPORT -90
+#define GHC_EPROTOTYPE -91
+#define GHC_ERANGE -92
+#define GHC_ERELOCATED -93
+#define GHC_EREMCHG -94
+#define GHC_EREMOTE -95
+#define GHC_EROFS -96
+#define GHC_ERPCMISMATCH -97
+#define GHC_ERREMOTE -98
+#define GHC_ESHUTDOWN -99
+#define GHC_ESOCKTNOSUPPORT -100
+#define GHC_ESOFT -101
+#define GHC_ESPIPE -102
+#define GHC_ESRCH -103
+#define GHC_ESRMNT -104
+#define GHC_ESTALE -105
+#define GHC_ETIME -106
+#define GHC_ETIMEDOUT -107
+#define GHC_ETOOMANYREFS -108
+#define GHC_ETXTBSY -109
+#define GHC_EUSERS -110
+#define GHC_EVERSION -111
+#define GHC_EWOULDBLOCK -112
+#define GHC_EXDEV -113
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: fileEOF.c,v 1.3 1998/12/02 13:27:22 simonm Exp $
+ *
+ * hIsEOF Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgInt
+fileEOF(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ if ( FILEOBJ_IS_EOF(fo) )
+ return 1;
+
+ if (fileLookAhead(ptr) != EOF)
+ return 0;
+ else if (ghc_errtype == ERR_EOF)
+ return 1;
+ else
+ return -1;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[fileEOF.lc]{hIsEOF Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgInt
-fileEOF(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
-
- if ( FILEOBJ_IS_EOF(fo) )
- return 1;
-
- if (fileLookAhead(ptr) != EOF)
- return 0;
- else if (ghc_errtype == ERR_EOF)
- return 1;
- else
- return -1;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: fileGetc.c,v 1.3 1998/12/02 13:27:23 simonm Exp $
+ *
+ * hGetChar Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+#include "error.h"
+
+#define EOT 4
+
+/* Pre-condition: only ever called on a readable fileObject */
+StgInt
+fileGetc(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int l,rc=0;
+ unsigned char c;
+
+#if 0
+ fprintf(stderr, "fgc: %d %d %d\n", fo->bufRPtr, fo->bufWPtr, fo->flags);
+#endif
+ /*
+ fileGetc does the following:
+ - if the input is buffered, try fetch the char from buffer.
+ - failing that,
+
+ - if the input stream is 'connected' to an output stream,
+ flush it before requesting any input.
+ - if unbuffered, read in one character.
+ - if line-buffered, read in one line, returning the first.
+ - if block-buffered, fill up block, returning the first.
+ */
+
+ if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+ }
+
+ fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
+
+ if ( FILEOBJ_IS_EOF(fo) ) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ }
+
+ if ( FILEOBJ_BUFFER_EMPTY(fo) ) {
+ ;
+ } else if ( FILEOBJ_UNBUFFERED(fo) && !FILEOBJ_HAS_PUSHBACKS(fo) ) {
+ ;
+ } else if ( FILEOBJ_UNBUFFERED(fo) ) { /* Unbuffered stream has pushbacks, retrieve them */
+ c=((unsigned char*)(fo->buf))[fo->bufRPtr++];
+ return (int)c;
+ } else {
+ c=((unsigned char*)(fo->buf))[fo->bufRPtr];
+ fo->bufRPtr++;
+ return (int)c;
+ }
+
+ /* Nothing in the buffer, go out and fetch a byte for our customer,
+ filling up the buffer if needs be.
+ */
+ if ( FILEOBJ_UNBUFFERED(fo) ) {
+ return (readChar(ptr));
+ } else if ( FILEOBJ_LINEBUFFERED(fo) ) {
+
+ /* if input stream is connect to an output stream, flush it first */
+ if ( fo->connectedTo != NULL &&
+ fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE) ) {
+ rc = flushFile((StgForeignPtr)fo->connectedTo);
+ }
+ if (rc < 0) return rc;
+
+ rc = fill_up_line_buffer(fo);
+ if (rc < 0) return rc;
+
+ c=((unsigned char*)(fo->buf))[fo->bufRPtr];
+ fo->bufRPtr++;
+ return (int)c;
+
+ } else { /* Fully-buffered */
+ rc = readBlock(ptr);
+ if (rc < 0) return rc;
+
+ c=((unsigned char*)(fo->buf))[fo->bufRPtr];
+ fo->bufRPtr++;
+ return (int)c;
+ }
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[fileGetc.lc]{hGetChar Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-#include "error.h"
-
-#define EOT 4
-
-/* Pre-condition: only ever called on a readable fileObject */
-StgInt
-fileGetc(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int l,rc=0;
- unsigned char c;
-
-#if 0
- fprintf(stderr, "fgc: %d %d %d\n", fo->bufRPtr, fo->bufWPtr, fo->flags);
-#endif
- /*
- fileGetc does the following:
- - if the input is buffered, try fetch the char from buffer.
- - failing that,
-
- - if the input stream is 'connected' to an output stream,
- flush it before requesting any input.
- - if unbuffered, read in one character.
- - if line-buffered, read in one line, returning the first.
- - if block-buffered, fill up block, returning the first.
- */
-
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
-
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- if ( FILEOBJ_BUFFER_EMPTY(fo) ) {
- ;
- } else if ( FILEOBJ_UNBUFFERED(fo) && !FILEOBJ_HAS_PUSHBACKS(fo) ) {
- ;
- } else if ( FILEOBJ_UNBUFFERED(fo) ) { /* Unbuffered stream has pushbacks, retrieve them */
- c=((unsigned char*)(fo->buf))[fo->bufRPtr++];
- return (int)c;
- } else {
- c=((unsigned char*)(fo->buf))[fo->bufRPtr];
- fo->bufRPtr++;
- return (int)c;
- }
-
- /* Nothing in the buffer, go out and fetch a byte for our customer,
- filling up the buffer if needs be.
- */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- return (readChar(ptr));
- } else if ( FILEOBJ_LINEBUFFERED(fo) ) {
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE) ) {
- rc = flushFile((StgForeignObj)fo->connectedTo);
- }
- if (rc < 0) return rc;
-
- rc = fill_up_line_buffer(fo);
- if (rc < 0) return rc;
-
- c=((unsigned char*)(fo->buf))[fo->bufRPtr];
- fo->bufRPtr++;
- return (int)c;
-
- } else { /* Fully-buffered */
- rc = readBlock(ptr);
- if (rc < 0) return rc;
-
- c=((unsigned char*)(fo->buf))[fo->bufRPtr];
- fo->bufRPtr++;
- return (int)c;
- }
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: fileLookAhead.c,v 1.3 1998/12/02 13:27:25 simonm Exp $
+ *
+ * hLookAhead Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgInt
+fileLookAhead(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int c, rc;
+
+#if 0
+ fprintf(stderr, "flh: %d %d %d\n",fo->bufRPtr, fo->bufWPtr, fo->flags);
+#endif
+
+ /*
+ * fileLookahead reads the next character (hopefully from the buffer),
+ * before putting it back and returning the char.
+ *
+ */
+
+ if ( FILEOBJ_IS_EOF(fo) ) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ }
+
+ if ( (c = fileGetc(ptr)) < 0 ) {
+ return c;
+ }
+
+ rc = ungetChar(ptr,(char)c);
+ if ( rc < 0 ) {
+ return rc;
+ } else {
+ return c;
+ }
+}
+
+StgInt
+ungetChar(ptr,c)
+StgForeignPtr ptr;
+StgChar c;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int rc = 0, sz = 0;
+
+#if 0
+ fprintf(stderr, "ug: %d %d %c\n",fo->bufRPtr, fo->bufWPtr,(char)c, fo->flags);
+#endif
+
+ /* Sanity check */
+ if ( !FILEOBJ_READABLE(fo) ) {
+ ghc_errno = GHC_EINVAL;
+ ghc_errstr = "object not readable";
+ return -1;
+ }
+
+ /* For an unbuffered file object, we lazily
+ allocate a pushback buffer. The sizeof the pushback
+ buffer is (globally) configurable.
+ */
+ sz = getPushbackBufSize();
+ if ( FILEOBJ_UNBUFFERED(fo) && fo->buf==NULL && sz > 0 ) {
+ if ((fo->buf = malloc(sz*sizeof(char))) == NULL ) {
+ return -1;
+ }
+ fo->bufSize = sz;
+ ((unsigned char*)fo->buf)[sz-1]=(unsigned char)c;
+ fo->bufWPtr = sz; /* Points one past the end of pushback buffer */
+ fo->bufRPtr = sz-1; /* points to current char. */
+ return 0;
+ }
+
+ if ( fo->bufWPtr > 0 && fo->bufRPtr > 0 ) {
+ fo->bufRPtr -= 1;
+ ((unsigned char*)fo->buf)[fo->bufRPtr]=(unsigned char)c;
+ return 0;
+ } else if ( fo->buf != NULL &&
+ fo->bufSize > 0 &&
+ fo->bufWPtr == 0 &&
+ fo->bufRPtr==0 ) { /* empty buffer waiting to be filled up */
+ fo->bufRPtr=fo->bufSize-1;
+ ((unsigned char*)fo->buf)[fo->bufRPtr]=(unsigned char)c;
+ fo->bufWPtr=fo->bufSize;
+ return 0;
+ } else {
+ return -1;
+ }
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[fileLookAhead.lc]{hLookAhead Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgInt
-fileLookAhead(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int c, rc;
-
-#if 0
- fprintf(stderr, "flh: %d %d %d\n",fo->bufRPtr, fo->bufWPtr, fo->flags);
-#endif
-
- /*
- * fileLookahead reads the next character (hopefully from the buffer),
- * before putting it back and returning the char.
- *
- */
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- if ( (c = fileGetc(ptr)) < 0 ) {
- return c;
- }
-
- rc = ungetChar(ptr,(char)c);
- if ( rc < 0 ) {
- return rc;
- } else {
- return c;
- }
-}
-
-StgInt
-ungetChar(ptr,c)
-StgForeignObj ptr;
-StgChar c;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0, sz = 0;
-
-#if 0
- fprintf(stderr, "ug: %d %d %c\n",fo->bufRPtr, fo->bufWPtr,(char)c, fo->flags);
-#endif
-
- /* Sanity check */
- if ( !FILEOBJ_READABLE(fo) ) {
- ghc_errno = GHC_EINVAL;
- ghc_errstr = "object not readable";
- return -1;
- }
-
- /* For an unbuffered file object, we lazily
- allocate a pushback buffer. The sizeof the pushback
- buffer is (globally) configurable.
- */
- sz = getPushbackBufSize();
- if ( FILEOBJ_UNBUFFERED(fo) && fo->buf==NULL && sz > 0 ) {
- if ((fo->buf = malloc(sz*sizeof(char))) == NULL ) {
- return -1;
- }
- fo->bufSize = sz;
- ((unsigned char*)fo->buf)[sz-1]=(unsigned char)c;
- fo->bufWPtr = sz; /* Points one past the end of pushback buffer */
- fo->bufRPtr = sz-1; /* points to current char. */
- return 0;
- }
-
- if ( fo->bufWPtr > 0 && fo->bufRPtr > 0 ) {
- fo->bufRPtr -= 1;
- ((unsigned char*)fo->buf)[fo->bufRPtr]=(unsigned char)c;
- return 0;
- } else if ( fo->buf != NULL &&
- fo->bufSize > 0 &&
- fo->bufWPtr == 0 &&
- fo->bufRPtr==0 ) { /* empty buffer waiting to be filled up */
- fo->bufRPtr=fo->bufSize-1;
- ((unsigned char*)fo->buf)[fo->bufRPtr]=(unsigned char)c;
- fo->bufWPtr=fo->bufSize;
- return 0;
- } else {
- return -1;
- }
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: fileObject.c,v 1.2 1998/12/02 13:27:26 simonm Exp $
+ *
+ * hPutStr Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+#include "fileObject.h"
+
+void
+setBufFlags(fo, flg)
+StgForeignPtr fo;
+StgInt flg;
+{
+ ((IOFileObject*)fo)->flags = flg;
+ return;
+}
+
+void
+setBufWPtr(fo, len)
+StgForeignPtr fo;
+StgInt len;
+{
+ ((IOFileObject*)fo)->bufWPtr = len;
+ return;
+}
+
+StgInt
+getBufWPtr(fo)
+StgForeignPtr fo;
+{
+ return (((IOFileObject*)fo)->bufWPtr);
+}
+
+StgInt
+getBufSize(fo)
+StgForeignPtr fo;
+{
+ return (((IOFileObject*)fo)->bufSize);
+}
+
+void
+setBuf(fo, buf,sz)
+StgForeignPtr fo;
+StgAddr buf;
+StgInt sz;
+{
+ ((IOFileObject*)fo)->buf = buf;
+ ((IOFileObject*)fo)->bufSize = sz;
+ return;
+}
+
+StgAddr
+getBuf(fo)
+StgForeignPtr fo;
+{ return (((IOFileObject*)fo)->buf); }
+
+StgAddr
+getWriteableBuf(ptr)
+StgForeignPtr ptr;
+{
+ /* getWriteableBuf() is called prior to starting to pack
+ a Haskell string into the IOFileObject buffer. It takes
+ care of flushing the (input) buffer in the case we're
+ dealing with a RW handle.
+ */
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
+ flushReadBuffer(ptr); /* ignoring return code */
+ /* Ahead of time really, but indicate that we're (just about to) write */
+ }
+ fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
+ return (fo->buf);
+}
+
+StgAddr
+getBufStart(fo,count)
+StgForeignPtr fo;
+StgInt count;
+{ return ((char*)((IOFileObject*)fo)->buf + (((IOFileObject*)fo)->bufRPtr) - count); }
+
+StgInt
+getFileFd(fo)
+StgForeignPtr fo;
+{ return (((IOFileObject*)fo)->fd); }
+
+StgInt
+getConnFileFd(fo)
+StgForeignPtr fo;
+{ return (((IOFileObject*)fo)->connectedTo->fd); }
+
+
+void
+setFd(fo,fp)
+StgForeignPtr fo;
+StgInt fp;
+{ ((IOFileObject*)fo)->fd = fp;
+ return;
+}
+
+void
+setConnectedTo(fo, fw, flg)
+StgForeignPtr fo;
+StgForeignPtr fw;
+StgInt flg;
+{
+ if( flg && (! isatty(((IOFileObject*)fo)->fd) || !isatty(((IOFileObject*)fw)->fd)) ) {
+ return;
+ }
+ ((IOFileObject*)fo)->connectedTo = (IOFileObject*)fw;
+ return;
+}
+
+static int __pushback_buf_size__ = 2;
+
+void
+setPushbackBufSize(i)
+StgInt i;
+{ __pushback_buf_size__ = (i > 0 ? i : 0); }
+
+StgInt
+getPushbackBufSize()
+{ return (__pushback_buf_size__); }
+
+void
+clearNonBlockingIOFlag__ (ptr)
+StgForeignPtr ptr;
+{ ((IOFileObject*)ptr)->flags &= ~FILEOBJ_NONBLOCKING_IO; }
+
+void
+setNonBlockingIOFlag__ (ptr)
+StgForeignPtr ptr;
+{ ((IOFileObject*)ptr)->flags |= FILEOBJ_NONBLOCKING_IO; }
+
+void
+clearConnNonBlockingIOFlag__ (ptr)
+StgForeignPtr ptr;
+{ ((IOFileObject*)ptr)->connectedTo->flags &= ~FILEOBJ_NONBLOCKING_IO; }
+
+void
+setConnNonBlockingIOFlag__ (ptr)
+StgForeignPtr ptr;
+{
+ if ( ((IOFileObject*)ptr)->connectedTo != NULL ) {
+ ((IOFileObject*)ptr)->connectedTo->flags |= FILEOBJ_NONBLOCKING_IO;
+ }
+ return;
+}
+
+
+/* Only ever called on line-buffered file objects */
+StgInt
+fill_up_line_buffer(fo)
+IOFileObject* fo;
+{
+ int count,len, ipos;
+ unsigned char* p;
+
+ /* ToDo: deal with buffer overflow (i.e., realloc buffer if this happens) */
+
+ if ( fo->bufRPtr == fo->bufWPtr ) { /* There's nothing in the buffer, reset */
+ fo->bufRPtr=0;
+ fo->bufWPtr=0;
+ }
+ ipos = fo->bufWPtr;
+ len = fo->bufSize - fo->bufWPtr + 1;
+ p = (unsigned char*)fo->buf + fo->bufWPtr;
+
+ if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady ((StgForeignPtr)fo,0) != 1 )
+ return FILEOBJ_BLOCKED_READ;
+
+ if ((count = read(fo->fd, p, len)) <= 0) {
+ if (count == 0) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ FILEOBJ_SET_EOF(fo);
+ return -1;
+ } else if ( count == -1 && errno == EAGAIN) {
+ errno = 0;
+ return FILEOBJ_BLOCKED_READ;
+ } else if ( count == -1 && errno != EINTR ) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ fo->bufWPtr += count;
+ return (fo->bufWPtr - ipos);
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\subsection[fileObject.lc]{Managing file objects}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-#include "fileObject.h"
-
-void
-setBufFlags(fo, flg)
-StgForeignObj fo;
-StgInt flg;
-{
- ((IOFileObject*)fo)->flags = flg;
- return;
-}
-
-void
-setBufWPtr(fo, len)
-StgForeignObj fo;
-StgInt len;
-{
- ((IOFileObject*)fo)->bufWPtr = len;
- return;
-}
-
-StgInt
-getBufWPtr(fo)
-StgForeignObj fo;
-{
- return (((IOFileObject*)fo)->bufWPtr);
-}
-
-StgInt
-getBufSize(fo)
-StgForeignObj fo;
-{
- return (((IOFileObject*)fo)->bufSize);
-}
-
-void
-setBuf(fo, buf,sz)
-StgForeignObj fo;
-StgAddr buf;
-StgInt sz;
-{
- ((IOFileObject*)fo)->buf = buf;
- ((IOFileObject*)fo)->bufSize = sz;
- return;
-}
-
-StgAddr
-getBuf(fo)
-StgForeignObj fo;
-{ return (((IOFileObject*)fo)->buf); }
-
-StgAddr
-getWriteableBuf(ptr)
-StgForeignObj ptr;
-{
- /* getWriteableBuf() is called prior to starting to pack
- a Haskell string into the IOFileObject buffer. It takes
- care of flushing the (input) buffer in the case we're
- dealing with a RW handle.
- */
- IOFileObject* fo = (IOFileObject*)ptr;
-
- if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
- flushReadBuffer(ptr); /* ignoring return code */
- /* Ahead of time really, but indicate that we're (just about to) write */
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
- return (fo->buf);
-}
-
-StgAddr
-getBufStart(fo,count)
-StgForeignObj fo;
-StgInt count;
-{ return ((char*)((IOFileObject*)fo)->buf + (((IOFileObject*)fo)->bufRPtr) - count); }
-
-StgInt
-getFileFd(fo)
-StgForeignObj fo;
-{ return (((IOFileObject*)fo)->fd); }
-
-StgInt
-getConnFileFd(fo)
-StgForeignObj fo;
-{ return (((IOFileObject*)fo)->connectedTo->fd); }
-
-
-void
-setFd(fo,fp)
-StgForeignObj fo;
-StgInt fp;
-{ ((IOFileObject*)fo)->fd = fp;
- return;
-}
-
-void
-setConnectedTo(fo, fw, flg)
-StgForeignObj fo;
-StgForeignObj fw;
-StgInt flg;
-{
- if( flg && (! isatty(((IOFileObject*)fo)->fd) || !isatty(((IOFileObject*)fw)->fd)) ) {
- return;
- }
- ((IOFileObject*)fo)->connectedTo = (IOFileObject*)fw;
- return;
-}
-
-static int __pushback_buf_size__ = 2;
-
-void
-setPushbackBufSize(i)
-StgInt i;
-{ __pushback_buf_size__ = (i > 0 ? i : 0); }
-
-StgInt
-getPushbackBufSize()
-{ return (__pushback_buf_size__); }
-
-void
-clearNonBlockingIOFlag__ (ptr)
-StgForeignObj ptr;
-{ ((IOFileObject*)ptr)->flags &= ~FILEOBJ_NONBLOCKING_IO; }
-
-void
-setNonBlockingIOFlag__ (ptr)
-StgForeignObj ptr;
-{ ((IOFileObject*)ptr)->flags |= FILEOBJ_NONBLOCKING_IO; }
-
-void
-clearConnNonBlockingIOFlag__ (ptr)
-StgForeignObj ptr;
-{ ((IOFileObject*)ptr)->connectedTo->flags &= ~FILEOBJ_NONBLOCKING_IO; }
-
-void
-setConnNonBlockingIOFlag__ (ptr)
-StgForeignObj ptr;
-{
- if ( ((IOFileObject*)ptr)->connectedTo != NULL ) {
- ((IOFileObject*)ptr)->connectedTo->flags |= FILEOBJ_NONBLOCKING_IO;
- }
- return;
-}
-
-
-/* Only ever called on line-buffered file objects */
-StgInt
-fill_up_line_buffer(fo)
-IOFileObject* fo;
-{
- int count,len, ipos;
- unsigned char* p;
-
- /* ToDo: deal with buffer overflow (i.e., realloc buffer if this happens) */
-
- if ( fo->bufRPtr == fo->bufWPtr ) { /* There's nothing in the buffer, reset */
- fo->bufRPtr=0;
- fo->bufWPtr=0;
- }
- ipos = fo->bufWPtr;
- len = fo->bufSize - fo->bufWPtr + 1;
- p = (unsigned char*)fo->buf + fo->bufWPtr;
-
- if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady ((StgForeignObj)fo,0) != 1 )
- return FILEOBJ_BLOCKED_READ;
-
- if ((count = read(fo->fd, p, len)) <= 0) {
- if (count == 0) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- FILEOBJ_SET_EOF(fo);
- return -1;
- } else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
- } else if ( count == -1 && errno != EINTR ) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- fo->bufWPtr += count;
- return (fo->bufWPtr - ipos);
-}
-
-
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: filePosn.c,v 1.3 1998/12/02 13:27:27 simonm Exp $
+ *
+ * hGetPosn and hSetPosn Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgInt
+getFilePosn(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ StgInt posn;
+
+ while ( (posn = lseek(fo->fd, 0, SEEK_CUR)) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (fo->flags & FILEOBJ_WRITE) {
+ posn += fo->bufWPtr;
+ } else if (fo->flags & FILEOBJ_READ) {
+ posn -= (fo->bufWPtr - fo->bufRPtr);
+ }
+ return posn;
+}
+
+/* The following is only called with a position that we've already visited
+ (this is ensured by making the Haskell file posn. type abstract.)
+*/
+StgInt
+setFilePosn(ptr, posn)
+StgForeignPtr ptr;
+StgInt posn;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int rc;
+
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+
+ while (lseek(fo->fd, posn, SEEK_SET) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ FILEOBJ_CLEAR_EOF(fo);
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[filePosn.lc]{hGetPosn and hSetPosn Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgInt
-getFilePosn(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- StgInt posn;
-
- while ( (posn = lseek(fo->fd, 0, SEEK_CUR)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (fo->flags & FILEOBJ_WRITE) {
- posn += fo->bufWPtr;
- } else if (fo->flags & FILEOBJ_READ) {
- posn -= (fo->bufWPtr - fo->bufRPtr);
- }
- return posn;
-}
-
-/* The following is only called with a position that we've already visited
- (this is ensured by making the Haskell file posn. type abstract.)
-*/
-StgInt
-setFilePosn(ptr, posn)
-StgForeignObj ptr;
-StgInt posn;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc;
-
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
-
- while (lseek(fo->fd, posn, SEEK_SET) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- FILEOBJ_CLEAR_EOF(fo);
- return 0;
-}
-
-\end{code}
-
-
-
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: filePutc.c,v 1.3 1998/12/02 13:27:29 simonm Exp $
+ *
+ * hPutChar Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+#include "error.h"
+
+#define TERMINATE_LINE(x) ((x) == '\n')
+
+StgInt
+filePutc(ptr, c)
+StgForeignPtr ptr;
+StgChar c;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int rc = 0;
+
+ /* What filePutc needs to do:
+
+ - if there's no buffering => write it out.
+ - if the buffer is line-buffered
+ write out buffer (+char), iff buffer would be full afterwards ||
+ new char is the newline character
+ add to buffer , otherwise
+ - if the buffer is fully-buffered
+ write out buffer (+char), iff adding char fills up buffer.
+ add char to buffer, otherwise.
+
+ In the cases where a file is buffered, the invariant is that operations
+ that fill up a buffer also flushes them. A consequence of this here, is
+ that we're guaranteed to be passed a buffer with space for (at least)
+ the one char we're adding.
+
+ Supporting RW objects adds yet another twist, since we have to make
+ sure that if such objects have been read from just previously, we
+ flush(i.e., empty) the buffer first. (We could be smarter about this,
+ but aren't!)
+
+ */
+
+ if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
+ rc = flushReadBuffer(ptr);
+ if (rc<0) return rc;
+ }
+
+ fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
+
+ /* check whether we can just add it to the buffer.. */
+ if ( FILEOBJ_UNBUFFERED(fo) ) {
+ ;
+ } else {
+ /* We're buffered, add it to the pack */
+ ((char*)fo->buf)[fo->bufWPtr] = (char)c;
+ fo->bufWPtr++;
+ /* If the buffer filled up as a result, *or*
+ the added character terminated a line
+ => flush.
+ */
+ if ( FILEOBJ_BUFFER_FULL(fo) ||
+ (FILEOBJ_LINEBUFFERED(fo) && TERMINATE_LINE(c)) ) {
+ rc = writeBuffer(ptr, fo->bufWPtr);
+ /* Undo the write if we're blocking..*/
+ if (rc == FILEOBJ_BLOCKED_WRITE ) fo->bufWPtr--;
+ }
+ return rc;
+ }
+
+ if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady(ptr,0) != 1 )
+ return FILEOBJ_BLOCKED_WRITE;
+
+ /* Unbuffered, write the character directly. */
+ while ((rc = write(fo->fd, &c, 1)) == 0 && errno == EINTR) ;
+
+ if (rc == 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ return 0;
+
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[filePut.lc]{hPutChar Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-#include "error.h"
-
-#define TERMINATE_LINE(x) ((x) == '\n')
-
-StgInt
-filePutc(ptr, c)
-StgForeignObj ptr;
-StgChar c;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
-
- /* What filePutc needs to do:
-
- - if there's no buffering => write it out.
- - if the buffer is line-buffered
- write out buffer (+char), iff buffer would be full afterwards ||
- new char is the newline character
- add to buffer , otherwise
- - if the buffer is fully-buffered
- write out buffer (+char), iff adding char fills up buffer.
- add char to buffer, otherwise.
-
- In the cases where a file is buffered, the invariant is that operations
- that fill up a buffer also flushes them. A consequence of this here, is
- that we're guaranteed to be passed a buffer with space for (at least)
- the one char we're adding.
-
- Supporting RW objects adds yet another twist, since we have to make
- sure that if such objects have been read from just previously, we
- flush(i.e., empty) the buffer first. (We could be smarter about this,
- but aren't!)
-
- */
-
- if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
- rc = flushReadBuffer(ptr);
- if (rc<0) return rc;
- }
-
- fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
-
- /* check whether we can just add it to the buffer.. */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- ;
- } else {
- /* We're buffered, add it to the pack */
- ((char*)fo->buf)[fo->bufWPtr] = (char)c;
- fo->bufWPtr++;
- /* If the buffer filled up as a result, *or*
- the added character terminated a line
- => flush.
- */
- if ( FILEOBJ_BUFFER_FULL(fo) ||
- (FILEOBJ_LINEBUFFERED(fo) && TERMINATE_LINE(c)) ) {
- rc = writeBuffer(ptr, fo->bufWPtr);
- /* Undo the write if we're blocking..*/
- if (rc == FILEOBJ_BLOCKED_WRITE ) fo->bufWPtr--;
- }
- return rc;
- }
-
- if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady(ptr,0) != 1 )
- return FILEOBJ_BLOCKED_WRITE;
-
- /* Unbuffered, write the character directly. */
- while ((rc = write(fo->fd, &c, 1)) == 0 && errno == EINTR) ;
-
- if (rc == 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- return 0;
-
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: fileSize.c,v 1.3 1998/12/02 13:27:30 simonm Exp $
+ *
+ * hClose Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+StgInt
+fileSize(ptr, result)
+StgForeignPtr ptr;
+StgByteArray result;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct stat sb;
+ int rc = 0;
+
+ /* Flush buffer in order to get as an accurate size as poss. */
+ rc = flushFile(ptr);
+ if (rc < 0) return rc;
+
+ while (fstat(fo->fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (S_ISREG(sb.st_mode)) {
+ /* result will be word aligned */
+ *(off_t *) result = sb.st_size;
+ return 0;
+ } else {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "not a regular file";
+ return -1;
+ }
+}
+
+StgInt
+fileSize_int64(ptr, result)
+StgForeignPtr ptr;
+StgByteArray result;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct stat sb;
+ int rc = 0;
+
+ /* Flush buffer in order to get as an accurate size as poss. */
+ rc = flushFile(ptr);
+ if (rc < 0) return rc;
+
+ while (fstat(fo->fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (S_ISREG(sb.st_mode)) {
+ /* result will be word aligned */
+ *(StgInt64*) result = (StgInt64)sb.st_size;
+ return 0;
+ } else {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "not a regular file";
+ return -1;
+ }
+}
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[fileSize.lc]{hfileSize Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-fileSize(ptr, result)
-StgForeignObj ptr;
-StgByteArray result;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- int rc = 0;
-
- /* Flush buffer in order to get as an accurate size as poss. */
- rc = flushFile(ptr);
- if (rc < 0) return rc;
-
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISREG(sb.st_mode)) {
- /* result will be word aligned */
- *(off_t *) result = sb.st_size;
- return 0;
- } else {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a regular file";
- return -1;
- }
-}
-
-\end{code}
+++ /dev/null
-%
-%
-%
-
-Stubs to check for extremities of (IEEE) floats,
-the tests have been (artfully) lifted from the hbc-0.9999.3 (lib/fltcode.c)
-source.
-
-All tests return non-zero values to indicate success.
-
-(SOF 95/98 - Bugfixed and tidied up.)
-
-ToDo:
- - avoid hard-wiring the fact that on an
- Alpha we repr. a StgFloat as a double.
- (introduce int equivalent of {ASSIGN,PK}_FLT? )
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "ieee-flpt.h"
-#include "floatExtreme.h"
-
-#ifdef BIGENDIAN
-#define L 1
-#define H 0
-#else
-#define L 0
-#define H 1
-#endif
-
-#ifdef IEEE_FLOATING_POINT
-
-/*
-
- To recap, here's the representation of a double precision
- IEEE floating point number:
-
- sign 63 sign bit (0==positive, 1==negative)
- exponent 62-52 exponent (biased by 1023)
- fraction 51-0 fraction (bits to right of binary point)
-*/
-
-StgInt
-isDoubleNaN(d)
-StgDouble d;
-{
- union { double d; int i[2]; } u;
- int hx,lx;
- int r;
-
- u.d = d;
-
- /* Spelt out for clarity */
- hx = u.i[H];
- lx = u.i[L];
- return ( ( (hx & 0x7ff00000) == 0x7ff00000 ) && /* Is the exponent all ones? */
- ( (hx & 0xfffff ) != 0 || /* and the mantissa non-zero? */
- ((unsigned int)lx != 0) )
- );
-
-/* Old definition:
- hx &= 0x7fffffff;
- hx |= (unsigned int)(lx|(-lx))>>31;
- hx = 0x7ff00000 - hx;
- r = (int)((unsigned int)(hx))>>31;
- return (r);
-*/
-
-}
-
-StgInt
-isDoubleInfinite(d)
-StgDouble d;
-{
- union { double d; int i[2]; } u;
- int high,low;
-
- u.d = d;
- high = u.i[H];
- low = u.i[L];
-
- /* Inf iff exponent is all ones, mantissa all zeros */
- high &= 0x7fffffff; /* mask out sign bit */
- high ^= 0x7ff00000; /* flip the exponent bits */
- high |= low;
- return (high == 0);
-}
-
-StgInt
-isDoubleDenormalized(d)
-StgDouble d;
-{
- union { double d; int i[2]; } u;
- int high, low, iexp;
-
- u.d = d;
-
- /* A (single/double/quad) precision floating point number
- is denormalised iff:
- - exponent is zero
- - mantissa is non-zero.
- - (don't care about setting of sign bit.)
-
- */
-
- high = u.i[H];
- low = u.i[L];
- iexp = high & (0x7ff << 20); /* Get at the exponent */
-
- return ( (iexp == 0) && /* exponent all zero? */
- ( (high & 0xfffff ) != 0 || /* and the mantissa non-zero? */
- ((unsigned int)low != 0) )
- );
-
-}
-
-StgInt
-isDoubleNegativeZero(d)
-StgDouble d;
-{
- union { double d; int i[2]; } u;
- int high, iexp;
-
- u.d = d;
- /* sign (bit 63) set (only) => negative zero */
- return (u.i[H] == 0x80000000 && u.i[L] == 0);
-}
-
-/* Same tests, this time for StgFloats. */
-
-/*
-
- To recap, here's the representation of a single precision
- IEEE floating point number:
-
- sign 31 sign bit (0 == positive, 1 == negative)
- exponent 30-23 exponent (biased by 127)
- fraction 22-0 fraction (bits to right of binary point)
-*/
-
-
-StgInt
-isFloatNaN(f)
-StgFloat f;
-{
-#if defined(alpha_TARGET_OS)
- /* StgFloat = double on alphas */
- return (isDoubleNaN(f));
-#else
- int r;
- union { StgFloat f; int i; } u;
- u.f = f;
-
- /* Floating point NaN iff exponent is all ones, mantissa is
- non-zero (but see below.) */
-
- u.i &= 0x7fffffff; /* mask out sign bit */
- u.i = 0x7f800000 - u.i; /* <0 if exponent is max and mantissa non-zero. */
- r = (int)(((unsigned int)(u.i))>>31); /* Get at the sign.. */
- return (r);
-
- /* In case we should ever want to distinguish.. */
-#if 0 && WE_JUST_WANT_QUIET_NAN
- int iexp;
- iexp = u.i & (0xff << 23); /* Get at the exponent part.. */
- /* Quiet NaN */
- return ( ( iexp == (int)0x7f800000 ) && /* exponent all ones. */
- (u.i & (0x80 << 22) ) /* MSB of mantissa is set */
- );
-#endif
-#if 0 && WE_WANT_SIGNALLING_NAN
- /* Signalling/trapping NaN */
- int iexp;
- iexp = u.i & (0xff << 23); /* Get at the exponent part.. */
- return ( ( iexp == (int)0x7f800000 ) && /* ..it's all ones. */
- ((u.i & (0x80 << 22)) == 0) && /* MSB of mantissa is clear */
- ((u.i & 0x7fffff) != 0) /* rest of mantissa is non-zero */
- );
-#endif
-
-#endif
-}
-
-StgInt
-isFloatInfinite(f)
-StgFloat f;
-{
-#if defined(alpha_TARGET_OS)
- /* StgFloat = double on alphas */
- return (isDoubleInfinite(f));
-#else
- union { StgFloat f; int i; } u;
- u.f = f;
-
- /* A float is Inf iff exponent is max (all ones),
- and mantissa is min(all zeros.) */
-
- u.i &= 0x7fffffff; /* mask out sign bit */
- u.i ^= 0x7f800000; /* invert exponent bits */
- return (u.i == 0);
-#endif
-}
-
-StgInt
-isFloatDenormalized(f)
-StgFloat f;
-{
-#if defined(alpha_TARGET_OS)
- /* StgFloat = double on alphas */
- return (isDoubleDenormalized(f));
-#else
- int iexp, imant;
- union { StgFloat f; int i; } u;
- u.f = f;
-
- iexp = u.i & (0xff << 23); /* Get at the exponent part */
- imant = u.i & 0x3fffff; /* ditto, mantissa */
- /* A (single/double/quad) precision floating point number
- is denormalised iff:
- - exponent is zero
- - mantissa is non-zero.
- - (don't care about setting of sign bit.)
-
- */
- return ( (iexp == 0) && (imant != 0 ) );
-#endif
-}
-
-StgInt
-isFloatNegativeZero(f)
-StgFloat f;
-{
-#if defined(alpha_TARGET_OS)
- /* StgFloat = double on alphas */
- return (isDoubleNegativeZero(f));
-#else
- union { StgFloat f; int i; } u;
- u.f = f;
-
- /* sign (bit 31) set (only) => negative zero */
- return (u.i == (int)0x80000000);
-#endif
-}
-
-
-#else
-
-StgInt isDoubleNaN(d) StgDouble d; { return 0; }
-StgInt isDoubleInfinite(d) StgDouble d; { return 0; }
-StgInt isDoubleDenormalized(d) StgDouble d; { return 0; }
-StgInt isDoubleNegativeZero(d) StgDouble d; { return 0; }
-StgInt isFloatNaN(f) StgFloat f; { return 0; }
-StgInt isFloatInfinite(f) StgFloat f; { return 0; }
-StgInt isFloatDenormalized(f) StgFloat f; { return 0; }
-StgInt isFloatNegativeZero(f) StgFloat f; { return 0; }
-
-#endif
-
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: flushFile.c,v 1.3 1998/12/02 13:27:32 simonm Exp $
+ *
+ * hFlush Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgInt
+flushFile(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int rc = 0;
+
+ if ( (fo->flags & FILEOBJ_FLUSH) && !FILEOBJ_BUFFER_EMPTY(fo) ) {
+ rc = writeBuffer(ptr,fo->bufWPtr - fo->bufRPtr);
+ }
+
+ return rc;
+}
+
+StgInt
+flushBuffer(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int rc = 0;
+
+ /* If the file object is writeable, or if its
+ RW and the last operation on it was a write,
+ flush it.
+ */
+ if ( (!FILEOBJ_READABLE(fo) && FILEOBJ_WRITEABLE(fo)) || (FILEOBJ_RW(fo) && FILEOBJ_JUST_WRITTEN(fo)) ) {
+ rc = flushFile(ptr);
+ if (rc<0) return rc;
+ }
+
+ /* Reset read & write pointer for input buffers */
+ if ( (fo->flags & FILEOBJ_READ) ) {
+ fo->bufRPtr=0;
+ fo->bufWPtr=0;
+ }
+ return 0;
+}
+
+/*
+ For RW file objects, flushing input buffers doesn't just involve
+ resetting the read & write pointers, we also have to change the
+ underlying file position to point to the effective read position.
+
+ (Sigh, I now understand the real reason for why stdio opted for
+ the solution of leaving this to the programmer!)
+*/
+StgInt
+flushReadBuffer(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int delta;
+
+ delta = fo->bufWPtr - fo->bufRPtr;
+
+ if ( delta > 0 ) {
+ while ( lseek(fo->fd, -delta, SEEK_CUR) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ }
+
+ fo->bufRPtr=0;
+ fo->bufWPtr=0;
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[flushFile.lc]{hFlush Runtime Support}
-
-Empty contents of output buffers.
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgInt
-flushFile(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
-
- if ( (fo->flags & FILEOBJ_FLUSH) && !FILEOBJ_BUFFER_EMPTY(fo) ) {
- rc = writeBuffer(ptr,fo->bufWPtr - fo->bufRPtr);
- }
-
- return rc;
-}
-
-StgInt
-flushBuffer(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
-
- /* If the file object is writeable, or if its
- RW and the last operation on it was a write,
- flush it.
- */
- if ( (!FILEOBJ_READABLE(fo) && FILEOBJ_WRITEABLE(fo)) || (FILEOBJ_RW(fo) && FILEOBJ_JUST_WRITTEN(fo)) ) {
- rc = flushFile(ptr);
- if (rc<0) return rc;
- }
-
- /* Reset read & write pointer for input buffers */
- if ( (fo->flags & FILEOBJ_READ) ) {
- fo->bufRPtr=0;
- fo->bufWPtr=0;
- }
- return 0;
-}
-
-/*
- For RW file objects, flushing input buffers doesn't just involve
- resetting the read & write pointers, we also have to change the
- underlying file position to point to the effective read position.
-
- (Sigh, I now understand the real reason for why stdio opted for
- the solution of leaving this to the programmer!)
-*/
-StgInt
-flushReadBuffer(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int delta;
-
- delta = fo->bufWPtr - fo->bufRPtr;
-
- if ( delta > 0 ) {
- while ( lseek(fo->fd, -delta, SEEK_CUR) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- }
-
- fo->bufRPtr=0;
- fo->bufWPtr=0;
- return 0;
-}
-
-void
-flushConnectedHandle(ptr)
-StgForeignObj ptr;
-{
- StgInt rc;
- IOFileObject* fo = (IOFileObject*)ptr;
-
-
- /* if the stream is connected to an output stream, flush it first */
- if ( fo->connectedTo != NULL && fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE) ) {
- rc = flushBuffer((StgForeignObj)fo->connectedTo);
- }
- /* Willfully ignore return code for now */
- return;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: freeFile.c,v 1.3 1998/12/02 13:27:34 simonm Exp $
+ *
+ * Giving up files
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+#include "fileObject.h"
+
+/* sigh, the FILEs attached to the standard descriptors are
+ handled differently. We don't want them freed via the
+ ForeignObj finaliser, as we probably want to use these
+ before we *really* shut down (dumping stats etc.)
+*/
+void freeStdFile(fp)
+StgForeignPtr fp;
+{ return; }
+
+void freeStdFileObject(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ /* Don't close the file, just flush the buffer */
+ if (fo != NULL && fo->fd != -1) {
+ if (fo->buf != NULL && (fo->flags & FILEOBJ_FLUSH) && fo->bufWPtr > 0) {
+ /* Flush buffer contents */
+ writeBuffer((StgForeignPtr)fo, fo->bufWPtr);
+ }
+ }
+}
+
+void freeFileObject(ptr)
+StgForeignPtr ptr;
+{
+ /*
+ * The finaliser for the file objects embedded in Handles. The RTS
+ * assumes that the finaliser runs without problems, so all
+ * we can do here is flish buffers + close(), and hope nothing went wrong.
+ *
+ */
+
+ int rc;
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ if ( fo == NULL )
+ return;
+
+ if ( fo->fd == -1 || (rc = unlockFile(fo->fd)) ) {
+ /* If the file handle has been explicitly closed
+ * (via closeFile()), we will have given
+ * up our process lock, so we break off and just return.
+ */
+ return;
+ }
+
+ if (fo->buf != NULL && fo->bufWPtr > 0) {
+ /* Flush buffer contents before closing underlying file */
+ fo->flags &= ~FILEOBJ_RW_WRITE | ~FILEOBJ_RW_READ;
+ flushFile(ptr);
+ }
+
+ rc = close(fo->fd);
+ /* Error or no error, we don't care.. */
+
+ return;
+}
+
+StgAddr ref_freeStdFileObject(void)
+{
+ return (StgAddr)&freeStdFileObject;
+}
+
+StgAddr ref_freeFileObject(void)
+{
+ return (StgAddr)&freeFileObject;
+}
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
-%
-\subsection[freeFile.lc]{Giving up files}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-#include "fileObject.h"
-
-/* sigh, the FILEs attached to the standard descriptors are
- handled differently. We don't want them freed via the
- ForeignObj finaliser, as we probably want to use these
- before we *really* shut down (dumping stats etc.)
-*/
-void freeStdFile(fp)
-StgForeignObj fp;
-{ return; }
-
-void freeStdFileObject(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
-
- /* Don't close the file, just flush the buffer */
- if (fo != NULL && fo->fd != -1) {
- if (fo->buf != NULL && (fo->flags & FILEOBJ_FLUSH) && fo->bufWPtr > 0) {
- /* Flush buffer contents */
- writeBuffer((StgForeignObj)fo, fo->bufWPtr);
- }
- }
-}
-
-void freeFileObject(ptr)
-StgForeignObj ptr;
-{
- /*
- * The finaliser for the file objects embedded in Handles. The RTS
- * assumes that the finaliser runs without problems, so all
- * we can do here is flish buffers + close(), and hope nothing went wrong.
- *
- */
-
- int rc;
- IOFileObject* fo = (IOFileObject*)ptr;
-
- if ( fo == NULL )
- return;
-
- if ( fo->fd == -1 || (rc = unlockFile(fo->fd)) ) {
- /* If the file handle has been explicitly closed
- * (via closeFile()), we will have given
- * up our process lock, so we break off and just return.
- */
- return;
- }
-
- if (fo->buf != NULL && fo->bufWPtr > 0) {
- /* Flush buffer contents before closing underlying file */
- fo->flags &= ~FILEOBJ_RW_WRITE | ~FILEOBJ_RW_READ;
- flushFile(ptr);
- }
-
- rc = close(fo->fd);
- /* Error or no error, we don't care.. */
-
- return;
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: getBufferMode.c,v 1.3 1998/12/02 13:27:35 simonm Exp $
+ *
+ * hIs...Buffered Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+/*
+ * We try to guess what the default buffer mode is going to be based
+ * on the type of file we're attached to.
+ */
+
+#define GBM_NB (0)
+#define GBM_LB (-1)
+#define GBM_BB (-2)
+#define GBM_ERR (-3)
+
+StgInt
+getBufferMode(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct stat sb;
+ int fd = fo->fd;
+
+ /* Try to find out the file type */
+ while (fstat(fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return GBM_ERR;
+ }
+ }
+ /* Terminals are line-buffered by default */
+ if (S_ISCHR(sb.st_mode) && isatty(fd) == 1) {
+ fo ->flags |= FILEOBJ_LB;
+ return GBM_LB;
+ /* Default size block buffering for the others */
+ } else {
+ fo ->flags |= FILEOBJ_BB;
+ return GBM_BB;
+ }
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[getBufferMode.lc]{hIs...Buffered Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-/*
- * We try to guess what the default buffer mode is going to be based
- * on the type of file we're attached to.
- */
-
-#define GBM_NB (0)
-#define GBM_LB (-1)
-#define GBM_BB (-2)
-#define GBM_ERR (-3)
-
-StgInt
-getBufferMode(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- int fd = fo->fd;
-
- /* Try to find out the file type */
- while (fstat(fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return GBM_ERR;
- }
- }
- /* Terminals are line-buffered by default */
- if (S_ISCHR(sb.st_mode) && isatty(fd) == 1) {
- fo ->flags |= FILEOBJ_LB;
- return GBM_LB;
- /* Default size block buffering for the others */
- } else {
- fo ->flags |= FILEOBJ_BB;
- return GBM_BB;
- }
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: getCPUTime.c,v 1.3 1998/12/02 13:27:36 simonm Exp $
+ *
+ * getCPUTime Runtime Support
+ */
+
+#ifndef _AIX
+#define NON_POSIX_SOURCE /*needed for solaris2 only?*/
+#endif
+
+/* how is this to work given we have not read platform.h yet? */
+#ifdef hpux_TARGET_OS
+#define _INCLUDE_HPUX_SOURCE
+#endif
+
+#include "Rts.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TIMES_H
+#include <sys/times.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
+#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS
+#include <sys/resource.h>
+#endif
+
+#ifdef HAVE_SYS_TIMEB_H
+#include <sys/timeb.h>
+#endif
+
+#ifdef hpux_TARGET_OS
+#include <sys/syscall.h>
+#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
+#define HAVE_GETRUSAGE
+#endif
+
+StgInt
+clockTicks ()
+{
+ return (
+#if defined(CLK_TCK)
+ CLK_TCK
+#else
+ sysconf(_SC_CLK_TCK)
+#endif
+ );
+}
+
+/*
+ * Our caller wants a pointer to four StgInts,
+ * user seconds, user nanoseconds, system seconds, system nanoseconds.
+ * Yes, the timerval has unsigned components, but nanoseconds take only
+ * 30 bits, and our CPU usage would have to be over 68 years for the
+ * seconds to overflow 31 bits.
+ */
+
+StgByteArray
+getCPUTime(StgByteArray cpuStruct)
+{
+ StgInt *cpu=(StgInt *)cpuStruct;
+
+/* getrusage() is right royal pain to deal with when targetting multiple
+ versions of Solaris, since some versions supply it in libc (2.3 and 2.5),
+ while 2.4 has got it in libucb (I wouldn't be too surprised if it was back
+ again in libucb in 2.6..)
+
+ Avoid the problem by resorting to times() instead.
+*/
+#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS && ! solaris2_TARGET_OS
+ struct rusage t;
+
+ getrusage(RUSAGE_SELF, &t);
+ cpu[0] = t.ru_utime.tv_sec;
+ cpu[1] = 1000 * t.ru_utime.tv_usec;
+ cpu[2] = t.ru_stime.tv_sec;
+ cpu[3] = 1000 * t.ru_stime.tv_usec;
+
+#else
+# if defined(HAVE_TIMES)
+ struct tms t;
+# if defined(CLK_TCK)
+# define ticks CLK_TCK
+# else
+ long ticks;
+ ticks = sysconf(_SC_CLK_TCK);
+# endif
+
+ times(&t);
+ cpu[0] = t.tms_utime / ticks;
+ cpu[1] = (t.tms_utime - cpu[0] * ticks) * (1000000000 / ticks);
+ cpu[2] = t.tms_stime / ticks;
+ cpu[3] = (t.tms_stime - cpu[2] * ticks) * (1000000000 / ticks);
+
+# else
+ return NULL;
+# endif
+#endif
+ return (StgByteArray) cpuStruct;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[getCPUTime.lc]{getCPUTime Runtime Support}
-
-\begin{code}
-
-#ifndef _AIX
-#define NON_POSIX_SOURCE /*needed for solaris2 only?*/
-#endif
-
-/* how is this to work given we have not read platform.h yet? */
-#ifdef hpux_TARGET_OS
-#define _INCLUDE_HPUX_SOURCE
-#endif
-
-#include "rtsdefs.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_SYS_TIMES_H
-#include <sys/times.h>
-#endif
-
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#endif
-
-#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS
-#include <sys/resource.h>
-#endif
-
-#ifdef HAVE_SYS_TIMEB_H
-#include <sys/timeb.h>
-#endif
-
-#ifdef hpux_TARGET_OS
-#include <sys/syscall.h>
-#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
-#define HAVE_GETRUSAGE
-#endif
-
-StgInt
-clockTicks ()
-{
- return (
-#if defined(CLK_TCK)
- CLK_TCK
-#else
- sysconf(_SC_CLK_TCK)
-#endif
- );
-}
-
-/*
- * Our caller wants a pointer to four StgInts,
- * user seconds, user nanoseconds, system seconds, system nanoseconds.
- * Yes, the timerval has unsigned components, but nanoseconds take only
- * 30 bits, and our CPU usage would have to be over 68 years for the
- * seconds to overflow 31 bits.
- */
-
-StgByteArray
-getCPUTime(StgByteArray cpuStruct)
-{
- StgInt *cpu=(StgInt *)cpuStruct;
-
-/* getrusage() is right royal pain to deal with when targetting multiple
- versions of Solaris, since some versions supply it in libc (2.3 and 2.5),
- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back
- again in libucb in 2.6..)
-
- Avoid the problem by resorting to times() instead.
-*/
-#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS && ! solaris2_TARGET_OS
- struct rusage t;
-
- getrusage(RUSAGE_SELF, &t);
- cpu[0] = t.ru_utime.tv_sec;
- cpu[1] = 1000 * t.ru_utime.tv_usec;
- cpu[2] = t.ru_stime.tv_sec;
- cpu[3] = 1000 * t.ru_stime.tv_usec;
-
-#else
-# if defined(HAVE_TIMES)
- struct tms t;
-# if defined(CLK_TCK)
-# define ticks CLK_TCK
-# else
- long ticks;
- ticks = sysconf(_SC_CLK_TCK);
-# endif
-
- times(&t);
- cpu[0] = t.tms_utime / ticks;
- cpu[1] = (t.tms_utime - cpu[0] * ticks) * (1000000000 / ticks);
- cpu[2] = t.tms_stime / ticks;
- cpu[3] = (t.tms_stime - cpu[2] * ticks) * (1000000000 / ticks);
-
-# else
- return NULL;
-# endif
-#endif
- return (StgByteArray) cpuStruct;
-}
-
-\end{code}
-
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: getClockTime.c,v 1.3 1998/12/02 13:27:38 simonm Exp $
+ *
+ * getClockTime Runtime Support
+ */
+
+#ifndef _AIX
+#define NON_POSIX_SOURCE /* gettimeofday */
+#endif
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_GETCLOCK
+
+# ifdef HAVE_SYS_TIMERS_H
+# define POSIX_4D9 1
+# include <sys/timers.h>
+# endif
+
+#else
+# ifdef HAVE_GETTIMEOFDAY
+
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# endif
+
+# else
+
+# ifdef HAVE_TIME_H
+# include <time.h>
+# endif
+
+# endif
+#endif
+
+StgInt
+getClockTime(StgByteArray sec, StgByteArray nsec)
+{
+#ifdef HAVE_GETCLOCK
+ struct timespec tp;
+
+ if (getclock(TIMEOFDAY, &tp) != 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ ((unsigned long int *)sec)[0] = tp.tv_sec;
+ ((unsigned long int *)nsec)[0] = tp.tv_nsec;
+ return 0;
+#else
+#ifdef HAVE_GETTIMEOFDAY
+ struct timeval tp;
+
+ if (gettimeofday(&tp, NULL) != 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ ((unsigned long int *)sec)[0] = tp.tv_sec;
+ ((unsigned long int *)nsec)[0] = tp.tv_usec * 1000;
+ return 0;
+#else
+ time_t t;
+ if ((t = time(NULL)) == (time_t) -1) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ ((unsigned long int *)sec)[0] = t;
+ ((unsigned long int *)nsec)[0] = 0;
+ return 0;
+#endif
+#endif
+}
+
+StgInt
+prim_getClockTime(StgByteArray sec, StgByteArray nsec)
+{
+#ifdef HAVE_GETCLOCK
+ struct timespec tp;
+
+ if (getclock(TIMEOFDAY, &tp) != 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ ((StgInt64*)sec)[0] = tp.tv_sec;
+ ((StgInt64*)nsec)[0] = tp.tv_nsec;
+ return 0;
+#else
+#ifdef HAVE_GETTIMEOFDAY
+ struct timeval tp;
+
+ if (gettimeofday(&tp, NULL) != 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ ((StgInt64*)sec)[0] = tp.tv_sec;
+ ((StgInt64*)nsec)[0] = tp.tv_usec * 1000;
+ return 0;
+#else
+ time_t t;
+ if ((t = time(NULL)) == (time_t) -1) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ ((StgInt64*)sec)[0] = t;
+ ((StgInt64*)nsec)[0] = 0;
+ return 0;
+#endif
+#endif
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[getClockTime.lc]{getClockTime Runtime Support}
-
-\begin{code}
-
-#ifndef _AIX
-#define NON_POSIX_SOURCE /* gettimeofday */
-#endif
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_GETCLOCK
-
-# ifdef HAVE_SYS_TIMERS_H
-# define POSIX_4D9 1
-# include <sys/timers.h>
-# endif
-
-#else
-# ifdef HAVE_GETTIMEOFDAY
-
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# endif
-
-# else
-
-# ifdef HAVE_TIME_H
-# include <time.h>
-# endif
-
-# endif
-#endif
-
-StgInt
-getClockTime(StgByteArray sec, StgByteArray nsec)
-{
-#ifdef HAVE_GETCLOCK
- struct timespec tp;
-
- if (getclock(TIMEOFDAY, &tp) != 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- ((unsigned long int *)sec)[0] = tp.tv_sec;
- ((unsigned long int *)nsec)[0] = tp.tv_nsec;
- return 0;
-#else
-#ifdef HAVE_GETTIMEOFDAY
- struct timeval tp;
-
- if (gettimeofday(&tp, NULL) != 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- ((unsigned long int *)sec)[0] = tp.tv_sec;
- ((unsigned long int *)nsec)[0] = tp.tv_usec * 1000;
- return 0;
-#else
- time_t t;
- if ((t = time(NULL)) == (time_t) -1) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- ((unsigned long int *)sec)[0] = t;
- ((unsigned long int *)nsec)[0] = 0;
- return 0;
-#endif
-#endif
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: getCurrentDirectory.c,v 1.3 1998/12/02 13:27:39 simonm Exp $
+ *
+ * getCurrentDirectory Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifndef PATH_MAX
+#ifdef MAXPATHLEN
+#define PATH_MAX MAXPATHLEN
+#else
+#define PATH_MAX 1024
+#endif
+#endif
+
+StgAddr
+getCurrentDirectory(void)
+{
+ char *pwd;
+ int alloc;
+
+ alloc = PATH_MAX;
+ if ((pwd = malloc(alloc)) == NULL) {
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "not enough virtual memory";
+ return NULL;
+ }
+ while (getcwd(pwd, alloc) == NULL) {
+ if (errno == ERANGE) {
+ alloc += PATH_MAX;
+ if ((pwd = realloc(pwd, alloc)) == NULL) {
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "not enough virtual memory";
+ return NULL;
+ }
+ } else if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return NULL;
+ }
+ }
+ return (StgAddr) pwd;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[getCurrentDirectory.lc]{getCurrentDirectory Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifndef PATH_MAX
-#ifdef MAXPATHLEN
-#define PATH_MAX MAXPATHLEN
-#else
-#define PATH_MAX 1024
-#endif
-#endif
-
-StgAddr
-getCurrentDirectory(STG_NO_ARGS)
-{
- char *pwd;
- int alloc;
-
- alloc = PATH_MAX;
- if ((pwd = malloc(alloc)) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- return NULL;
- }
- while (getcwd(pwd, alloc) == NULL) {
- if (errno == ERANGE) {
- alloc += PATH_MAX;
- if ((pwd = realloc(pwd, alloc)) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- return NULL;
- }
- } else if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return NULL;
- }
- }
- return (StgAddr) pwd;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: getDirectoryContents.c,v 1.3 1998/12/02 13:27:40 simonm Exp $
+ *
+ * getDirectoryContents Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_DIRENT_H
+#include <dirent.h>
+#endif
+
+#ifndef LINK_MAX
+#define LINK_MAX 1024
+#endif
+
+/* For cleanup of partial answer on error */
+
+static void
+freeEntries(char **entries, int count)
+{
+ int i;
+
+ for (i = 0; i < count; i++)
+ free(entries[i]);
+ free(entries);
+}
+
+/*
+ * Our caller expects a malloc'ed array of malloc'ed string pointers.
+ * To ensure consistency when mixing this with other directory
+ * operations, we collect the entire list in one atomic operation,
+ * rather than reading the directory lazily.
+ */
+StgAddr
+getDirectoryContents(path)
+StgByteArray path;
+{
+ struct stat sb;
+ DIR *dir;
+ struct dirent *d;
+ char **entries;
+ int alloc, count, len;
+
+ /* Check for an actual directory */
+ while (stat(path, &sb) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return NULL;
+ }
+ }
+ if (!S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "not a directory";
+ return NULL;
+ }
+
+ alloc = LINK_MAX;
+ if ((entries = (char **) malloc(alloc * sizeof(char *))) == NULL) {
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "not enough virtual memory";
+ return NULL;
+ }
+
+ while ((dir = opendir(path)) == NULL) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ free(entries);
+ return NULL;
+ }
+ }
+
+ count = 0;
+ for (;;) {
+ errno = 0; /* unchanged by readdir on EOF */
+ while ((d = readdir(dir)) == NULL) {
+ if (errno == 0) {
+ entries[count] = NULL;
+ (void) closedir(dir);
+ return (StgAddr) entries;
+ } else if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ freeEntries(entries, count);
+ (void) closedir(dir);
+ return NULL;
+ }
+ errno = 0;
+ }
+ len = strlen(d->d_name);
+ if ((entries[count] = malloc(len+1)) == NULL) {
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "not enough virtual memory";
+ freeEntries(entries, count);
+ (void) closedir(dir);
+ return NULL;
+ }
+ strcpy(entries[count], d->d_name);
+ /* Terminate the sucker */
+ *(entries[count] + len) = 0;
+ if (++count == alloc) {
+ alloc += LINK_MAX;
+ if ((entries = (char **) realloc(entries, alloc * sizeof(char *))) == NULL) {
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "not enough virtual memory";
+ freeEntries(entries, count);
+ (void) closedir(dir);
+ return NULL;
+ }
+ }
+ }
+}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: getLock.c,v 1.3 1998/12/02 13:27:41 simonm Exp $
+ *
+ * stdin/stout/stderr Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+#ifndef FD_SETSIZE
+#define FD_SETSIZE 256
+#endif
+
+typedef struct {
+ dev_t device;
+ ino_t inode;
+ int fd;
+} Lock;
+
+static Lock readLock[FD_SETSIZE];
+static Lock writeLock[FD_SETSIZE];
+
+static int readLocks = 0;
+static int writeLocks = 0;
+
+int
+lockFile(fd, exclusive)
+int fd;
+int exclusive;
+{
+ int i;
+ struct stat sb;
+
+ while (fstat(fd, &sb) < 0) {
+ if (errno != EINTR) {
+ return -1;
+ }
+ }
+
+ /* Only lock regular files */
+ if (!S_ISREG(sb.st_mode))
+ return 0;
+
+ for (i = 0; i < writeLocks; i++)
+ if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
+ errno = EAGAIN;
+ return -1;
+ }
+
+ if (!exclusive) {
+ i = readLocks++;
+ readLock[i].device = sb.st_dev;
+ readLock[i].inode = sb.st_ino;
+ readLock[i].fd = fd;
+ return 0;
+ }
+
+ for (i = 0; i < readLocks; i++)
+ if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) {
+ errno = EAGAIN;
+ return -1;
+ }
+
+ i = writeLocks++;
+ writeLock[i].device = sb.st_dev;
+ writeLock[i].inode = sb.st_ino;
+ writeLock[i].fd = fd;
+ return 0;
+}
+
+int
+unlockFile(fd)
+int fd;
+{
+ int i, rc;
+
+ for (i = 0; i < readLocks; i++)
+ if (readLock[i].fd == fd) {
+ while (++i < readLocks)
+ readLock[i - 1] = readLock[i];
+ readLocks--;
+ return 0;
+ }
+
+ for (i = 0; i < writeLocks; i++)
+ if (writeLock[i].fd == fd) {
+ while (++i < writeLocks)
+ writeLock[i - 1] = writeLock[i];
+ writeLocks--;
+ return 0;
+ }
+ /* Signal that we did not find an entry */
+ return 1;
+}
+
+StgInt
+getLock(fd, exclusive)
+StgInt fd;
+StgInt exclusive;
+{
+ if (lockFile(fd, exclusive) < 0) {
+ if (errno == EBADF)
+ return 0;
+ else {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ case GHC_EAGAIN:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "file is locked";
+ break;
+ }
+ /* Not so sure we want to do this, since getLock()
+ is only called on the standard file descriptors.. */
+ /*(void) close(fd); */
+ return -1;
+ }
+ }
+ return 1;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[getLock.lc]{stdin/stout/stderr Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-#ifndef FD_SETSIZE
-#define FD_SETSIZE 256
-#endif
-
-typedef struct {
- dev_t device;
- ino_t inode;
- int fd;
-} Lock;
-
-static Lock readLock[FD_SETSIZE];
-static Lock writeLock[FD_SETSIZE];
-
-static int readLocks = 0;
-static int writeLocks = 0;
-
-int
-lockFile(fd, exclusive)
-int fd;
-int exclusive;
-{
- int i;
- struct stat sb;
-
- while (fstat(fd, &sb) < 0) {
- if (errno != EINTR) {
- return -1;
- }
- }
-
- /* Only lock regular files */
- if (!S_ISREG(sb.st_mode))
- return 0;
-
- for (i = 0; i < writeLocks; i++)
- if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
- errno = EAGAIN;
- return -1;
- }
-
- if (!exclusive) {
- i = readLocks++;
- readLock[i].device = sb.st_dev;
- readLock[i].inode = sb.st_ino;
- readLock[i].fd = fd;
- return 0;
- }
-
- for (i = 0; i < readLocks; i++)
- if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) {
- errno = EAGAIN;
- return -1;
- }
-
- i = writeLocks++;
- writeLock[i].device = sb.st_dev;
- writeLock[i].inode = sb.st_ino;
- writeLock[i].fd = fd;
- return 0;
-}
-
-int
-unlockFile(fd)
-int fd;
-{
- int i, rc;
-
- for (i = 0; i < readLocks; i++)
- if (readLock[i].fd == fd) {
- while (++i < readLocks)
- readLock[i - 1] = readLock[i];
- readLocks--;
- return 0;
- }
-
- for (i = 0; i < writeLocks; i++)
- if (writeLock[i].fd == fd) {
- while (++i < writeLocks)
- writeLock[i - 1] = writeLock[i];
- writeLocks--;
- return 0;
- }
- /* Signal that we did not find an entry */
- return 1;
-}
-
-StgInt
-getLock(fd, exclusive)
-StgInt fd;
-StgInt exclusive;
-{
- if (lockFile(fd, exclusive) < 0) {
- if (errno == EBADF)
- return 0;
- else {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "file is locked";
- break;
- }
- /* Not so sure we want to do this, since getLock()
- is only called on the standard file descriptors.. */
- /*(void) close(fd); */
- return -1;
- }
- }
- return 1;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: inputReady.c,v 1.3 1998/12/02 13:27:42 simonm Exp $
+ *
+ * hReady Runtime Support
+ */
+
+/* select and supporting types is not */
+#ifndef _AIX
+#define NON_POSIX_SOURCE
+#endif
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef _AIX
+/* this is included from sys/types.h only if _BSD is defined. */
+/* Since it is not, I include it here. - andre */
+#include <sys/select.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
+/*
+ * inputReady(ptr, msecs) checks to see whether input is available
+ * on the file object 'ptr', timing out after (approx.) 'msec' milliseconds.
+ * Input meaning 'can I safely read at least a *character* from this file
+ * object without blocking?'
+ *
+ * If the file object has a non-empty buffer, the test is trivial. If not,
+ * we select() on the (readable) file descriptor.
+ *
+ * Notice that for file descriptors connected to ttys in non-canonical mode
+ * (i.e., it's buffered), inputReady will not return true until a *complete
+ * line* can be read.
+ */
+
+StgInt
+inputReady(ptr, msecs)
+StgForeignPtr ptr;
+StgInt msecs;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int c, fd, maxfd, ready;
+ fd_set rfd;
+ struct timeval tv;
+
+ if ( FILEOBJ_IS_EOF(fo) )
+ return 0;
+
+ if ( !FILEOBJ_BUFFER_EMPTY(fo) ) {
+ /* Don't look any further, there's stuff in the buffer */
+ return 1;
+ }
+
+ fd = fo->fd;
+
+ /* Now try to get a character */
+ FD_ZERO(&rfd);
+ FD_SET(fd, &rfd);
+ /* select() will consider the descriptor set in the range of 0 to (maxfd-1) */
+ maxfd = fd + 1;
+ tv.tv_sec = msecs / 1000;
+ tv.tv_usec = msecs % 1000;
+ while ((ready = select(maxfd, &rfd, NULL, NULL, &tv)) < 0 ) {
+ if (errno != EINTR ) {
+ cvtErrno();
+ stdErrno();
+ ready = -1;
+ break;
+ }
+ }
+
+ /* 1 => Input ready, 0 => time expired (-1 error) */
+ return (ready);
+
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[inputReady.lc]{hReady Runtime Support}
-
-\begin{code}
-
-/* select and supporting types is not */
-#ifndef _AIX
-#define NON_POSIX_SOURCE
-#endif
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef _AIX
-/* this is included from sys/types.h only if _BSD is defined. */
-/* Since it is not, I include it here. - andre */
-#include <sys/select.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#endif
-
-/*
- * inputReady(ptr, msecs) checks to see whether input is available
- * on the file object 'ptr', timing out after (approx.) 'msec' milliseconds.
- * Input meaning 'can I safely read at least a *character* from this file
- * object without blocking?'
- *
- * If the file object has a non-empty buffer, the test is trivial. If not,
- * we select() on the (readable) file descriptor.
- *
- * Notice that for file descriptors connected to ttys in non-canonical mode
- * (i.e., it's buffered), inputReady will not return true until a *complete
- * line* can be read.
- */
-
-StgInt
-inputReady(ptr, msecs)
-StgForeignObj ptr;
-StgInt msecs;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int c, fd, maxfd, ready;
- fd_set rfd;
- struct timeval tv;
-
- if ( FILEOBJ_IS_EOF(fo) )
- return 0;
-
- if ( !FILEOBJ_BUFFER_EMPTY(fo) ) {
- /* Don't look any further, there's stuff in the buffer */
- return 1;
- }
-
- fd = fo->fd;
-
- /* Now try to get a character */
- FD_ZERO(&rfd);
- FD_SET(fd, &rfd);
- /* select() will consider the descriptor set in the range of 0 to (maxfd-1) */
- maxfd = fd + 1;
- tv.tv_sec = msecs / 1000;
- tv.tv_usec = msecs % 1000;
- while ((ready = select(maxfd, &rfd, NULL, NULL, &tv)) < 0 ) {
- if (errno != EINTR ) {
- cvtErrno();
- stdErrno();
- ready = -1;
- break;
- }
- }
-
- /* 1 => Input ready, 0 => time expired (-1 error) */
- return (ready);
-
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: openFile.c,v 1.3 1998/12/02 13:27:44 simonm Exp $
+ *
+ * openFile Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+#include "fileObject.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+IOFileObject*
+openStdFile(fd,flags,rd)
+StgInt fd;
+StgInt flags;
+StgInt rd;
+{
+ IOFileObject* fo;
+
+ if ((fo = malloc(sizeof(IOFileObject))) == NULL)
+ return NULL;
+ fo->fd = fd;
+ fo->buf = NULL;
+ fo->bufWPtr = 0;
+ fo->bufRPtr = 0;
+ fo->flags = flags | FILEOBJ_STD | ( rd ? FILEOBJ_READ : FILEOBJ_WRITE);
+ fo->connectedTo = NULL;
+ return fo;
+}
+
+#define OPENFILE_APPEND 0
+#define OPENFILE_WRITE 1
+#define OPENFILE_READ_ONLY 2
+#define OPENFILE_READ_WRITE 3
+
+IOFileObject*
+openFile(file, how, binary, flags)
+StgByteArray file;
+StgInt how;
+StgInt binary;
+StgInt flags;
+{
+ FILE *fp;
+ int fd;
+ int oflags;
+ int exclusive;
+ int created = 0;
+ struct stat sb;
+ IOFileObject* fo;
+
+#ifdef __CONCURRENT_HASKELL__
+#warning FixMe: Ignoring bogus bit 7 in openFiles 2nd argument
+ how = how & 0x7f;
+#endif
+
+ /*
+ * Since we aren't supposed to succeed when we're opening for writing and
+ * there's another writer, we can't just do an open() with O_WRONLY.
+ */
+
+ switch (how) {
+ case OPENFILE_APPEND:
+ oflags = O_WRONLY | O_NOCTTY | O_APPEND;
+ exclusive = 1;
+ break;
+ case OPENFILE_WRITE:
+ oflags = O_WRONLY | O_NOCTTY;
+ exclusive = 1;
+ break;
+ case OPENFILE_READ_ONLY:
+ oflags = O_RDONLY | O_NOCTTY;
+ exclusive = 0;
+ break;
+ case OPENFILE_READ_WRITE:
+ oflags = O_RDWR | O_NOCTTY;
+ exclusive = 0;
+ break;
+ default:
+ fprintf(stderr, "openFile: unknown mode `%d'\n", how);
+ exit(EXIT_FAILURE);
+ }
+
+#if HAVE_O_BINARY
+ if (binary)
+ oflags |= O_BINARY;
+#endif
+
+ /* First try to open without creating */
+ while ((fd = open(file, oflags, 0666)) < 0) {
+ if (errno == ENOENT) {
+ if ( how == OPENFILE_READ_ONLY ) {
+ /* For ReadMode, just bail out now */
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "file does not exist";
+ return NULL;
+ } else {
+ /* If it is a dangling symlink, break off now, too. */
+ struct stat st;
+ if ( lstat(file,&st) == 0) {
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "dangling symlink";
+ return NULL;
+ }
+ }
+ /* Now try to create it */
+ while ((fd = open(file, oflags | O_CREAT | O_EXCL, 0666)) < 0) {
+ if (errno == EEXIST) {
+ /* Race detected; go back and open without creating it */
+ break;
+ } else if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_ENOENT:
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no path to file";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "unsupported owner or group";
+ break;
+ }
+ return NULL;
+ }
+ }
+ if (fd >= 0) {
+ created = 1;
+ break;
+ }
+ } else if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no path to file";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "unsupported owner or group";
+ break;
+ }
+ return NULL;
+ }
+ }
+
+ /* Make sure that we aren't looking at a directory */
+
+ while (fstat(fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ if (created)
+ (void) unlink(file);
+ (void) close(fd);
+ return NULL;
+ }
+ }
+ if (S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "file is a directory";
+ /* We can't have created it in this case. */
+ (void) close(fd);
+
+ return NULL;
+ }
+ /* Use our own personal locking */
+
+ if (lockFile(fd, exclusive) < 0) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ case GHC_EAGAIN:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "file is locked";
+ break;
+ }
+ if (created)
+ (void) unlink(file);
+ (void) close(fd);
+ return NULL;
+ }
+
+ /*
+ * Write mode is supposed to truncate the file. Unfortunately, our pal
+ * ftruncate() is non-POSIX, so we truncate with a second open, which may fail.
+ */
+
+ if ( how == OPENFILE_WRITE ) {
+ int fd2, oflags2;
+
+ oflags2 = oflags | O_TRUNC;
+ while ((fd2 = open(file, oflags2, 0666)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ if (created)
+ (void) unlink(file);
+ (void) close(fd);
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EAGAIN:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "enforced lock prevents truncation";
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no path to file";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "unsupported owner or group";
+ break;
+ }
+ return NULL;
+ }
+ }
+ close(fd2);
+ }
+
+ /* Allocate a IOFileObject to hold the information
+ we need to record per-handle for the various C stubs.
+ This chunk of memory is wrapped up inside a foreign object,
+ so it will be finalised and freed properly when we're
+ through with the handle.
+ */
+ if ((fo = malloc(sizeof(IOFileObject))) == NULL)
+ return NULL;
+
+ fo->fd = fd;
+ fo->buf = NULL;
+ fo->bufWPtr = 0;
+ fo->bufRPtr = 0;
+ fo->flags = flags | ( (how == OPENFILE_READ_ONLY || how == OPENFILE_READ_WRITE) ? FILEOBJ_READ : 0)
+ | ( (how == OPENFILE_APPEND || how == OPENFILE_READ_WRITE) ? FILEOBJ_WRITE : 0);
+ fo->connectedTo = NULL;
+ return fo;
+}
+
+/* `Lock' file descriptor and return file object. */
+IOFileObject*
+openFd(fd,oflags,flags)
+StgInt fd;
+StgInt oflags;
+StgInt flags;
+{
+ int exclusive;
+ FILE* fp;
+ IOFileObject* fo;
+
+ if (lockFile(fd, exclusive) < 0) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ case GHC_EAGAIN:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "file is locked";
+ break;
+ }
+ return NULL;
+ }
+
+ /* See openFileObject() comment */
+ if ((fo = malloc(sizeof(IOFileObject))) == NULL)
+ return NULL;
+ fo->fd = fd;
+ fo->buf = NULL;
+ fo->bufWPtr = 0;
+ fo->bufRPtr = 0;
+ fo->flags = flags | ( oflags & O_RDONLY ? FILEOBJ_READ
+ : oflags & O_RDWR ? FILEOBJ_READ
+ : 0)
+ | ( oflags & O_WRONLY ? FILEOBJ_WRITE
+ : oflags & O_RDWR ? FILEOBJ_WRITE
+ : 0);
+ fo->connectedTo = NULL;
+ return fo;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[openFile.lc]{openFile Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-#include "fileObject.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-IOFileObject*
-openStdFile(fd,flags,rd)
-StgInt fd;
-StgInt flags;
-StgInt rd;
-{
- IOFileObject* fo;
-
- if ((fo = malloc(sizeof(IOFileObject))) == NULL)
- return NULL;
- fo->fd = fd;
- fo->buf = NULL;
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->flags = flags | FILEOBJ_STD | ( rd ? FILEOBJ_READ : FILEOBJ_WRITE);
- fo->connectedTo = NULL;
- return fo;
-}
-
-#define OPENFILE_APPEND 0
-#define OPENFILE_WRITE 1
-#define OPENFILE_READ_ONLY 2
-#define OPENFILE_READ_WRITE 3
-
-IOFileObject*
-openFile(file, how, binary, flags)
-StgByteArray file;
-StgInt how;
-StgInt binary;
-StgInt flags;
-{
- FILE *fp;
- int fd;
- int oflags;
- int exclusive;
- int created = 0;
- struct stat sb;
- IOFileObject* fo;
-
- /*
- * Since we aren't supposed to succeed when we're opening for writing and
- * there's another writer, we can't just do an open() with O_WRONLY.
- */
-
- switch (how) {
- case OPENFILE_APPEND:
- oflags = O_WRONLY | O_NOCTTY | O_APPEND;
- exclusive = 1;
- break;
- case OPENFILE_WRITE:
- oflags = O_WRONLY | O_NOCTTY;
- exclusive = 1;
- break;
- case OPENFILE_READ_ONLY:
- oflags = O_RDONLY | O_NOCTTY;
- exclusive = 0;
- break;
- case OPENFILE_READ_WRITE:
- oflags = O_RDWR | O_NOCTTY;
- exclusive = 0;
- break;
- default:
- fprintf(stderr, "openFile: unknown mode `%d'\n", how);
- EXIT(EXIT_FAILURE);
- }
-
-#if HAVE_O_BINARY
- if (binary)
- oflags |= O_BINARY;
-#endif
-
- /* First try to open without creating */
- while ((fd = open(file, oflags, 0666)) < 0) {
- if (errno == ENOENT) {
- if ( how == OPENFILE_READ_ONLY ) {
- /* For ReadMode, just bail out now */
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "file does not exist";
- return NULL;
- } else {
- /* If it is a dangling symlink, break off now, too. */
- struct stat st;
- if ( lstat(file,&st) == 0) {
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "dangling symlink";
- return NULL;
- }
- }
- /* Now try to create it */
- while ((fd = open(file, oflags | O_CREAT | O_EXCL, 0666)) < 0) {
- if (errno == EEXIST) {
- /* Race detected; go back and open without creating it */
- break;
- } else if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOENT:
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return NULL;
- }
- }
- if (fd >= 0) {
- created = 1;
- break;
- }
- } else if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return NULL;
- }
- }
-
- /* Make sure that we aren't looking at a directory */
-
- while (fstat(fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- if (created)
- (void) unlink(file);
- (void) close(fd);
- return NULL;
- }
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- /* We can't have created it in this case. */
- (void) close(fd);
-
- return NULL;
- }
- /* Use our own personal locking */
-
- if (lockFile(fd, exclusive) < 0) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "file is locked";
- break;
- }
- if (created)
- (void) unlink(file);
- (void) close(fd);
- return NULL;
- }
-
- /*
- * Write mode is supposed to truncate the file. Unfortunately, our pal
- * ftruncate() is non-POSIX, so we truncate with a second open, which may fail.
- */
-
- if ( how == OPENFILE_WRITE ) {
- int fd2, oflags2;
-
- oflags2 = oflags | O_TRUNC;
- while ((fd2 = open(file, oflags2, 0666)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- if (created)
- (void) unlink(file);
- (void) close(fd);
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "enforced lock prevents truncation";
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return NULL;
- }
- }
- close(fd2);
- }
-
- /* Allocate a IOFileObject to hold the information
- we need to record per-handle for the various C stubs.
- This chunk of memory is wrapped up inside a foreign object,
- so it will be finalised and freed properly when we're
- through with the handle.
- */
- if ((fo = malloc(sizeof(IOFileObject))) == NULL)
- return NULL;
-
- fo->fd = fd;
- fo->buf = NULL;
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->flags = flags | ( (how == OPENFILE_READ_ONLY || how == OPENFILE_READ_WRITE) ? FILEOBJ_READ : 0)
- | ( (how == OPENFILE_APPEND || how == OPENFILE_READ_WRITE) ? FILEOBJ_WRITE : 0);
- fo->connectedTo = NULL;
- return fo;
-}
-
-/* `Lock' file descriptor and return file object. */
-IOFileObject*
-openFd(fd,oflags,flags)
-StgInt fd;
-StgInt oflags;
-StgInt flags;
-{
- int exclusive;
- FILE* fp;
- IOFileObject* fo;
-
- if (lockFile(fd, exclusive) < 0) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "file is locked";
- break;
- }
- return NULL;
- }
-
- /* See openFileObject() comment */
- if ((fo = malloc(sizeof(IOFileObject))) == NULL)
- return NULL;
- fo->fd = fd;
- fo->buf = NULL;
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->flags = flags | ( oflags & O_RDONLY ? FILEOBJ_READ
- : oflags & O_RDWR ? FILEOBJ_READ
- : 0)
- | ( oflags & O_WRONLY ? FILEOBJ_WRITE
- : oflags & O_RDWR ? FILEOBJ_WRITE
- : 0);
- fo->connectedTo = NULL;
- return fo;
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: readFile.c,v 1.3 1998/12/02 13:27:45 simonm Exp $
+ *
+ * hGetContents Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#define EOT 4
+
+/* Filling up a (block-buffered) buffer, that
+ is completely empty. */
+StgInt
+readBlock(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int count,rc=0;
+ int fd;
+
+ /* Check if someone hasn't zapped us */
+ if ( fo == NULL || fo->fd == -1 )
+ return -2;
+
+ fd = fo->fd;
+
+ if ( FILEOBJ_IS_EOF(fo) ) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ }
+
+ /* Weird case: buffering has suddenly been turned off.
+ Return non-std value and deal with this case on the Haskell side.
+ */
+ if ( FILEOBJ_UNBUFFERED(fo) ) {
+ return -3;
+ }
+
+ /* if input stream is connect to an output stream, flush this one first. */
+ if ( fo->connectedTo != NULL &&
+ fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE)
+ ) {
+ rc = flushFile((StgForeignPtr)fo->connectedTo);
+ }
+ if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
+
+ /* RW object: flush the (output) buffer first. */
+ if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+ }
+ fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
+
+ /* return the unread parts of the file buffer..*/
+ if ( fo->flags & FILEOBJ_READ &&
+ fo->bufRPtr > 0 &&
+ fo->bufWPtr > fo->bufRPtr ) {
+ count = fo->bufWPtr - fo->bufRPtr;
+ fo->bufRPtr=0;
+ return count;
+ }
+
+#if 0
+ fprintf(stderr, "rb: %d %d %d\n", fo->bufRPtr, fo->bufWPtr, fo->bufSize);
+#endif
+
+ if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady (ptr,0) != 1 )
+ return FILEOBJ_BLOCKED_READ;
+
+ while ((count = read(fd, fo->buf, fo->bufSize)) <= 0) {
+ if ( count == 0 ) {
+ FILEOBJ_SET_EOF(fo);
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ } else if ( count == -1 && errno == EAGAIN) {
+ errno = 0;
+ return FILEOBJ_BLOCKED_READ;
+ } else if ( count == -1 && errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ fo->bufWPtr = count;
+ fo->bufRPtr = 0;
+ return count;
+}
+
+/* Filling up a (block-buffered) buffer of length len */
+StgInt
+readChunk(ptr,buf,len)
+StgForeignPtr ptr;
+StgAddr buf;
+StgInt len;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int count=0,rc=0, total_count;
+ int fd;
+ char* p;
+
+ /* Check if someone hasn't zapped us */
+ if ( fo == NULL )
+ return -2;
+
+ fd = fo->fd;
+
+ if ( fd == -1 ) /* File has been closed for us */
+ return -2;
+
+ if ( FILEOBJ_IS_EOF(fo) ) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ }
+
+ /* if input stream is connect to an output stream, flush it first */
+ if ( fo->connectedTo != NULL &&
+ fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE)
+ ) {
+ rc = flushFile((StgForeignPtr)fo->connectedTo);
+ }
+ if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
+
+ /* RW object: flush the (output) buffer first. */
+ if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+ }
+ fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
+
+ /* copy the unread parts of the file buffer..*/
+ if ( FILEOBJ_READABLE(fo) &&
+ fo->bufRPtr > 0 &&
+ fo->bufWPtr >= fo->bufRPtr ) {
+ count = ( len < (fo->bufWPtr - fo->bufRPtr)) ? len : (fo->bufWPtr - fo->bufRPtr);
+ memcpy(buf,fo->buf, count);
+ fo->bufWPtr=0;
+ fo->bufRPtr=0;
+
+ }
+
+ if (len - count <= 0)
+ return count;
+
+ len -= count;
+ p = buf;
+ p += count;
+ total_count = count;
+
+ if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady (ptr,0) != 1 )
+ return FILEOBJ_BLOCKED_READ;
+
+ while ((count = read(fd, p, len)) < len) {
+ if ( count == 0 ) { /* EOF */
+ break;
+ } else if ( count == -1 && errno == EAGAIN) {
+ errno = 0;
+ return FILEOBJ_BLOCKED_READ;
+ } else if ( count == -1 && errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ total_count += count;
+ len -= count;
+ p += count;
+ }
+
+ total_count += count;
+ fo->bufWPtr = total_count;
+ fo->bufRPtr = 0;
+ return total_count;
+}
+
+/*
+ readLine() tries to fill the buffer up with a line of chars, returning
+ the length of the resulting line.
+
+ Users of readLine() should immediately afterwards copy out the line
+ from the buffer.
+
+*/
+
+StgInt
+readLine(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ char *s;
+ int rc=0, count;
+
+ /* Check if someone hasn't zapped us */
+ if ( fo == NULL || fo->fd == -1 )
+ return -2;
+
+ if ( FILEOBJ_IS_EOF(fo) ) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ }
+
+ /* Weird case: buffering has been turned off.
+ Return non-std value and deal with this case on the Haskell side.
+ */
+ if ( FILEOBJ_UNBUFFERED(fo) ) {
+ return -3;
+ }
+
+ /* if input stream is connect to an output stream, flush it first */
+ if ( fo->connectedTo != NULL &&
+ fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE)
+ ) {
+ rc = flushFile((StgForeignPtr)fo->connectedTo);
+ }
+ if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
+
+ /* RW object: flush the (output) buffer first. */
+ if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) ) {
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+ }
+ fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
+
+ if ( fo->bufRPtr < 0 || fo->bufRPtr >= fo->bufWPtr ) { /* Buffer is empty */
+ fo->bufRPtr=0; fo->bufWPtr=0;
+ rc = fill_up_line_buffer(fo);
+ if (rc < 0) return rc;
+ }
+
+ while (1) {
+ unsigned char* s1 = memchr((unsigned char *)fo->buf+fo->bufRPtr, '\n', fo->bufWPtr - fo->bufRPtr);
+ if (s1 != NULL ) { /* Found one */
+ /* Note: we *don't* zero terminate the line */
+ count = s1 - ((unsigned char*)fo->buf + fo->bufRPtr) + 1;
+ fo->bufRPtr += count;
+ return count;
+ } else {
+ /* Just return partial line */
+ count = fo->bufWPtr - fo->bufRPtr;
+ fo->bufRPtr += count;
+ return count;
+ }
+ }
+
+}
+
+StgInt
+readChar(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo= (IOFileObject*)ptr;
+ int count,rc=0;
+ char c;
+
+ /* Check if someone hasn't zapped us */
+ if ( fo == NULL || fo->fd == -1)
+ return -2;
+
+ if ( FILEOBJ_IS_EOF(fo) ) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ }
+
+ /* Buffering has been changed, report back */
+ if ( FILEOBJ_LINEBUFFERED(fo) ) {
+ return -3;
+ } else if ( FILEOBJ_BLOCKBUFFERED(fo) ) {
+ return -4;
+ }
+
+ /* if input stream is connect to an output stream, flush it first */
+ if ( fo->connectedTo != NULL &&
+ fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE)
+ ) {
+ rc = flushFile((StgForeignPtr)fo->connectedTo);
+ }
+ if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
+
+ /* RW object: flush the (output) buffer first. */
+ if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+ }
+ fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
+
+ if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady (ptr,0) != 1 )
+ return FILEOBJ_BLOCKED_READ;
+
+ while ( (count = read(fo->fd, &c, 1)) <= 0 ) {
+ if ( count == 0 ) {
+ ghc_errtype = ERR_EOF;
+ ghc_errstr = "";
+ return -1;
+ } else if ( count == -1 && errno == EAGAIN) {
+ errno = 0;
+ return FILEOBJ_BLOCKED_READ;
+ } else if ( count == -1 && errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+
+ if ( isatty(fo->fd) && c == EOT ) {
+ return EOF;
+ } else {
+ return (int)c;
+ }
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[readFile.lc]{hGetContents Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#define EOT 4
-
-/* Filling up a (block-buffered) buffer, that
- is completely empty. */
-StgInt
-readBlock(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int count,rc=0;
- int fd;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL || fo->fd == -1 )
- return -2;
-
- fd = fo->fd;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- /* Weird case: buffering has suddenly been turned off.
- Return non-std value and deal with this case on the Haskell side.
- */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- return -3;
- }
-
- /* if input stream is connect to an output stream, flush this one first. */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignObj)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- /* return the unread parts of the file buffer..*/
- if ( fo->flags & FILEOBJ_READ &&
- fo->bufRPtr > 0 &&
- fo->bufWPtr > fo->bufRPtr ) {
- count = fo->bufWPtr - fo->bufRPtr;
- fo->bufRPtr=0;
- return count;
- }
-
-#if 0
- fprintf(stderr, "rb: %d %d %d\n", fo->bufRPtr, fo->bufWPtr, fo->bufSize);
-#endif
-
- if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady (ptr,0) != 1 )
- return FILEOBJ_BLOCKED_READ;
-
- while ((count = read(fd, fo->buf, fo->bufSize)) <= 0) {
- if ( count == 0 ) {
- FILEOBJ_SET_EOF(fo);
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- } else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
- } else if ( count == -1 && errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- fo->bufWPtr = count;
- fo->bufRPtr = 0;
- return count;
-}
-
-/* Filling up a (block-buffered) buffer of length len */
-StgInt
-readChunk(ptr,buf,len)
-StgForeignObj ptr;
-StgAddr buf;
-StgInt len;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int count=0,rc=0, total_count;
- int fd;
- char* p;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL )
- return -2;
-
- fd = fo->fd;
-
- if ( fd == -1 ) /* File has been closed for us */
- return -2;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignObj)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- /* copy the unread parts of the file buffer..*/
- if ( FILEOBJ_READABLE(fo) &&
- fo->bufRPtr > 0 &&
- fo->bufWPtr >= fo->bufRPtr ) {
- count = ( len < (fo->bufWPtr - fo->bufRPtr)) ? len : (fo->bufWPtr - fo->bufRPtr);
- memcpy(buf,fo->buf, count);
- fo->bufWPtr=0;
- fo->bufRPtr=0;
-
- }
-
- if (len - count <= 0)
- return count;
-
- len -= count;
- p = buf;
- p += count;
- total_count = count;
-
- if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady (ptr,0) != 1 )
- return FILEOBJ_BLOCKED_READ;
-
- while ((count = read(fd, p, len)) < len) {
- if ( count == 0 ) { /* EOF */
- break;
- } else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
- } else if ( count == -1 && errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- total_count += count;
- len -= count;
- p += count;
- }
-
- total_count += count;
- fo->bufWPtr = total_count;
- fo->bufRPtr = 0;
- return total_count;
-}
-
-/*
- readLine() tries to fill the buffer up with a line of chars, returning
- the length of the resulting line.
-
- Users of readLine() should immediately afterwards copy out the line
- from the buffer.
-
-*/
-
-StgInt
-readLine(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- char *s;
- int rc=0, count;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL || fo->fd == -1 )
- return -2;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- /* Weird case: buffering has been turned off.
- Return non-std value and deal with this case on the Haskell side.
- */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- return -3;
- }
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignObj)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- if ( fo->bufRPtr < 0 || fo->bufRPtr >= fo->bufWPtr ) { /* Buffer is empty */
- fo->bufRPtr=0; fo->bufWPtr=0;
- rc = fill_up_line_buffer(fo);
- if (rc < 0) return rc;
- }
-
- while (1) {
- unsigned char* s1 = memchr((unsigned char *)fo->buf+fo->bufRPtr, '\n', fo->bufWPtr - fo->bufRPtr);
- if (s1 != NULL ) { /* Found one */
- /* Note: we *don't* zero terminate the line */
- count = s1 - ((unsigned char*)fo->buf + fo->bufRPtr) + 1;
- fo->bufRPtr += count;
- return count;
- } else {
- /* Just return partial line */
- count = fo->bufWPtr - fo->bufRPtr;
- fo->bufRPtr += count;
- return count;
- }
- }
-
-}
-
-StgInt
-readChar(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo= (IOFileObject*)ptr;
- int count,rc=0;
- char c;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL || fo->fd == -1)
- return -2;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- /* Buffering has been changed, report back */
- if ( FILEOBJ_LINEBUFFERED(fo) ) {
- return -3;
- } else if ( FILEOBJ_BLOCKBUFFERED(fo) ) {
- return -4;
- }
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignObj)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady (ptr,0) != 1 )
- return FILEOBJ_BLOCKED_READ;
-
- while ( (count = read(fo->fd, &c, 1)) <= 0 ) {
- if ( count == 0 ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- } else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
- } else if ( count == -1 && errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- if ( isatty(fo->fd) && c == EOT ) {
- return EOF;
- } else {
- return (int)c;
- }
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: removeDirectory.c,v 1.3 1998/12/02 13:27:47 simonm Exp $
+ *
+ * removeDirectory Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+StgInt
+removeDirectory(path)
+StgByteArray path;
+{
+ struct stat sb;
+
+ /* Check for an actual directory */
+ while (stat(path, &sb) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (!S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "not a directory";
+ return -1;
+ }
+ while (rmdir(path) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_ENOTEMPTY:
+ case GHC_EEXIST:
+ ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
+ ghc_errstr = "directory not empty";
+ break;
+ }
+ return -1;
+ }
+ }
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[removeDirectory.lc]{removeDirectory Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-removeDirectory(path)
-StgByteArray path;
-{
- struct stat sb;
-
- /* Check for an actual directory */
- while (stat(path, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (!S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- return -1;
- }
- while (rmdir(path) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOTEMPTY:
- case GHC_EEXIST:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "directory not empty";
- break;
- }
- return -1;
- }
- }
- return 0;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: removeFile.c,v 1.3 1998/12/02 13:27:49 simonm Exp $
+ *
+ * removeFile Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+StgInt
+removeFile(path)
+StgByteArray path;
+{
+ struct stat sb;
+
+ /* Check for a non-directory */
+ while (stat(path, &sb) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "file is a directory";
+ return -1;
+ }
+ while (unlink(path) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[removeFile.lc]{removeFile Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-removeFile(path)
-StgByteArray path;
-{
- struct stat sb;
-
- /* Check for a non-directory */
- while (stat(path, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- return -1;
- }
- while (unlink(path) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: renameDirectory.c,v 1.3 1998/12/02 13:27:50 simonm Exp $
+ *
+ * renameDirectory Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+StgInt
+renameDirectory(opath, npath)
+StgByteArray opath;
+StgByteArray npath;
+{
+ struct stat sb;
+
+ /* Check for an actual directory */
+ while (stat(opath, &sb) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (!S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "not a directory";
+ return -1;
+ }
+ while(rename(opath, npath) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[renameDirectory.lc]{renameDirectory Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-renameDirectory(opath, npath)
-StgByteArray opath;
-StgByteArray npath;
-{
- struct stat sb;
-
- /* Check for an actual directory */
- while (stat(opath, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (!S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- return -1;
- }
- while(rename(opath, npath) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: renameFile.c,v 1.3 1998/12/02 13:27:51 simonm Exp $
+ *
+ * renameFile Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+StgInt
+renameFile(opath, npath)
+StgByteArray opath;
+StgByteArray npath;
+{
+ struct stat sb;
+ int fd;
+ int created = 0;
+
+ /* Check for a non-directory source */
+ while (stat(opath, &sb) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "file is a directory";
+ return -1;
+ }
+
+ /* Ensure a non-directory destination */
+
+ /* First try to open without creating */
+ while ((fd = open(npath, O_RDONLY | O_NOCTTY, 0)) < 0) {
+ if (errno == ENOENT) {
+ /* Now try to create it */
+ while ((fd = open(npath, O_RDONLY | O_NOCTTY | O_CREAT | O_EXCL, 0)) < 0) {
+ if (errno == EEXIST) {
+ /* Race detected; go back and open without creating it */
+ break;
+ } else if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_ENOENT:
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no path to file";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "unsupported owner or group";
+ break;
+ }
+ return -1;
+ }
+ }
+ if (fd >= 0) {
+ created = 1;
+ break;
+ }
+ } else if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_NOSUCHTHING;
+ ghc_errstr = "no path to file";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "unsupported owner or group";
+ break;
+ }
+ return -1;
+ }
+ }
+
+ /* Make sure that we aren't looking at a directory */
+
+ while (fstat(fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ if (created)
+ (void) unlink(npath);
+ (void) close(fd);
+ return -1;
+ }
+ }
+ if (S_ISDIR(sb.st_mode)) {
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "destination is a directory";
+ /* We can't have created it in this case. */
+ (void) close(fd);
+ return -1;
+ }
+
+ while(rename(opath, npath) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ if (created)
+ (void) unlink(npath);
+ (void) close(fd);
+ return -1;
+ }
+ }
+
+ close(fd);
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[renameFile.lc]{renameFile Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-StgInt
-renameFile(opath, npath)
-StgByteArray opath;
-StgByteArray npath;
-{
- struct stat sb;
- int fd;
- int created = 0;
-
- /* Check for a non-directory source */
- while (stat(opath, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- return -1;
- }
-
- /* Ensure a non-directory destination */
-
- /* First try to open without creating */
- while ((fd = open(npath, O_RDONLY | O_NOCTTY, 0)) < 0) {
- if (errno == ENOENT) {
- /* Now try to create it */
- while ((fd = open(npath, O_RDONLY | O_NOCTTY | O_CREAT | O_EXCL, 0)) < 0) {
- if (errno == EEXIST) {
- /* Race detected; go back and open without creating it */
- break;
- } else if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOENT:
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return -1;
- }
- }
- if (fd >= 0) {
- created = 1;
- break;
- }
- } else if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return -1;
- }
- }
-
- /* Make sure that we aren't looking at a directory */
-
- while (fstat(fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- if (created)
- (void) unlink(npath);
- (void) close(fd);
- return -1;
- }
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "destination is a directory";
- /* We can't have created it in this case. */
- (void) close(fd);
- return -1;
- }
-
- while(rename(opath, npath) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- if (created)
- (void) unlink(npath);
- (void) close(fd);
- return -1;
- }
- }
-
- close(fd);
- return 0;
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: seekFile.c,v 1.3 1998/12/02 13:27:53 simonm Exp $
+ *
+ * hSeek and hIsSeekable Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+/* Invoked by IO.hSeek only */
+StgInt
+seekFile(ptr, whence, size, d)
+StgForeignPtr ptr;
+StgInt whence;
+StgInt size;
+StgByteArray d;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct stat sb;
+ off_t offset;
+ int posn_delta =0;
+ int rc = 0;
+
+ switch (whence) {
+ case 0: whence=SEEK_SET; break;
+ case 1: whence=SEEK_CUR; break;
+ case 2: whence=SEEK_END; break;
+ default: whence=SEEK_SET; break; /* Should never happen, really */
+ }
+
+ /*
+ * We need to snatch the offset out of an MP_INT. The bits are there sans sign,
+ * which we pick up from our size parameter. If abs(size) is greater than 1,
+ * this integer is just too big.
+ */
+
+ switch (size) {
+ case -1:
+ offset = -*(StgInt *) d;
+ break;
+ case 0:
+ offset = 0;
+ break;
+ case 1:
+ offset = *(StgInt *) d;
+ break;
+ default:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "offset out of range";
+ return -1;
+ }
+
+ /* If we're doing a relative seek, see if we cannot deal
+ * with the request without flushing the buffer..
+ *
+ * Note: the wording in the report is vague here, but
+ * we only avoid flushing on *input* buffers and *not* output ones.
+ */
+ if ( whence == SEEK_CUR &&
+ (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo) &&
+ (fo->bufRPtr + (int)offset) < fo->bufWPtr &&
+ (fo->bufRPtr + (int)offset) >= 0) ) { /* The input buffer case */
+ fo->bufRPtr += (int)offset;
+ return 0;
+ } else if ( whence == SEEK_CUR && (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo)) ) {
+ /* We're seeking outside the input buffer,
+ record delta so that we can adjust the file position
+ reported from the underlying fd to get
+ at the real position we're at when we take into account
+ buffering.
+ */
+ posn_delta = fo->bufWPtr - fo->bufRPtr; /* number of chars left in the buffer */
+ if (posn_delta < 0) posn_delta=0;
+ }
+
+ /* If we cannot seek within our current buffer, flush it. */
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+
+ /* Try to find out the file type & size for a physical file */
+ while (fstat(fo->fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (S_ISREG(sb.st_mode)) {
+ /* Verify that we are not seeking beyond end-of-file */
+ off_t posn;
+
+ switch (whence) {
+ case SEEK_SET:
+ posn = offset;
+ break;
+ case SEEK_CUR:
+ while ((posn = lseek(fo->fd, 0, SEEK_CUR)) == -1) {
+ /* the possibility seems awfully remote */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ posn -= posn_delta;
+ posn += offset;
+ offset -= posn_delta; /* adjust the offset to include the buffer delta */
+ break;
+ case SEEK_END:
+ posn = (off_t)sb.st_size + offset;
+ break;
+ }
+ if (posn > sb.st_size) {
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "seek position beyond end of file";
+ return -1;
+ }
+ } else if (S_ISFIFO(sb.st_mode)) {
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "can't seek on a pipe";
+ return -1;
+ } else {
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "can't seek on a device";
+ return -1;
+ }
+ while ( lseek(fo->fd, offset, whence) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ /* Clear EOF */
+ FILEOBJ_CLEAR_EOF(fo);
+ return 0;
+}
+
+/* Invoked by IO.hSeek only */
+StgInt
+seekFile_int64(ptr, whence, d)
+StgForeignPtr ptr;
+StgInt whence;
+StgInt64 d;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct stat sb;
+ off_t offset = d;
+ int posn_delta =0;
+ int rc = 0;
+
+ switch (whence) {
+ case 0: whence=SEEK_SET; break;
+ case 1: whence=SEEK_CUR; break;
+ case 2: whence=SEEK_END; break;
+ default: whence=SEEK_SET; break; /* Should never happen, really */
+ }
+
+ /* If we're doing a relative seek, see if we cannot deal
+ * with the request without flushing the buffer..
+ *
+ * Note: the wording in the report is vague here, but
+ * we only avoid flushing on *input* buffers and *not* output ones.
+ */
+ if ( whence == SEEK_CUR &&
+ (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo) &&
+ (fo->bufRPtr + (int)offset) < fo->bufWPtr &&
+ (fo->bufRPtr + (int)offset) >= 0) ) { /* The input buffer case */
+ fo->bufRPtr += (int)offset;
+ return 0;
+ } else if ( whence == SEEK_CUR && (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo)) ) {
+ /* We're seeking outside the input buffer,
+ record delta so that we can adjust the file position
+ reported from the underlying fd to get
+ at the real position we're at when we take into account
+ buffering.
+ */
+ posn_delta = fo->bufWPtr - fo->bufRPtr; /* number of chars left in the buffer */
+ if (posn_delta < 0) posn_delta=0;
+ }
+
+ /* If we cannot seek within our current buffer, flush it. */
+ rc = flushBuffer(ptr);
+ if (rc < 0) return rc;
+
+ /* Try to find out the file type & size for a physical file */
+ while (fstat(fo->fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ if (S_ISREG(sb.st_mode)) {
+ /* Verify that we are not seeking beyond end-of-file */
+ off_t posn;
+
+ switch (whence) {
+ case SEEK_SET:
+ posn = offset;
+ break;
+ case SEEK_CUR:
+ while ((posn = lseek(fo->fd, 0, SEEK_CUR)) == -1) {
+ /* the possibility seems awfully remote */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ posn -= posn_delta;
+ posn += offset;
+ offset -= posn_delta; /* adjust the offset to include the buffer delta */
+ break;
+ case SEEK_END:
+ posn = (off_t)sb.st_size + offset;
+ break;
+ }
+ if (posn > sb.st_size) {
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "seek position beyond end of file";
+ return -1;
+ }
+ } else if (S_ISFIFO(sb.st_mode)) {
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "can't seek on a pipe";
+ return -1;
+ } else {
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "can't seek on a device";
+ return -1;
+ }
+ while ( lseek(fo->fd, offset, whence) == -1) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ /* Clear EOF */
+ FILEOBJ_CLEAR_EOF(fo);
+ return 0;
+}
+
+StgInt
+seekFileP(ptr)
+StgForeignPtr ptr;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ struct stat sb;
+
+ /* Try to find out the file type */
+ while (fstat(fo->fd, &sb) < 0) {
+ /* highly unlikely */
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ /* Regular files are okay */
+ if (S_ISREG(sb.st_mode)) {
+ return 1;
+ }
+ /* For now, everything else is not */
+ else {
+ return 0;
+ }
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[seekFile.lc]{hSeek and hIsSeekable Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-/* Invoked by IO.hSeek only */
-StgInt
-seekFile(ptr, whence, size, d)
-StgForeignObj ptr;
-StgInt whence;
-StgInt size;
-StgByteArray d;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- off_t offset;
- int posn_delta =0;
- int rc = 0;
-
- switch (whence) {
- case 0: whence=SEEK_SET; break;
- case 1: whence=SEEK_CUR; break;
- case 2: whence=SEEK_END; break;
- default: whence=SEEK_SET; break; /* Should never happen, really */
- }
-
- /*
- * We need to snatch the offset out of an MP_INT. The bits are there sans sign,
- * which we pick up from our size parameter. If abs(size) is greater than 1,
- * this integer is just too big.
- */
-
- switch (size) {
- case -1:
- offset = -*(StgInt *) d;
- break;
- case 0:
- offset = 0;
- break;
- case 1:
- offset = *(StgInt *) d;
- break;
- default:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "offset out of range";
- return -1;
- }
-
- /* If we're doing a relative seek, see if we cannot deal
- * with the request without flushing the buffer..
- *
- * Note: the wording in the report is vague here, but
- * we only avoid flushing on *input* buffers and *not* output ones.
- */
- if ( whence == SEEK_CUR &&
- (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo) &&
- (fo->bufRPtr + (int)offset) < fo->bufWPtr &&
- (fo->bufRPtr + (int)offset) >= 0) ) { /* The input buffer case */
- fo->bufRPtr += (int)offset;
- return 0;
- } else if ( whence == SEEK_CUR && (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo)) ) {
- /* We're seeking outside the input buffer,
- record delta so that we can adjust the file position
- reported from the underlying fd to get
- at the real position we're at when we take into account
- buffering.
- */
- posn_delta = fo->bufWPtr - fo->bufRPtr; /* number of chars left in the buffer */
- if (posn_delta < 0) posn_delta=0;
- }
-
- /* If we cannot seek within our current buffer, flush it. */
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
-
- /* Try to find out the file type & size for a physical file */
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISREG(sb.st_mode)) {
- /* Verify that we are not seeking beyond end-of-file */
- off_t posn;
-
- switch (whence) {
- case SEEK_SET:
- posn = offset;
- break;
- case SEEK_CUR:
- while ((posn = lseek(fo->fd, 0, SEEK_CUR)) == -1) {
- /* the possibility seems awfully remote */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- posn -= posn_delta;
- posn += offset;
- offset -= posn_delta; /* adjust the offset to include the buffer delta */
- break;
- case SEEK_END:
- posn = (off_t)sb.st_size + offset;
- break;
- }
- if (posn > sb.st_size) {
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "seek position beyond end of file";
- return -1;
- }
- } else if (S_ISFIFO(sb.st_mode)) {
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't seek on a pipe";
- return -1;
- } else {
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't seek on a device";
- return -1;
- }
- while ( lseek(fo->fd, offset, whence) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- /* Clear EOF */
- FILEOBJ_CLEAR_EOF(fo);
- return 0;
-}
-
-StgInt
-seekFileP(ptr)
-StgForeignObj ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
-
- /* Try to find out the file type */
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- /* Regular files are okay */
- if (S_ISREG(sb.st_mode)) {
- return 1;
- }
- /* For now, everything else is not */
- else {
- return 0;
- }
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: setBuffering.c,v 1.3 1998/12/02 13:27:54 simonm Exp $
+ *
+ * hSetBuffering Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_TERMIOS_H
+#include <termios.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+#define SB_NB (0)
+#define SB_LB (-1)
+#define SB_BB (-2)
+
+StgInt
+setBuffering(ptr, size)
+StgForeignPtr ptr;
+StgInt size;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int flags, rc=0;
+ int input, isaterm;
+ struct termios tio;
+ struct stat sb;
+
+
+ /* First off, flush old buffer.. */
+ if ( (fo->flags & FILEOBJ_FLUSH) ) {
+ rc = flushBuffer(ptr);
+ }
+ if (rc<0) return rc;
+
+ /* Let go of old buffer, and reset buffer pointers. */
+ if ( fo->buf != NULL ) {
+ free(fo->buf);
+ fo->bufWPtr = 0;
+ fo->bufRPtr = 0;
+ fo->bufSize = 0;
+ fo->buf = NULL;
+ }
+
+ while ((flags = fcntl(fo->fd, F_GETFL)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ flags &= O_ACCMODE;
+ input = flags == O_RDONLY || flags == O_RDWR;
+
+ isaterm = input && isatty(fo->fd);
+
+ switch (size) {
+ case SB_NB:
+ fo->flags &= ~FILEOBJ_LB & ~FILEOBJ_BB;
+
+ if (isaterm) {
+ /* Switch over to canonical mode. */
+ if (tcgetattr(fo->fd, &tio) < 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ tio.c_lflag &= ~ICANON;
+ tio.c_cc[VMIN] = 1;
+ tio.c_cc[VTIME] = 0;
+ if (tcsetattr(fo->fd, TCSANOW, &tio) < 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return 0;
+ case SB_LB:
+ fo->flags &= ~FILEOBJ_BB;
+ fo->flags |= FILEOBJ_LB;
+ size = BUFSIZ;
+ break;
+ case SB_BB:
+
+#if HAVE_ST_BLKSIZE
+ while (fstat(fo->fd, &sb) < 0) {
+ /* not very likely.. */
+ if ( errno != EINTR ) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ size = sb.st_blksize;
+#else
+ size = BUFSIZ;
+#endif
+ fo->flags &= ~FILEOBJ_LB;
+ fo->flags |= FILEOBJ_BB;
+ /* fall through */
+ default:
+ break;
+ }
+
+ if ( size > 0) {
+ fo->buf = malloc(size*sizeof(char));
+ if (fo->buf == NULL) {
+ return -1;
+ }
+ fo->bufSize = size;
+ }
+ if (isaterm) {
+
+ /*
+ * Try to switch back to cooked mode.
+ */
+
+ if (tcgetattr(fo->fd, &tio) < 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ tio.c_lflag |= ICANON;
+ if (tcsetattr(fo->fd, TCSANOW, &tio) < 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return 0;
+}
+
+StgInt const_BUFSIZ() { return BUFSIZ; }
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[setBuffering.lc]{hSetBuffering Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_TERMIOS_H
-#include <termios.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-#define SB_NB (0)
-#define SB_LB (-1)
-#define SB_BB (-2)
-
-StgInt
-setBuffering(ptr, size)
-StgForeignObj ptr;
-StgInt size;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int flags, rc=0;
- int input, isaterm;
- struct termios tio;
- struct stat sb;
-
-
- /* First off, flush old buffer.. */
- if ( (fo->flags & FILEOBJ_FLUSH) ) {
- rc = flushBuffer(ptr);
- }
- if (rc<0) return rc;
-
- /* Let go of old buffer, and reset buffer pointers. */
- if ( fo->buf != NULL ) {
- free(fo->buf);
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->bufSize = 0;
- fo->buf = NULL;
- }
-
- while ((flags = fcntl(fo->fd, F_GETFL)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- flags &= O_ACCMODE;
- input = flags == O_RDONLY || flags == O_RDWR;
-
- isaterm = input && isatty(fo->fd);
-
- switch (size) {
- case SB_NB:
- fo->flags &= ~FILEOBJ_LB & ~FILEOBJ_BB;
-
- if (isaterm) {
- /* Switch over to canonical mode. */
- if (tcgetattr(fo->fd, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- tio.c_lflag &= ~ICANON;
- tio.c_cc[VMIN] = 1;
- tio.c_cc[VTIME] = 0;
- if (tcsetattr(fo->fd, TCSANOW, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
- case SB_LB:
- fo->flags &= ~FILEOBJ_BB;
- fo->flags |= FILEOBJ_LB;
- size = BUFSIZ;
- break;
- case SB_BB:
-
-#if HAVE_ST_BLKSIZE
- while (fstat(fo->fd, &sb) < 0) {
- /* not very likely.. */
- if ( errno != EINTR ) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- size = sb.st_blksize;
-#else
- size = BUFSIZ;
-#endif
- fo->flags &= ~FILEOBJ_LB;
- fo->flags |= FILEOBJ_BB;
- /* fall through */
- default:
- break;
- }
-
- if ( size > 0) {
- fo->buf = malloc(size*sizeof(char));
- if (fo->buf == NULL) {
- return -1;
- }
- fo->bufSize = size;
- }
- if (isaterm) {
-
- /*
- * Try to switch back to cooked mode.
- */
-
- if (tcgetattr(fo->fd, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- tio.c_lflag |= ICANON;
- if (tcsetattr(fo->fd, TCSANOW, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: setCurrentDirectory.c,v 1.3 1998/12/02 13:27:56 simonm Exp $
+ *
+ * setCurrentDirectory Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgInt
+setCurrentDirectory(path)
+StgByteArray path;
+{
+ while (chdir(path) != 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return 0;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[setCurrentDirectory.lc]{setCurrentDirectory Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgInt
-setCurrentDirectory(path)
-StgByteArray path;
-{
- while (chdir(path) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: showTime.c,v 1.3 1998/12/02 13:27:57 simonm Exp $
+ *
+ * ClockTime.showsPrec Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#if TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# if HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+#endif
+
+StgAddr
+showTime(I_ size, StgByteArray d, StgByteArray buf)
+{
+ time_t t;
+ struct tm *tm;
+
+ switch(size) {
+ default:
+ return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range");
+ case 0:
+ t = 0;
+ break;
+ case -1:
+ t = - (time_t) ((StgInt *)d)[0];
+ if (t > 0)
+ return
+ (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range");
+ break;
+ case 1:
+ t = (time_t) ((StgInt *)d)[0];
+ if (t < 0)
+ return (StgAddr) strcpy(buf, "ClockTime.show{LibTime}: out of range");
+ break;
+ }
+ tm = localtime(&t);
+ if (tm != NULL && strftime(buf, 32 /*Magic number*/, "%a %b %d %T %Z %Y", tm) > 0)
+ return (StgAddr)buf;
+ return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: internal error");
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[showTime.lc]{ClockTime.showsPrec Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-
-StgAddr
-showTime(I_ size, StgByteArray d, StgByteArray buf)
-{
- time_t t;
- struct tm *tm;
-
- switch(size) {
- default:
- return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range");
- case 0:
- t = 0;
- break;
- case -1:
- t = - (time_t) ((StgInt *)d)[0];
- if (t > 0)
- return
- (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range");
- break;
- case 1:
- t = (time_t) ((StgInt *)d)[0];
- if (t < 0)
- return (StgAddr) strcpy(buf, "ClockTime.show{LibTime}: out of range");
- break;
- }
- tm = localtime(&t);
- if (tm != NULL && strftime(buf, 32 /*Magic number*/, "%a %b %d %T %Z %Y", tm) > 0)
- return (StgAddr)buf;
- return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: internal error");
-}
-\end{code}
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: stgio.h,v 1.8 1998/12/02 13:27:58 simonm Exp $
+ *
+ * Helper code for GHC's IO subsystem.
+ */
+
#ifndef STGIO_H
#define STGIO_H
* routines (to check consistency).
*/
-/* closeFile.lc */
-StgAddr allocMemory__ PROTO((StgInt));
-
-/* closeFile.lc */
-StgInt closeFile PROTO((StgForeignObj,StgInt));
-
-/* createDirectory.lc */
-StgInt createDirectory PROTO((StgByteArray));
-
-/* directoryAux.lc */
-StgAddr openDir__ PROTO((StgByteArray));
-StgAddr readDir__ PROTO((StgAddr));
-
-/* echoAux.lc */
-StgInt setTerminalEcho PROTO((StgForeignObj, StgInt));
-StgInt getTerminalEcho PROTO((StgForeignObj));
-StgInt isTerminalDevice PROTO((StgForeignObj));
-
-/* env.lc */
-char * strDup PROTO((const char *));
-int setenviron PROTO((char **));
-int copyenv (STG_NO_ARGS);
-int _setenv PROTO((char *));
-int delenv PROTO((char *));
-
-/* errno.lc */
+#include "error.h"
+
+/* closeFile.c */
+StgAddr allocMemory__ (StgInt);
+
+/* closeFile.c */
+StgInt closeFile (StgForeignPtr,StgInt);
+
+/* createDirectory.c */
+StgInt createDirectory (StgByteArray);
+
+/* directoryAux.c */
+StgAddr openDir__ (StgByteArray);
+StgAddr readDir__ (StgAddr);
+StgAddr get_dirent_d_name (StgAddr);
+StgWord get_stat_st_mode (StgAddr);
+StgInt64 get_stat_st_mtime(StgAddr);
+void set_stat_st_mtime(StgByteArray, StgByteArray);
+StgInt sizeof_stat (void);
+StgInt prim_stat (StgAddr,StgAddr);
+StgInt const_F_OK (void);
+StgWord const_S_IRUSR (void);
+StgWord const_S_IWUSR (void);
+StgWord const_S_IXUSR (void);
+StgInt prim_S_ISDIR (StgWord);
+StgInt prim_S_ISREG (StgWord);
+
+/* echoAux.c */
+StgInt setTerminalEcho (StgForeignPtr, StgInt);
+StgInt getTerminalEcho (StgForeignPtr);
+StgInt isTerminalDevice (StgForeignPtr);
+
+/* env.c */
+char * strDup (const char *);
+int setenviron (char **);
+int copyenv (void);
+int _setenv (char *);
+int delenv (char *);
+
+/* errno.c */
extern int ghc_errno;
extern int ghc_errtype;
-void cvtErrno(STG_NO_ARGS);
-void stdErrno(STG_NO_ARGS);
-StgAddr getErrStr__(STG_NO_ARGS);
-StgInt getErrNo__(STG_NO_ARGS);
-StgInt getErrType__(STG_NO_ARGS);
-
-/* execvpe.lc */
-int execvpe PROTO((char *, char **, char **));
-
-/* fileEOF.lc */
-StgInt fileEOF PROTO((StgForeignObj));
-/* fileGetc.lc */
-StgInt fileGetc PROTO((StgForeignObj));
-
-/* fileLookAhead.lc */
-StgInt fileLookAhead PROTO((StgForeignObj));
-StgInt ungetChar PROTO((StgForeignObj,StgChar));
-
-/* fileObject.lc */
-void setBufFlags PROTO((StgForeignObj, StgInt));
-void setBufWPtr PROTO((StgForeignObj, StgInt));
-StgInt getBufWPtr PROTO((StgForeignObj));
-void setBuf PROTO((StgForeignObj, StgAddr, StgInt));
-StgAddr getBuf PROTO((StgForeignObj));
-StgAddr getWriteableBuf PROTO((StgForeignObj));
-StgAddr getBufStart PROTO((StgForeignObj,StgInt));
-StgInt getBufSize PROTO((StgForeignObj));
-void setFilePtr PROTO((StgForeignObj, StgAddr));
-StgAddr getFilePtr PROTO((StgForeignObj));
-void setConnectedTo PROTO((StgForeignObj, StgForeignObj, StgInt));
-void setPushbackBufSize PROTO((StgInt));
-StgInt getPushbackBufSize (STG_NO_ARGS);
-void setNonBlockingIOFlag__ PROTO((StgForeignObj));
-void clearNonBlockingIOFlag__ PROTO((StgForeignObj));
-void setConnNonBlockingIOFlag__ PROTO((StgForeignObj));
-void clearConnNonBlockingIOFlag__ PROTO((StgForeignObj));
-StgInt getFileFd PROTO((StgForeignObj));
-StgInt getConnFileFd PROTO((StgForeignObj));
-
-/* filePosn.lc */
-StgInt getFilePosn PROTO((StgForeignObj));
-StgInt setFilePosn PROTO((StgForeignObj, StgInt));
-
-/* filePutc.lc */
-StgInt filePutc PROTO((StgForeignObj, StgChar));
-
-/* fileSize.lc */
-StgInt fileSize PROTO((StgForeignObj, StgByteArray));
-
-/* flushFile.lc */
-StgInt flushFile PROTO((StgForeignObj));
-StgInt flushBuffer PROTO((StgForeignObj));
-StgInt flushReadBuffer PROTO((StgForeignObj));
-void flushConnectedHandle PROTO((StgForeignObj));
-
-/* freeFile.lc */
-void freeStdFile PROTO((StgForeignObj));
-void freeFile PROTO((StgForeignObj));
-void freeStdFileObject PROTO((StgForeignObj));
-void freeFileObject PROTO((StgForeignObj));
-
-/* getBufferMode.lc */
-StgInt getBufferMode PROTO((StgForeignObj));
-
-/* getClockTime.lc */
-StgInt getClockTime PROTO((StgByteArray, StgByteArray));
-StgAddr showTime PROTO((I_, StgByteArray, StgByteArray));
-StgAddr toClockSec PROTO((I_, I_, I_, I_, I_, I_, I_, StgByteArray));
-StgAddr toLocalTime PROTO((I_, StgByteArray, StgByteArray));
-StgAddr toUTCTime PROTO((I_, StgByteArray, StgByteArray));
-
-/* getCPUTime.lc */
-StgByteArray getCPUTime PROTO((StgByteArray));
-StgInt clockTicks();
-
-/* getCurrentDirectory.lc */
-StgAddr getCurrentDirectory(STG_NO_ARGS);
-
-/* getLock.lc */
-int lockFile PROTO((int, int));
-int unlockFile PROTO((int));
-StgInt getLock PROTO((StgInt, StgInt));
-
-/* inputReady.lc */
-StgInt inputReady PROTO((StgForeignObj,StgInt));
-
-/* openFile.lc */
-IOFileObject* openFile PROTO((StgByteArray, StgInt, StgInt, StgInt));
-IOFileObject* openFd PROTO((StgInt, StgInt, StgInt));
-IOFileObject* openStdFile PROTO((StgInt, StgInt, StgInt));
-
-/* readFile.lc */
-StgInt readBlock PROTO((StgForeignObj));
-StgInt readChunk PROTO((StgForeignObj,StgAddr,StgInt));
-StgInt readLine PROTO((StgForeignObj));
-StgInt readChar PROTO((StgForeignObj));
-
-/* removeDirectory.lc */
-StgInt removeDirectory PROTO((StgByteArray));
-
-/* removeFile.lc */
-StgInt removeFile PROTO((StgByteArray));
-
-/* renameDirectory.lc */
-StgInt renameDirectory PROTO((StgByteArray, StgByteArray));
-
-/* renameFile.lc */
-StgInt renameFile PROTO((StgByteArray, StgByteArray));
-
-/* seekFile.lc */
-StgInt seekFile PROTO((StgForeignObj, StgInt, StgInt, StgByteArray));
-StgInt seekFileP PROTO((StgForeignObj));
-
-/* setBuffering.lc */
-StgInt setBuffering PROTO((StgForeignObj, StgInt));
-
-/* setCurrentDirectory.lc */
-StgInt setCurrentDirectory PROTO((StgByteArray));
-
-/* showTime.lc */
-StgAddr showTime PROTO((StgInt, StgByteArray, StgByteArray));
-
-/* system.lc */
-StgInt systemCmd PROTO((StgByteArray));
-
-/* toLocalTime.lc */
-StgAddr toLocalTime PROTO((StgInt, StgByteArray, StgByteArray));
-
-/* toUTCTime.lc */
-StgAddr toUTCTime PROTO((StgInt, StgByteArray, StgByteArray));
-
-/* toClockSec.lc */
-StgAddr toClockSec PROTO((StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgByteArray));
-
-/* writeError.lc */
-void writeErrString__ PROTO((StgAddr, StgByteArray, StgInt));
-/* writeFile.lc */
-StgInt writeFile PROTO((StgAddr, StgForeignObj, StgInt));
-StgInt writeBuf PROTO((StgForeignObj, StgAddr, StgInt));
-StgInt writeBufBA PROTO((StgForeignObj, StgByteArray, StgInt));
-StgInt writeFileObject PROTO((StgForeignObj, StgInt));
-StgInt writeBuffer PROTO((StgForeignObj, StgInt));
+extern char* ghc_errstr;
+
+void cvtErrno(void);
+void stdErrno(void);
+void convertErrno(void);
+StgAddr getErrStr__(void);
+StgInt getErrNo__(void);
+StgInt getErrType__(void);
+
+/* execvpe.c */
+int execvpe (char *, char **, char **);
+
+/* fileEOF.c */
+StgInt fileEOF (StgForeignPtr);
+/* fileGetc.c */
+StgInt fileGetc (StgForeignPtr);
+
+/* fileLookAhead.c */
+StgInt fileLookAhead (StgForeignPtr);
+StgInt ungetChar (StgForeignPtr,StgChar);
+
+/* fileObject.c */
+void setBufFlags (StgForeignPtr, StgInt);
+void setBufWPtr (StgForeignPtr, StgInt);
+StgInt getBufWPtr (StgForeignPtr);
+void setBuf (StgForeignPtr, StgAddr, StgInt);
+StgAddr getBuf (StgForeignPtr);
+StgAddr getWriteableBuf (StgForeignPtr);
+StgAddr getBufStart (StgForeignPtr,StgInt);
+StgInt getBufSize (StgForeignPtr);
+void setFilePtr (StgForeignPtr, StgAddr);
+StgAddr getFilePtr (StgForeignPtr);
+void setConnectedTo (StgForeignPtr, StgForeignPtr, StgInt);
+void setPushbackBufSize (StgInt);
+StgInt getPushbackBufSize (void);
+void setNonBlockingIOFlag__ (StgForeignPtr);
+void clearNonBlockingIOFlag__ (StgForeignPtr);
+void setConnNonBlockingIOFlag__ (StgForeignPtr);
+void clearConnNonBlockingIOFlag__ (StgForeignPtr);
+StgInt getFileFd (StgForeignPtr);
+StgInt getConnFileFd (StgForeignPtr);
+StgInt fill_up_line_buffer(IOFileObject*);
+
+/* filePosn.c */
+StgInt getFilePosn (StgForeignPtr);
+StgInt setFilePosn (StgForeignPtr, StgInt);
+
+/* filePutc.c */
+StgInt filePutc (StgForeignPtr, StgChar);
+
+/* fileSize.c */
+StgInt fileSize (StgForeignPtr, StgByteArray);
+StgInt fileSize_int64 (StgForeignPtr, StgByteArray);
+
+/* flushFile.c */
+StgInt flushFile (StgForeignPtr);
+StgInt flushBuffer (StgForeignPtr);
+StgInt flushReadBuffer (StgForeignPtr);
+
+/* freeFile.c */
+void freeStdFile (StgForeignPtr);
+void freeFile (StgForeignPtr);
+void freeStdFileObject (StgForeignPtr);
+void freeFileObject (StgForeignPtr);
+
+StgAddr ref_freeStdFileObject (void);
+StgAddr ref_freeFileObject (void);
+
+/* getBufferMode.c */
+StgInt getBufferMode (StgForeignPtr);
+
+/* getClockTime.c */
+StgInt getClockTime (StgByteArray, StgByteArray);
+StgInt prim_getClockTime(StgByteArray, StgByteArray);
+
+/* getCPUTime.c */
+StgByteArray getCPUTime (StgByteArray);
+StgInt clockTicks(void);
+
+/* getCurrentDirectory.c */
+StgAddr getCurrentDirectory(void);
+
+/* getDirectoryContents.c */
+StgAddr getDirectoryContents (StgByteArray);
+
+/* getLock.c */
+int lockFile (int, int);
+int unlockFile (int);
+StgInt getLock (StgInt, StgInt);
+
+/* inputReady.c */
+StgInt inputReady (StgForeignPtr, StgInt);
+
+/* openFile.c */
+IOFileObject* openFile (StgByteArray, StgInt, StgInt, StgInt);
+IOFileObject* openFd (StgInt, StgInt, StgInt);
+IOFileObject* openStdFile (StgInt, StgInt, StgInt);
+
+/* progargs.c */
+StgAddr get_prog_argv(void);
+StgInt get_prog_argc(void);
+
+/* readFile.c */
+StgInt readBlock (StgForeignPtr);
+StgInt readChunk (StgForeignPtr,StgAddr,StgInt);
+StgInt readLine (StgForeignPtr);
+StgInt readChar (StgForeignPtr);
+
+/* removeDirectory.c */
+StgInt removeDirectory (StgByteArray);
+
+/* removeFile.c */
+StgInt removeFile (StgByteArray);
+
+/* renameDirectory.c */
+StgInt renameDirectory (StgByteArray, StgByteArray);
+
+/* renameFile.c */
+StgInt renameFile (StgByteArray, StgByteArray);
+
+/* seekFile.c */
+StgInt seekFile (StgForeignPtr, StgInt, StgInt, StgByteArray);
+StgInt seekFile_int64 (StgForeignPtr, StgInt, StgInt64);
+StgInt seekFileP (StgForeignPtr);
+
+/* setBuffering.c */
+StgInt setBuffering (StgForeignPtr, StgInt);
+StgInt const_BUFSIZ (void);
+
+/* setCurrentDirectory.c */
+StgInt setCurrentDirectory (StgByteArray);
+
+/* showTime.c */
+StgAddr showTime (StgInt, StgByteArray, StgByteArray);
+
+/* system.c */
+StgInt systemCmd (StgByteArray);
+
+/* timezone.c */
+StgInt get_tm_sec ( StgAddr );
+StgInt get_tm_min ( StgAddr );
+StgInt get_tm_hour ( StgAddr );
+StgInt get_tm_mday ( StgAddr );
+StgInt get_tm_mon ( StgAddr );
+StgInt get_tm_year ( StgAddr );
+StgInt get_tm_wday ( StgAddr );
+StgInt get_tm_yday ( StgAddr );
+StgInt get_tm_isdst ( StgAddr );
+StgAddr prim_ZONE ( StgAddr );
+StgInt prim_GMTOFF ( StgAddr );
+StgInt prim_SETZONE ( StgAddr, StgAddr );
+StgInt sizeof_word ( void );
+StgInt sizeof_struct_tm ( void );
+StgInt sizeof_time_t ( void );
+
+/* toLocalTime.c */
+StgAddr toLocalTime (StgInt, StgByteArray, StgByteArray);
+StgInt prim_toLocalTime ( StgInt64,StgByteArray );
+
+/* toUTCTime.c */
+StgAddr toUTCTime (StgInt, StgByteArray, StgByteArray);
+StgInt prim_toUTCTime ( StgInt64,StgByteArray );
+
+/* toClockSec.c */
+StgAddr toClockSec (StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgByteArray);
+StgInt prim_toClockSec(StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgByteArray);
+
+/* writeError.c */
+void writeErrString__ (StgAddr, StgByteArray, StgInt);
+/* writeFile.c */
+StgInt writeBuf (StgForeignPtr, StgAddr, StgInt);
+StgInt writeBufBA (StgForeignPtr, StgByteArray, StgInt);
+StgInt writeFileObject (StgForeignPtr, StgInt);
+StgInt writeBuffer (StgForeignPtr, StgInt);
#endif /* ! STGIO_H */
+
+
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: system.c,v 1.3 1998/12/02 13:27:59 simonm Exp $
+ *
+ * system Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+
+#ifdef HAVE_VFORK_H
+#include <vfork.h>
+#endif
+
+#ifdef HAVE_VFORK
+#define fork vfork
+#endif
+
+StgInt
+systemCmd(cmd)
+StgByteArray cmd;
+{
+#if defined(cygwin32_TARGET_OS)
+ /* The implementation of std. fork() has its problems
+ under cygwin32-b18, so we fall back on using libc's
+ system() instead. (It in turn has problems, as it
+ does not wait until the sub shell has finished before
+ returning. Using sleep() works around that.)
+ */
+ if (system(cmd) < 0) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ sleep(1);
+ return 0;
+#else
+ int pid;
+ int wstat;
+
+ switch(pid = fork()) {
+ case -1:
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ case 0:
+ /* the child */
+ execl("/bin/sh", "sh", "-c", cmd, NULL);
+ _exit(127);
+ }
+
+ while (waitpid(pid, &wstat, 0) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+
+ if (WIFEXITED(wstat))
+ return WEXITSTATUS(wstat);
+ else if (WIFSIGNALED(wstat)) {
+ ghc_errtype = ERR_INTERRUPTED;
+ ghc_errstr = "system command interrupted";
+ }
+ else {
+ /* This should never happen */
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "internal error (process neither exited nor signalled)";
+ }
+ return -1;
+#endif
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[system.lc]{system Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_WAIT_H
-#include <sys/wait.h>
-#endif
-
-#ifdef HAVE_VFORK_H
-#include <vfork.h>
-#endif
-
-#ifdef HAVE_VFORK
-#define fork vfork
-#endif
-
-StgInt
-systemCmd(cmd)
-StgByteArray cmd;
-{
-#if defined(cygwin32_TARGET_OS)
- /* The implementation of std. fork() has its problems
- under cygwin32-b18, so we fall back on using libc's
- system() instead. (It in turn has problems, as it
- does not wait until the sub shell has finished before
- returning. Using sleep() works around that.)
- */
- if (system(cmd) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- sleep(1);
- return 0;
-#else
- int pid;
- int wstat;
-
- switch(pid = fork()) {
- case -1:
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- case 0:
- /* the child */
- execl("/bin/sh", "sh", "-c", cmd, NULL);
- _exit(127);
- }
-
- while (waitpid(pid, &wstat, 0) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- if (WIFEXITED(wstat))
- return WEXITSTATUS(wstat);
- else if (WIFSIGNALED(wstat)) {
- ghc_errtype = ERR_INTERRUPTED;
- ghc_errstr = "system command interrupted";
- }
- else {
- /* This should never happen */
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "internal error (process neither exited nor signalled)";
- }
- return -1;
-#endif
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: timezone.c,v 1.2 1998/12/02 13:28:00 simonm Exp $
+ *
+ * Timezone Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+#include "timezone.h"
+
+StgInt get_tm_sec ( StgAddr x ) { return ((struct tm*)x)->tm_sec; }
+StgInt get_tm_min ( StgAddr x ) { return ((struct tm*)x)->tm_min; }
+StgInt get_tm_hour ( StgAddr x ) { return ((struct tm*)x)->tm_hour; }
+StgInt get_tm_mday ( StgAddr x ) { return ((struct tm*)x)->tm_mday; }
+StgInt get_tm_mon ( StgAddr x ) { return ((struct tm*)x)->tm_mon; }
+StgInt get_tm_year ( StgAddr x ) { return ((struct tm*)x)->tm_year; }
+StgInt get_tm_wday ( StgAddr x ) { return ((struct tm*)x)->tm_wday; }
+StgInt get_tm_yday ( StgAddr x ) { return ((struct tm*)x)->tm_yday; }
+StgInt get_tm_isdst ( StgAddr x ) { return ((struct tm*)x)->tm_isdst; }
+StgAddr prim_ZONE ( StgAddr x ) { return ZONE(x); }
+StgInt prim_GMTOFF ( StgAddr x ) { return GMTOFF(x); }
+
+StgInt prim_SETZONE ( StgAddr x, StgAddr y )
+{
+ SETZONE(x,y);
+}
+
+StgInt sizeof_word ( void ) { return (sizeof(unsigned int)); }
+StgInt sizeof_struct_tm ( void ) { return (sizeof(struct tm)); }
+StgInt sizeof_time_t ( void ) { return (sizeof(time_t)); }
+
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: timezone.h,v 1.3 1998/12/02 13:28:01 simonm Exp $
+ *
+ * Time-zone support header
+ */
+
#ifndef TIMEZONE_H
#define TIMEZONE_H
#define _OSF_SOURCE
+#if HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
+
#if linux_TARGET_OS
/* Sigh, RedHat 5 has the TM_ZONE stuff, but only when _BSD_SOURCE is
* on. The configure script erroneously says we've got TM_ZONE, so
#else /* ! HAVE_TM_ZONE */
# if HAVE_TZNAME || cygwin32_TARGET_OS
#if cygwin32_TARGET_OS
-extern char *tzname;
-#else
-extern char *tzname[2];
+#define tzname _tzname
#endif
+extern char *tzname[2];
# define ZONE(x) (((struct tm *)x)->tm_isdst ? tzname[1] : tzname[0])
# define SETZONE(x,z)
# else /* ! HAVE_TZNAME */
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: toClockSec.c,v 1.3 1998/12/02 13:28:01 simonm Exp $
+ *
+ * toClockSec Runtime Support
+ */
+
+#include "Rts.h"
+#include "timezone.h"
+#include "stgio.h"
+
+StgAddr
+toClockSec(I_ year, I_ mon, I_ mday, I_ hour, I_ min, I_ sec, I_ isdst, StgByteArray res)
+{
+ struct tm tm;
+ time_t t;
+
+ tm.tm_year = year - 1900;
+ tm.tm_mon = mon;
+ tm.tm_mday = mday;
+ tm.tm_hour = hour;
+ tm.tm_min = min;
+ tm.tm_sec = sec;
+ tm.tm_isdst = isdst;
+
+#ifdef HAVE_MKTIME
+ t = mktime(&tm);
+#else
+#ifdef HAVE_TIMELOCAL
+ t = timelocal(&tm);
+#else
+ t = (time_t) -1;
+#endif
+#endif
+ if (t == (time_t) -1)
+ return NULL;
+
+ *(time_t *)res = t;
+ return res;
+}
+
+StgInt
+prim_toClockSec(I_ year, I_ mon, I_ mday, I_ hour, I_ min, I_ sec, I_ isdst, StgByteArray res)
+{
+ struct tm tm;
+ time_t t;
+
+ tm.tm_year = year - 1900;
+ tm.tm_mon = mon;
+ tm.tm_mday = mday;
+ tm.tm_hour = hour;
+ tm.tm_min = min;
+ tm.tm_sec = sec;
+ tm.tm_isdst = isdst;
+
+#ifdef HAVE_MKTIME
+ t = mktime(&tm);
+#else
+#ifdef HAVE_TIMELOCAL
+ t = timelocal(&tm);
+#else
+ t = (time_t) -1;
+#endif
+#endif
+ if (t == (time_t) -1)
+ return 0;
+
+ *(time_t *)res = t;
+ return 1;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[toClockSec.lc]{toClockSec Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "timezone.h"
-#include "stgio.h"
-
-StgAddr
-toClockSec(I_ year, I_ mon, I_ mday, I_ hour, I_ min, I_ sec, I_ isdst, StgByteArray res)
-{
- struct tm tm;
- time_t t;
-
- tm.tm_year = year - 1900;
- tm.tm_mon = mon;
- tm.tm_mday = mday;
- tm.tm_hour = hour;
- tm.tm_min = min;
- tm.tm_sec = sec;
- tm.tm_isdst = isdst;
-
-#ifdef HAVE_MKTIME
- t = mktime(&tm);
-#else
-#ifdef HAVE_TIMELOCAL
- t = timelocal(&tm);
-#else
- t = (time_t) -1;
-#endif
-#endif
- if (t == (time_t) -1)
- return NULL;
-
- *(time_t *)res = t;
- return res;
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: toLocalTime.c,v 1.3 1998/12/02 13:28:02 simonm Exp $
+ *
+ * toCalendarTime Runtime Support
+ */
+
+#include "Rts.h"
+#include "timezone.h"
+#include "stgio.h"
+
+StgAddr
+toLocalTime(I_ size, StgByteArray d, StgByteArray res)
+{
+ struct tm *tm,*tmp=(struct tm *)res;
+ time_t t;
+
+ switch(size) {
+ default:
+ return NULL;
+ case 0:
+ t = 0;
+ break;
+ case -1:
+ t = - (time_t) ((StgInt *)d)[0];
+ if (t > 0)
+ return NULL;
+ break;
+ case 1:
+ t = (time_t) ((StgInt *)d)[0];
+ if (t < 0)
+ return NULL;
+ break;
+ }
+ tm = localtime(&t);
+
+ if (tm == NULL)
+ return NULL;
+
+ /*
+ localtime() may return a ptr to statically allocated storage,
+ so to make toLocalTime reentrant, we manually copy
+ the structure into the (struct tm *) passed in.
+ */
+ tmp->tm_sec = tm->tm_sec;
+ tmp->tm_min = tm->tm_min;
+ tmp->tm_hour = tm->tm_hour;
+ tmp->tm_mday = tm->tm_mday;
+ tmp->tm_mon = tm->tm_mon;
+ tmp->tm_year = tm->tm_year;
+ tmp->tm_wday = tm->tm_wday;
+ tmp->tm_yday = tm->tm_yday;
+ tmp->tm_isdst = tm->tm_isdst;
+ /*
+ If you don't have tm_zone in (struct tm), but
+ you get at it via the shared tmzone[], you'll
+ lose. Same goes for the tm_gmtoff field.
+
+ */
+#if HAVE_TM_ZONE
+ strcpy(tmp->tm_zone,tm->tm_zone);
+ tmp->tm_gmtoff = tm->tm_gmtoff;
+#endif
+
+ return (StgAddr)res;
+}
+
+/* Note that we DO NOT return res as a result.
+ * res is typically a MutableByteArray and it seems very dubious
+ * to return a pointer into the middle of it.
+ */
+StgInt prim_toLocalTime ( StgInt64 d, StgByteArray res)
+{
+ struct tm *tm,*tmp=(struct tm *)res;
+ time_t t = (time_t) d;
+
+ if (t < 0)
+ return 0;
+
+ tm = localtime(&t);
+
+ if (tm == NULL)
+ return 0;
+
+ /*
+ localtime() may return a ptr to statically allocated storage,
+ so to make toLocalTime reentrant, we manually copy
+ the structure into the (struct tm *) passed in.
+ */
+ tmp->tm_sec = tm->tm_sec;
+ tmp->tm_min = tm->tm_min;
+ tmp->tm_hour = tm->tm_hour;
+ tmp->tm_mday = tm->tm_mday;
+ tmp->tm_mon = tm->tm_mon;
+ tmp->tm_year = tm->tm_year;
+ tmp->tm_wday = tm->tm_wday;
+ tmp->tm_yday = tm->tm_yday;
+ tmp->tm_isdst = tm->tm_isdst;
+ /*
+ If you don't have tm_zone in (struct tm), but
+ you get at it via the shared tmzone[], you'll
+ lose. Same goes for the tm_gmtoff field.
+
+ */
+#if HAVE_TM_ZONE
+ strcpy(tmp->tm_zone,tm->tm_zone);
+ tmp->tm_gmtoff = tm->tm_gmtoff;
+#endif
+
+ return 1;
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[toLocalTime.lc]{toCalendarTime Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "timezone.h"
-#include "stgio.h"
-
-StgAddr
-toLocalTime(I_ size, StgByteArray d, StgByteArray res)
-{
- struct tm *tm,*tmp=(struct tm *)res;
- time_t t;
-
- switch(size) {
- default:
- return NULL;
- case 0:
- t = 0;
- break;
- case -1:
- t = - (time_t) ((StgInt *)d)[0];
- if (t > 0)
- return NULL;
- break;
- case 1:
- t = (time_t) ((StgInt *)d)[0];
- if (t < 0)
- return NULL;
- break;
- }
- tm = localtime(&t);
-
- if (tm == NULL)
- return NULL;
-
- /*
- localtime() may return a ptr to statically allocated storage,
- so to make toLocalTime reentrant, we manually copy
- the structure into the (struct tm *) passed in.
- */
- tmp->tm_sec = tm->tm_sec;
- tmp->tm_min = tm->tm_min;
- tmp->tm_hour = tm->tm_hour;
- tmp->tm_mday = tm->tm_mday;
- tmp->tm_mon = tm->tm_mon;
- tmp->tm_year = tm->tm_year;
- tmp->tm_wday = tm->tm_wday;
- tmp->tm_yday = tm->tm_yday;
- tmp->tm_isdst = tm->tm_isdst;
- /*
- If you don't have tm_zone in (struct tm), but
- you get at it via the shared tmzone[], you'll
- lose. Same goes for the tm_gmtoff field.
-
- */
-#if HAVE_TM_ZONE
- strcpy(tmp->tm_zone,tm->tm_zone);
- tmp->tm_gmtoff = tm->tm_gmtoff;
-#endif
-
- return (StgAddr)res;
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: toUTCTime.c,v 1.3 1998/12/02 13:28:04 simonm Exp $
+ *
+ * toUTCTime Runtime Support
+ */
+
+#include "Rts.h"
+#include "timezone.h"
+#include "stgio.h"
+
+StgAddr
+toUTCTime(I_ size, StgByteArray d, StgByteArray res)
+{
+ time_t t;
+ struct tm *tm,*tmp=(struct tm *)res;
+
+ switch(size) {
+ default:
+ return NULL;
+ case 0:
+ t = 0;
+ break;
+ case -1:
+ t = - (time_t) ((StgInt *)d)[0];
+ if (t > 0)
+ return NULL;
+ break;
+ case 1:
+ t = (time_t) ((StgInt *)d)[0];
+ if (t < 0)
+ return NULL;
+ break;
+ }
+ tm = gmtime(&t);
+
+ if (tm == NULL)
+ return NULL;
+
+ /*
+ gmtime() may return a ptr to statically allocated storage,
+ so to make toUTCTime reentrant, we manually copy
+ the structure into the (struct tm *) passed in.
+ */
+ tmp->tm_sec = tm->tm_sec;
+ tmp->tm_min = tm->tm_min;
+ tmp->tm_hour = tm->tm_hour;
+ tmp->tm_mday = tm->tm_mday;
+ tmp->tm_mon = tm->tm_mon;
+ tmp->tm_year = tm->tm_year;
+ tmp->tm_wday = tm->tm_wday;
+ tmp->tm_yday = tm->tm_yday;
+ tmp->tm_isdst = tm->tm_isdst;
+ /*
+ If you don't have tm_zone in (struct tm), but
+ you get at it via the shared tmzone[], you'll
+ lose. Same goes for the tm_gmtoff field.
+
+ */
+#if HAVE_TM_ZONE
+ strcpy(tmp->tm_zone,tm->tm_zone);
+ tmp->tm_gmtoff = tm->tm_gmtoff;
+#endif
+
+ return (StgAddr)res;
+}
+
+StgInt
+prim_toUTCTime(StgInt64 d, StgByteArray res)
+{
+ time_t t;
+ struct tm *tm,*tmp=(struct tm *)res;
+
+ t = (time_t) d;
+ if (t < 0)
+ return 0;
+
+ tm = gmtime(&t);
+
+ if (tm == NULL)
+ return 0;
+
+ /*
+ gmtime() may return a ptr to statically allocated storage,
+ so to make toUTCTime reentrant, we manually copy
+ the structure into the (struct tm *) passed in.
+ */
+ tmp->tm_sec = tm->tm_sec;
+ tmp->tm_min = tm->tm_min;
+ tmp->tm_hour = tm->tm_hour;
+ tmp->tm_mday = tm->tm_mday;
+ tmp->tm_mon = tm->tm_mon;
+ tmp->tm_year = tm->tm_year;
+ tmp->tm_wday = tm->tm_wday;
+ tmp->tm_yday = tm->tm_yday;
+ tmp->tm_isdst = tm->tm_isdst;
+ /*
+ If you don't have tm_zone in (struct tm), but
+ you get at it via the shared tmzone[], you'll
+ lose. Same goes for the tm_gmtoff field.
+
+ */
+#if HAVE_TM_ZONE
+ strcpy(tmp->tm_zone,tm->tm_zone);
+ tmp->tm_gmtoff = tm->tm_gmtoff;
+#endif
+
+ return 1;
+}
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\subsection[toUTCTime.lc]{toUTCTime Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "timezone.h"
-#include "stgio.h"
-
-#ifdef cygwin32_TARGET_OS
-extern char *_tzname;
-char *tzname;
-#endif
-
-StgAddr
-toUTCTime(I_ size, StgByteArray d, StgByteArray res)
-{
- time_t t;
- struct tm *tm,*tmp=(struct tm *)res;
-
- switch(size) {
- default:
- return NULL;
- case 0:
- t = 0;
- break;
- case -1:
- t = - (time_t) ((StgInt *)d)[0];
- if (t > 0)
- return NULL;
- break;
- case 1:
- t = (time_t) ((StgInt *)d)[0];
- if (t < 0)
- return NULL;
- break;
- }
- tm = gmtime(&t);
-
- if (tm == NULL)
- return NULL;
-
- /*
- gmtime() may return a ptr to statically allocated storage,
- so to make toUTCTime reentrant, we manually copy
- the structure into the (struct tm *) passed in.
- */
- tmp->tm_sec = tm->tm_sec;
- tmp->tm_min = tm->tm_min;
- tmp->tm_hour = tm->tm_hour;
- tmp->tm_mday = tm->tm_mday;
- tmp->tm_mon = tm->tm_mon;
- tmp->tm_year = tm->tm_year;
- tmp->tm_wday = tm->tm_wday;
- tmp->tm_yday = tm->tm_yday;
- tmp->tm_isdst = tm->tm_isdst;
- /*
- If you don't have tm_zone in (struct tm), but
- you get at it via the shared tmzone[], you'll
- lose. Same goes for the tm_gmtoff field.
-
- */
-#if HAVE_TM_ZONE
- strcpy(tmp->tm_zone,tm->tm_zone);
- tmp->tm_gmtoff = tm->tm_gmtoff;
-#endif
-
- return (StgAddr)res;
-}
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1998
+ *
+ * $Id: writeError.c,v 1.2 1998/12/02 13:28:05 simonm Exp $
+ *
+ * hPutStr Runtime Support
+ */
+
+/*
+Writing out error messages. This is done outside Haskell
+(i.e., no use of the IO implementation is made), since it
+might be in an unstable state (e.g., hClose stderr >> error "foo")
+
+(A secondary reason is that ``error'' is used by the IO
+implementation in one or two places.)
+
+*/
+
+#include "Rts.h"
+#include "stgio.h"
+
+void
+writeErrString__ (msg_hdr, msg, len)
+StgAddr msg_hdr;
+StgByteArray msg;
+StgInt len;
+{
+ int count = 0;
+ char* p = (char*)msg;
+ char nl = '\n';
+
+ /* Print error msg header */
+ if (msg_hdr) {
+ ((void (*)(int))msg_hdr)(2/*stderr*/);
+ }
+
+ while ( (count = write(2,p,len)) < len) {
+ if (errno != EINTR ) {
+ return;
+ }
+ len -= count;
+ p += count;
+ }
+ write(2, &nl, 1);
+}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-
-Writing out error messages. This is done outside Haskell
-(i.e., no use of the IO implementation is made), since it
-might be in an unstable state (e.g., hClose stderr >> error "foo")
-
-(A secondary reason is that ``error'' is used by the IO
-implementation in one or two places.)
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-void
-writeErrString__ (msg_hdr, msg, len)
-StgAddr msg_hdr;
-StgByteArray msg;
-StgInt len;
-{
- int count = 0;
- char* p = (char*)msg;
- char nl = '\n';
-
- /* Print error msg header */
- ((void (*)(int))msg_hdr)(2/*stderr*/);
-
- while ( (count = write(2,p,len)) < len) {
- if (errno != EINTR ) {
- return;
- }
- len -= count;
- p += count;
- }
- write(2, &nl, 1);
-}
-
-\end{code}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: writeFile.c,v 1.3 1998/12/02 13:28:07 simonm Exp $
+ *
+ * hPutStr Runtime Support
+ */
+
+#include "Rts.h"
+#include "stgio.h"
+
+StgInt
+writeFileObject(ptr, bytes)
+StgForeignPtr ptr;
+StgInt bytes;
+{
+ int rc=0;
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ char *p = (char *) fo->buf;
+
+ /* If we've got a r/w file object in our hand, flush the
+ (input) buffer contents first.
+ */
+ if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
+ fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
+ rc = flushReadBuffer(ptr);
+ if (rc < 0) return rc;
+ }
+
+ return (writeBuffer(ptr, bytes));
+}
+
+StgInt
+writeBuffer(ptr, bytes)
+StgForeignPtr ptr;
+StgInt bytes;
+{
+ int count, rc=0;
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ char *p = (char *) fo->buf;
+
+ /* Disallow short writes */
+ if (bytes == 0 || fo->buf == NULL)
+ return 0;
+
+ if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady(ptr,0) != 1 )
+ return FILEOBJ_BLOCKED_WRITE;
+
+ while ((count = write(fo->fd, fo->buf, bytes)) < bytes) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ bytes -= count;
+ p += count;
+ }
+ /* Signal that we've emptied the buffer */
+ fo->bufWPtr=0;
+ return 0;
+}
+
+
+StgInt
+writeBuf(ptr, buf, len)
+StgForeignPtr ptr;
+StgAddr buf;
+StgInt len;
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int count;
+ int rc = 0;
+ char *p = (char *) buf;
+
+ if (len == 0 )
+ return 0;
+
+ /* First of all, check if we do need to flush the buffer .. */
+ /* Note - in the case of line buffering, we do not currently check
+ whether we need to flush buffer due to line terminators in the
+ buffer we're outputting */
+ if ( fo->buf != NULL && /* buffered and */
+ (fo->bufWPtr + len < (fo->bufSize)) /* there's room */
+ ) {
+ /* Block copying is likely to be cheaper than, flush, followed by write */
+ memcpy(((char*)fo->buf + fo->bufWPtr), buf, len);
+ fo->bufWPtr += len;
+ return 0;
+ }
+ /* If we do overflow, flush current contents of the buffer and
+ directly output the chunk.
+ (no attempt at splitting up the chunk is currently made)
+ */
+ if ( fo->buf != NULL && /* buffered and */
+ (fo->bufWPtr + len >= (fo->bufSize)) /* there's not room */
+ ) {
+ /* Flush buffer */
+ rc = writeFileObject(ptr, fo->bufWPtr);
+ /* ToDo: undo buffer fill if we're blocking.. */
+ }
+
+ if (rc != 0) {
+ return rc;
+ }
+
+ if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady(ptr,0) != 1 )
+ return FILEOBJ_BLOCKED_WRITE;
+
+ /* Disallow short writes */
+ while ((count = write(fo->fd, (char *)buf, (int)len)) < len) {
+ if (errno != EINTR) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ len -= count;
+ p += count;
+ }
+
+ return 0;
+}
+
+StgInt
+writeBufBA(ptr, buf, len)
+ StgForeignPtr ptr;
+StgByteArray buf;
+StgInt len;
+{ return (writeBuf(ptr,(StgAddr)buf, len)); }
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994
-%
-\subsection[writeFile.lc]{hPutStr Runtime Support}
-
-\begin{code}
-
-#include "rtsdefs.h"
-#include "stgio.h"
-
-StgInt
-writeFileObject(ptr, bytes)
-StgForeignObj ptr;
-StgInt bytes;
-{
- int rc=0;
- IOFileObject* fo = (IOFileObject*)ptr;
-
- char *p = (char *) fo->buf;
-
- /* If we've got a r/w file object in our hand, flush the
- (input) buffer contents first.
- */
- if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
- fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
- rc = flushReadBuffer(ptr);
- if (rc < 0) return rc;
- }
-
- return (writeBuffer(ptr, bytes));
-}
-
-StgInt
-writeBuffer(ptr, bytes)
-StgForeignObj ptr;
-StgInt bytes;
-{
- int count, rc=0;
- IOFileObject* fo = (IOFileObject*)ptr;
-
- char *p = (char *) fo->buf;
-
- /* Disallow short writes */
- if (bytes == 0 || fo->buf == NULL)
- return 0;
-
- if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady(ptr,0) != 1 )
- return FILEOBJ_BLOCKED_WRITE;
-
- while ((count = write(fo->fd, fo->buf, bytes)) < bytes) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- bytes -= count;
- p += count;
- }
- /* Signal that we've emptied the buffer */
- fo->bufWPtr=0;
- return 0;
-}
-
-
-StgInt
-writeBuf(ptr, buf, len)
-StgForeignObj ptr;
-StgAddr buf;
-StgInt len;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int count;
- int rc = 0;
- char *p = (char *) buf;
-
- if (len == 0 )
- return 0;
-
-
- /* First of all, check if we do need to flush the buffer .. */
- /* Note - in the case of line buffering, we do not currently check
- whether we need to flush buffer due to line terminators in the
- buffer we're outputting */
- if ( fo->buf != NULL && /* buffered and */
- (fo->bufWPtr + len < (fo->bufSize)) /* there's room */
- ) {
- /* Block copying is likely to be cheaper than, flush, followed by write */
- memcpy(((char*)fo->buf + fo->bufWPtr), buf, len);
- fo->bufWPtr += len;
- return 0;
- }
- /* If we do overflow, flush current contents of the buffer and
- directly output the chunk.
- (no attempt at splitting up the chunk is currently made)
- */
- if ( fo->buf != NULL && /* buffered and */
- (fo->bufWPtr + len >= (fo->bufSize)) /* there's not room */
- ) {
- /* Flush buffer */
- rc = writeFileObject(ptr, fo->bufWPtr);
- /* ToDo: undo buffer fill if we're blocking.. */
- }
-
- if (rc != 0) {
- return rc;
- }
-
- if ( fo->flags & FILEOBJ_NONBLOCKING_IO && inputReady(ptr,0) != 1 )
- return FILEOBJ_BLOCKED_WRITE;
-
- /* Disallow short writes */
- while ((count = write(fo->fd, (char *)buf, (int)len)) < len) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- len -= count;
- p += count;
- }
-
- return 0;
-}
-
-StgInt
-writeBufBA(ptr, buf, len)
-StgForeignObj ptr;
-StgByteArray buf;
-StgInt len;
-{ return (writeBuf(ptr,(StgAddr)buf, len)); }
-
-
-\end{code}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * Foreign export adjustor thunks
+ *
+ * Copyright (c) 1998.
+ *
+ * ---------------------------------------------------------------------------*/
+
+/* A little bit of background...
+
+An adjustor thunk is a dynamically allocated code snippet that allows
+Haskell closures to be viewed as C function pointers.
+
+Stable pointers provide a way for the outside world to get access to,
+and evaluate, Haskell heap objects, with the RTS providing a small
+range of ops for doing so. So, assuming we've got a stable pointer in
+our hand in C, we can jump into the Haskell world and evaluate a callback
+procedure, say. This works OK in some cases where callbacks are used, but
+does require the external code to know about stable pointers and how to deal
+with them. We'd like to hide the Haskell-nature of a callback and have it
+be invoked just like any other C function pointer.
+
+Enter adjustor thunks. An adjustor thunk is a little piece of code
+that's generated on-the-fly (one per Haskell closure being exported)
+that, when entered using some 'universal' calling convention (e.g., the
+C calling convention on platform X), pushes an implicit stable pointer
+(to the Haskell callback) before calling another (static) C function stub
+which takes care of entering the Haskell code via its stable pointer.
+
+An adjustor thunk is allocated on the C heap, and is called from within
+Haskell just before handing out the function pointer to the Haskell (IO)
+action. User code should never have to invoke it explicitly.
+
+An adjustor thunk differs from a C function pointer in one respect: when
+the code is through with it, it has to be freed in order to release Haskell
+and C resources. Failure to do so result in memory leaks on both the C and
+Haskell side.
+
+*/
+#include "Rts.h"
+#include "RtsUtils.h"
+
+/* Heavily arch-specific, I'm afraid.. */
+#if defined(i386_TARGET_ARCH)
+char*
+createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
+{
+ void *adjustor,*adj;
+ unsigned char* adj_code;
+ int i;
+ size_t sizeof_adjustor;
+
+ if (cconv == 0) { /* the adjustor will be _stdcall'ed */
+
+ /* Magic constant computed by inspecting the code length of
+ the following assembly language snippet
+ (offset and machine code prefixed):
+
+ <0>: 58 popl %eax # temp. remove ret addr..
+ <1>: 68 63 fd fc fe fa pushl 0xfafefcfd # constant is large enough to
+ # hold a StgStablePtr
+ <6>: 50 pushl %eax # put back ret. addr
+ <7>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr
+ <c>: ff e0 jmp %eax # and jump to it.
+ # the callee cleans up the it will then clean up the stack
+ */
+ sizeof_adjustor = 15*sizeof(char);
+
+ if ((adjustor = stgMallocBytes(sizeof_adjustor,"createAdjustor")) == NULL) {
+ return NULL;
+ }
+
+ adj_code = (unsigned char*)adjustor;
+ adj_code[0] = (unsigned char)0x58; /* popl %eax */
+ adj_code[1] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */
+
+ adj = (StgStablePtr*)(adj_code+2);
+ *((StgStablePtr*)adj) = (StgStablePtr)hptr;
+
+ i = 2 + sizeof(StgStablePtr);
+ adj_code[i] = (unsigned char)0x50; /* pushl %eax */
+ adj_code[i+1] = (unsigned char)0xb8; /* movl $wptr, %eax */
+ adj = (char*)(adj_code+i+2);
+ *((StgFunPtr*)adj) = (StgFunPtr)wptr;
+
+ i = i+2+sizeof(StgFunPtr);
+ adj_code[i] = (unsigned char)0xff; /* jmp %eax */
+ adj_code[i+1] = (unsigned char)0xe0;
+
+ } else { /* the adjustor will be _ccall'ed */
+
+ /* Magic constant computed by inspecting the code length of
+ the following assembly language snippet
+ (offset and machine code prefixed):
+
+ <0>: 58 popl %eax # temp. remove ret addr..
+ <1>: 68 63 fd fc fe fa pushl 0xfafefcfd # constant is large enough to
+ # hold a StgStablePtr
+ <6>: 50 pushl %eax # put back ret. addr
+ <7>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr
+ <c>: ff d0 call %eax # and call it.
+ <e>: 58 popl %eax # store away return address.
+ <f>: 83 c4 04 addl $0x4,%esp # remove stable pointer
+ <12>: 50 pushl %eax # put back return address.
+ <13>: c3 ret # return to where you came from.
+
+ */
+ sizeof_adjustor = 20*sizeof(char);
+
+ if ((adjustor = stgMallocBytes(sizeof_adjustor,"createAdjustor")) == NULL) {
+ return NULL;
+ }
+
+ adj_code = (unsigned char*)adjustor;
+ adj_code[0] = (unsigned char)0x58; /* popl %eax */
+ adj_code[1] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */
+
+ adj = (StgStablePtr*)(adj_code+2);
+ *((StgStablePtr*)adj) = (StgStablePtr)hptr;
+
+ i = 2 + sizeof(StgStablePtr);
+ adj_code[i] = (unsigned char)0x50; /* pushl %eax */
+ adj_code[i+1] = (unsigned char)0xb8; /* movl $wptr, %eax */
+ adj = (char*)(adj_code+i+2);
+ *((StgFunPtr*)adj) = (StgFunPtr)wptr;
+
+ i = i+2+sizeof(StgFunPtr);
+ adj_code[i] = (unsigned char)0xff; /* call %eax */
+ adj_code[i+1] = (unsigned char)0xd0;
+ adj_code[i+2] = (unsigned char)0x58; /* popl %eax */
+ adj_code[i+3] = (unsigned char)0x83; /* addl $0x4, %esp */
+ adj_code[i+4] = (unsigned char)0xc4;
+ adj_code[i+5] = (unsigned char)0x04;
+ adj_code[i+6] = (unsigned char)0x50; /* pushl %eax */
+ adj_code[i+7] = (unsigned char)0xc3; /* ret */
+ }
+
+ /* Have fun! */
+ return (adjustor);
+}
+
+void
+freeHaskellFunctionPtr(void* ptr)
+{
+ char* tmp;
+
+ /* Free the stable pointer first..*/
+ tmp=(char*)ptr+2;
+ freeStablePointer(*((StgStablePtr*)tmp));
+
+ free(ptr);
+}
+
+#endif /* i386_TARGET_ARCH */
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Bytecode assembler
+ *
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: Assembler.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:28:09 $
+ *
+ * This module provides functions to construct BCOs and other closures
+ * required by the bytecode compiler.
+ *
+ * It is supposed to shield the compiler from platform dependent information
+ * such as:
+ *
+ * o sizeof(StgFloat)
+ * o sizeof(I#)
+ *
+ * and from details of how the abstract machine is implemented such as:
+ *
+ * o what does a BCO look like?
+ * o how many bytes does the "Push InfoTable" instruction require?
+ *
+ * Details of design:
+ * o (To handle letrecs) We allocate Aps, Paps and Cons using number of
+ * heap allocated args to determine size.
+ * We can't handle unboxed args :-(
+ * o All stack offsets are relative to position of Sp at start of
+ * function or thunk (not BCO - consider continuations)
+ * o Active thunks must be roots during GC - how to achieve this?
+ * o Each BCO contains its own stack and heap check
+ * We don't try to exploit the Hp check optimisation - easier to make
+ * each thunk stand on its own.
+ * o asBind returns a "varid" (which is, in fact, a stack offset)
+ * asVar acts on a "varid" - combining it with the current stack size to
+ * determine actual position
+ * o Assembler.h uses totally neutral types: strings, floats, ints, etc
+ * to minimise conflicts with other parts of the system.
+ * Simulated Stack
+ * ------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef INTERPRETER
+
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "Bytecodes.h"
+#include "Printer.h"
+#include "Disassembler.h"
+#include "Evaluator.h"
+#include "StgMiscClosures.h"
+#include "Storage.h"
+
+#define INSIDE_ASSEMBLER_C
+#include "Assembler.h"
+#undef INSIDE_ASSEMBLER_C
+
+/* --------------------------------------------------------------------------
+ * References between BCOs
+ *
+ * These are necessary because there can be circular references between
+ * BCOs so we have to keep track of all the references to each object
+ * and fill in all the references once we're done.
+ *
+ * ToDo: generalise to allow references between any objects
+ * ------------------------------------------------------------------------*/
+
+typedef struct {
+ AsmObject ref; /* who refers to it */
+ AsmNat i; /* index into some table held by referer */
+} AsmRef;
+
+/* --------------------------------------------------------------------------
+ * Queues (of instructions, ptrs, nonptrs)
+ * ------------------------------------------------------------------------*/
+
+/* ToDo: while debugging, we use a chunk size of 1 to stress-test the code
+ * this should be fine-tuned using statistics on common sizes
+ */
+
+#define InstrsChunkSize 40
+#define PtrsChunkSize 10
+#define RefsChunkSize 10
+#define NonPtrsChunkSize 10
+
+#define Queue Instrs
+#define Type StgNat8
+#include "QueueTemplate.h"
+#undef Type
+#undef Queue
+
+#define Queue Ptrs
+#define Type AsmObject
+#include "QueueTemplate.h"
+#undef Type
+#undef Queue
+
+#define Queue Refs
+#define Type AsmRef
+#include "QueueTemplate.h"
+#undef Type
+#undef Queue
+
+#define Queue NonPtrs
+#define Type StgWord
+#include "QueueTemplate.h"
+#undef Type
+#undef Queue
+
+/* --------------------------------------------------------------------------
+ * AsmObjects are used to build heap objects.
+ *
+ * AsmObjects can contain circular references to each other
+ * so we have to keep track of all the references which can't be filled
+ * in yet.
+ *
+ * When we finish building an AsmObject, we allocate an actual heap object and
+ * fill in all the references to the asmObject with pointers to the heap object.
+ *
+ * We obtain a limited form of polymorphism through inheritance by putting
+ * the AsmObject first in every structure (as in C++ implementations).
+ * We use the closure type of the allocated object to figure out
+ * where the payload lives in the closure.
+ * ------------------------------------------------------------------------*/
+/* ToDo: clean up terminology: is Closure right or should it be object or ... */
+
+struct AsmObject_ {
+ Refs refs;
+ Ptrs ptrs;
+ AsmNat num_unresolved; /* number of unfilled references */
+ StgClosure* closure; /* where object was allocated */
+};
+
+struct AsmCon_ {
+ struct AsmObject_ object; /* must be first in struct */
+
+ AsmInfo info;
+};
+
+struct AsmCAF_ {
+ struct AsmObject_ object; /* must be first in struct */
+};
+
+struct AsmBCO_ {
+ struct AsmObject_ object; /* must be first in struct */
+
+ Instrs is;
+ NonPtrs nps;
+
+ /* abstract machine ("executed" during compilation) */
+ AsmSp sp; /* stack ptr */
+ AsmSp max_sp;
+ StgWord hp; /* heap ptr */
+ StgWord max_hp;
+};
+
+static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference )
+{
+ ASSERT(obj->closure);
+ switch (get_itbl(obj->closure)->type) {
+ case BCO:
+ {
+ StgBCO* bco = stgCast(StgBCO*,obj->closure);
+ ASSERT(i < bco->n_ptrs && bcoConstPtr(bco,i) == NULL);
+ bcoConstCPtr(bco,i) = reference;
+ break;
+ }
+ case CAF_UNENTERED:
+ {
+ StgCAF* caf = stgCast(StgCAF*,obj->closure);
+ ASSERT(i == 0 && caf->body == NULL);
+ caf->body = reference;
+ break;
+ }
+ case CONSTR:
+ {
+ StgClosure* con = stgCast(StgClosure*,obj->closure);
+ ASSERT(i < get_itbl(con)->layout.payload.nptrs && payloadCPtr(con,i) == NULL);
+ payloadCPtr(con,i) = reference;
+ break;
+ }
+ case AP_UPD:
+ {
+ StgAP_UPD* ap = stgCast(StgAP_UPD*,obj->closure);
+ ASSERT(i < 1+ap->n_args);
+ if (i==0) {
+ ASSERT(ap->fun == NULL);
+ ap->fun = reference;
+ } else {
+ ASSERT(payloadCPtr(ap,i-1) == NULL);
+ payloadCPtr(ap,i-1) = reference;
+ }
+ break;
+ }
+ default:
+ barf("asmResolveRef");
+ }
+ obj->num_unresolved -= 1;
+
+ if (obj->num_unresolved == 0) {
+ /* todo: free the queues */
+
+ /* we don't print until all ptrs are resolved */
+ IF_DEBUG(codegen,printObj(obj->closure));
+ }
+}
+
+static void asmAddRef( AsmObject referent, AsmObject referer, AsmNat i )
+{
+ if (referent->closure) {
+ asmResolveRef(referer,i,(AsmClosure)referent->closure);
+ } else {
+ insertRefs(&(referent->refs),(AsmRef){referer,i});
+ }
+}
+
+void asmAddPtr( AsmObject obj, AsmObject arg )
+{
+ ASSERT(obj->closure == 0); /* can't extend an object once it's allocated */
+ insertPtrs( &obj->ptrs, arg );
+}
+
+static void asmBeginObject( AsmObject obj )
+{
+ obj->closure = NULL;
+ obj->num_unresolved = 0;
+ initRefs(&obj->refs);
+ initPtrs(&obj->ptrs);
+}
+
+static void asmEndObject( AsmObject obj, StgClosure* c )
+{
+ obj->num_unresolved = obj->ptrs.len;
+ obj->closure = c;
+ mapQueue(Ptrs, AsmObject, obj->ptrs, asmAddRef(x,obj,i));
+ mapQueue(Refs, AsmRef, obj->refs, asmResolveRef(x.ref,x.i,c));
+ if (obj->num_unresolved == 0) {
+ /* todo: free the queues */
+ /* we don't print until all ptrs are resolved */
+ IF_DEBUG(codegen,printObj(obj->closure));
+ }
+}
+
+int asmObjectHasClosure ( AsmObject obj )
+{
+ return (obj->num_unresolved == 0 && obj->closure);
+}
+
+AsmClosure asmClosureOfObject ( AsmObject obj )
+{
+ ASSERT(asmObjectHasClosure(obj));
+ return obj->closure;
+}
+
+void asmMarkObject ( AsmObject obj )
+{
+ ASSERT(obj->num_unresolved == 0 && obj->closure);
+ obj->closure = MarkRoot(obj->closure);
+}
+
+/* --------------------------------------------------------------------------
+ * Heap allocation
+ * ------------------------------------------------------------------------*/
+
+static StgClosure* asmAlloc( nat size )
+{
+ StgClosure* o = stgCast(StgClosure*,allocate(size));
+ ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ /* printf("Allocated %p .. %p\n", o, o+size-1); */
+ return o;
+}
+
+static void grabHpUpd( AsmBCO bco, nat size )
+{
+ /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
+ ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
+ bco->hp += size;
+}
+
+static void grabHpNonUpd( AsmBCO bco, nat size )
+{
+ /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
+ ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ bco->hp += size;
+}
+
+static void resetHp( AsmBCO bco, nat hp )
+{
+ bco->max_hp = stg_max(bco->hp,bco->max_hp);
+ bco->hp = hp;
+}
+
+static void resetSp( AsmBCO bco, AsmSp sp )
+{
+ bco->max_sp = stg_max(bco->sp,bco->max_sp);
+ bco->sp = sp;
+}
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+AsmObject asmMkObject( AsmClosure c )
+{
+ AsmObject obj = malloc(sizeof(struct AsmObject_));
+ if (obj == NULL) {
+ barf("Can't allocate AsmObject");
+ }
+ asmBeginObject(obj);
+ asmEndObject(obj,c);
+ return obj;
+}
+
+AsmCon asmBeginCon( AsmInfo info )
+{
+ AsmCon con = malloc(sizeof(struct AsmCon_));
+ if (con == NULL) {
+ barf("Can't allocate AsmCon");
+ }
+ asmBeginObject(&con->object);
+ con->info = info;
+ return con;
+}
+
+void asmEndCon( AsmCon con )
+{
+ nat p = con->object.ptrs.len;
+ nat np = stg_max(0,MIN_NONUPD_SIZE-p);
+
+ StgClosure* c = asmAlloc(CONSTR_sizeW(p,np));
+ StgClosure* o = stgCast(StgClosure*,c);
+ SET_HDR(o,con->info,??);
+ mapQueue(Ptrs, AsmObject, con->object.ptrs, payloadCPtr(o,i) = NULL);
+ { nat i; for( i=0; i<np; ++i ) { payloadWord(o,p+i) = 0xdeadbeef; } }
+ asmEndObject(&con->object,c);
+}
+
+AsmCAF asmBeginCAF( void )
+{
+ AsmCAF caf = malloc(sizeof(struct AsmCAF_));
+ if (caf == NULL) {
+ barf("Can't allocate AsmCAF");
+ }
+ asmBeginObject(&caf->object);
+ return caf;
+}
+
+void asmEndCAF( AsmCAF caf, AsmBCO body )
+{
+ StgClosure* c = asmAlloc(CAF_sizeW());
+ StgCAF* o = stgCast(StgCAF*,c);
+ SET_HDR(o,&CAF_UNENTERED_info,??);
+ o->body = NULL;
+ o->value = stgCast(StgClosure*,0xdeadbeef);
+ o->link = stgCast(StgCAF*,0xdeadbeef);
+ asmAddPtr(&caf->object,&body->object);
+ asmEndObject(&caf->object,c);
+}
+
+AsmBCO asmBeginBCO( void )
+{
+ AsmBCO bco = malloc(sizeof(struct AsmBCO_));
+ if (bco == NULL) {
+ barf("Can't allocate AsmBCO");
+ }
+ asmBeginObject(&bco->object);
+ initInstrs(&bco->is);
+ initNonPtrs(&bco->nps);
+
+ bco->max_sp = bco->sp = 0;
+ bco->max_hp = bco->hp = 0;
+ return bco;
+}
+
+void asmEndBCO( AsmBCO bco )
+{
+ nat p = bco->object.ptrs.len;
+ nat np = bco->nps.len;
+#if 0
+ nat is = bco->is.len + 4; /* 4 for stack and heap checks */
+#else
+ nat is = bco->is.len + 2; /* 4 for stack check */
+#endif
+
+ StgClosure* c = asmAlloc(BCO_sizeW(p,np,is));
+ StgBCO* o = stgCast(StgBCO*,c);
+ SET_HDR(o,&BCO_info,??);
+ o->n_ptrs = p;
+ o->n_words = np;
+ o->n_instrs = is;
+ mapQueue(Ptrs, AsmObject, bco->object.ptrs, bcoConstCPtr(o,i) = NULL);
+ mapQueue(NonPtrs, StgWord, bco->nps, bcoConstWord(o,i) = x);
+ {
+ nat j = 0;
+ bco->max_sp = stg_max(bco->sp,bco->max_sp);
+ bco->max_hp = stg_max(bco->hp,bco->max_hp);
+ bcoInstr(o,j++) = i_STK_CHECK;
+ bcoInstr(o,j++) = bco->max_sp;
+#if 0
+ bcoInstr(o,j++) = i_HP_CHECK;
+ bcoInstr(o,j++) = bco->max_hp;
+#endif
+ mapQueue(Instrs, StgNat8, bco->is, bcoInstr(o,j++) = x);
+ ASSERT(j == is);
+ }
+ asmEndObject(&bco->object,c);
+}
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+static void asmInstr( AsmBCO bco, StgWord i )
+{
+ ASSERT(i < 256); /* must be a byte */
+ insertInstrs(&(bco->is),i);
+}
+
+static void asmPtr( AsmBCO bco, AsmObject x )
+{
+ insertPtrs( &bco->object.ptrs, x );
+}
+
+static void asmWord( AsmBCO bco, StgWord i )
+{
+ insertNonPtrs( &bco->nps, i );
+}
+
+#define asmWords(bco,ty,x) \
+ { \
+ union { ty a; AsmWord b[sizeofW(ty)]; } p; \
+ nat i; \
+ p.a = x; \
+ for( i = 0; i < sizeofW(ty); i++ ) { \
+ asmWord(bco,p.b[i]); \
+ } \
+ }
+
+static StgWord repSizeW( AsmRep rep )
+{
+ switch (rep) {
+ case CHAR_REP: return sizeofW(StgWord) + sizeofW(StgChar);
+
+ case BOOL_REP:
+ case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt);
+#ifdef PROVIDE_INT64
+ case INT64_REP: return sizeofW(StgWord) + sizeofW(StgInt64);
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord);
+#endif
+#ifdef PROVIDE_ADDR
+ case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr);
+#endif
+ case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat);
+ case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble);
+#ifdef PROVIDE_STABLE
+ case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord);
+#endif
+
+#ifdef PROVIDE_INTEGER
+ case INTEGER_REP:
+#endif
+#ifdef PROVIDE_WEAK
+ case WEAK_REP:
+#endif
+#ifdef PROVIDE_FOREIGN
+ case FOREIGN_REP:
+#endif
+ case ALPHA_REP: /* a */
+ case BETA_REP: /* b */
+ case GAMMA_REP: /* c */
+ case HANDLER_REP: /* IOError -> IO a */
+ case ERROR_REP: /* IOError */
+#ifdef PROVIDE_ARRAY
+ case ARR_REP : /* PrimArray a */
+ case BARR_REP : /* PrimByteArray a */
+ case REF_REP : /* Ref s a */
+ case MUTARR_REP : /* PrimMutableArray s a */
+ case MUTBARR_REP: /* PrimMutableByteArray s a */
+#endif
+#ifdef PROVIDE_CONCURRENT
+ case THREADID_REP: /* ThreadId */
+ case MVAR_REP: /* MVar a */
+#endif
+ case PTR_REP: return sizeofW(StgPtr);
+
+ case VOID_REP: return sizeofW(StgWord);
+ default: barf("repSizeW %d",rep);
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Arg checks.
+ * ------------------------------------------------------------------------*/
+
+AsmSp asmBeginArgCheck ( AsmBCO bco )
+{
+ ASSERT(bco->sp == 0);
+ return bco->sp;
+}
+
+void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg )
+{
+ nat args = bco->sp - last_arg;
+ if (args != 0) { /* optimisation */
+ asmInstr(bco,i_ARG_CHECK);
+ asmInstr(bco,args);
+ grabHpNonUpd(bco,PAP_sizeW(args-1));
+ resetHp(bco,0);
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Creating and using "variables"
+ * ------------------------------------------------------------------------*/
+
+AsmVar asmBind ( AsmBCO bco, AsmRep rep )
+{
+ bco->sp += repSizeW(rep);
+ return bco->sp;
+}
+
+void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep )
+{
+ switch (rep) {
+ case BOOL_REP:
+ case INT_REP:
+ asmInstr(bco,i_VAR_INT);
+ break;
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ asmInstr(bco,i_VAR_INT64);
+ break;
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ asmInstr(bco,i_VAR_WORD);
+ break;
+#endif
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ asmInstr(bco,i_VAR_ADDR);
+ break;
+#endif
+ case CHAR_REP:
+ asmInstr(bco,i_VAR_CHAR);
+ break;
+ case FLOAT_REP:
+ asmInstr(bco,i_VAR_FLOAT);
+ break;
+ case DOUBLE_REP:
+ asmInstr(bco,i_VAR_DOUBLE);
+ break;
+#ifdef PROVIDE_STABLE
+ case STABLE_REP:
+ asmInstr(bco,i_VAR_STABLE);
+ break;
+#endif
+
+#ifdef PROVIDE_INTEGER
+ case INTEGER_REP:
+#endif
+#ifdef PROVIDE_WEAK
+ case WEAK_REP:
+#endif
+#ifdef PROVIDE_FOREIGN
+ case FOREIGN_REP:
+#endif
+ case ALPHA_REP: /* a */
+ case BETA_REP: /* b */
+ case GAMMA_REP: /* c */
+ case HANDLER_REP: /* IOError -> IO a */
+ case ERROR_REP: /* IOError */
+#ifdef PROVIDE_ARRAY
+ case ARR_REP : /* PrimArray a */
+ case BARR_REP : /* PrimByteArray a */
+ case REF_REP : /* Ref s a */
+ case MUTARR_REP : /* PrimMutableArray s a */
+ case MUTBARR_REP: /* PrimMutableByteArray s a */
+#endif
+#ifdef PROVIDE_CONCURRENT
+ case THREADID_REP: /* ThreadId */
+ case MVAR_REP: /* MVar a */
+#endif
+ case PTR_REP:
+ asmInstr(bco,i_VAR);
+ break;
+
+ case VOID_REP:
+ asmInstr(bco,i_VOID);
+ bco->sp += repSizeW(rep);
+ return; /* NB we don't break! */
+ default:
+ barf("asmVar %d",rep);
+ }
+ asmInstr(bco,bco->sp - v);
+ bco->sp += repSizeW(rep);
+}
+
+/* --------------------------------------------------------------------------
+ * Tail calls
+ * ------------------------------------------------------------------------*/
+
+AsmSp asmBeginEnter( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndEnter( AsmBCO bco, AsmSp sp1, AsmSp sp2 )
+{
+ int x = bco->sp - sp1;
+ int y = sp1 - sp2;
+ ASSERT(x >= 0 && y >= 0);
+ if (y != 0) {
+ asmInstr(bco,i_SLIDE);
+ asmInstr(bco,x);
+ asmInstr(bco,y);
+ bco->sp -= sp1 - sp2;
+ }
+ asmInstr(bco,i_ENTER);
+}
+
+/* --------------------------------------------------------------------------
+ * Build boxed Ints, Floats, etc
+ * ------------------------------------------------------------------------*/
+
+AsmVar asmBox( AsmBCO bco, AsmRep rep )
+{
+ switch (rep) {
+ case CHAR_REP:
+ asmInstr(bco,i_PACK_CHAR);
+ grabHpNonUpd(bco,CZh_sizeW);
+ break;
+ case INT_REP:
+ asmInstr(bco,i_PACK_INT);
+ grabHpNonUpd(bco,IZh_sizeW);
+ break;
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ asmInstr(bco,i_PACK_INT64);
+ grabHpNonUpd(bco,I64Zh_sizeW);
+ break;
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ asmInstr(bco,i_PACK_WORD);
+ grabHpNonUpd(bco,WZh_sizeW);
+ break;
+#endif
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ asmInstr(bco,i_PACK_ADDR);
+ grabHpNonUpd(bco,AZh_sizeW);
+ break;
+#endif
+ case FLOAT_REP:
+ asmInstr(bco,i_PACK_FLOAT);
+ grabHpNonUpd(bco,FZh_sizeW);
+ break;
+ case DOUBLE_REP:
+ asmInstr(bco,i_PACK_DOUBLE);
+ grabHpNonUpd(bco,DZh_sizeW);
+ break;
+#ifdef PROVIDE_STABLE
+ case STABLE_REP:
+ asmInstr(bco,i_PACK_STABLE);
+ grabHpNonUpd(bco,StableZh_sizeW);
+ break;
+#endif
+
+ default:
+ barf("asmBox %d",rep);
+ }
+ /* NB: these operations DO pop their arg */
+ bco->sp -= repSizeW(rep); /* pop unboxed arg */
+ bco->sp += sizeofW(StgPtr); /* push box */
+ return bco->sp;
+}
+
+/* --------------------------------------------------------------------------
+ * Unbox Ints, Floats, etc
+ * ------------------------------------------------------------------------*/
+
+AsmVar asmUnbox( AsmBCO bco, AsmRep rep )
+{
+ switch (rep) {
+ case INT_REP:
+ asmInstr(bco,i_UNPACK_INT);
+ break;
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ asmInstr(bco,i_UNPACK_INT64);
+ break;
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ asmInstr(bco,i_UNPACK_WORD);
+ break;
+#endif
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ asmInstr(bco,i_UNPACK_ADDR);
+ break;
+#endif
+ case CHAR_REP:
+ asmInstr(bco,i_UNPACK_CHAR);
+ break;
+ case FLOAT_REP:
+ asmInstr(bco,i_UNPACK_FLOAT);
+ break;
+ case DOUBLE_REP:
+ asmInstr(bco,i_UNPACK_DOUBLE);
+ break;
+ case STABLE_REP:
+ asmInstr(bco,i_UNPACK_STABLE);
+ break;
+
+ default:
+ barf("asmUnbox %d",rep);
+ }
+ /* NB: these operations DO NOT pop their arg */
+ bco->sp += repSizeW(rep); /* push unboxed arg */
+ return bco->sp;
+}
+
+/* --------------------------------------------------------------------------
+ * Return unboxed Ints, Floats, etc
+ * ------------------------------------------------------------------------*/
+
+void asmReturnUnboxed( AsmBCO bco, AsmRep rep )
+{
+ switch (rep) {
+ case CHAR_REP:
+ asmInstr(bco,i_RETURN_CHAR);
+ break;
+ case INT_REP:
+ asmInstr(bco,i_RETURN_INT);
+ break;
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ asmInstr(bco,i_RETURN_INT64);
+ break;
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ asmInstr(bco,i_RETURN_WORD);
+ break;
+#endif
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ asmInstr(bco,i_RETURN_ADDR);
+ break;
+#endif
+ case FLOAT_REP:
+ asmInstr(bco,i_RETURN_FLOAT);
+ break;
+ case DOUBLE_REP:
+ asmInstr(bco,i_RETURN_DOUBLE);
+ break;
+#ifdef PROVIDE_STABLE
+ case STABLE_REP:
+ asmInstr(bco,i_RETURN_STABLE);
+ break;
+#endif
+#ifdef PROVIDE_INTEGER
+ case INTEGER_REP:
+#endif
+#ifdef PROVIDE_WEAK
+ case WEAK_REP:
+#endif
+#ifdef PROVIDE_FOREIGN
+ case FOREIGN_REP:
+#endif
+#ifdef PROVIDE_ARRAY
+ case ARR_REP : /* PrimArray a */
+ case BARR_REP : /* PrimByteArray a */
+ case REF_REP : /* Ref s a */
+ case MUTARR_REP : /* PrimMutableArray s a */
+ case MUTBARR_REP: /* PrimMutableByteArray s a */
+#endif
+#ifdef PROVIDE_CONCURRENT
+ case THREADID_REP: /* ThreadId */
+ case MVAR_REP: /* MVar a */
+#endif
+ asmInstr(bco,i_RETURN_GENERIC);
+ break;
+ default:
+ barf("asmReturnUnboxed %d",rep);
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Push unboxed Ints, Floats, etc
+ * ------------------------------------------------------------------------*/
+
+void asmConstInt( AsmBCO bco, AsmInt x )
+{
+ asmInstr(bco,i_CONST_INT);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmInt,x);
+ bco->sp += repSizeW(INT_REP);
+}
+
+#ifdef PROVIDE_INT64
+void asmConstInt64( AsmBCO bco, AsmInt64 x )
+{
+ asmInstr(bco,i_CONST_INT64);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmInt64,x);
+ bco->sp += repSizeW(INT64_REP);
+}
+#endif
+
+#ifdef PROVIDE_INTEGER
+void asmConstInteger( AsmBCO bco, AsmString x )
+{
+ asmInstr(bco,i_CONST_INTEGER);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmString,x);
+ bco->sp += repSizeW(INTEGER_REP);
+}
+#endif
+
+#ifdef PROVIDE_ADDR
+void asmConstAddr( AsmBCO bco, AsmAddr x )
+{
+ asmInstr(bco,i_CONST_ADDR);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmAddr,x);
+ bco->sp += repSizeW(ADDR_REP);
+}
+#endif
+
+#ifdef PROVIDE_WORD
+void asmConstWord( AsmBCO bco, AsmWord x )
+{
+ asmInstr(bco,i_CONST_INT);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmWord,x);
+ bco->sp += repSizeW(WORD_REP);
+}
+#endif
+
+void asmConstChar( AsmBCO bco, AsmChar x )
+{
+ asmInstr(bco,i_CONST_CHAR);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmChar,x);
+ bco->sp += repSizeW(CHAR_REP);
+}
+
+void asmConstFloat( AsmBCO bco, AsmFloat x )
+{
+ asmInstr(bco,i_CONST_FLOAT);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmFloat,x);
+ bco->sp += repSizeW(FLOAT_REP);
+}
+
+void asmConstDouble( AsmBCO bco, AsmDouble x )
+{
+ asmInstr(bco,i_CONST_DOUBLE);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmDouble,x);
+ bco->sp += repSizeW(DOUBLE_REP);
+}
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+/* a mildly bogus pair of functions... */
+AsmSp asmBeginCase( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndCase( AsmBCO bco )
+{
+}
+
+AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr )
+{
+ asmInstr(bco,i_RETADDR);
+ asmInstr(bco,bco->object.ptrs.len);
+ asmPtr(bco,&(ret_addr->object));
+ bco->sp += 2 * sizeofW(StgPtr);
+ return bco->sp;
+}
+
+AsmBCO asmBeginContinuation ( AsmSp sp )
+{
+ AsmBCO bco = asmBeginBCO();
+ bco->sp = sp;
+ return bco;
+}
+
+void asmEndContinuation ( AsmBCO bco )
+{
+ asmEndBCO(bco);
+}
+
+/* --------------------------------------------------------------------------
+ * Branches
+ * ------------------------------------------------------------------------*/
+
+AsmSp asmBeginAlt( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndAlt( AsmBCO bco, AsmSp sp )
+{
+#if 0
+ /* This warning is now redundant since we no longer use the hp/max_hp
+ * information calculated by the assembler
+ */
+#warning ToDo: adjust hp/max_hp in asmEndAlt
+#endif
+ resetSp(bco,sp);
+}
+
+AsmPc asmTest( AsmBCO bco, AsmWord tag )
+{
+ asmInstr(bco,i_TEST);
+ asmInstr(bco,tag);
+ asmInstr(bco,0);
+ return bco->is.len;
+}
+
+AsmPc asmTestInt( AsmBCO bco, AsmVar v, AsmInt x )
+{
+ asmVar(bco,v,INT_REP);
+ asmConstInt(bco,x);
+ asmInstr(bco,i_TEST_INT);
+ asmInstr(bco,0);
+ bco->sp -= 2*repSizeW(INT_REP);
+ return bco->is.len;
+}
+
+void asmFixBranch( AsmBCO bco, AsmPc from )
+{
+ int distance = bco->is.len - from;
+ ASSERT(distance >= 0);
+ setInstrs(&(bco->is),from-1,distance);
+}
+
+void asmPanic( AsmBCO bco )
+{
+ asmInstr(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
+}
+
+/* --------------------------------------------------------------------------
+ * Primops
+ * ------------------------------------------------------------------------*/
+
+AsmSp asmBeginPrim( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base )
+{
+ asmInstr(bco,prim->prefix);
+ asmInstr(bco,prim->opcode);
+ bco->sp = base;
+}
+
+/* Hugs used to let you add arbitrary primops with arbitrary types
+ * just by editing Prelude.hs or any other file you wanted.
+ * We deliberately avoided that approach because we wanted more
+ * control over which primops are provided.
+ */
+const AsmPrim asmPrimOps[] = {
+
+ /* Char# operations */
+ { "primGtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_gtChar }
+ , { "primGeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_geChar }
+ , { "primEqChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_eqChar }
+ , { "primNeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_neChar }
+ , { "primLtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_ltChar }
+ , { "primLeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_leChar }
+ , { "primCharToInt", "C", "I", MONAD_Id, i_PRIMOP1, i_charToInt }
+ , { "primIntToChar", "I", "C", MONAD_Id, i_PRIMOP1, i_intToChar }
+
+ /* Int# operations */
+ , { "primGtInt", "II", "B", MONAD_Id, i_PRIMOP1, i_gtInt }
+ , { "primGeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_geInt }
+ , { "primEqInt", "II", "B", MONAD_Id, i_PRIMOP1, i_eqInt }
+ , { "primNeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_neInt }
+ , { "primLtInt", "II", "B", MONAD_Id, i_PRIMOP1, i_ltInt }
+ , { "primLeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_leInt }
+ , { "primMinInt", "", "I", MONAD_Id, i_PRIMOP1, i_minInt }
+ , { "primMaxInt", "", "I", MONAD_Id, i_PRIMOP1, i_maxInt }
+ , { "primPlusInt", "II", "I", MONAD_Id, i_PRIMOP1, i_plusInt }
+ , { "primMinusInt", "II", "I", MONAD_Id, i_PRIMOP1, i_minusInt }
+ , { "primTimesInt", "II", "I", MONAD_Id, i_PRIMOP1, i_timesInt }
+ , { "primQuotInt", "II", "I", MONAD_Id, i_PRIMOP1, i_quotInt }
+ , { "primRemInt", "II", "I", MONAD_Id, i_PRIMOP1, i_remInt }
+ , { "primQuotRemInt", "II", "II", MONAD_Id, i_PRIMOP1, i_quotRemInt }
+ , { "primNegateInt", "I", "I", MONAD_Id, i_PRIMOP1, i_negateInt }
+
+ , { "primAndInt", "II", "I", MONAD_Id, i_PRIMOP1, i_andInt }
+ , { "primOrInt", "II", "I", MONAD_Id, i_PRIMOP1, i_orInt }
+ , { "primXorInt", "II", "I", MONAD_Id, i_PRIMOP1, i_xorInt }
+ , { "primNotInt", "I", "I", MONAD_Id, i_PRIMOP1, i_notInt }
+ , { "primShiftLInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftLInt }
+ , { "primShiftRAInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt }
+ , { "primShiftRLInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt }
+
+#ifdef PROVIDE_INT64
+ /* Int64# operations */
+ , { "primGtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_gtInt64 }
+ , { "primGeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_geInt64 }
+ , { "primEqInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_eqInt64 }
+ , { "primNeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_neInt64 }
+ , { "primLtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_ltInt64 }
+ , { "primLeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_leInt64 }
+ , { "primMinInt64", "", "z", MONAD_Id, i_PRIMOP1, i_minInt64 }
+ , { "primMaxInt64", "", "z", MONAD_Id, i_PRIMOP1, i_maxInt64 }
+ , { "primPlusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_plusInt64 }
+ , { "primMinusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_minusInt64 }
+ , { "primTimesInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_timesInt64 }
+ , { "primQuotInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_quotInt64 }
+ , { "primRemInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_remInt64 }
+ , { "primQuotRemInt64", "zz", "zz", MONAD_Id, i_PRIMOP1, i_quotRemInt64 }
+ , { "primNegateInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_negateInt64 }
+
+ , { "primAndInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_andInt64 }
+ , { "primOrInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_orInt64 }
+ , { "primXorInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_xorInt64 }
+ , { "primNotInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_notInt64 }
+ , { "primShiftLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftLInt64 }
+ , { "primShiftRAInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRAInt64 }
+ , { "primShiftRLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRLInt64 }
+
+ , { "primInt64ToInt", "z", "I", MONAD_Id, i_PRIMOP1, i_int64ToInt }
+ , { "primIntToInt64", "I", "z", MONAD_Id, i_PRIMOP1, i_intToInt64 }
+#ifdef PROVIDE_WORD
+ , { "primInt64ToWord", "z", "W", MONAD_Id, i_PRIMOP1, i_int64ToWord }
+ , { "primWordToInt64", "W", "z", MONAD_Id, i_PRIMOP1, i_wordToInt64 }
+#endif
+ , { "primInt64ToFloat", "z", "F", MONAD_Id, i_PRIMOP1, i_int64ToFloat }
+ , { "primFloatToInt64", "F", "z", MONAD_Id, i_PRIMOP1, i_floatToInt64 }
+ , { "primInt64ToDouble", "z", "D", MONAD_Id, i_PRIMOP1, i_int64ToDouble }
+ , { "primDoubleToInt64", "D", "z", MONAD_Id, i_PRIMOP1, i_doubleToInt64 }
+#endif
+
+#ifdef PROVIDE_WORD
+ /* Word# operations */
+ , { "primGtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_gtWord }
+ , { "primGeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_geWord }
+ , { "primEqWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_eqWord }
+ , { "primNeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_neWord }
+ , { "primLtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_ltWord }
+ , { "primLeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_leWord }
+ , { "primMinWord", "", "W", MONAD_Id, i_PRIMOP1, i_minWord }
+ , { "primMaxWord", "", "W", MONAD_Id, i_PRIMOP1, i_maxWord }
+ , { "primPlusWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_plusWord }
+ , { "primMinusWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_minusWord }
+ , { "primTimesWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_timesWord }
+ , { "primQuotWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_quotWord }
+ , { "primRemWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_remWord }
+ , { "primQuotRemWord", "WW", "WW", MONAD_Id, i_PRIMOP1, i_quotRemWord }
+ , { "primNegateWord", "W", "W", MONAD_Id, i_PRIMOP1, i_negateWord }
+
+ , { "primAndWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_andWord }
+ , { "primOrWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_orWord }
+ , { "primXorWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_xorWord }
+ , { "primNotWord", "W", "W", MONAD_Id, i_PRIMOP1, i_notWord }
+ , { "primShiftLWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftLWord }
+ , { "primShiftRAWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftRAWord }
+ , { "primShiftRLWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftRLWord }
+
+ , { "primIntToWord", "I", "W", MONAD_Id, i_PRIMOP1, i_intToWord }
+ , { "primWordToInt", "W", "I", MONAD_Id, i_PRIMOP1, i_wordToInt }
+#endif
+
+#ifdef PROVIDE_ADDR
+ /* Addr# operations */
+ , { "primGtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_gtAddr }
+ , { "primGeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_geAddr }
+ , { "primEqAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_eqAddr }
+ , { "primNeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_neAddr }
+ , { "primLtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_ltAddr }
+ , { "primLeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_leAddr }
+ , { "primIntToAddr", "I", "A", MONAD_Id, i_PRIMOP1, i_intToAddr }
+ , { "primAddrToInt", "A", "I", MONAD_Id, i_PRIMOP1, i_addrToInt }
+
+ , { "primIndexCharOffAddr", "AI", "C", MONAD_Id, i_PRIMOP1, i_indexCharOffAddr }
+ , { "primIndexIntOffAddr", "AI", "I", MONAD_Id, i_PRIMOP1, i_indexIntOffAddr }
+#ifdef PROVIDE_INT64
+ , { "primIndexInt64OffAddr", "AI", "z", MONAD_Id, i_PRIMOP1, i_indexInt64OffAddr }
+#endif
+ , { "primIndexWordOffAddr", "AI", "W", MONAD_Id, i_PRIMOP1, i_indexWordOffAddr }
+ , { "primIndexAddrOffAddr", "AI", "A", MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr }
+ , { "primIndexFloatOffAddr", "AI", "F", MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr }
+ , { "primIndexDoubleOffAddr", "AI", "D", MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr }
+#ifdef PROVIDE_STABLE
+ , { "primIndexStableOffAddr", "AI", "s", MONAD_Id, i_PRIMOP1, i_indexStableOffAddr }
+#endif
+
+ /* These ops really ought to be in the IO monad */
+ , { "primReadCharOffAddr", "AI", "C", MONAD_ST, i_PRIMOP1, i_readCharOffAddr }
+ , { "primReadIntOffAddr", "AI", "I", MONAD_ST, i_PRIMOP1, i_readIntOffAddr }
+#ifdef PROVIDE_INT64
+ , { "primReadInt64OffAddr", "AI", "z", MONAD_ST, i_PRIMOP1, i_readInt64OffAddr }
+#endif
+ , { "primReadWordOffAddr", "AI", "W", MONAD_ST, i_PRIMOP1, i_readWordOffAddr }
+ , { "primReadAddrOffAddr", "AI", "A", MONAD_ST, i_PRIMOP1, i_readAddrOffAddr }
+ , { "primReadFloatOffAddr", "AI", "F", MONAD_ST, i_PRIMOP1, i_readFloatOffAddr }
+ , { "primReadDoubleOffAddr", "AI", "D", MONAD_ST, i_PRIMOP1, i_readDoubleOffAddr }
+#ifdef PROVIDE_STABLE
+ , { "primReadStableOffAddr", "AI", "s", MONAD_ST, i_PRIMOP1, i_readStableOffAddr }
+#endif
+
+ /* These ops really ought to be in the IO monad */
+ , { "primWriteCharOffAddr", "AIC", "", MONAD_ST, i_PRIMOP1, i_writeCharOffAddr }
+ , { "primWriteIntOffAddr", "AII", "", MONAD_ST, i_PRIMOP1, i_writeIntOffAddr }
+#ifdef PROVIDE_INT64
+ , { "primWriteInt64OffAddr", "AIz", "", MONAD_ST, i_PRIMOP1, i_writeInt64OffAddr }
+#endif
+ , { "primWriteWordOffAddr", "AIW", "", MONAD_ST, i_PRIMOP1, i_writeWordOffAddr }
+ , { "primWriteAddrOffAddr", "AIA", "", MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr }
+ , { "primWriteFloatOffAddr", "AIF", "", MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr }
+ , { "primWriteDoubleOffAddr", "AID", "", MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr }
+#ifdef PROVIDE_STABLE
+ , { "primWriteStableOffAddr", "AIs", "", MONAD_ST, i_PRIMOP1, i_writeStableOffAddr }
+#endif
+
+#endif /* PROVIDE_ADDR */
+
+#ifdef PROVIDE_INTEGER
+ /* Integer operations */
+ , { "primCompareInteger", "ZZ", "I", MONAD_Id, i_PRIMOP1, i_compareInteger }
+ , { "primNegateInteger", "Z", "Z", MONAD_Id, i_PRIMOP1, i_negateInteger }
+ , { "primPlusInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_plusInteger }
+ , { "primMinusInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_minusInteger }
+ , { "primTimesInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_timesInteger }
+ , { "primQuotRemInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_quotRemInteger }
+ , { "primDivModInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_divModInteger }
+ , { "primIntegerToInt", "Z", "I", MONAD_Id, i_PRIMOP1, i_integerToInt }
+ , { "primIntToInteger", "I", "Z", MONAD_Id, i_PRIMOP1, i_intToInteger }
+ , { "primIntegerToInt64", "Z", "z", MONAD_Id, i_PRIMOP1, i_integerToInt64 }
+ , { "primInt64ToInteger", "z", "Z", MONAD_Id, i_PRIMOP1, i_int64ToInteger }
+#ifdef PROVIDE_WORD
+ , { "primIntegerToWord", "Z", "W", MONAD_Id, i_PRIMOP1, i_integerToWord }
+ , { "primWordToInteger", "W", "Z", MONAD_Id, i_PRIMOP1, i_wordToInteger }
+#endif
+ , { "primIntegerToFloat", "Z", "F", MONAD_Id, i_PRIMOP1, i_integerToFloat }
+ , { "primFloatToInteger", "F", "Z", MONAD_Id, i_PRIMOP1, i_floatToInteger }
+ , { "primIntegerToDouble", "Z", "D", MONAD_Id, i_PRIMOP1, i_integerToDouble }
+ , { "primDoubleToInteger", "D", "Z", MONAD_Id, i_PRIMOP1, i_doubleToInteger }
+#endif
+
+ /* Float# operations */
+ , { "primGtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_gtFloat }
+ , { "primGeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_geFloat }
+ , { "primEqFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_eqFloat }
+ , { "primNeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_neFloat }
+ , { "primLtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_ltFloat }
+ , { "primLeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_leFloat }
+ , { "primMinFloat", "", "F", MONAD_Id, i_PRIMOP1, i_minFloat }
+ , { "primMaxFloat", "", "F", MONAD_Id, i_PRIMOP1, i_maxFloat }
+ , { "primRadixFloat", "", "I", MONAD_Id, i_PRIMOP1, i_radixFloat }
+ , { "primDigitsFloat", "", "I", MONAD_Id, i_PRIMOP1, i_digitsFloat }
+ , { "primMinExpFloat", "", "I", MONAD_Id, i_PRIMOP1, i_minExpFloat }
+ , { "primMaxExpFloat", "", "I", MONAD_Id, i_PRIMOP1, i_maxExpFloat }
+ , { "primPlusFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_plusFloat }
+ , { "primMinusFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_minusFloat }
+ , { "primTimesFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_timesFloat }
+ , { "primDivideFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_divideFloat }
+ , { "primNegateFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_negateFloat }
+ , { "primFloatToInt", "F", "I", MONAD_Id, i_PRIMOP1, i_floatToInt }
+ , { "primIntToFloat", "I", "F", MONAD_Id, i_PRIMOP1, i_intToFloat }
+ , { "primExpFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_expFloat }
+ , { "primLogFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_logFloat }
+ , { "primSqrtFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sqrtFloat }
+ , { "primSinFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sinFloat }
+ , { "primCosFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_cosFloat }
+ , { "primTanFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanFloat }
+ , { "primAsinFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_asinFloat }
+ , { "primAcosFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_acosFloat }
+ , { "primAtanFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_atanFloat }
+ , { "primSinhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sinhFloat }
+ , { "primCoshFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_coshFloat }
+ , { "primTanhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanhFloat }
+ , { "primPowerFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_powerFloat }
+#ifdef PROVIDE_INT64
+ , { "primDecodeFloatz", "F", "zI", MONAD_Id, i_PRIMOP1, i_decodeFloatz }
+ , { "primEncodeFloatz", "zI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatz }
+#endif
+#ifdef PROVIDE_INTEGER
+ , { "primDecodeFloatZ", "F", "ZI", MONAD_Id, i_PRIMOP1, i_decodeFloatZ }
+ , { "primEncodeFloatZ", "ZI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatZ }
+#endif
+ , { "primIsNaNFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNaNFloat }
+ , { "primIsInfiniteFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteFloat }
+ , { "primIsDenormalizedFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedFloat }
+ , { "primIsNegativeZeroFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroFloat }
+ , { "primIsIEEEFloat", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEFloat }
+
+ /* Double# operations */
+ , { "primGtDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_gtDouble }
+ , { "primGeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_geDouble }
+ , { "primEqDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_eqDouble }
+ , { "primNeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_neDouble }
+ , { "primLtDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_ltDouble }
+ , { "primLeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_leDouble }
+ , { "primMinDouble", "", "D", MONAD_Id, i_PRIMOP1, i_minDouble }
+ , { "primMaxDouble", "", "D", MONAD_Id, i_PRIMOP1, i_maxDouble }
+ , { "primRadixDouble", "", "I", MONAD_Id, i_PRIMOP1, i_radixDouble }
+ , { "primDigitsDouble", "", "I", MONAD_Id, i_PRIMOP1, i_digitsDouble }
+ , { "primMinExpDouble", "", "I", MONAD_Id, i_PRIMOP1, i_minExpDouble }
+ , { "primMaxExpDouble", "", "I", MONAD_Id, i_PRIMOP1, i_maxExpDouble }
+ , { "primPlusDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_plusDouble }
+ , { "primMinusDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_minusDouble }
+ , { "primTimesDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_timesDouble }
+ , { "primDivideDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_divideDouble }
+ , { "primNegateDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_negateDouble }
+ , { "primDoubleToInt", "D", "I", MONAD_Id, i_PRIMOP1, i_doubleToInt }
+ , { "primIntToDouble", "I", "D", MONAD_Id, i_PRIMOP1, i_intToDouble }
+ , { "primDoubleToFloat", "D", "F", MONAD_Id, i_PRIMOP1, i_doubleToFloat }
+ , { "primFloatToDouble", "F", "D", MONAD_Id, i_PRIMOP1, i_floatToDouble }
+ , { "primExpDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_expDouble }
+ , { "primLogDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_logDouble }
+ , { "primSqrtDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sqrtDouble }
+ , { "primSinDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sinDouble }
+ , { "primCosDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_cosDouble }
+ , { "primTanDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanDouble }
+ , { "primAsinDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_asinDouble }
+ , { "primAcosDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_acosDouble }
+ , { "primAtanDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_atanDouble }
+ , { "primSinhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sinhDouble }
+ , { "primCoshDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_coshDouble }
+ , { "primTanhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanhDouble }
+ , { "primPowerDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_powerDouble }
+#ifdef PROVIDE_INT64
+ , { "primDecodeDoublez", "D", "zI", MONAD_Id, i_PRIMOP1, i_decodeDoublez }
+ , { "primEncodeDoublez", "zI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoublez }
+#endif
+#ifdef PROVIDE_INTEGER
+ , { "primDecodeDoubleZ", "D", "ZI", MONAD_Id, i_PRIMOP1, i_decodeDoubleZ }
+ , { "primEncodeDoubleZ", "ZI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoubleZ }
+#endif
+ , { "primIsNaNDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNaNDouble }
+ , { "primIsInfiniteDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteDouble }
+ , { "primIsDenormalizedDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedDouble }
+ , { "primIsNegativeZeroDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroDouble }
+ , { "primIsIEEEDouble", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEDouble }
+
+
+ /* Polymorphic force :: a -> (# #) */
+ , { "primForce", "a", "", MONAD_Id, i_PRIMOP2, i_force }
+
+ /* Error operations - not in IO monad! */
+ , { "primRaise", "E", "a", MONAD_Id, i_PRIMOP2, i_raise }
+ , { "primCatch'", "aH", "a", MONAD_Id, i_PRIMOP2, i_catch }
+
+#ifdef PROVIDE_ARRAY
+ /* Ref operations */
+ , { "primNewRef", "a", "R", MONAD_ST, i_PRIMOP2, i_newRef }
+ , { "primWriteRef", "Ra", "", MONAD_ST, i_PRIMOP2, i_writeRef }
+ , { "primReadRef", "R", "a", MONAD_ST, i_PRIMOP2, i_readRef }
+ , { "primSameRef", "RR", "B", MONAD_Id, i_PRIMOP2, i_sameRef }
+
+ /* PrimArray operations */
+ , { "primSameMutableArray", "MM", "B", MONAD_Id, i_PRIMOP2, i_sameMutableArray }
+ , { "primUnsafeFreezeArray", "M", "X", MONAD_ST, i_PRIMOP2, i_unsafeFreezeArray }
+ , { "primNewArray", "Ia", "M", MONAD_ST, i_PRIMOP2, i_newArray }
+ , { "primWriteArray", "MIa", "", MONAD_ST, i_PRIMOP2, i_writeArray }
+ , { "primReadArray", "MI", "a", MONAD_ST, i_PRIMOP2, i_readArray }
+ , { "primIndexArray", "XI", "a", MONAD_Id, i_PRIMOP2, i_indexArray }
+ , { "primSizeArray", "X", "I", MONAD_Id, i_PRIMOP2, i_sizeArray }
+ , { "primSizeMutableArray", "M", "I", MONAD_Id, i_PRIMOP2, i_sizeMutableArray }
+
+ /* Prim[Mutable]ByteArray operations */
+ , { "primSameMutableByteArray", "mm", "B", MONAD_Id, i_PRIMOP2, i_sameMutableByteArray }
+ , { "primUnsafeFreezeByteArray", "m", "x", MONAD_ST, i_PRIMOP2, i_unsafeFreezeByteArray }
+
+ , { "primNewByteArray", "I", "m", MONAD_ST, i_PRIMOP2, i_newByteArray }
+
+ , { "primWriteCharArray", "mIC", "", MONAD_ST, i_PRIMOP2, i_writeCharArray }
+ , { "primReadCharArray", "mI", "C", MONAD_ST, i_PRIMOP2, i_readCharArray }
+ , { "primIndexCharArray", "xI", "C", MONAD_Id, i_PRIMOP2, i_indexCharArray }
+
+ , { "primWriteIntArray", "mII", "", MONAD_ST, i_PRIMOP2, i_writeIntArray }
+ , { "primReadIntArray", "mI", "I", MONAD_ST, i_PRIMOP2, i_readIntArray }
+ , { "primIndexIntArray", "xI", "I", MONAD_Id, i_PRIMOP2, i_indexIntArray }
+
+#ifdef PROVIDE_INT64
+ , { "primWriteInt64Array", "mIz", "", MONAD_ST, i_PRIMOP2, i_writeInt64Array }
+ , { "primReadInt64Array", "mI", "z", MONAD_ST, i_PRIMOP2, i_readInt64Array }
+ , { "primIndexInt64Array", "xI", "z", MONAD_Id, i_PRIMOP2, i_indexInt64Array }
+#endif
+
+ /* {new,write,read,index}IntegerArray not provided */
+
+#ifdef PROVIDE_WORD
+ , { "primWriteWordArray", "mIW", "", MONAD_ST, i_PRIMOP2, i_writeWordArray }
+ , { "primReadWordArray", "mI", "W", MONAD_ST, i_PRIMOP2, i_readWordArray }
+ , { "primIndexWordArray", "xI", "W", MONAD_Id, i_PRIMOP2, i_indexWordArray }
+#endif
+#ifdef PROVIDE_ADDR
+ , { "primWriteAddrArray", "mIA", "", MONAD_ST, i_PRIMOP2, i_writeAddrArray }
+ , { "primReadAddrArray", "mI", "A", MONAD_ST, i_PRIMOP2, i_readAddrArray }
+ , { "primIndexAddrArray", "xI", "A", MONAD_Id, i_PRIMOP2, i_indexAddrArray }
+#endif
+ , { "primWriteFloatArray", "mIF", "", MONAD_ST, i_PRIMOP2, i_writeFloatArray }
+ , { "primReadFloatArray", "mI", "F", MONAD_ST, i_PRIMOP2, i_readFloatArray }
+ , { "primIndexFloatArray", "xI", "F", MONAD_Id, i_PRIMOP2, i_indexFloatArray }
+
+ , { "primWriteDoubleArray" , "mID", "", MONAD_ST, i_PRIMOP2, i_writeDoubleArray }
+ , { "primReadDoubleArray", "mI", "D", MONAD_ST, i_PRIMOP2, i_readDoubleArray }
+ , { "primIndexDoubleArray", "xI", "D", MONAD_Id, i_PRIMOP2, i_indexDoubleArray }
+
+#ifdef PROVIDE_STABLE
+ , { "primWriteStableArray", "mIs", "", MONAD_ST, i_PRIMOP2, i_writeStableArray }
+ , { "primReadStableArray", "mI", "s", MONAD_ST, i_PRIMOP2, i_readStableArray }
+ , { "primIndexStableArray", "xI", "s", MONAD_Id, i_PRIMOP2, i_indexStableArray }
+#endif
+
+ /* {new,write,read,index}ForeignObjArray not provided */
+
+#endif PROVIDE_ARRAY
+
+#ifdef PROVIDE_FOREIGN
+ /* ForeignObj# operations */
+ , { "primMakeForeignObj", "A", "f", MONAD_IO, i_PRIMOP2, i_makeForeignObj }
+#endif
+#ifdef PROVIDE_WEAK
+ /* WeakPair# operations */
+ , { "primMakeWeak", "bac", "w", MONAD_IO, i_PRIMOP2, i_makeWeak }
+ , { "primDeRefWeak", "w", "Ia", MONAD_IO, i_PRIMOP2, i_deRefWeak }
+#endif
+#ifdef PROVIDE_STABLE
+ /* StablePtr# operations */
+ , { "primMakeStablePtr", "a", "s", MONAD_IO, i_PRIMOP2, i_makeStablePtr }
+ , { "primDeRefStablePtr", "s", "a", MONAD_IO, i_PRIMOP2, i_deRefStablePtr }
+ , { "primFreeStablePtr", "s", "", MONAD_IO, i_PRIMOP2, i_freeStablePtr }
+#endif
+#ifdef PROVIDE_PTREQUALITY
+ , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality }
+#endif
+#ifdef PROVIDE_COERCE
+ , { "primUnsafeCoerce", "a", "b", MONAD_Id, i_PRIMOP2, i_unsafeCoerce }
+#endif
+#ifdef PROVIDE_CONCURRENT
+ /* Concurrency operations */
+ , { "primFork", "a", "T", MONAD_IO, i_PRIMOP2, i_fork }
+ , { "primKillThread", "T", "", MONAD_IO, i_PRIMOP2, i_killThread }
+ , { "primSameMVar", "rr", "B", MONAD_Id, i_PRIMOP2, i_sameMVar }
+ , { "primNewMVar", "", "r", MONAD_IO, i_PRIMOP2, i_newMVar }
+ , { "primTakeMVar", "r", "a", MONAD_IO, i_PRIMOP2, i_takeMVar }
+ , { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar }
+ , { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay }
+ , { "primWaitRead", "I", "", MONAD_IO, i_PRIMOP2, i_waitRead }
+ , { "primWaitWrite", "I", "", MONAD_IO, i_PRIMOP2, i_waitWrite }
+#endif
+
+ /* Ccall is polyadic - so it's excluded from this table */
+
+ , { 0,0,0,0 }
+};
+
+const AsmPrim ccall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_Id };
+const AsmPrim ccall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_IO };
+
+const AsmPrim* asmFindPrim( char* s )
+{
+ int i;
+ for (i=0; asmPrimOps[i].name; ++i) {
+ if (strcmp(s,asmPrimOps[i].name)==0) {
+ return &asmPrimOps[i];
+ }
+ }
+ return 0;
+}
+
+const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
+{
+ nat i;
+ for (i=0; asmPrimOps[i].name; ++i) {
+ if (asmPrimOps[i].prefix == prefix && asmPrimOps[i].opcode == op) {
+ return &asmPrimOps[i];
+ }
+ }
+ return 0;
+}
+
+/* --------------------------------------------------------------------------
+ * Heap manipulation
+ * ------------------------------------------------------------------------*/
+
+AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info )
+{
+ ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ asmInstr(bco,i_ALLOC_CONSTR);
+ asmInstr(bco,bco->nps.len);
+ asmWords(bco,AsmInfo,info);
+ bco->sp += sizeofW(StgClosurePtr);
+ grabHpNonUpd(bco,sizeW_fromITBL(info));
+ return bco->sp;
+}
+
+AsmSp asmBeginPack( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info )
+{
+ nat size = bco->sp - start;
+ ASSERT(bco->sp >= start);
+ ASSERT(start >= v);
+ /* only reason to include info is for this assertion */
+ ASSERT(info->layout.payload.ptrs == size);
+ asmInstr(bco,i_PACK);
+ asmInstr(bco,bco->sp - v);
+ bco->sp = start;
+}
+
+void asmBeginUnpack( AsmBCO bco )
+{
+ /* dummy to make it look prettier */
+}
+
+void asmEndUnpack( AsmBCO bco )
+{
+ asmInstr(bco,i_UNPACK);
+}
+
+AsmVar asmAllocAP( AsmBCO bco, AsmNat words )
+{
+ asmInstr(bco,i_ALLOC_AP);
+ asmInstr(bco,words);
+ bco->sp += sizeofW(StgPtr);
+ grabHpUpd(bco,AP_sizeW(words));
+ return bco->sp;
+}
+
+AsmSp asmBeginMkAP( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start )
+{
+ asmInstr(bco,i_MKAP);
+ asmInstr(bco,bco->sp-v);
+ asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */
+ bco->sp = start;
+}
+
+AsmVar asmAllocPAP( AsmBCO bco, AsmNat size )
+{
+ asmInstr(bco,i_ALLOC_PAP);
+ asmInstr(bco,size);
+ bco->sp += sizeofW(StgPtr);
+ return bco->sp;
+}
+
+AsmSp asmBeginMkPAP( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start )
+{
+ asmInstr(bco,i_MKPAP);
+ asmInstr(bco,bco->sp-v);
+ asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */
+ bco->sp = start;
+}
+
+AsmVar asmClosure( AsmBCO bco, AsmObject p )
+{
+ StgWord o = bco->object.ptrs.len;
+ if (o < 256) {
+ asmInstr(bco,i_CONST);
+ asmInstr(bco,o);
+ asmPtr(bco,p);
+ } else {
+ asmInstr(bco,i_CONST2);
+ asmInstr(bco,o / 256);
+ asmInstr(bco,o % 256);
+ asmPtr(bco,p);
+ }
+ bco->sp += sizeofW(StgPtr);
+ return bco->sp;
+}
+
+/* --------------------------------------------------------------------------
+ * Building InfoTables
+ * ------------------------------------------------------------------------*/
+
+AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs )
+{
+ StgInfoTable* info = stgMallocBytes( sizeof(StgInfoTable),"asmMkInfo");
+ /* Note: the evaluator automatically pads objects with the right number
+ * of non-ptrs to satisfy MIN_NONUPD_SIZE restrictions.
+ */
+ AsmNat nptrs = stg_max(0,MIN_NONUPD_SIZE-ptrs);
+
+ /* initialisation code based on INFO_TABLE_CONSTR */
+ info->layout.payload.ptrs = ptrs;
+ info->layout.payload.nptrs = nptrs;
+ info->srt_len = tag;
+ info->type = CONSTR;
+ info->flags = FLAGS_CONSTR;
+#ifdef USE_MINIINTERPRETER
+ info->entry = stgCast(StgFunPtr,&Hugs_CONSTR_entry);
+#else
+#warning asmMkInfo: Need to insert entry code in some cunning way
+#endif
+ ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ return info;
+}
+
+/*-------------------------------------------------------------------------*/
+
+#endif /* INTERPRETER */
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: BlockAlloc.c,v 1.2 1998/12/02 13:28:12 simonm Exp $
+ *
+ * The block allocator and free list manager.
+ *
+ * This is the architecture independent part of the block allocator.
+ * It requires only the following support from the operating system:
+ *
+ * void *getMBlock();
+ *
+ * returns the address of an MBLOCK_SIZE region of memory, aligned on
+ * an MBLOCK_SIZE boundary. There is no requirement for successive
+ * calls to getMBlock to return strictly increasing addresses.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "BlockAlloc.h"
+#include "MBlock.h"
+
+static void initMBlock(void *mblock);
+static bdescr *allocMegaGroup(nat mblocks);
+static void freeMegaGroup(bdescr *bd);
+
+static bdescr *free_list;
+
+/* -----------------------------------------------------------------------------
+ Initialisation
+ -------------------------------------------------------------------------- */
+
+void initBlockAllocator(void)
+{
+ free_list = NULL;
+}
+
+/* -----------------------------------------------------------------------------
+ Allocation
+ -------------------------------------------------------------------------- */
+
+static inline void
+initGroup(nat n, bdescr *head)
+{
+ bdescr *bd;
+ nat i;
+
+ if (n != 0) {
+ head->blocks = n;
+ head->free = head->start;
+ for (i=1, bd = head+1; i < n; i++, bd++) {
+ bd->free = 0;
+ bd->link = head;
+ }
+ }
+}
+
+bdescr *
+allocGroup(nat n)
+{
+ void *mblock;
+ bdescr *bd, **last;
+
+ if (n > BLOCKS_PER_MBLOCK) {
+ return allocMegaGroup(BLOCKS_TO_MBLOCKS(n));
+ }
+
+ last = &free_list;
+ for (bd = free_list; bd != NULL; bd = bd->link) {
+ if (bd->blocks == n) { /* exactly the right size! */
+ *last = bd->link;
+ /* no initialisation necessary - this is already a
+ * self-contained block group. */
+ return bd;
+ }
+ if (bd->blocks > n) { /* block too big... */
+ bd->blocks -= n; /* take a chunk off the *end* */
+ bd += bd->blocks;
+ initGroup(n, bd); /* initialise it */
+ return bd;
+ }
+ last = &bd->link;
+ }
+
+ mblock = getMBlock(); /* get a new megablock */
+ initMBlock(mblock); /* initialise the start fields */
+ bd = FIRST_BDESCR(mblock);
+ initGroup(n,bd); /* we know the group will fit */
+ initGroup(BLOCKS_PER_MBLOCK-n, bd+n);
+ freeGroup(bd+n); /* add the rest on to the free list */
+ return bd;
+}
+
+bdescr *
+allocBlock(void)
+{
+ return allocGroup(1);
+}
+
+/* -----------------------------------------------------------------------------
+ Any request larger than BLOCKS_PER_MBLOCK needs a megablock group.
+ First, search the free list for enough contiguous megablocks to
+ fulfill the request - if we don't have enough, we need to
+ allocate some new ones.
+
+ A megablock group looks just like a normal block group, except that
+ the blocks field in the head will be larger than BLOCKS_PER_MBLOCK.
+
+ Note that any objects placed in this group must start in the first
+ megablock, since the other blocks don't have block descriptors.
+ -------------------------------------------------------------------------- */
+
+static bdescr *
+allocMegaGroup(nat n)
+{
+ nat mbs_found;
+ bdescr *bd, *last, *grp_start, *grp_prev;
+
+ mbs_found = 0;
+ grp_start = NULL;
+ grp_prev = NULL;
+ last = NULL;
+ for (bd = free_list; bd != NULL; bd = bd->link) {
+
+ if (bd->blocks == BLOCKS_PER_MBLOCK) { /* whole megablock found */
+
+ if (grp_start == NULL) { /* is it the first one we've found? */
+ grp_start = bd;
+ grp_prev = last;
+ mbs_found = 1;
+ } else {
+ mbs_found++;
+ }
+
+ if (mbs_found == n) { /* found enough contig megablocks? */
+ break;
+ }
+ }
+
+ else { /* only a partial megablock, start again */
+ grp_start = NULL;
+ }
+
+ last = bd;
+ }
+
+ /* found all the megablocks we need on the free list
+ */
+ if (mbs_found == n) {
+ /* remove the megablocks from the free list */
+ if (grp_prev == NULL) { /* bd now points to the last mblock */
+ free_list = bd->link;
+ } else {
+ grp_prev->link = bd->link;
+ }
+ }
+
+ /* the free list wasn't sufficient, allocate all new mblocks.
+ */
+ else {
+ void *mblock = getMBlocks(n);
+ initMBlock(mblock); /* only need to init the 1st one */
+ grp_start = FIRST_BDESCR(mblock);
+ }
+
+ /* set up the megablock group */
+ initGroup(BLOCKS_PER_MBLOCK, grp_start);
+ grp_start->blocks = MBLOCK_GROUP_BLOCKS(n);
+ return grp_start;
+}
+
+/* -----------------------------------------------------------------------------
+ De-Allocation
+ -------------------------------------------------------------------------- */
+
+/* coalesce the group p with p->link if possible.
+ *
+ * Returns p->link if no coalescing was done, otherwise returns a
+ * pointer to the newly enlarged group p.
+ */
+
+static inline bdescr *
+coalesce(bdescr *p)
+{
+ bdescr *bd, *q;
+ nat i;
+
+ q = p->link;
+ if (q != NULL && p->start + p->blocks * BLOCK_SIZE_W == q->start) {
+ /* can coalesce */
+ p->blocks += q->blocks;
+ p->link = q->link;
+ for (i = 0, bd = q; i < q->blocks; bd++, i++) {
+ bd->free = 0;
+ bd->link = p;
+ }
+ return p;
+ }
+ return q;
+}
+
+void
+freeGroup(bdescr *p)
+{
+ bdescr *bd, *last;
+
+ /* are we dealing with a megablock group? */
+ if (p->blocks > BLOCKS_PER_MBLOCK) {
+ freeMegaGroup(p);
+ return;
+ }
+
+ /* find correct place in free list to place new group */
+ last = NULL;
+ for (bd = free_list; bd != NULL && bd->start < p->start;
+ bd = bd->link) {
+ last = bd;
+ }
+
+ /* now, last = previous group (or NULL) */
+ if (last == NULL) {
+ p->link = free_list;
+ free_list = p;
+ } else {
+ /* coalesce with previous group if possible */
+ p->link = last->link;
+ last->link = p;
+ p = coalesce(last);
+ }
+
+ /* coalesce with next group if possible */
+ coalesce(p);
+ IF_DEBUG(sanity, checkFreeListSanity());
+}
+
+static void
+freeMegaGroup(bdescr *p)
+{
+ nat n;
+
+ n = p->blocks * BLOCK_SIZE / MBLOCK_SIZE + 1;
+ for (; n > 0; (W_)p += MBLOCK_SIZE, n--) {
+ initMBlock((void *)((W_)p & ~MBLOCK_MASK));
+ initGroup(BLOCKS_PER_MBLOCK, p);
+ freeGroup(p);
+ }
+}
+
+void
+freeChain(bdescr *bd)
+{
+ bdescr *next_bd;
+ while (bd != NULL) {
+ next_bd = bd->link;
+#ifdef DEBUG
+ bd->free = (void *)-1; /* indicates that this block is free */
+#endif
+ freeGroup(bd);
+ bd = next_bd;
+ }
+}
+
+static void
+initMBlock(void *mblock)
+{
+ bdescr *bd;
+ void *block;
+
+ /* the first few Bdescr's in a block are unused, so we don't want to
+ * put them all on the free list.
+ */
+ block = FIRST_BLOCK(mblock);
+ bd = FIRST_BDESCR(mblock);
+
+ /* Initialise the start field of each block descriptor
+ */
+ for (; block <= LAST_BLOCK(mblock); bd += 1, (lnat)block += BLOCK_SIZE) {
+ bd->start = block;
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Debugging
+ -------------------------------------------------------------------------- */
+
+#ifdef DEBUG
+void
+checkFreeListSanity(void)
+{
+ bdescr *bd;
+
+ for (bd = free_list; bd != NULL; bd = bd->link) {
+ IF_DEBUG(block_alloc,
+ fprintf(stderr,"group at 0x%x, length %d blocks\n",
+ (nat)bd->start, bd->blocks));
+ ASSERT(bd->blocks > 0);
+ if (bd->link != NULL) {
+ /* make sure we're fully coalesced */
+ ASSERT(bd->start + bd->blocks * BLOCK_SIZE_W != bd->link->start);
+ ASSERT(bd->start < bd->link->start);
+ }
+ }
+}
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: BlockAlloc.h,v 1.2 1998/12/02 13:28:13 simonm Exp $
+ *
+ * Block Allocator Interface
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef BLOCK_ALLOC_H
+#define BLOCK_ALLOC_H
+
+/* Initialisation ---------------------------------------------------------- */
+
+extern void initBlockAllocator(void);
+
+/* Allocation -------------------------------------------------------------- */
+
+extern bdescr *allocGroup(nat n);
+extern bdescr *allocBlock(void);
+
+/* De-Allocation ----------------------------------------------------------- */
+
+extern void freeGroup(bdescr *p);
+extern void freeChain(bdescr *p);
+
+/* Finding the block descriptor for a given block -------------------------- */
+
+static inline bdescr *Bdescr(StgPtr p)
+{
+ return (bdescr *)
+ ((((W_)p & MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT))
+ | ((W_)p & ~MBLOCK_MASK)
+ );
+}
+
+/* Debugging -------------------------------------------------------------- */
+
+#ifdef DEBUG
+extern void checkFreeListSanity(void);
+#endif
+
+#endif BLOCK_ALLOC_H
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+
+/* --------------------------------------------------------------------------
+ * Instructions
+ *
+ * Notes:
+ * o INTERNAL_ERROR is never generated by the compiler and usually
+ * indicates as error in the heap.
+ * PANIC is generated by the compiler whenever it tests an "irrefutable"
+ * pattern which fails. If we don't see too many of these, we could
+ * optimise out the redundant test.
+ *
+ * o If you add any new instructions, you have to check that each enumeration
+ * has at most 256 entries in it --- some of the lists are very close to
+ * overflowing.
+ * ------------------------------------------------------------------------*/
+
+typedef enum
+ { i_INTERNAL_ERROR /* Instruction 0 raises an internal error */
+
+ , i_PANIC /* irrefutable pattern match failed! */
+
+ , i_STK_CHECK
+ , i_HP_CHECK
+
+ , i_ARG_CHECK
+
+ , i_ALLOC_AP
+ , i_ALLOC_PAP
+ , i_ALLOC_CONSTR
+ , i_MKAP
+ , i_MKPAP
+ , i_PACK
+
+ , i_SLIDE
+
+ , i_TEST
+ , i_UNPACK
+
+ , i_VAR
+ , i_CONST
+ , i_CONST2 /* 16 bit offsets - ad-hoc fix for general problem */
+ , i_ENTER
+
+ , i_RETADDR
+
+ , i_VOID
+
+ , i_RETURN_GENERIC
+
+ , i_VAR_INT
+ , i_CONST_INT
+ , i_RETURN_INT
+ , i_PACK_INT
+ , i_UNPACK_INT
+ , i_TEST_INT
+
+#ifdef PROVIDE_INT64
+ , i_VAR_INT64
+ , i_CONST_INT64
+ , i_RETURN_INT64
+ , i_PACK_INT64
+ , i_UNPACK_INT64
+#endif
+#ifdef PROVIDE_INTEGER
+ , i_CONST_INTEGER
+#endif
+#ifdef PROVIDE_WORD
+ , i_VAR_WORD
+ , i_CONST_WORD
+ , i_RETURN_WORD
+ , i_PACK_WORD
+ , i_UNPACK_WORD
+#endif
+#ifdef PROVIDE_ADDR
+ , i_VAR_ADDR
+ , i_CONST_ADDR
+ , i_RETURN_ADDR
+ , i_PACK_ADDR
+ , i_UNPACK_ADDR
+#endif
+ , i_VAR_CHAR
+ , i_CONST_CHAR
+ , i_RETURN_CHAR
+ , i_PACK_CHAR
+ , i_UNPACK_CHAR
+
+ , i_VAR_FLOAT
+ , i_CONST_FLOAT
+ , i_RETURN_FLOAT
+ , i_PACK_FLOAT
+ , i_UNPACK_FLOAT
+
+ , i_VAR_DOUBLE
+ , i_CONST_DOUBLE
+ , i_RETURN_DOUBLE
+ , i_PACK_DOUBLE
+ , i_UNPACK_DOUBLE
+
+#ifdef PROVIDE_STABLE
+ , i_VAR_STABLE
+ , i_RETURN_STABLE
+ , i_PACK_STABLE
+ , i_UNPACK_STABLE
+#endif
+
+ , i_PRIMOP1 /* Primop: next byte is an Primop1 */
+ , i_PRIMOP2 /* Primop: next byte is an Primop2 */
+
+ , MAX_Instr = i_PRIMOP2
+} Instr;
+
+typedef enum
+ { i_INTERNAL_ERROR1 /* Instruction 0 raises an internal error */
+
+ /* Char# operations */
+ , i_gtChar
+ , i_geChar
+ , i_eqChar
+ , i_neChar
+ , i_ltChar
+ , i_leChar
+ , i_charToInt
+ , i_intToChar
+
+ /* Int# operations */
+ , i_gtInt
+ , i_geInt
+ , i_eqInt
+ , i_neInt
+ , i_ltInt
+ , i_leInt
+ , i_minInt
+ , i_maxInt
+ , i_plusInt
+ , i_minusInt
+ , i_timesInt
+ , i_quotInt
+ , i_remInt
+ , i_quotRemInt
+ , i_negateInt
+ , i_andInt
+ , i_orInt
+ , i_xorInt
+ , i_notInt
+ , i_shiftLInt
+ , i_shiftRAInt
+ , i_shiftRLInt
+
+#ifdef PROVIDE_INT64
+ /* Int64# operations */
+ , i_gtInt64
+ , i_geInt64
+ , i_eqInt64
+ , i_neInt64
+ , i_ltInt64
+ , i_leInt64
+ , i_minInt64
+ , i_maxInt64
+ , i_plusInt64
+ , i_minusInt64
+ , i_timesInt64
+ , i_quotInt64
+ , i_remInt64
+ , i_quotRemInt64
+ , i_negateInt64
+ , i_andInt64
+ , i_orInt64
+ , i_xorInt64
+ , i_notInt64
+ , i_shiftLInt64
+ , i_shiftRAInt64
+ , i_shiftRLInt64
+ , i_int64ToInt
+ , i_intToInt64
+#ifdef PROVIDE_WORD
+ , i_int64ToWord
+ , i_wordToInt64
+#endif
+ , i_int64ToFloat
+ , i_floatToInt64
+ , i_int64ToDouble
+ , i_doubleToInt64
+#endif
+#ifdef PROVIDE_WORD
+ /* Word# operations */
+ , i_gtWord
+ , i_geWord
+ , i_eqWord
+ , i_neWord
+ , i_ltWord
+ , i_leWord
+ , i_minWord
+ , i_maxWord
+ , i_plusWord
+ , i_minusWord
+ , i_timesWord
+ , i_quotWord
+ , i_remWord
+ , i_quotRemWord
+ , i_negateWord
+ , i_andWord
+ , i_orWord
+ , i_xorWord
+ , i_notWord
+ , i_shiftLWord
+ , i_shiftRAWord
+ , i_shiftRLWord
+ , i_intToWord
+ , i_wordToInt
+#endif
+#ifdef PROVIDE_ADDR
+ /* Addr# operations */
+ , i_gtAddr
+ , i_geAddr
+ , i_eqAddr
+ , i_neAddr
+ , i_ltAddr
+ , i_leAddr
+ , i_intToAddr
+ , i_addrToInt
+
+ /* Stateless Addr operations */
+ , i_indexCharOffAddr
+ , i_indexIntOffAddr
+#ifdef PROVIDE_INT64
+ , i_indexInt64OffAddr
+#endif
+#ifdef PROVIDE_WORD
+ , i_indexWordOffAddr
+#endif
+#ifdef PROVIDE_ADDR
+ , i_indexAddrOffAddr
+#endif
+ , i_indexFloatOffAddr
+ , i_indexDoubleOffAddr
+#ifdef PROVIDE_STABLE
+ , i_indexStableOffAddr
+#endif
+
+ , i_readCharOffAddr
+ , i_readIntOffAddr
+#ifdef PROVIDE_INT64
+ , i_readInt64OffAddr
+#endif
+#ifdef PROVIDE_WORD
+ , i_readWordOffAddr
+#endif
+#ifdef PROVIDE_ADDR
+ , i_readAddrOffAddr
+#endif
+ , i_readFloatOffAddr
+ , i_readDoubleOffAddr
+#ifdef PROVIDE_STABLE
+ , i_readStableOffAddr
+#endif
+
+ , i_writeCharOffAddr
+ , i_writeIntOffAddr
+#ifdef PROVIDE_INT64
+ , i_writeInt64OffAddr
+#endif
+#ifdef PROVIDE_WORD
+ , i_writeWordOffAddr
+#endif
+#ifdef PROVIDE_ADDR
+ , i_writeAddrOffAddr
+#endif
+ , i_writeFloatOffAddr
+ , i_writeDoubleOffAddr
+#ifdef PROVIDE_STABLE
+ , i_writeStableOffAddr
+#endif
+
+#endif /* PROVIDE_ADDR */
+
+#ifdef PROVIDE_INTEGER
+ /* Integer operations */
+ , i_compareInteger
+ , i_negateInteger
+ , i_plusInteger
+ , i_minusInteger
+ , i_timesInteger
+ , i_quotRemInteger
+ , i_divModInteger
+ , i_integerToInt
+ , i_intToInteger
+#ifdef PROVIDE_INT64
+ , i_integerToInt64
+ , i_int64ToInteger
+#endif
+#ifdef PROVIDE_WORD
+ , i_integerToWord
+ , i_wordToInteger
+#endif
+ , i_integerToFloat
+ , i_floatToInteger
+ , i_integerToDouble
+ , i_doubleToInteger
+#endif
+
+ /* Float# operations */
+ , i_gtFloat
+ , i_geFloat
+ , i_eqFloat
+ , i_neFloat
+ , i_ltFloat
+ , i_leFloat
+ , i_minFloat
+ , i_maxFloat
+ , i_radixFloat
+ , i_digitsFloat
+ , i_minExpFloat
+ , i_maxExpFloat
+ , i_plusFloat
+ , i_minusFloat
+ , i_timesFloat
+ , i_divideFloat
+ , i_negateFloat
+ , i_floatToInt
+ , i_intToFloat
+ , i_expFloat
+ , i_logFloat
+ , i_sqrtFloat
+ , i_sinFloat
+ , i_cosFloat
+ , i_tanFloat
+ , i_asinFloat
+ , i_acosFloat
+ , i_atanFloat
+ , i_sinhFloat
+ , i_coshFloat
+ , i_tanhFloat
+ , i_powerFloat
+#ifdef PROVIDE_INT64
+ , i_decodeFloatz
+ , i_encodeFloatz
+#endif
+#ifdef PROVIDE_INTEGER
+ , i_decodeFloatZ
+ , i_encodeFloatZ
+#endif
+ , i_isNaNFloat
+ , i_isInfiniteFloat
+ , i_isDenormalizedFloat
+ , i_isNegativeZeroFloat
+ , i_isIEEEFloat
+
+ /* Double# operations */
+ , i_gtDouble
+ , i_geDouble
+ , i_eqDouble
+ , i_neDouble
+ , i_ltDouble
+ , i_leDouble
+ , i_minDouble
+ , i_maxDouble
+ , i_radixDouble
+ , i_digitsDouble
+ , i_minExpDouble
+ , i_maxExpDouble
+ , i_plusDouble
+ , i_minusDouble
+ , i_timesDouble
+ , i_divideDouble
+ , i_negateDouble
+ , i_doubleToInt
+ , i_intToDouble
+ , i_doubleToFloat
+ , i_floatToDouble
+ , i_expDouble
+ , i_logDouble
+ , i_sqrtDouble
+ , i_sinDouble
+ , i_cosDouble
+ , i_tanDouble
+ , i_asinDouble
+ , i_acosDouble
+ , i_atanDouble
+ , i_sinhDouble
+ , i_coshDouble
+ , i_tanhDouble
+ , i_powerDouble
+#ifdef PROVIDE_INT64
+ , i_decodeDoublez
+ , i_encodeDoublez
+#endif
+#ifdef PROVIDE_INTEGER
+ , i_decodeDoubleZ
+ , i_encodeDoubleZ
+#endif
+ , i_isNaNDouble
+ , i_isInfiniteDouble
+ , i_isDenormalizedDouble
+ , i_isNegativeZeroDouble
+ , i_isIEEEDouble
+
+ /* If you add a new primop to this table, check you don't
+ * overflow the 256 limit. That is MAX_Primop1 <= 255.
+ * Current value (30/10/98) = 0xc8
+ */
+ , MAX_Primop1 = i_isIEEEDouble
+} Primop1;
+
+
+typedef enum
+ { i_INTERNAL_ERROR2 /* Instruction 0 raises an internal error */
+
+ , i_raise
+ , i_catch
+ , i_force
+
+#ifdef PROVIDE_ARRAY
+ /* Ref operations */
+ , i_newRef
+ , i_writeRef
+ , i_readRef
+ , i_sameRef
+
+ /* Prim[Mutable]Array operations */
+ , i_sameMutableArray
+ , i_unsafeFreezeArray
+
+ , i_newArray
+ , i_writeArray
+ , i_readArray
+ , i_indexArray
+ , i_sizeArray
+ , i_sizeMutableArray
+
+ /* Prim[Mutable]ByteArray operations */
+ , i_sameMutableByteArray
+ , i_unsafeFreezeByteArray
+ , i_newByteArray
+
+ , i_writeCharArray
+ , i_readCharArray
+ , i_indexCharArray
+
+ , i_writeIntArray
+ , i_readIntArray
+ , i_indexIntArray
+
+#ifdef PROVIDE_INT64
+ , i_writeInt64Array
+ , i_readInt64Array
+ , i_indexInt64Array
+#endif
+
+ /* {write,read,index}IntegerArray not provided */
+
+#ifdef PROVIDE_WORD
+ , i_writeWordArray
+ , i_readWordArray
+ , i_indexWordArray
+#endif
+#ifdef PROVIDE_ADDR
+ , i_writeAddrArray
+ , i_readAddrArray
+ , i_indexAddrArray
+#endif
+ , i_writeFloatArray
+ , i_readFloatArray
+ , i_indexFloatArray
+
+ , i_writeDoubleArray
+ , i_readDoubleArray
+ , i_indexDoubleArray
+
+#ifdef PROVIDE_STABLE
+ , i_writeStableArray
+ , i_readStableArray
+ , i_indexStableArray
+#endif
+
+ /* {write,read,index}ForeignObjArray not provided */
+
+#endif /* PROVIDE_ARRAY */
+
+#ifdef PROVIDE_PTREQUALITY
+ , i_reallyUnsafePtrEquality
+#endif
+#ifdef PROVIDE_COERCE
+ , i_unsafeCoerce
+#endif
+
+#ifdef PROVIDE_FOREIGN
+ /* ForeignObj# operations */
+ , i_makeForeignObj
+
+ , indexCharOffForeignObj
+ , indexIntOffForeignObj
+ , indexInt64OffForeignObj
+ , indexWordOffForeignObj
+ , indexAddrOffForeignObj
+ , indexFloatOffForeignObj
+ , indexDoubleOffForeignObj
+ , indexStablePtrOffForeignObj
+#endif
+#ifdef PROVIDE_WEAK
+ /* Weak# operations */
+ , i_makeWeak
+ , i_deRefWeak
+#endif
+#ifdef PROVIDE_STABLE
+ /* StablePtr# operations */
+ , i_makeStablePtr
+ , i_deRefStablePtr
+ , i_freeStablePtr
+#endif
+
+#ifdef PROVIDE_CONCURRENT
+ /* Concurrency operations */
+ , i_fork
+ , i_killThread
+ , i_sameMVar
+ , i_newMVar
+ , i_takeMVar
+ , i_putMVar
+ , i_delay
+ , i_waitRead
+ , i_waitWrite
+#endif
+
+ /* CCall! */
+ , i_ccall_Id
+ , i_ccall_IO
+
+ /* If you add a new primop to this table, check you don't
+ * overflow the 256 limit. That is MAX_Primop2 <= 255.
+ * Current value (30/10/98) = 0x42
+ */
+ , MAX_Primop2 = i_ccall_IO
+} Primop2;
+
+typedef unsigned int InstrPtr; /* offset of instruction within BCO */
+
+/*-------------------------------------------------------------------------*/
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: DebugProf.c,v 1.2 1998/12/02 13:28:14 simonm Exp $
+ *
+ * (c) The GHC Team 1998
+ *
+ * Simple Heap Profiling
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "Printer.h"
+#include "BlockAlloc.h"
+#include "DebugProf.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "Stats.h"
+
+#if defined(DEBUG) && ! defined(PROFILING)
+
+char prof_filename[128];
+FILE *prof_file;
+
+static void clear_table_data(void);
+static void fprint_data(FILE *fp);
+
+/* -----------------------------------------------------------------------------
+ Hash table for symbols.
+ -------------------------------------------------------------------------- */
+
+typedef struct {
+ const char *name;
+ void *ptr;
+ nat data;
+} symbol_info;
+
+#define SYMBOL_HASH_SIZE 0x3fff
+
+symbol_info symbol_hash[SYMBOL_HASH_SIZE];
+
+static inline nat
+hash(void *ptr)
+{
+ return ((W_)ptr)>>4 & 0x3fff;
+}
+
+static void
+initSymbolHash(void)
+{
+ nat i;
+
+ for (i=0; i < SYMBOL_HASH_SIZE; i++) {
+ symbol_hash[i].ptr = NULL;
+ }
+}
+
+static nat
+lookup_symbol(void *addr)
+{
+ nat orig_bucket = hash(addr);
+ nat bucket;
+
+ bucket = orig_bucket;
+ while (bucket < SYMBOL_HASH_SIZE && symbol_hash[bucket].ptr != NULL) {
+ if (symbol_hash[bucket].ptr == addr) {
+ return bucket;
+ }
+ bucket++;
+ }
+ if (bucket == SYMBOL_HASH_SIZE) {
+ bucket = 0;
+ while (bucket < orig_bucket && symbol_hash[bucket].ptr != NULL) {
+ if (symbol_hash[bucket].ptr == addr) {
+ return bucket;
+ }
+ bucket++;
+ }
+ if (bucket == orig_bucket) {
+ barf("out of symbol table space");
+ }
+ }
+
+ symbol_hash[bucket].ptr = addr;
+ lookupGHCName(addr,&symbol_hash[bucket].name);
+ symbol_hash[bucket].data = 0;
+ return bucket;
+}
+
+static void
+clear_table_data(void)
+{
+ nat i;
+
+ for (i = 0; i < SYMBOL_HASH_SIZE; i++) {
+ symbol_hash[i].data = 0;
+ }
+}
+
+static void
+fprint_data(FILE *fp)
+{
+ nat i;
+
+ for (i = 0; i < SYMBOL_HASH_SIZE; i++) {
+ if (symbol_hash[i].data) {
+ fprintf(fp, " %s %d\n", symbol_hash[i].name, symbol_hash[i].data);
+ }
+ }
+}
+
+static inline void
+add_data(void *addr, nat data)
+{
+ symbol_hash[lookup_symbol(addr)].data += data;
+}
+
+/* -----------------------------------------------------------------------------
+ Closure Type Profiling;
+ -------------------------------------------------------------------------- */
+
+static nat closure_types[N_CLOSURE_TYPES];
+
+static char *type_names[] = {
+ "INVALID_OBJECT"
+ , "CONSTR"
+ , "CONSTR_INTLIKE"
+ , "CONSTR_CHARLIKE"
+ , "CONSTR_STATIC"
+ , "CONSTR_NOCAF_STATIC"
+
+ , "FUN"
+ , "FUN_STATIC"
+
+ , "THUNK"
+ , "THUNK_STATIC"
+ , "THUNK_SELECTOR"
+
+ , "BCO"
+ , "AP_UPD"
+
+ , "PAP"
+
+ , "IND"
+ , "IND_OLDGEN"
+ , "IND_PERM"
+ , "IND_OLDGEN_PERM"
+ , "IND_STATIC"
+
+ , "RET_BCO"
+ , "RET_SMALL"
+ , "RET_VEC_SMALL"
+ , "RET_BIG"
+ , "RET_VEC_BIG"
+ , "RET_DYN"
+ , "UPDATE_FRAME"
+ , "CATCH_FRAME"
+ , "STOP_FRAME"
+ , "SEQ_FRAME"
+
+ , "BLACKHOLE"
+ , "MVAR"
+
+ , "ARR_WORDS"
+ , "ARR_PTRS"
+
+ , "MUT_ARR_WORDS"
+ , "MUT_ARR_PTRS"
+ , "MUT_ARR_PTRS_FROZEN"
+ , "MUT_VAR"
+
+ , "WEAK"
+ , "FOREIGN"
+
+ , "TSO"
+
+ , "BLOCKED_FETCH"
+ , "FETCH_ME"
+
+ , "EVACUATED"
+};
+
+static void
+fprint_closure_types(FILE *fp)
+{
+ nat i;
+
+ for (i = 0; i < N_CLOSURE_TYPES; i++) {
+ if (closure_types[i]) {
+ fprintf(fp, " %s %d\n", type_names[i], closure_types[i]);
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ The profiler itself
+ -------------------------------------------------------------------------- */
+
+nat
+initProfiling(void)
+{
+ if (! RtsFlags.ProfFlags.doHeapProfile) {
+ return 0;
+ }
+
+ sprintf(prof_filename, "%.124s.hp", prog_argv[0]);
+
+ prof_file = fopen(prof_filename, "w");
+ if (prof_file == NULL) {
+ fprintf(stderr, "Can't open heap profiling log file %s\n",
+ prof_filename);
+ return 1;
+ }
+
+ fprintf(prof_file, "JOB \"%s\"\n", prog_argv[0]);
+ fprintf(prof_file, "DATE \"%s\"\n", time_str());
+
+ fprintf(prof_file, "SAMPLE_UNIT \"seconds\"\n");
+ fprintf(prof_file, "VALUE_UNIT \"bytes\"\n");
+
+ fprintf(prof_file, "BEGIN_SAMPLE 0.00\n");
+ fprintf(prof_file, "END_SAMPLE 0.00\n");
+
+ DEBUG_LoadSymbols(prog_argv[0]);
+
+ initSymbolHash();
+
+ return 0;
+}
+
+void
+endProfiling(void)
+{
+ StgDouble seconds;
+
+ if (! RtsFlags.ProfFlags.doHeapProfile) {
+ return;
+ }
+
+ seconds = usertime();
+ fprintf(prof_file, "BEGIN_SAMPLE %0.2f\n", seconds);
+ fprintf(prof_file, "END_SAMPLE %0.2f\n", seconds);
+ fclose(prof_file);
+}
+
+void
+heapCensus(bdescr *bd)
+{
+ StgPtr p;
+ const StgInfoTable *info;
+ StgDouble time;
+ nat size;
+
+ switch (RtsFlags.ProfFlags.doHeapProfile) {
+ case HEAP_BY_INFOPTR:
+ clear_table_data();
+ break;
+ case HEAP_BY_CLOSURE_TYPE:
+ memset(closure_types, 0, N_CLOSURE_TYPES * sizeof(nat));
+ break;
+ default:
+ return;
+ }
+
+ /* usertime() isn't very accurate, since it includes garbage
+ * collection time. We really want elapsed_mutator_time or
+ * something. ToDo.
+ */
+ time = usertime();
+ fprintf(prof_file, "BEGIN_SAMPLE %0.2f\n", time);
+
+ while (bd != NULL) {
+ p = bd->start;
+ while (p < bd->free) {
+ info = get_itbl((StgClosure *)p);
+
+ switch (info->type) {
+ case BCO:
+ size = bco_sizeW((StgBCO *)p);
+ break;
+
+ case FUN:
+ case THUNK:
+ case CONSTR:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case BLACKHOLE:
+ case WEAK:
+ case FOREIGN:
+ case MVAR:
+ case MUT_VAR:
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ case THUNK_STATIC:
+ case FUN_STATIC:
+ case IND_STATIC:
+ size = sizeW_fromITBL(info);
+ break;
+
+ case THUNK_SELECTOR:
+ size = sizeofW(StgHeader) + MIN_UPD_SIZE;
+ break;
+
+ case IND:
+ case IND_OLDGEN:
+ size = sizeofW(StgInd);
+ break;
+
+ case AP_UPD: /* we can treat this as being the same as a PAP */
+ case PAP:
+ size = pap_sizeW((StgPAP *)p);
+ break;
+
+ case ARR_WORDS:
+ case MUT_ARR_WORDS:
+ size = arr_words_sizeW(stgCast(StgArrWords*,p));
+ break;
+
+ case ARR_PTRS:
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ size = arr_ptrs_sizeW((StgArrPtrs *)p);
+ break;
+
+ case TSO:
+ size = tso_sizeW((StgTSO *)p);
+ break;
+
+ default:
+ barf("heapCensus");
+ }
+ switch (RtsFlags.ProfFlags.doHeapProfile) {
+ case HEAP_BY_INFOPTR:
+ add_data((void *)(*p), size * sizeof(W_));
+ break;
+ case HEAP_BY_CLOSURE_TYPE:
+ closure_types[info->type] += size * sizeof(W_);
+ break;
+ }
+ p += size;
+ }
+ bd = bd->link;
+ }
+
+ switch (RtsFlags.ProfFlags.doHeapProfile) {
+ case HEAP_BY_INFOPTR:
+ fprint_data(prof_file);
+ break;
+ case HEAP_BY_CLOSURE_TYPE:
+ fprint_closure_types(prof_file);
+ break;
+ }
+
+ fprintf(prof_file, "END_SAMPLE %0.2f\n", time);
+}
+
+#endif
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: DebugProf.h,v 1.2 1998/12/02 13:28:15 simonm Exp $
+ *
+ * (c) The GHC Team 1998
+ *
+ * Simple Heap Profiling
+ *
+ * ---------------------------------------------------------------------------*/
+
+#if !defined(PROFILING) && defined(DEBUG)
+
+extern nat initProfiling(void);
+extern void endProfiling(void);
+extern void heapCensus(bdescr *bd);
+
+#endif
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* -----------------------------------------------------------------------------
+ * Bytecode disassembler
+ *
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: Disassembler.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:28:15 $
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef INTERPRETER
+
+#include "RtsUtils.h"
+#include "Bytecodes.h"
+#include "Assembler.h"
+#include "Printer.h"
+#include "Disassembler.h"
+
+/* --------------------------------------------------------------------------
+ * Disassembler
+ * ------------------------------------------------------------------------*/
+
+static InstrPtr disNone ( StgBCO *bco, InstrPtr pc, char* i );
+static InstrPtr disInt ( StgBCO *bco, InstrPtr pc, char* i );
+static InstrPtr disIntInt ( StgBCO *bco, InstrPtr pc, char* i );
+static InstrPtr disInfo ( StgBCO *bco, InstrPtr pc, char* i );
+static InstrPtr disConstPtr ( StgBCO *bco, InstrPtr pc, char* i );
+static InstrPtr disConstInt ( StgBCO *bco, InstrPtr pc, char* i );
+static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i );
+static InstrPtr disConstFloat ( StgBCO *bco, InstrPtr pc, char* i );
+
+static InstrPtr disNone ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ fprintf(stderr,"%s",i);
+ return pc;
+}
+
+static InstrPtr disInt ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x = bcoInstr(bco,pc++);
+ ASSERT(pc < bco->n_instrs);
+ fprintf(stderr,"%s %d",i,x);
+ return pc;
+}
+
+static InstrPtr disIntInt ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x = bcoInstr(bco,pc++);
+ StgInt y = bcoInstr(bco,pc++);
+ fprintf(stderr,"%s %d %d",i,x,y);
+ return pc;
+}
+
+static InstrPtr disIntPC ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x = bcoInstr(bco,pc++);
+ StgWord y = bcoInstr(bco,pc++);
+ fprintf(stderr,"%s %d %d",i,x,pc+y);
+ return pc;
+}
+
+static InstrPtr disPC ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgWord y = bcoInstr(bco,pc++);
+ fprintf(stderr,"%s %d",i,pc+y);
+ return pc;
+}
+
+static InstrPtr disInfo ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInfoTable* info = bcoConstInfoPtr(bco,bcoInstr(bco,pc++));
+ /* ToDo: print contents of infotable */
+ fprintf(stderr,"%s ",i);
+ printPtr(stgCast(StgPtr,info));
+ return pc;
+}
+
+static InstrPtr disConstPtr ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt o = bcoInstr(bco,pc++);
+ StgPtr x = bcoConstPtr(bco,o);
+ fprintf(stderr,"%s [%d]=",i,o);
+ printPtr(x); /* bad way to print it... */
+ return pc;
+}
+
+static InstrPtr disConst2Ptr ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgWord o1 = bcoInstr(bco,pc++);
+ StgWord o2 = bcoInstr(bco,pc++);
+ StgWord o = o1*256 + o2;
+ StgPtr x = bcoConstPtr(bco,o);
+ fprintf(stderr,"%s [%d]=",i,o);
+ printPtr(x); /* bad way to print it... */
+ return pc;
+}
+
+static InstrPtr disConstInt ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x = bcoConstInt(bco,bcoInstr(bco,pc++));
+ fprintf(stderr,"%s %d",i,x);
+ return pc;
+}
+
+static InstrPtr disConstAddr ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgAddr x = bcoConstAddr(bco,bcoInstr(bco,pc++));
+ fprintf(stderr,"%s ",i);
+ printPtr(x);
+ return pc;
+}
+
+static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgChar x = bcoConstChar(bco,bcoInstr(bco,pc++));
+ fprintf(stderr,"%s '%c'",i,x);
+ return pc;
+}
+
+static InstrPtr disConstFloat ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgFloat x = bcoConstFloat(bco,bcoInstr(bco,pc++));
+ fprintf(stderr,"%s %f",i,x);
+ return pc;
+}
+
+static InstrPtr disConstDouble ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgDouble x = bcoConstDouble(bco,bcoInstr(bco,pc++));
+ fprintf(stderr,"%s %f",i,x);
+ return pc;
+}
+
+InstrPtr disInstr( StgBCO *bco, InstrPtr pc )
+{
+ Instr in;
+ ASSERT(pc < bco->n_instrs);
+ in = bcoInstr(bco,pc++);
+ switch (in) {
+ case i_INTERNAL_ERROR:
+ return disNone(bco,pc,"INTERNAL_ERROR");
+ case i_PANIC:
+ return disNone(bco,pc,"PANIC");
+ case i_HP_CHECK:
+ return disInt(bco,pc,"HP_CHECK");
+ case i_STK_CHECK:
+ return disInt(bco,pc,"STK_CHECK");
+ case i_ARG_CHECK:
+ return disInt(bco,pc,"ARG_CHECK");
+ case i_ALLOC_AP:
+ return disInt(bco,pc,"ALLOC_AP");
+ case i_ALLOC_PAP:
+ return disInt(bco,pc,"ALLOC_PAP");
+ case i_ALLOC_CONSTR:
+ return disInfo(bco,pc,"ALLOC_CONSTR");
+ case i_MKAP:
+ return disIntInt(bco,pc,"MKAP");
+ case i_MKPAP:
+ return disIntInt(bco,pc,"MKPAP");
+ case i_PACK:
+ return disInt(bco,pc,"PACK");
+ case i_SLIDE:
+ return disIntInt(bco,pc,"SLIDE");
+ case i_ENTER:
+ return disNone(bco,pc,"ENTER");
+ case i_RETADDR:
+ return disConstPtr(bco,pc,"RETADDR");
+ case i_TEST:
+ return disIntPC(bco,pc,"TEST");
+ case i_UNPACK:
+ return disNone(bco,pc,"UNPACK");
+ case i_VAR:
+ return disInt(bco,pc,"VAR");
+ case i_CONST:
+ return disConstPtr(bco,pc,"CONST");
+ case i_CONST2:
+ return disConst2Ptr(bco,pc,"CONST2");
+
+ case i_VOID:
+ return disNone(bco,pc,"VOID");
+
+ case i_RETURN_GENERIC:
+ return disNone(bco,pc,"RETURN_GENERIC");
+
+ case i_VAR_INT:
+ return disInt(bco,pc,"VAR_INT");
+ case i_CONST_INT:
+ return disConstInt(bco,pc,"CONST_INT");
+ case i_RETURN_INT:
+ return disNone(bco,pc,"RETURN_INT");
+ case i_PACK_INT:
+ return disNone(bco,pc,"PACK_INT");
+ case i_UNPACK_INT:
+ return disNone(bco,pc,"UNPACK_INT");
+ case i_TEST_INT:
+ return disPC(bco,pc,"TEST_INT");
+
+#ifdef PROVIDE_INT64
+ case i_VAR_INT64:
+ return disInt(bco,pc,"VAR_INT64");
+ case i_CONST_INT64:
+ return disConstInt(bco,pc,"CONST_INT64");
+ case i_RETURN_INT64:
+ return disNone(bco,pc,"RETURN_INT64");
+ case i_PACK_INT64:
+ return disNone(bco,pc,"PACK_INT64");
+ case i_UNPACK_INT64:
+ return disNone(bco,pc,"UNPACK_INT64");
+#endif
+#ifdef PROVIDE_INTEGER
+ case i_CONST_INTEGER:
+ return disConstAddr(bco,pc,"CONST_INTEGER");
+#endif
+#ifdef PROVIDE_WORD
+ case i_VAR_WORD:
+ return disInt(bco,pc,"VAR_WORD");
+ case i_CONST_WORD:
+ return disConstInt(bco,pc,"CONST_WORD");
+ case i_RETURN_WORD:
+ return disNone(bco,pc,"RETURN_WORD");
+ case i_PACK_WORD:
+ return disNone(bco,pc,"PACK_WORD");
+ case i_UNPACK_WORD:
+ return disNone(bco,pc,"UNPACK_WORD");
+#endif
+#ifdef PROVIDE_ADDR
+ case i_VAR_ADDR:
+ return disInt(bco,pc,"VAR_ADDR");
+ case i_CONST_ADDR:
+ return disConstAddr(bco,pc,"CONST_ADDR");
+ case i_RETURN_ADDR:
+ return disNone(bco,pc,"RETURN_ADDR");
+ case i_PACK_ADDR:
+ return disNone(bco,pc,"PACK_ADDR");
+ case i_UNPACK_ADDR:
+ return disNone(bco,pc,"UNPACK_ADDR");
+#endif
+ case i_VAR_CHAR:
+ return disInt(bco,pc,"VAR_CHAR");
+ case i_CONST_CHAR:
+ return disConstChar(bco,pc,"CONST_CHAR");
+ case i_RETURN_CHAR:
+ return disNone(bco,pc,"RETURN_CHAR");
+ case i_PACK_CHAR:
+ return disNone(bco,pc,"PACK_CHAR");
+ case i_UNPACK_CHAR:
+ return disNone(bco,pc,"UNPACK_CHAR");
+
+ case i_VAR_FLOAT:
+ return disInt(bco,pc,"VAR_FLOAT");
+ case i_CONST_FLOAT:
+ return disConstFloat(bco,pc,"CONST_FLOAT");
+ case i_RETURN_FLOAT:
+ return disNone(bco,pc,"RETURN_FLOAT");
+ case i_PACK_FLOAT:
+ return disNone(bco,pc,"PACK_FLOAT");
+ case i_UNPACK_FLOAT:
+ return disNone(bco,pc,"UNPACK_FLOAT");
+
+ case i_VAR_DOUBLE:
+ return disInt(bco,pc,"VAR_DOUBLE");
+ case i_CONST_DOUBLE:
+ return disConstDouble(bco,pc,"CONST_DOUBLE");
+ case i_RETURN_DOUBLE:
+ return disNone(bco,pc,"RETURN_DOUBLE");
+ case i_PACK_DOUBLE:
+ return disNone(bco,pc,"PACK_DOUBLE");
+ case i_UNPACK_DOUBLE:
+ return disNone(bco,pc,"UNPACK_DOUBLE");
+
+#ifdef PROVIDE_STABLE
+ case i_VAR_STABLE:
+ return disInt(bco,pc,"VAR_STABLE");
+ case i_RETURN_STABLE:
+ return disNone(bco,pc,"RETURN_STABLE");
+ case i_PACK_STABLE:
+ return disNone(bco,pc,"PACK_STABLE");
+ case i_UNPACK_STABLE:
+ return disNone(bco,pc,"UNPACK_STABLE");
+#endif
+
+ case i_PRIMOP1:
+ {
+ Primop1 op = bcoInstr(bco,pc++);
+ switch (op) {
+ case i_INTERNAL_ERROR1:
+ return disNone(bco,pc,"INTERNAL_ERROR1");
+ default:
+ {
+ const AsmPrim* p = asmFindPrimop(i_PRIMOP1,op);
+ if (p) {
+ return disNone(bco,pc,p->name);
+ }
+ barf("Unrecognised primop1 %d\n",op);
+ }
+ }
+ }
+ case i_PRIMOP2:
+ {
+ Primop2 op = bcoInstr(bco,pc++);
+ switch (op) {
+ case i_INTERNAL_ERROR2:
+ return disNone(bco,pc,"INTERNAL_ERROR2");
+ case i_ccall_Id:
+ return disNone(bco,pc,"ccall_Id");
+ case i_ccall_IO:
+ return disNone(bco,pc,"ccall_IO");
+ default:
+ {
+ const AsmPrim* p = asmFindPrimop(i_PRIMOP2,op);
+ if (p) {
+ return disNone(bco,pc,p->name);
+ }
+ barf("Unrecognised primop2 %d\n",op);
+ }
+ }
+ }
+ default:
+ barf("Unrecognised instruction %d\n",in);
+ }
+}
+
+void disassemble( StgBCO *bco, char* prefix )
+{
+ int pc = 0;
+ int pcLim = bco->n_instrs;
+ ASSERT( get_itbl(bco)->type == BCO);
+ while (pc < pcLim) {
+ fprintf(stderr,"%s%d:\t",prefix,pc);
+ pc = disInstr(bco,pc);
+ fprintf(stderr,"\n");
+ }
+}
+
+#endif /* INTERPRETER */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Disassembler.h,v 1.2 1998/12/02 13:28:16 simonm Exp $
+ *
+ * Prototypes for functions in Disassembler.c
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern InstrPtr disInstr ( StgBCO *bco, InstrPtr pc );
+extern void disassemble( StgBCO *bco, char* prefix );
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* -----------------------------------------------------------------------------
+ * Bytecode evaluator
+ *
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: Evaluator.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:28:17 $
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef INTERPRETER
+
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "Updates.h"
+#include "Storage.h"
+#include "SchedAPI.h" /* for createGenThread */
+#include "Schedule.h" /* for context_switch */
+
+#include "Bytecodes.h"
+#include "Assembler.h" /* for CFun stuff */
+#include "ForeignCall.h"
+#include "StablePtr.h"
+#include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
+#include "Evaluator.h"
+
+#ifdef DEBUG
+#include "Printer.h"
+#include "Disassembler.h"
+
+#include "Sanity.h"
+#include "StgRun.h"
+#endif
+
+#include <math.h> /* These are for primops */
+#include <limits.h> /* These are for primops */
+#include <float.h> /* These are for primops */
+#ifdef HAVE_IEEE754_H
+#include <ieee754.h> /* These are for primops */
+#endif
+#ifdef PROVIDE_INTEGER
+#include "gmp.h" /* These are for primops */
+#endif
+
+/* An incredibly useful abbreviation.
+ * Interestingly, there are some uses of END_TSO_QUEUE_closure that
+ * can't use it because they use the closure at type StgClosure* or
+ * even StgPtr*. I suspect they should be changed. -- ADR
+ */
+#define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
+
+/* These macros are rather delicate - read a good ANSI C book carefully
+ * before meddling.
+ */
+#define mystr(x) #x
+#define mycat(x,y) x##y
+#define mycat2(x,y) mycat(x,y)
+#define mycat3(x,y,z) mycat2(x,mycat2(y,z))
+
+/* --------------------------------------------------------------------------
+ * Hugs Hooks - a bit of a hack
+ * ------------------------------------------------------------------------*/
+
+void setRtsFlags( int x );
+void setRtsFlags( int x )
+{
+ *(int*)(&(RtsFlags.DebugFlags)) = x;
+}
+
+/* --------------------------------------------------------------------------
+ * RTS Hooks
+ *
+ * ToDo: figure out why these are being used and crush them!
+ * ------------------------------------------------------------------------*/
+
+void OnExitHook (void)
+{
+}
+void StackOverflowHook (unsigned long stack_size)
+{
+ fprintf(stderr,"Stack Overflow\n");
+ exit(1);
+}
+void OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
+{
+ fprintf(stderr,"Out Of Heap\n");
+ exit(1);
+}
+void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
+{
+ fprintf(stderr,"Malloc Fail\n");
+ exit(1);
+}
+void defaultsHook (void)
+{
+ /* do nothing */
+}
+
+/* --------------------------------------------------------------------------
+ * MPZ helpers
+ * ------------------------------------------------------------------------*/
+
+#ifdef PROVIDE_INTEGER
+static inline mpz_ptr mpz_alloc ( void );
+static inline void mpz_free ( mpz_ptr );
+
+static inline mpz_ptr mpz_alloc ( void )
+{
+ mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc"));
+ mpz_init(r);
+ return r;
+}
+
+static inline void mpz_free ( mpz_ptr a )
+{
+ mpz_clear(a);
+ free(a);
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+static inline void PushTag ( StackTag t );
+static inline void PushPtr ( StgPtr x );
+static inline void PushCPtr ( StgClosure* x );
+static inline void PushInt ( StgInt x );
+static inline void PushWord ( StgWord x );
+
+static inline void PushTag ( StackTag t ) { *(--Sp) = t; }
+static inline void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; }
+static inline void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; }
+static inline void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; }
+static inline void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; }
+
+static inline void checkTag ( StackTag t1, StackTag t2 );
+static inline void PopTag ( StackTag t );
+static inline StgPtr PopPtr ( void );
+static inline StgClosure* PopCPtr ( void );
+static inline StgInt PopInt ( void );
+static inline StgWord PopWord ( void );
+
+static inline void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);}
+static inline void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); }
+static inline StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; }
+static inline StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; }
+static inline StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; }
+static inline StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; }
+
+static inline StgPtr stackPtr ( StgStackOffset i );
+static inline StgInt stackInt ( StgStackOffset i );
+static inline StgWord stackWord ( StgStackOffset i );
+
+static inline StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); }
+static inline StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); }
+static inline StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); }
+
+static inline void setStackWord ( StgStackOffset i, StgWord w );
+
+static inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
+
+static inline void PushTaggedRealWorld( void );
+static inline void PushTaggedInt ( StgInt x );
+#ifdef PROVIDE_INT64
+static inline void PushTaggedInt64 ( StgInt64 x );
+#endif
+#ifdef PROVIDE_INTEGER
+static inline void PushTaggedInteger ( mpz_ptr x );
+#endif
+#ifdef PROVIDE_WORD
+static inline void PushTaggedWord ( StgWord x );
+#endif
+#ifdef PROVIDE_ADDR
+static inline void PushTaggedAddr ( StgAddr x );
+#endif
+static inline void PushTaggedChar ( StgChar x );
+static inline void PushTaggedFloat ( StgFloat x );
+static inline void PushTaggedDouble ( StgDouble x );
+static inline void PushTaggedStablePtr ( StgStablePtr x );
+static inline void PushTaggedBool ( int x );
+
+static inline void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); }
+static inline void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
+#ifdef PROVIDE_INT64
+static inline void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); }
+#endif
+#ifdef PROVIDE_INTEGER
+static inline void PushTaggedInteger ( mpz_ptr x )
+{
+ StgForeignObj *result;
+ StgWeak *w;
+
+ result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
+ SET_HDR(result,&FOREIGN_info,CCCS);
+ result -> data = x;
+
+#if 0 /* For now we don't deallocate Integer's at all */
+ w = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
+ SET_HDR(w, &WEAK_info, CCCS);
+ w->key = stgCast(StgClosure*,result);
+ w->value = stgCast(StgClosure*,result); /* or any other closure you have handy */
+ w->finaliser = funPtrToIO(mpz_free);
+ w->link = weak_ptr_list;
+ weak_ptr_list = w;
+ IF_DEBUG(weak, fprintf(stderr,"New weak pointer watching Foreign MPZ at %p\n",w));
+#endif
+
+ PushPtr(stgCast(StgPtr,result));
+}
+#endif
+#ifdef PROVIDE_WORD
+static inline void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
+#endif
+#ifdef PROVIDE_ADDR
+static inline void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
+#endif
+static inline void PushTaggedChar ( StgChar x ) { Sp -= sizeofW(StgChar); *Sp = x; PushTag(CHAR_TAG); }
+static inline void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
+static inline void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
+static inline void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
+static inline void PushTaggedBool ( int x ) { PushTaggedInt(x); }
+
+static inline void PopTaggedRealWorld ( void );
+static inline StgInt PopTaggedInt ( void );
+#ifdef PROVIDE_INT64
+static inline StgInt64 PopTaggedInt64 ( void );
+#endif
+#ifdef PROVIDE_INTEGER
+static inline mpz_ptr PopTaggedInteger ( void );
+#endif
+#ifdef PROVIDE_WORD
+static inline StgWord PopTaggedWord ( void );
+#endif
+#ifdef PROVIDE_ADDR
+static inline StgAddr PopTaggedAddr ( void );
+#endif
+static inline StgChar PopTaggedChar ( void );
+static inline StgFloat PopTaggedFloat ( void );
+static inline StgDouble PopTaggedDouble ( void );
+static inline StgStablePtr PopTaggedStablePtr ( void );
+
+static inline void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); }
+static inline StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;}
+#ifdef PROVIDE_INT64
+static inline StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;}
+#endif
+#ifdef PROVIDE_INTEGER
+static inline mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);}
+#endif
+#ifdef PROVIDE_WORD
+static inline StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;}
+#endif
+#ifdef PROVIDE_ADDR
+static inline StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;}
+#endif
+static inline StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = *stgCast(StgChar*, Sp); Sp += sizeofW(StgChar); return r;}
+static inline StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;}
+static inline StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;}
+static inline StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;}
+
+static inline StgInt taggedStackInt ( StgStackOffset i );
+#ifdef PROVIDE_INT64
+static inline StgInt64 taggedStackInt64 ( StgStackOffset i );
+#endif
+#ifdef PROVIDE_WORD
+static inline StgWord taggedStackWord ( StgStackOffset i );
+#endif
+#ifdef PROVIDE_ADDR
+static inline StgAddr taggedStackAddr ( StgStackOffset i );
+#endif
+static inline StgChar taggedStackChar ( StgStackOffset i );
+static inline StgFloat taggedStackFloat ( StgStackOffset i );
+static inline StgDouble taggedStackDouble ( StgStackOffset i );
+static inline StgStablePtr taggedStackStable ( StgStackOffset i );
+
+static inline StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
+#ifdef PROVIDE_INT64
+static inline StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); }
+#endif
+#ifdef PROVIDE_WORD
+static inline StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
+#endif
+#ifdef PROVIDE_ADDR
+static inline StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
+#endif
+static inline StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return *stgCast(StgChar*, Sp+1+i); }
+static inline StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
+static inline StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
+static inline StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
+
+
+/* --------------------------------------------------------------------------
+ * Heap allocation
+ *
+ * Should we allocate from a nursery or use the
+ * doYouWantToGC/allocate interface? We'd already implemented a
+ * nursery-style scheme when the doYouWantToGC/allocate interface
+ * was implemented.
+ * One reason to prefer the doYouWantToGC/allocate interface is to
+ * support operations which allocate an unknown amount in the heap
+ * (array ops, gmp ops, etc)
+ * ------------------------------------------------------------------------*/
+
+static inline StgPtr grabHpUpd( nat size )
+{
+ ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
+ return allocate(size);
+}
+
+static inline StgPtr grabHpNonUpd( nat size )
+{
+ ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ return allocate(size);
+}
+
+/* --------------------------------------------------------------------------
+ * Manipulate "update frame" list:
+ * o Update frames (based on stg_do_update and friends in Updates.hc)
+ * o Error handling/catching (based on catchZh_fast and friends in Prims.hc)
+ * o Seq frames (based on seq_frame_entry in Prims.hc)
+ * o Stop frames
+ * ------------------------------------------------------------------------*/
+
+static inline void PopUpdateFrame ( StgClosure* obj );
+static inline void PushCatchFrame ( StgClosure* catcher );
+static inline void PopCatchFrame ( void );
+static inline void PushSeqFrame ( void );
+static inline void PopSeqFrame ( void );
+
+static inline StgClosure* raiseAnError ( StgClosure* errObj );
+
+static inline void PopUpdateFrame( StgClosure* obj )
+{
+ /* NB: doesn't assume that Sp == Su */
+ IF_DEBUG(evaluator,
+ fprintf(stderr, "Updating ");
+ printPtr(stgCast(StgPtr,Su->updatee));
+ fprintf(stderr, " with ");
+ printObj(obj);
+ fprintf(stderr,"\nSp = %p\tSu = %p\n", Sp, Su);
+ );
+#ifndef LAZY_BLACKHOLING
+ ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
+ || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
+ );
+#endif /* LAZY_BLACKHOLING */
+ UPD_IND(Su->updatee,obj);
+ Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
+ Su = Su->link;
+}
+
+static inline void PopStopFrame( StgClosure* obj )
+{
+ /* Move Su just off the end of the stack, we're about to spam the
+ * STOP_FRAME with the return value.
+ */
+ Su = stgCast(StgUpdateFrame*,Sp+1);
+ *stgCast(StgClosure**,Sp) = obj;
+}
+
+static inline void PushCatchFrame( StgClosure* handler )
+{
+ StgCatchFrame* fp;
+ /* ToDo: stack check! */
+ Sp -= sizeofW(StgCatchFrame*); /* ToDo: this can't be right */
+ fp = stgCast(StgCatchFrame*,Sp);
+ SET_HDR(fp,&catch_frame_info,CCCS);
+ fp->handler = handler;
+ fp->link = Su;
+ Su = stgCast(StgUpdateFrame*,fp);
+}
+
+static inline void PopCatchFrame( void )
+{
+ /* NB: doesn't assume that Sp == Su */
+ /* fprintf(stderr,"Popping catch frame\n"); */
+ Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
+ Su = stgCast(StgCatchFrame*,Su)->link;
+}
+
+static inline void PushSeqFrame( void )
+{
+ StgSeqFrame* fp;
+ /* ToDo: stack check! */
+ Sp -= sizeofW(StgSeqFrame*); /* ToDo: this can't be right */
+ fp = stgCast(StgSeqFrame*,Sp);
+ SET_HDR(fp,&seq_frame_info,CCCS);
+ fp->link = Su;
+ Su = stgCast(StgUpdateFrame*,fp);
+}
+
+static inline void PopSeqFrame( void )
+{
+ /* NB: doesn't assume that Sp == Su */
+ Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
+ Su = stgCast(StgSeqFrame*,Su)->link;
+}
+
+static inline StgClosure* raiseAnError( StgClosure* errObj )
+{
+ while (1) {
+ switch (get_itbl(Su)->type) {
+ case UPDATE_FRAME:
+ UPD_INPLACE1(Su->updatee,&raise_info,errObj);
+ Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
+ Su = Su->link;
+ break;
+ case SEQ_FRAME:
+ PopSeqFrame();
+ break;
+ case CATCH_FRAME: /* found it! */
+ {
+ StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
+ StgClosure *handler = fp->handler;
+ Su = fp->link;
+ Sp += sizeofW(StgCatchFrame); /* Pop */
+ PushCPtr(errObj);
+ return handler;
+ }
+ case STOP_FRAME:
+ barf("raiseError: STOP_FRAME");
+ default:
+ barf("raiseError: weird activation record");
+ }
+ }
+}
+
+static StgClosure* raisePrim(char* msg)
+{
+ /* ToDo: figure out some way to turn the msg into a Haskell Exception
+ * Hack: we don't know how to build an Exception but we do know how
+ * to build a (recursive!) error object.
+ * The result isn't pretty but it's (slightly) better than nothing.
+ */
+ nat size = sizeof(StgClosure) + 1;
+ StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size));
+ SET_INFO(errObj,&raise_info);
+ errObj->payload[0] = errObj;
+
+#if 0
+ belch(msg);
+#else
+ /* At the moment, I prefer to put it on stdout to make things as
+ * close to Hugs' old behaviour as possible.
+ */
+ fprintf(stdout, "Program error: %s", msg);
+ fflush(stdout);
+#endif
+ return raiseAnError(stgCast(StgClosure*,errObj));
+}
+
+#define raiseIndex(where) raisePrim("Array index out of range in " where)
+#define raiseDiv0(where) raisePrim("Division by 0 in " where)
+
+/* --------------------------------------------------------------------------
+ * Evaluator
+ * ------------------------------------------------------------------------*/
+
+#define OP_CC_B(e) \
+{ \
+ unsigned char x = PopTaggedChar(); \
+ unsigned char y = PopTaggedChar(); \
+ PushTaggedBool(e); \
+}
+
+#define OP_C_I(e) \
+{ \
+ unsigned char x = PopTaggedChar(); \
+ PushTaggedInt(e); \
+}
+
+#define OP__I(e) \
+{ \
+ PushTaggedInt(e); \
+}
+
+#define OP_IW_I(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ StgWord y = PopTaggedWord(); \
+ PushTaggedInt(e); \
+}
+
+#define OP_II_I(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ StgInt y = PopTaggedInt(); \
+ PushTaggedInt(e); \
+}
+
+#define OP_II_B(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ StgInt y = PopTaggedInt(); \
+ PushTaggedBool(e); \
+}
+
+#define OP__A(e) \
+{ \
+ PushTaggedAddr(e); \
+}
+
+#define OP_I_A(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedAddr(e); \
+}
+
+#define OP_I_I(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedInt(e); \
+}
+
+#define OP__C(e) \
+{ \
+ PushTaggedChar(e); \
+}
+
+#define OP_I_C(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedChar(e); \
+}
+
+#define OP__W(e) \
+{ \
+ PushTaggedWord(e); \
+}
+
+#define OP_I_W(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedWord(e); \
+}
+
+#define OP__F(e) \
+{ \
+ PushTaggedFloat(e); \
+}
+
+#define OP_I_F(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedFloat(e); \
+}
+
+#define OP__D(e) \
+{ \
+ PushTaggedDouble(e); \
+}
+
+#define OP_I_D(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedDouble(e); \
+}
+
+#ifdef PROVIDE_WORD
+#define OP_WW_B(e) \
+{ \
+ StgWord x = PopTaggedWord(); \
+ StgWord y = PopTaggedWord(); \
+ PushTaggedBool(e); \
+}
+
+#define OP_WW_W(e) \
+{ \
+ StgWord x = PopTaggedWord(); \
+ StgWord y = PopTaggedWord(); \
+ PushTaggedWord(e); \
+}
+
+#define OP_W_I(e) \
+{ \
+ StgWord x = PopTaggedWord(); \
+ PushTaggedInt(e); \
+}
+
+#define OP_W_W(e) \
+{ \
+ StgWord x = PopTaggedWord(); \
+ PushTaggedWord(e); \
+}
+#endif
+
+#ifdef PROVIDE_ADDR
+#define OP_AA_B(e) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ StgAddr y = PopTaggedAddr(); \
+ PushTaggedBool(e); \
+}
+#define OP_A_I(e) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ PushTaggedInt(e); \
+}
+#define OP_AI_C(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgChar r; \
+ s; \
+ PushTaggedChar(r); \
+}
+#define OP_AI_I(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgInt r; \
+ s; \
+ PushTaggedInt(r); \
+}
+#define OP_AI_z(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgInt64 r; \
+ s; \
+ PushTaggedInt64(r); \
+}
+#define OP_AI_A(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgAddr r; \
+ s; \
+ PushTaggedAddr(s); \
+}
+#define OP_AI_F(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgFloat r; \
+ s; \
+ PushTaggedFloat(r); \
+}
+#define OP_AI_D(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgDouble r; \
+ s; \
+ PushTaggedDouble(r); \
+}
+#define OP_AI_s(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgStablePtr r; \
+ s; \
+ PushTaggedStablePtr(r); \
+}
+#define OP_AIC_(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgChar z = PopTaggedChar(); \
+ s; \
+}
+#define OP_AII_(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgInt z = PopTaggedInt(); \
+ s; \
+}
+#define OP_AIz_(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgInt64 z = PopTaggedInt64(); \
+ s; \
+}
+#define OP_AIA_(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgAddr z = PopTaggedAddr(); \
+ s; \
+}
+#define OP_AIF_(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgFloat z = PopTaggedFloat(); \
+ s; \
+}
+#define OP_AID_(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgDouble z = PopTaggedDouble(); \
+ s; \
+}
+#define OP_AIs_(s) \
+{ \
+ StgAddr x = PopTaggedAddr(); \
+ int y = PopTaggedInt(); \
+ StgStablePtr z = PopTaggedStablePtr(); \
+ s; \
+}
+
+#endif /* PROVIDE_ADDR */
+
+#define OP_FF_B(e) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ StgFloat y = PopTaggedFloat(); \
+ PushTaggedBool(e); \
+}
+
+#define OP_FF_F(e) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ StgFloat y = PopTaggedFloat(); \
+ PushTaggedFloat(e); \
+}
+
+#define OP_F_F(e) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ PushTaggedFloat(e); \
+}
+
+#define OP_F_B(e) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ PushTaggedBool(e); \
+}
+
+#define OP_F_I(e) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ PushTaggedInt(e); \
+}
+
+#define OP_F_D(e) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ PushTaggedDouble(e); \
+}
+
+#define OP_DD_B(e) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ StgDouble y = PopTaggedDouble(); \
+ PushTaggedBool(e); \
+}
+
+#define OP_DD_D(e) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ StgDouble y = PopTaggedDouble(); \
+ PushTaggedDouble(e); \
+}
+
+#define OP_D_B(e) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ PushTaggedBool(e); \
+}
+
+#define OP_D_D(e) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ PushTaggedDouble(e); \
+}
+
+#define OP_D_I(e) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ PushTaggedInt(e); \
+}
+
+#define OP_D_F(e) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ PushTaggedFloat(e); \
+}
+
+#ifdef PROVIDE_INT64
+#define OP_zI_F(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ int y = PopTaggedInt(); \
+ PushTaggedFloat(e); \
+}
+#define OP_zI_D(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ int y = PopTaggedInt(); \
+ PushTaggedDouble(e); \
+}
+#define OP_zz_I(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ StgInt64 y = PopTaggedInt64(); \
+ PushTaggedInt(e); \
+}
+#define OP_z_z(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ PushTaggedInt64(e); \
+}
+#define OP_zz_z(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ StgInt64 y = PopTaggedInt64(); \
+ PushTaggedInt64(e); \
+}
+#define OP_zW_z(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ StgWord y = PopTaggedWord(); \
+ PushTaggedInt64(e); \
+}
+#define OP_zz_zZ(e1,e2) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ StgInt64 y = PopTaggedInt64(); \
+ PushTaggedInt64(e1); \
+ PushTaggedInt64(e2); \
+}
+#define OP_zz_B(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ StgInt64 y = PopTaggedInt64(); \
+ PushTaggedBool(e); \
+}
+#define OP__z(e) \
+{ \
+ PushTaggedInt64(e); \
+}
+#define OP_z_I(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ PushTaggedInt(e); \
+}
+#define OP_I_z(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedInt64(e); \
+}
+#ifdef PROVIDE_WORD
+#define OP_z_W(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ PushTaggedWord(e); \
+}
+#define OP_W_z(e) \
+{ \
+ StgWord x = PopTaggedWord(); \
+ PushTaggedInt64(e); \
+}
+#endif
+#define OP_z_F(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ printf("%lld = %f\n",x,(float)(e)); \
+ PushTaggedFloat(e); \
+}
+#define OP_F_z(e) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ PushTaggedInt64(e); \
+}
+#define OP_z_D(e) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ PushTaggedDouble(e); \
+}
+#define OP_D_z(e) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ PushTaggedInt64(e); \
+}
+#endif
+
+#ifdef PROVIDE_INTEGER
+
+#define OP_ZI_F(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ int y = PopTaggedInt(); \
+ PushTaggedFloat(e); \
+}
+#define OP_F_ZI(s) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ mpz_ptr r1 = mpz_alloc(); \
+ StgInt r2; \
+ s; \
+ PushTaggedInt(r2); \
+ PushTaggedInteger(r1); \
+}
+#define OP_ZI_D(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ int y = PopTaggedInt(); \
+ PushTaggedDouble(e); \
+}
+#define OP_D_ZI(s) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ mpz_ptr r1 = mpz_alloc(); \
+ StgInt r2; \
+ s; \
+ PushTaggedInt(r2); \
+ PushTaggedInteger(r1); \
+}
+#define OP_Z_Z(s) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ mpz_ptr r = mpz_alloc(); \
+ s; \
+ PushTaggedInteger(r); \
+}
+#define OP_ZZ_Z(s) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ mpz_ptr y = PopTaggedInteger(); \
+ mpz_ptr r = mpz_alloc(); \
+ s; \
+ PushTaggedInteger(r); \
+}
+#define OP_ZZ_B(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ mpz_ptr y = PopTaggedInteger(); \
+ PushTaggedBool(e); \
+}
+#define OP_Z_I(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ PushTaggedInt(e); \
+}
+#define OP_I_Z(s) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ mpz_ptr r = mpz_alloc(); \
+ s; \
+ PushTaggedInteger(r); \
+}
+#ifdef PROVIDE_INT64
+#define OP_Z_z(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ PushTaggedInt64(e); \
+}
+#define OP_z_Z(s) \
+{ \
+ StgInt64 x = PopTaggedInt64(); \
+ mpz_ptr r = mpz_alloc(); \
+ s; \
+ PushTaggedInteger(r); \
+}
+#endif
+#ifdef PROVIDE_WORD
+#define OP_Z_W(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ PushTaggedWord(e); \
+}
+#define OP_W_Z(s) \
+{ \
+ StgWord x = PopTaggedWord(); \
+ mpz_ptr r = mpz_alloc(); \
+ s; \
+ PushTaggedInteger(r); \
+}
+#endif
+#define OP_Z_F(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ PushTaggedFloat(e); \
+}
+#define OP_F_Z(s) \
+{ \
+ StgFloat x = PopTaggedFloat(); \
+ mpz_ptr r = mpz_alloc(); \
+ s; \
+ PushTaggedInteger(r); \
+}
+#define OP_Z_D(e) \
+{ \
+ mpz_ptr x = PopTaggedInteger(); \
+ PushTaggedDouble(e); \
+}
+#define OP_D_Z(s) \
+{ \
+ StgDouble x = PopTaggedDouble(); \
+ mpz_ptr r = mpz_alloc(); \
+ s; \
+ PushTaggedInteger(r); \
+}
+
+#endif /* ifdef PROVIDE_INTEGER */
+
+#ifdef PROVIDE_ARRAY
+#define HEADER_mI(ty,where) \
+ StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
+ nat i = PopTaggedInt(); \
+ if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \
+ obj = raiseIndex(where); \
+ goto enterLoop; \
+ }
+#define OP_mI_ty(ty,where,s) \
+{ \
+ HEADER_mI(mycat2(Stg,ty),where) \
+ { mycat2(Stg,ty) r; \
+ s; \
+ mycat2(PushTagged,ty)(r); \
+ } \
+}
+#define OP_mIty_(ty,where,s) \
+{ \
+ HEADER_mI(mycat2(Stg,ty),where) \
+ { \
+ mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
+ s; \
+ } \
+}
+
+#endif /* PROVIDE_ARRAY */
+
+
+/* This is written as one giant function in the hope that gcc will do
+ * a better job of register allocation.
+ */
+StgThreadReturnCode enter( StgClosure* obj )
+{
+ /* We use a char so that we'll do a context_switch check every 256
+ * iterations.
+ */
+ char enterCount = 0;
+enterLoop:
+ /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
+ ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
+#if 0
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);
+ printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
+ fprintf(stderr,"Entering: "); printObj(obj);
+ );
+#endif
+#if 0
+ IF_DEBUG(sanity,
+ {
+ /*belch("Starting sanity check");
+ *SaveThreadState();
+ *checkTSO(CurrentTSO, heap_step);
+ * This check fails if we've done any updates because we
+ * whack into holes in the heap.
+ *checkHeap(?,?);
+ *belch("Ending sanity check");
+ */
+ }
+ );
+#endif
+#if 0
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"Continue?\n");
+ getchar()
+ );
+#endif
+ if (++enterCount == 0 && context_switch) {
+ PushCPtr(obj); /* code to restart with */
+ return ThreadYielding;
+ }
+ switch ( get_itbl(obj)->type ) {
+ case INVALID_OBJECT:
+ barf("Invalid object %p",obj);
+ case BCO:
+ {
+ StgBCO* bco = stgCast(StgBCO*,obj);
+ InstrPtr pc = 0;
+#if 1 /* We don't use an explicit HP_CHECK anymore */
+ if (doYouWantToGC()) {
+ PushCPtr(obj); /* code to restart with */
+ return HeapOverflow;
+ }
+#endif
+ while (1) {
+ ASSERT(pc < bco->n_instrs);
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc);
+ disInstr(bco,pc);
+ /*fprintf(stderr,"\t"); printStackObj(Sp); */
+ fprintf(stderr,"\n");
+ );
+ switch (bcoInstr(bco,pc++)) {
+ case i_INTERNAL_ERROR:
+ barf("INTERNAL_ERROR at %p:%d",bco,pc-1);
+ case i_PANIC:
+ barf("PANIC at %p:%d",bco,pc-1);
+#if 0
+ case i_HP_CHECK:
+ {
+ int n = bcoInstr(bco,pc++);
+ /* ToDo: we could allocate the whole thing now and
+ * slice it up ourselves
+ */
+ if (doYouWantToGC()) {
+ PushCPtr(obj); /* code to restart with */
+ return HeapOverflow;
+ }
+ break;
+ }
+#endif
+ case i_STK_CHECK:
+ {
+ int n = bcoInstr(bco,pc++);
+ if (Sp - n < SpLim) {
+ PushCPtr(obj); /* code to restart with */
+ return StackOverflow;
+ }
+ break;
+ }
+ case i_ARG_CHECK:
+ {
+ /* ToDo: make sure that hp check allows for possible PAP */
+ nat n = bcoInstr(bco,pc++);
+ if (stgCast(StgPtr,Sp + n) > stgCast(StgPtr,Su)) {
+ StgWord words = (P_)Su - Sp;
+
+ /* first build a PAP */
+ ASSERT((P_)Su >= Sp); /* was (words >= 0) but that's always true */
+ if (words == 0) { /* optimisation */
+ /* Skip building the PAP and update with an indirection. */
+ } else { /* Build the PAP. */
+ /* In the evaluator, we avoid the need to do
+ * a heap check here by including the size of
+ * the PAP in the heap check we performed
+ * when we entered the BCO.
+ */
+ StgInt i;
+ StgPAP* pap = stgCast(StgPAP*,grabHpNonUpd(PAP_sizeW(words)));
+ SET_HDR(pap,&PAP_info,CC_pap);
+ pap->n_args = words;
+ pap->fun = obj;
+ for(i = 0; i < (I_)words; ++i) {
+ payloadWord(pap,i) = Sp[i];
+ }
+ Sp += words;
+ obj = stgCast(StgClosure*,pap);
+ }
+
+ /* now deal with "update frame" */
+ /* as an optimisation, we process all on top of stack instead of just the top one */
+ ASSERT(Sp==(P_)Su);
+ do {
+ switch (get_itbl(Su)->type) {
+ case CATCH_FRAME:
+ PopCatchFrame();
+ break;
+ case UPDATE_FRAME:
+ PopUpdateFrame(obj);
+ break;
+ case STOP_FRAME:
+ PopStopFrame(obj);
+ return ThreadFinished;
+ case SEQ_FRAME:
+ PopSeqFrame();
+ break;
+ default:
+ barf("Invalid update frame during argcheck");
+ }
+ } while (Sp==(P_)Su);
+ goto enterLoop;
+ }
+ break;
+ }
+ case i_ALLOC_AP:
+ {
+ int words = bcoInstr(bco,pc++);
+ PushPtr(grabHpUpd(AP_sizeW(words)));
+ break;
+ }
+ case i_ALLOC_CONSTR:
+ {
+ StgInfoTable* info = bcoConstAddr(bco,bcoInstr(bco,pc++));
+ StgClosure* c = stgCast(StgClosure*,grabHpNonUpd(sizeW_fromITBL(info)));
+ SET_HDR(c,info,??);
+ PushPtr(stgCast(StgPtr,c));
+ break;
+ }
+ case i_MKAP:
+ {
+ int x = bcoInstr(bco,pc++); /* ToDo: Word not Int! */
+ int y = bcoInstr(bco,pc++);
+ StgAP_UPD* o = stgCast(StgAP_UPD*,stackPtr(x));
+ SET_HDR(o,&AP_UPD_info,??);
+ o->n_args = y;
+ o->fun = stgCast(StgClosure*,PopPtr());
+ for(x=0; x < y; ++x) {
+ payloadWord(o,x) = PopWord();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ break;
+ }
+ case i_MKPAP:
+ {
+ int x = bcoInstr(bco,pc++);
+ int y = bcoInstr(bco,pc++);
+ StgPAP* o = stgCast(StgPAP*,stackPtr(x));
+ SET_HDR(o,&PAP_info,??);
+ o->n_args = y;
+ o->fun = stgCast(StgClosure*,PopPtr());
+ for(x=0; x < y; ++x) {
+ payloadWord(o,x) = PopWord();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ break;
+ }
+ case i_PACK:
+ {
+ int offset = bcoInstr(bco,pc++);
+ StgClosure* o = stgCast(StgClosure*,stackPtr(offset));
+ const StgInfoTable* info = get_itbl(o);
+ nat p = info->layout.payload.ptrs;
+ nat np = info->layout.payload.nptrs;
+ nat i;
+ for(i=0; i < p; ++i) {
+ payloadCPtr(o,i) = PopCPtr();
+ }
+ for(i=0; i < np; ++i) {
+ payloadWord(o,p+i) = 0xdeadbeef;
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ break;
+ }
+ case i_SLIDE:
+ {
+ int x = bcoInstr(bco,pc++);
+ int y = bcoInstr(bco,pc++);
+ ASSERT(Sp+x+y <= stgCast(StgPtr,Su));
+ /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
+ while(--x >= 0) {
+ setStackWord(x+y,stackWord(x));
+ }
+ Sp += y;
+ break;
+ }
+ case i_ENTER:
+ {
+ obj = PopCPtr();
+ goto enterLoop;
+ }
+ case i_RETADDR:
+ {
+ PushPtr(bcoConstPtr(bco,bcoInstr(bco,pc++)));
+ PushPtr(stgCast(StgPtr,&ret_bco_info));
+ break;
+ }
+ case i_TEST:
+ {
+ int tag = bcoInstr(bco,pc++);
+ StgWord offset = bcoInstr(bco,pc++);
+ if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) {
+ pc += offset;
+ }
+ break;
+ }
+ case i_UNPACK:
+ {
+ StgClosure* o = stgCast(StgClosure*,stackPtr(0));
+ const StgInfoTable* itbl = get_itbl(o);
+ int i = itbl->layout.payload.ptrs;
+ ASSERT( itbl->type == CONSTR
+ || itbl->type == CONSTR_STATIC
+ || itbl->type == CONSTR_NOCAF_STATIC
+ );
+ while (--i>=0) {
+ PushCPtr(payloadCPtr(o,i));
+ }
+ break;
+ }
+ case i_VAR:
+ {
+ PushPtr(stackPtr(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST:
+ {
+ PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++))));
+ break;
+ }
+ case i_CONST2:
+ {
+ StgWord o1 = bcoInstr(bco,pc++);
+ StgWord o2 = bcoInstr(bco,pc++);
+ StgWord o = o1*256 + o2;
+ PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o)));
+ break;
+ }
+ case i_VOID:
+ {
+ PushTaggedRealWorld();
+ break;
+ }
+ case i_VAR_INT:
+ {
+ PushTaggedInt(taggedStackInt(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST_INT:
+ {
+ PushTaggedInt(bcoConstInt(bco,bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_INT:
+ {
+ ASSERT(0);
+ break;
+ }
+ case i_PACK_INT:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(IZh_sizeW));
+ SET_HDR(o,&IZh_con_info,??);
+ payloadWord(o,0) = PopTaggedInt();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ PushPtr(stgCast(StgPtr,o));
+ break;
+ }
+ case i_UNPACK_INT:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /* ASSERT(isIntLike(con)); */
+ PushTaggedInt(payloadWord(con,0));
+ break;
+ }
+ case i_TEST_INT:
+ {
+ StgWord offset = bcoInstr(bco,pc++);
+ StgInt x = PopTaggedInt();
+ StgInt y = PopTaggedInt();
+ if (x != y) {
+ pc += offset;
+ }
+ break;
+ }
+#ifdef PROVIDE_INT64
+ case i_VAR_INT64:
+ {
+ PushTaggedInt64(taggedStackInt64(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST_INT64:
+ {
+ PushTaggedInt64(bcoConstInt64(bco,bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_INT64:
+ {
+ ASSERT(0); /* ToDo(); */
+ break;
+ }
+ case i_PACK_INT64:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64Zh_sizeW));
+ SET_HDR(o,&I64Zh_con_info,??);
+ ASSIGN_Int64(&payloadWord(o,0),PopTaggedInt64());
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ PushPtr(stgCast(StgPtr,o));
+ break;
+ }
+ case i_UNPACK_INT64:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /*ASSERT(isInt64Like(con)); */
+ PushTaggedInt64(PK_Int64(&payloadWord(con,0)));
+ break;
+ }
+#endif
+#ifdef PROVIDE_INTEGER
+ case i_CONST_INTEGER:
+ {
+ char* s = bcoConstAddr(bco,bcoInstr(bco,pc++));
+ mpz_ptr r = mpz_alloc();
+ if (s[0] == '0' && s[1] == 'x') {
+ mpz_set_str(r,s+2,16);
+ } else {
+ mpz_set_str(r,s,10);
+ }
+ PushTaggedInteger(r);
+ break;
+ }
+#endif
+
+#ifdef PROVIDE_WORD
+ case i_VAR_WORD:
+ {
+ PushTaggedWord(taggedStackWord(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST_WORD:
+ {
+ PushTaggedWord(bcoConstWord(bco,bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_WORD:
+ {
+ ASSERT(0);
+ break;
+ }
+ case i_PACK_WORD:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(WZh_sizeW));
+
+ SET_HDR(o,&WZh_con_info,??);
+ payloadWord(o,0) = PopTaggedWord();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ PushPtr(stgCast(StgPtr,o));
+ break;
+ }
+ case i_UNPACK_WORD:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /* ASSERT(isWordLike(con)); */
+ PushTaggedWord(payloadWord(con,0));
+ break;
+ }
+#endif
+#ifdef PROVIDE_ADDR
+ case i_VAR_ADDR:
+ {
+ PushTaggedAddr(taggedStackAddr(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST_ADDR:
+ {
+ PushTaggedAddr(bcoConstAddr(bco,bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_ADDR:
+ {
+ ASSERT(0);
+ break;
+ }
+ case i_PACK_ADDR:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(AZh_sizeW));
+ SET_HDR(o,&AZh_con_info,??);
+ payloadPtr(o,0) = PopTaggedAddr();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ PushPtr(stgCast(StgPtr,o));
+ break;
+ }
+ case i_UNPACK_ADDR:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /* ASSERT(isAddrLike(con)); */
+ PushTaggedAddr(payloadPtr(con,0));
+ break;
+ }
+#endif
+ case i_VAR_CHAR:
+ {
+ PushTaggedChar(taggedStackChar(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST_CHAR:
+ {
+ PushTaggedChar(bcoConstChar(bco,bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_CHAR:
+ {
+ ASSERT(0);
+ break;
+ }
+ case i_PACK_CHAR:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(CZh_sizeW));
+ SET_HDR(o,&CZh_con_info,??);
+ payloadWord(o,0) = PopTaggedChar();
+ PushPtr(stgCast(StgPtr,o));
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ break;
+ }
+ case i_UNPACK_CHAR:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /* ASSERT(isCharLike(con)); */
+ PushTaggedChar(payloadWord(con,0));
+ break;
+ }
+ case i_VAR_FLOAT:
+ {
+ PushTaggedFloat(taggedStackFloat(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST_FLOAT:
+ {
+ PushTaggedFloat(bcoConstFloat(bco,bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_FLOAT:
+ {
+ ASSERT(0);
+ break;
+ }
+ case i_PACK_FLOAT:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(FZh_sizeW));
+ SET_HDR(o,&FZh_con_info,??);
+ ASSIGN_FLT(&payloadWord(o,0),PopTaggedFloat());
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ PushPtr(stgCast(StgPtr,o));
+ break;
+ }
+ case i_UNPACK_FLOAT:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /* ASSERT(isFloatLike(con)); */
+ PushTaggedFloat(PK_FLT(&payloadWord(con,0)));
+ break;
+ }
+ case i_VAR_DOUBLE:
+ {
+ PushTaggedDouble(taggedStackDouble(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_CONST_DOUBLE:
+ {
+ PushTaggedDouble(bcoConstDouble(bco,bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_DOUBLE:
+ {
+ ASSERT(0);
+ break;
+ }
+ case i_PACK_DOUBLE:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(DZh_sizeW));
+ SET_HDR(o,&DZh_con_info,??);
+ ASSIGN_DBL(&payloadWord(o,0),PopTaggedDouble());
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ PushPtr(stgCast(StgPtr,o));
+ break;
+ }
+ case i_UNPACK_DOUBLE:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /* ASSERT(isDoubleLike(con)); */
+ PushTaggedDouble(PK_DBL(&payloadWord(con,0)));
+ break;
+ }
+#ifdef PROVIDE_STABLE
+ case i_VAR_STABLE:
+ {
+ PushTaggedStablePtr(taggedStackStable(bcoInstr(bco,pc++)));
+ break;
+ }
+ case i_RETURN_STABLE:
+ {
+ ASSERT(0);
+ break;
+ }
+ case i_PACK_STABLE:
+ {
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(StableZh_sizeW));
+ SET_HDR(o,&StablePtr_con_info,??);
+ payloadWord(o,0) = PopTaggedStablePtr();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ PushPtr(stgCast(StgPtr,o));
+ break;
+ }
+ case i_UNPACK_STABLE:
+ {
+ StgClosure* con = stgCast(StgClosure*,stackPtr(0));
+ /* ASSERT(isStableLike(con)); */
+ PushTaggedStablePtr(payloadWord(con,0));
+ break;
+ }
+#endif
+ case i_PRIMOP1:
+ {
+ switch (bcoInstr(bco,pc++)) {
+ case i_INTERNAL_ERROR1:
+ barf("INTERNAL_ERROR1 at %p:%d",bco,pc-1);
+
+ case i_gtChar: OP_CC_B(x>y); break;
+ case i_geChar: OP_CC_B(x>=y); break;
+ case i_eqChar: OP_CC_B(x==y); break;
+ case i_neChar: OP_CC_B(x!=y); break;
+ case i_ltChar: OP_CC_B(x<y); break;
+ case i_leChar: OP_CC_B(x<=y); break;
+ case i_charToInt: OP_C_I(x); break;
+ case i_intToChar: OP_I_C(x); break;
+
+ case i_gtInt: OP_II_B(x>y); break;
+ case i_geInt: OP_II_B(x>=y); break;
+ case i_eqInt: OP_II_B(x==y); break;
+ case i_neInt: OP_II_B(x!=y); break;
+ case i_ltInt: OP_II_B(x<y); break;
+ case i_leInt: OP_II_B(x<=y); break;
+ case i_minInt: OP__I(INT_MIN); break;
+ case i_maxInt: OP__I(INT_MAX); break;
+ case i_plusInt: OP_II_I(x+y); break;
+ case i_minusInt: OP_II_I(x-y); break;
+ case i_timesInt: OP_II_I(x*y); break;
+ case i_quotInt:
+ {
+ int x = PopTaggedInt();
+ int y = PopTaggedInt();
+ if (y == 0) {
+ obj = raiseDiv0("quotInt");
+ goto enterLoop;
+ }
+ /* ToDo: protect against minInt / -1 errors
+ * (repeat for all other division primops)
+ */
+ PushTaggedInt(x/y);
+ }
+ break;
+ case i_remInt:
+ {
+ int x = PopTaggedInt();
+ int y = PopTaggedInt();
+ if (y == 0) {
+ obj = raiseDiv0("remInt");
+ goto enterLoop;
+ }
+ PushTaggedInt(x%y);
+ }
+ break;
+ case i_quotRemInt:
+ {
+ StgInt x = PopTaggedInt();
+ StgInt y = PopTaggedInt();
+ if (y == 0) {
+ obj = raiseDiv0("quotRemInt");
+ goto enterLoop;
+ }
+ PushTaggedInt(x%y); /* last result */
+ PushTaggedInt(x/y); /* first result */
+ }
+ break;
+ case i_negateInt: OP_I_I(-x); break;
+
+ case i_andInt: OP_II_I(x&y); break;
+ case i_orInt: OP_II_I(x|y); break;
+ case i_xorInt: OP_II_I(x^y); break;
+ case i_notInt: OP_I_I(~x); break;
+ case i_shiftLInt: OP_IW_I(x<<y); break;
+ case i_shiftRAInt: OP_IW_I(x>>y); break; /* ToDo */
+ case i_shiftRLInt: OP_IW_I(x>>y); break; /* ToDo */
+
+#ifdef PROVIDE_INT64
+ case i_gtInt64: OP_zz_B(x>y); break;
+ case i_geInt64: OP_zz_B(x>=y); break;
+ case i_eqInt64: OP_zz_B(x==y); break;
+ case i_neInt64: OP_zz_B(x!=y); break;
+ case i_ltInt64: OP_zz_B(x<y); break;
+ case i_leInt64: OP_zz_B(x<=y); break;
+ case i_minInt64: OP__z(0x800000000000LL); break;
+ case i_maxInt64: OP__z(0x7fffffffffffLL); break;
+ case i_plusInt64: OP_zz_z(x+y); break;
+ case i_minusInt64: OP_zz_z(x-y); break;
+ case i_timesInt64: OP_zz_z(x*y); break;
+ case i_quotInt64:
+ {
+ StgInt64 x = PopTaggedInt64();
+ StgInt64 y = PopTaggedInt64();
+ if (y == 0) {
+ obj = raiseDiv0("quotInt64");
+ goto enterLoop;
+ }
+ /* ToDo: protect against minInt64 / -1 errors
+ * (repeat for all other division primops)
+ */
+ PushTaggedInt64(x/y);
+ }
+ break;
+ case i_remInt64:
+ {
+ StgInt64 x = PopTaggedInt64();
+ StgInt64 y = PopTaggedInt64();
+ if (y == 0) {
+ obj = raiseDiv0("remInt64");
+ goto enterLoop;
+ }
+ PushTaggedInt64(x%y);
+ }
+ break;
+ case i_quotRemInt64:
+ {
+ StgInt64 x = PopTaggedInt64();
+ StgInt64 y = PopTaggedInt64();
+ if (y == 0) {
+ obj = raiseDiv0("quotRemInt64");
+ goto enterLoop;
+ }
+ PushTaggedInt64(x%y); /* last result */
+ PushTaggedInt64(x/y); /* first result */
+ }
+ break;
+ case i_negateInt64: OP_z_z(-x); break;
+
+ case i_andInt64: OP_zz_z(x&y); break;
+ case i_orInt64: OP_zz_z(x|y); break;
+ case i_xorInt64: OP_zz_z(x^y); break;
+ case i_notInt64: OP_z_z(~x); break;
+ case i_shiftLInt64: OP_zW_z(x<<y); break;
+ case i_shiftRAInt64: OP_zW_z(x>>y); break; /* ToDo */
+ case i_shiftRLInt64: OP_zW_z(x>>y); break; /* ToDo */
+
+ case i_int64ToInt: OP_z_I(x); break;
+ case i_intToInt64: OP_I_z(x); break;
+#ifdef PROVIDE_WORD
+ case i_int64ToWord: OP_z_W(x); break;
+ case i_wordToInt64: OP_W_z(x); break;
+#endif
+ case i_int64ToFloat: OP_z_F(x); break;
+ case i_floatToInt64: OP_F_z(x); break;
+ case i_int64ToDouble: OP_z_D(x); break;
+ case i_doubleToInt64: OP_D_z(x); break;
+#endif
+#ifdef PROVIDE_WORD
+ case i_gtWord: OP_WW_B(x>y); break;
+ case i_geWord: OP_WW_B(x>=y); break;
+ case i_eqWord: OP_WW_B(x==y); break;
+ case i_neWord: OP_WW_B(x!=y); break;
+ case i_ltWord: OP_WW_B(x<y); break;
+ case i_leWord: OP_WW_B(x<=y); break;
+ case i_minWord: OP__W(0); break;
+ case i_maxWord: OP__W(UINT_MAX); break;
+ case i_plusWord: OP_WW_W(x+y); break;
+ case i_minusWord: OP_WW_W(x-y); break;
+ case i_timesWord: OP_WW_W(x*y); break;
+ case i_quotWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ obj = raiseDiv0("quotWord");
+ goto enterLoop;
+ }
+ PushTaggedWord(x/y);
+ }
+ break;
+ case i_remWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ obj = raiseDiv0("remWord");
+ goto enterLoop;
+ }
+ PushTaggedWord(x%y);
+ }
+ break;
+ case i_quotRemWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ obj = raiseDiv0("quotRemWord");
+ goto enterLoop;
+ }
+ PushTaggedWord(x%y); /* last result */
+ PushTaggedWord(x/y); /* first result */
+ }
+ break;
+ case i_negateWord: OP_W_W(-x); break;
+ case i_andWord: OP_WW_W(x&y); break;
+ case i_orWord: OP_WW_W(x|y); break;
+ case i_xorWord: OP_WW_W(x^y); break;
+ case i_notWord: OP_W_W(~x); break;
+ case i_shiftLWord: OP_WW_W(x<<y); break;
+ case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
+ case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
+ case i_intToWord: OP_I_W(x); break;
+ case i_wordToInt: OP_W_I(x); break;
+#endif
+#ifdef PROVIDE_ADDR
+ case i_gtAddr: OP_AA_B(x>y); break;
+ case i_geAddr: OP_AA_B(x>=y); break;
+ case i_eqAddr: OP_AA_B(x==y); break;
+ case i_neAddr: OP_AA_B(x!=y); break;
+ case i_ltAddr: OP_AA_B(x<y); break;
+ case i_leAddr: OP_AA_B(x<=y); break;
+ case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
+ case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
+
+ case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break;
+ case i_readCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break;
+ case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrZh(x,y,z)); break;
+
+ case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break;
+ case i_readIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break;
+ case i_writeIntOffAddr: OP_AII_(writeIntOffAddrZh(x,y,z)); break;
+#ifdef PROVIDE_INT64
+ case i_indexInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break;
+ case i_readInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break;
+ case i_writeInt64OffAddr: OP_AIz_(writeInt64OffAddrZh(x,y,z)); break;
+#endif
+
+ case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break;
+ case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break;
+ case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrZh(x,y,z)); break;
+
+ case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break;
+ case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break;
+ case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrZh(x,y,z)); break;
+
+ case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break;
+ case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break;
+ case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrZh(x,y,z)); break;
+
+#ifdef PROVIDE_STABLE
+ case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
+ case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
+ case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrZh(x,y,z)); break;
+#endif
+
+#endif /* PROVIDE_ADDR */
+
+#ifdef PROVIDE_INTEGER
+ case i_compareInteger:
+ {
+ mpz_ptr x = PopTaggedInteger();
+ mpz_ptr y = PopTaggedInteger();
+ StgInt r = mpz_cmp(x,y);
+ PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
+ }
+ break;
+ case i_negateInteger: OP_Z_Z(mpz_neg(r,x)); break;
+ case i_plusInteger: OP_ZZ_Z(mpz_add(r,x,y)); break;
+ case i_minusInteger: OP_ZZ_Z(mpz_sub(r,x,y)); break;
+ case i_timesInteger: OP_ZZ_Z(mpz_mul(r,x,y)); break;
+ case i_quotRemInteger:
+ {
+ mpz_ptr x = PopTaggedInteger();
+ mpz_ptr y = PopTaggedInteger();
+ mpz_ptr q = mpz_alloc();
+ mpz_ptr r = mpz_alloc();
+ if (mpz_sgn(y) == 0) {
+ obj = raiseDiv0("quotRemInteger");
+ goto enterLoop;
+ }
+ mpz_tdiv_qr(q,r,x,y);
+ PushTaggedInteger(r); /* last result */
+ PushTaggedInteger(q); /* first result */
+ }
+ break;
+ case i_divModInteger:
+ {
+ mpz_ptr x = PopTaggedInteger();
+ mpz_ptr y = PopTaggedInteger();
+ mpz_ptr q = mpz_alloc();
+ mpz_ptr r = mpz_alloc();
+ if (mpz_sgn(y) == 0) {
+ obj = raiseDiv0("divModInteger");
+ goto enterLoop;
+ }
+ mpz_fdiv_qr(q,r,x,y);
+ PushTaggedInteger(r); /* last result */
+ PushTaggedInteger(q); /* first result */
+ }
+ break;
+ case i_integerToInt: OP_Z_I(mpz_get_si(x)); break;
+ case i_intToInteger: OP_I_Z(mpz_set_si(r,x)); break;
+#ifdef PROVIDE_INT64
+ case i_integerToInt64: OP_Z_z(mpz_get_si(x)); break;
+ case i_int64ToInteger: OP_z_Z(mpz_set_si(r,x)); break;
+#endif
+#ifdef PROVIDE_WORD
+ /* NB Use of mpz_get_si is quite deliberate since otherwise
+ * -255 is converted to 255.
+ */
+ case i_integerToWord: OP_Z_W(mpz_get_si(x)); break;
+ case i_wordToInteger: OP_W_Z(mpz_set_ui(r,x)); break;
+#endif
+ case i_integerToFloat: OP_Z_F(mpz_get_d(x)); break;
+ case i_floatToInteger: OP_F_Z(mpz_set_d(r,x)); break;
+ case i_integerToDouble: OP_Z_D(mpz_get_d(x)); break;
+ case i_doubleToInteger: OP_D_Z(mpz_set_d(r,x)); break;
+#endif /* PROVIDE_INTEGER */
+
+ case i_gtFloat: OP_FF_B(x>y); break;
+ case i_geFloat: OP_FF_B(x>=y); break;
+ case i_eqFloat: OP_FF_B(x==y); break;
+ case i_neFloat: OP_FF_B(x!=y); break;
+ case i_ltFloat: OP_FF_B(x<y); break;
+ case i_leFloat: OP_FF_B(x<=y); break;
+ case i_minFloat: OP__F(FLT_MIN); break;
+ case i_maxFloat: OP__F(FLT_MAX); break;
+ case i_radixFloat: OP__I(FLT_RADIX); break;
+ case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
+ case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
+ case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
+ case i_plusFloat: OP_FF_F(x+y); break;
+ case i_minusFloat: OP_FF_F(x-y); break;
+ case i_timesFloat: OP_FF_F(x*y); break;
+ case i_divideFloat:
+ {
+ StgFloat x = PopTaggedFloat();
+ StgFloat y = PopTaggedFloat();
+#if 0
+ if (y == 0) {
+ obj = raiseDiv0("divideFloat");
+ goto enterLoop;
+ }
+#endif
+ PushTaggedFloat(x/y);
+ }
+ break;
+ case i_negateFloat: OP_F_F(-x); break;
+ case i_floatToInt: OP_F_I(x); break;
+ case i_intToFloat: OP_I_F(x); break;
+ case i_expFloat: OP_F_F(exp(x)); break;
+ case i_logFloat: OP_F_F(log(x)); break;
+ case i_sqrtFloat: OP_F_F(sqrt(x)); break;
+ case i_sinFloat: OP_F_F(sin(x)); break;
+ case i_cosFloat: OP_F_F(cos(x)); break;
+ case i_tanFloat: OP_F_F(tan(x)); break;
+ case i_asinFloat: OP_F_F(asin(x)); break;
+ case i_acosFloat: OP_F_F(acos(x)); break;
+ case i_atanFloat: OP_F_F(atan(x)); break;
+ case i_sinhFloat: OP_F_F(sinh(x)); break;
+ case i_coshFloat: OP_F_F(cosh(x)); break;
+ case i_tanhFloat: OP_F_F(tanh(x)); break;
+ case i_powerFloat: OP_FF_F(pow(x,y)); break;
+
+#ifdef PROVIDE_INT64
+ /* Based on old Hugs code */
+ /* ToDo: use ~/fptools/ghc/runtime/prims/PrimArith.lc */
+ case i_encodeFloatz: OP_zI_F(ldexp(x,y)); break;
+ case i_decodeFloatz:
+ {
+ /* ToDo: this code is known to give very approximate results
+ * (even when StgInt64 overflow doesn't occur)
+ */
+ double f0 = PopTaggedFloat();
+ int n;
+ double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
+ double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
+ PushTaggedInt(n-FLT_MANT_DIG);
+ PushTaggedInt64((StgInt64)f2);
+#if 1 /* paranoia */
+ if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
+ fprintf(stderr,"*** primDecodeFloat mismatch: %.10f != %.10f\n",
+ ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
+ }
+#endif
+ }
+ break;
+#endif /* PROVIDE_INT64 */
+#ifdef PROVIDE_INTEGER
+ case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,y)); break;
+ case i_decodeFloatZ: OP_F_ZI(__decodeFloat(r1,&r2,x)); break;
+#endif
+ case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
+ case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
+ case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
+ case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
+ case i_gtDouble: OP_DD_B(x>y); break;
+ case i_geDouble: OP_DD_B(x>=y); break;
+ case i_eqDouble: OP_DD_B(x==y); break;
+ case i_neDouble: OP_DD_B(x!=y); break;
+ case i_ltDouble: OP_DD_B(x<y); break;
+ case i_leDouble: OP_DD_B(x<=y) break;
+ case i_minDouble: OP__D(DBL_MIN); break;
+ case i_maxDouble: OP__D(DBL_MAX); break;
+ case i_radixDouble: OP__I(FLT_RADIX); break;
+ case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
+ case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
+ case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
+ case i_plusDouble: OP_DD_D(x+y); break;
+ case i_minusDouble: OP_DD_D(x-y); break;
+ case i_timesDouble: OP_DD_D(x*y); break;
+ case i_divideDouble:
+ {
+ StgDouble x = PopTaggedDouble();
+ StgDouble y = PopTaggedDouble();
+#if 0
+ if (y == 0) {
+ obj = raiseDiv0("divideDouble");
+ goto enterLoop;
+ }
+#endif
+ PushTaggedDouble(x/y);
+ }
+ break;
+ case i_negateDouble: OP_D_D(-x); break;
+ case i_doubleToInt: OP_D_I(x); break;
+ case i_intToDouble: OP_I_D(x); break;
+ case i_doubleToFloat: OP_D_F(x); break;
+ case i_floatToDouble: OP_F_F(x); break;
+ case i_expDouble: OP_D_D(exp(x)); break;
+ case i_logDouble: OP_D_D(log(x)); break;
+ case i_sqrtDouble: OP_D_D(sqrt(x)); break;
+ case i_sinDouble: OP_D_D(sin(x)); break;
+ case i_cosDouble: OP_D_D(cos(x)); break;
+ case i_tanDouble: OP_D_D(tan(x)); break;
+ case i_asinDouble: OP_D_D(asin(x)); break;
+ case i_acosDouble: OP_D_D(acos(x)); break;
+ case i_atanDouble: OP_D_D(atan(x)); break;
+ case i_sinhDouble: OP_D_D(sinh(x)); break;
+ case i_coshDouble: OP_D_D(cosh(x)); break;
+ case i_tanhDouble: OP_D_D(tanh(x)); break;
+ case i_powerDouble: OP_DD_D(pow(x,y)); break;
+#ifdef PROVIDE_INT64
+ case i_encodeDoublez: OP_zI_D(ldexp(x,y)); break;
+ case i_decodeDoublez:
+ {
+ /* ToDo: this code is known to give very approximate results
+ * (even when StgInt64 overflow doesn't occur)
+ */
+ double f0 = PopTaggedDouble();
+ int n;
+ double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
+ double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
+ PushTaggedInt(n-FLT_MANT_DIG);
+ PushTaggedInt64((StgInt64)f2);
+#if 1 /* paranoia */
+ if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
+ fprintf(stderr,"*** primDecodeDouble mismatch: %.10f != %.10f\n",
+ ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
+ }
+#endif
+ }
+ break;
+#endif /* PROVIDE_INT64 */
+#ifdef PROVIDE_INTEGER
+ case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,y)); break;
+ case i_decodeDoubleZ: OP_D_ZI(__decodeDouble(r1,&r2,x)); break;
+#endif /* PROVIDE_INTEGER */
+ case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
+ case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
+ case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
+ case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
+ case i_isIEEEDouble:
+ {
+ PushTaggedBool(rtsTrue);
+ }
+ break;
+ default:
+ barf("Unrecognised primop1");
+ }
+ break;
+ }
+ case i_PRIMOP2:
+ {
+ switch (bcoInstr(bco,pc++)) {
+ case i_INTERNAL_ERROR2:
+ barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1);
+ case i_catch: /* catch#{e,h} */
+ {
+ StgClosure* h;
+ obj = PopCPtr();
+ h = PopCPtr();
+
+ /* catch suffers the same problem as takeMVar:
+ * it tries to do control flow even if it isn't
+ * the last instruction in the BCO.
+ * This can leave a mess on the stack if the
+ * last instructions are anything important
+ * like SLIDE. Our vile hack depends on the
+ * fact that with the current code generator,
+ * we know exactly that i_catch is followed
+ * by code that drops 2 variables off the
+ * stack.
+ * What a vile hack!
+ */
+ Sp += 2;
+
+ PushCatchFrame(h);
+ goto enterLoop;
+ }
+ case i_raise: /* raise#{err} */
+ {
+ StgClosure* err = PopCPtr();
+ obj = raiseAnError(err);
+ goto enterLoop;
+ }
+ case i_force: /* force#{x} (evaluate x, primreturn nothing) */
+ {
+ StgClosure* x;
+ obj = PopCPtr();
+
+ /* force suffers the same problem as takeMVar:
+ * it tries to do control flow even if it isn't
+ * the last instruction in the BCO.
+ * This can leave a mess on the stack if the
+ * last instructions are anything important
+ * like SLIDE. Our vile hack depends on the
+ * fact that with the current code generator,
+ * we know exactly that i_force is followed
+ * by code that drops 1 variable off the stack.
+ * What a vile hack!
+ */
+ Sp += 1;
+
+ PushSeqFrame();
+ goto enterLoop;
+ }
+#ifdef PROVIDE_ARRAY
+ case i_newRef:
+ {
+ StgClosure* init = PopCPtr();
+ StgMutVar* mv
+ = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
+ SET_HDR(mv,&MUT_VAR_info,CCCS);
+ mv->var = init;
+ PushPtr(stgCast(StgPtr,mv));
+ break;
+ }
+ case i_readRef:
+ {
+ StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
+ PushCPtr(mv->var);
+ break;
+ }
+ case i_writeRef:
+ {
+ StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
+ StgClosure* value = PopCPtr();
+ mv->var = value;
+ break;
+ }
+ case i_newArray:
+ {
+ nat n = PopTaggedInt(); /* or Word?? */
+ StgClosure* init = PopCPtr();
+ StgWord size = sizeofW(StgArrPtrs) + n;
+ nat i;
+ StgArrPtrs* arr
+ = stgCast(StgArrPtrs*,allocate(size));
+ SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
+ arr->ptrs = n;
+ for (i = 0; i < n; ++i) {
+ arr->payload[i] = init;
+ }
+ PushPtr(stgCast(StgPtr,arr));
+ break;
+ }
+ case i_readArray:
+ case i_indexArray:
+ {
+ StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ nat i = PopTaggedInt(); /* or Word?? */
+ StgWord n = arr->ptrs;
+ if (i >= n) {
+ obj = raiseIndex("{index,read}Array");
+ goto enterLoop;
+ }
+ PushCPtr(arr->payload[i]);
+ break;
+ }
+ case i_writeArray:
+ {
+ StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ nat i = PopTaggedInt(); /* or Word? */
+ StgClosure* v = PopCPtr();
+ StgWord n = arr->ptrs;
+ if (i >= n) {
+ obj = raiseIndex("{index,read}Array");
+ goto enterLoop;
+ }
+ arr->payload[i] = v;
+ break;
+ }
+ case i_sizeArray:
+ case i_sizeMutableArray:
+ {
+ StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ PushTaggedInt(arr->ptrs);
+ break;
+ }
+ case i_unsafeFreezeArray:
+ {
+ StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
+ PushPtr(stgCast(StgPtr,arr));
+ break;
+ }
+ case i_unsafeFreezeByteArray:
+ {
+ /* Delightfully simple :-) */
+ break;
+ }
+ case i_sameRef:
+ case i_sameMutableArray:
+ case i_sameMutableByteArray:
+ {
+ StgPtr x = PopPtr();
+ StgPtr y = PopPtr();
+ PushTaggedBool(x==y);
+ break;
+ }
+
+ case i_newByteArray:
+ {
+ nat n = PopTaggedInt(); /* or Word?? */
+ StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
+ StgWord size = sizeofW(StgArrWords) + words;
+ nat i;
+ StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
+ SET_HDR(arr,&MUT_ARR_WORDS_info,CCCS);
+ arr->words = words;
+#ifdef DEBUG
+ for (i = 0; i < n; ++i) {
+ arr->payload[i] = 0xdeadbeef;
+ }
+#endif
+ PushPtr(stgCast(StgPtr,arr));
+ break;
+ }
+
+ /* Most of these generate alignment warnings on Sparcs and similar architectures.
+ * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
+ */
+ case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayZh(r,x,i)); break;
+ case i_readCharArray: OP_mI_ty(Char,"readCharArray", readCharArrayZh(r,x,i)); break;
+ case i_writeCharArray: OP_mIty_(Char,"writeCharArray", writeCharArrayZh(x,i,z)); break;
+
+ case i_indexIntArray: OP_mI_ty(Int,"indexIntArray", indexIntArrayZh(r,x,i)); break;
+ case i_readIntArray: OP_mI_ty(Int,"readIntArray", readIntArrayZh(r,x,i)); break;
+ case i_writeIntArray: OP_mIty_(Int,"writeIntArray", writeIntArrayZh(x,i,z)); break;
+#ifdef PROVIDE_INT64
+ case i_indexInt64Array: OP_mI_ty(Int64,"indexInt64Array", indexInt64ArrayZh(r,x,i)); break;
+ case i_readInt64Array: OP_mI_ty(Int64,"readInt64Array", readInt64ArrayZh(r,x,i)); break;
+ case i_writeInt64Array: OP_mIty_(Int64,"writeInt64Array", writeInt64ArrayZh(x,i,z)); break;
+#endif
+#ifdef PROVIDE_ADDR
+ case i_indexAddrArray: OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayZh(r,x,i)); break;
+ case i_readAddrArray: OP_mI_ty(Addr,"readAddrArray", readAddrArrayZh(r,x,i)); break;
+ case i_writeAddrArray: OP_mIty_(Addr,"writeAddrArray", writeAddrArrayZh(x,i,z)); break;
+#endif
+ case i_indexFloatArray: OP_mI_ty(Float,"indexFloatArray", indexFloatArrayZh(r,x,i)); break;
+ case i_readFloatArray: OP_mI_ty(Float,"readFloatArray", readFloatArrayZh(r,x,i)); break;
+ case i_writeFloatArray: OP_mIty_(Float,"writeFloatArray", writeFloatArrayZh(x,i,z)); break;
+
+ case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayZh(r,x,i)); break;
+ case i_readDoubleArray: OP_mI_ty(Double,"readDoubleArray", readDoubleArrayZh(r,x,i)); break;
+ case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayZh(x,i,z)); break;
+
+#ifdef PROVIDE_STABLE
+ case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayZh(r,x,i)); break;
+ case i_readStableArray: OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayZh(r,x,i)); break;
+ case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayZh(x,i,z)); break;
+#endif
+
+#endif /* PROVIDE_ARRAY */
+#ifdef PROVIDE_COERCE
+ case i_unsafeCoerce:
+ {
+ /* Another nullop */
+ break;
+ }
+#endif
+#ifdef PROVIDE_PTREQUALITY
+ case i_reallyUnsafePtrEquality:
+ { /* identical to i_sameRef */
+ StgPtr x = PopPtr();
+ StgPtr y = PopPtr();
+ PushTaggedBool(x==y);
+ break;
+ }
+#endif
+#ifdef PROVIDE_FOREIGN
+ /* ForeignObj# operations */
+ case i_makeForeignObj:
+ {
+ StgForeignObj *result
+ = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
+ SET_HDR(result,&FOREIGN_info,CCCS);
+ result -> data = PopTaggedAddr();
+ PushPtr(stgCast(StgPtr,result));
+ break;
+ }
+#endif /* PROVIDE_FOREIGN */
+#ifdef PROVIDE_WEAK
+ case i_makeWeak:
+ {
+ StgWeak *w
+ = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
+ SET_HDR(w, &WEAK_info, CCCS);
+ w->key = PopCPtr();
+ w->value = PopCPtr();
+ w->finaliser = PopCPtr();
+ w->link = weak_ptr_list;
+ weak_ptr_list = w;
+ IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
+ PushPtr(stgCast(StgPtr,w));
+ break;
+ }
+ case i_deRefWeak:
+ {
+ StgWeak *w = stgCast(StgWeak*,PopPtr());
+ if (w->header.info == &WEAK_info) {
+ PushCPtr(w->value); /* last result */
+ PushTaggedInt(1); /* first result */
+ } else {
+ PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */
+ PushTaggedInt(0);
+ }
+ break;
+ }
+#endif /* PROVIDE_WEAK */
+#ifdef PROVIDE_STABLE
+ /* StablePtr# operations */
+ case i_makeStablePtr:
+ {
+ StgStablePtr stable_ptr;
+ if (stable_ptr_free == NULL) {
+ enlargeStablePtrTable();
+ }
+
+ stable_ptr = stable_ptr_free - stable_ptr_table;
+ stable_ptr_free = (P_*)*stable_ptr_free;
+ stable_ptr_table[stable_ptr] = PopPtr();
+
+ PushTaggedStablePtr(stable_ptr);
+ break;
+ }
+ case i_deRefStablePtr:
+ {
+ StgStablePtr stable_ptr = PopTaggedStablePtr();
+ PushPtr(stable_ptr_table[stable_ptr]);
+ break;
+ }
+
+ case i_freeStablePtr:
+ {
+ StgStablePtr stable_ptr = PopTaggedStablePtr();
+ stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;
+ stable_ptr_free = stable_ptr_table + stable_ptr;
+ break;
+ }
+#endif /* PROVIDE_STABLE */
+#ifdef PROVIDE_CONCURRENT
+ case i_fork:
+ {
+ StgClosure* c = PopCPtr();
+ StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
+ PushPtr(stgCast(StgPtr,t));
+
+ /* switch at the earliest opportunity */
+ context_switch = 1;
+ /* but don't automatically switch to GHC - or you'll waste your
+ * time slice switching back.
+ *
+ * Actually, there's more to it than that: the default
+ * (ThreadEnterGHC) causes the thread to crash - don't
+ * understand why. - ADR
+ */
+ t->whatNext = ThreadEnterHugs;
+ break;
+ }
+ case i_killThread:
+ {
+ StgTSO* tso = stgCast(StgTSO*,PopPtr());
+ deleteThread(tso);
+ if (tso == CurrentTSO) { /* suicide */
+ return ThreadFinished;
+ }
+ break;
+ }
+ case i_sameMVar:
+ { /* identical to i_sameRef */
+ StgPtr x = PopPtr();
+ StgPtr y = PopPtr();
+ PushTaggedBool(x==y);
+ break;
+ }
+ case i_newMVar:
+ {
+ StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+ mvar->head = mvar->tail = EndTSOQueue;
+ /* ToDo: this is a little strange */
+ mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
+ PushPtr(stgCast(StgPtr,mvar));
+ break;
+ }
+#if 1
+#if 0
+ToDo: another way out of the problem might be to add an explicit
+continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
+The problem with this plan is that now I dont know how much to chop
+off the stack.
+#endif
+ case i_takeMVar:
+ {
+ StgMVar *mvar = stgCast(StgMVar*,PopPtr());
+ /* If the MVar is empty, put ourselves
+ * on its blocking queue, and wait
+ * until we're woken up.
+ */
+ if (GET_INFO(mvar) != &FULL_MVAR_info) {
+ if (mvar->head == EndTSOQueue) {
+ mvar->head = CurrentTSO;
+ } else {
+ mvar->tail->link = CurrentTSO;
+ }
+ CurrentTSO->link = EndTSOQueue;
+ mvar->tail = CurrentTSO;
+
+ /* Hack, hack, hack.
+ * When we block, we push a restart closure
+ * on the stack - but which closure?
+ * We happen to know that the BCO we're
+ * executing looks like this:
+ *
+ * 0: STK_CHECK 4
+ * 2: HP_CHECK 3
+ * 4: TEST 0 29
+ * 7: UNPACK
+ * 8: VAR 3
+ * 10: VAR 1
+ * 12: primTakeMVar
+ * 14: ALLOC_CONSTR 0x8213a80
+ * 16: VAR 2
+ * 18: VAR 2
+ * 20: PACK 2
+ * 22: VAR 0
+ * 24: SLIDE 1 7
+ * 27: ENTER
+ * 28: PANIC
+ * 29: PANIC
+ *
+ * so we rearrange the stack to look the
+ * way it did when we entered this BCO
+ * and push ths BCO.
+ * What a disgusting hack!
+ */
+
+ PopPtr();
+ PopPtr();
+ PushCPtr(obj);
+ return ThreadBlocked;
+
+ } else {
+ PushCPtr(mvar->value);
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+ /* ToDo: this is a little strange */
+ mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
+ }
+ break;
+ }
+#endif
+ case i_putMVar:
+ {
+ StgMVar* mvar = stgCast(StgMVar*,PopPtr());
+ StgClosure* value = PopCPtr();
+ if (GET_INFO(mvar) == &FULL_MVAR_info) {
+ obj = raisePrim("putMVar {full MVar}");
+ goto enterLoop;
+ } else {
+ /* wake up the first thread on the
+ * queue, it will continue with the
+ * takeMVar operation and mark the
+ * MVar empty again.
+ */
+ StgTSO* tso = mvar->head;
+ SET_INFO(mvar,&FULL_MVAR_info);
+ mvar->value = value;
+ if (tso != EndTSOQueue) {
+ PUSH_ON_RUN_QUEUE(tso);
+ mvar->head = tso->link;
+ tso->link = EndTSOQueue;
+ if (mvar->head == EndTSOQueue) {
+ mvar->tail = EndTSOQueue;
+ }
+ }
+ }
+ /* yield for better communication performance */
+ context_switch = 1;
+ break;
+ }
+ case i_delay:
+ case i_waitRead:
+ case i_waitWrite:
+ /* As PrimOps.h says: Hmm, I'll think about these later. */
+ ASSERT(0);
+ break;
+#endif /* PROVIDE_CONCURRENT */
+ case i_ccall_Id:
+ case i_ccall_IO:
+ {
+ CFunDescriptor* descriptor = PopTaggedAddr();
+ StgAddr funPtr = PopTaggedAddr();
+ ccall(descriptor,funPtr);
+ break;
+ }
+ default:
+ barf("Unrecognised primop2");
+ }
+ break;
+ }
+ default:
+ barf("Unrecognised instruction");
+ }
+ }
+ barf("Ran off the end of bco - yoiks");
+ break;
+ }
+ case CAF_UNENTERED:
+ {
+ StgCAF* caf = stgCast(StgCAF*,obj);
+ if (Sp - sizeofW(StgUpdateFrame) < SpLim) {
+ PushCPtr(obj); /* code to restart with */
+ return StackOverflow;
+ }
+ /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
+ {
+ StgBlackHole* bh = stgCast(StgBlackHole*,grabHpUpd(BLACKHOLE_sizeW()));
+ SET_INFO(bh,&CAF_BLACKHOLE_info);
+ bh->blocking_queue = EndTSOQueue;
+ IF_DEBUG(gccafs,fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
+ SET_INFO(caf,&CAF_ENTERED_info);
+ caf->value = stgCast(StgClosure*,bh);
+ PUSH_UPD_FRAME(bh,0);
+ Sp -= sizeofW(StgUpdateFrame);
+ }
+ caf->link = enteredCAFs;
+ enteredCAFs = caf;
+ obj = caf->body;
+ goto enterLoop;
+ }
+ case CAF_ENTERED:
+ {
+ StgCAF* caf = stgCast(StgCAF*,obj);
+ obj = caf->value; /* it's just a fancy indirection */
+ goto enterLoop;
+ }
+ case BLACKHOLE:
+ case CAF_BLACKHOLE:
+ {
+ StgBlackHole* bh = stgCast(StgBlackHole*,obj);
+ /* Put ourselves on the blocking queue for this black hole and block */
+ CurrentTSO->link = bh->blocking_queue;
+ bh->blocking_queue = CurrentTSO;
+ PushCPtr(obj); /* code to restart with */
+ return ThreadBlocked;
+ }
+ case AP_UPD:
+ {
+ StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
+ int i = ap->n_args;
+ if (Sp - (i + sizeofW(StgUpdateFrame)) < SpLim) {
+ PushCPtr(obj); /* code to restart with */
+ return StackOverflow;
+ }
+ /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
+ PUSH_UPD_FRAME(ap,0);
+ Sp -= sizeofW(StgUpdateFrame);
+ while (--i >= 0) {
+ PushWord(payloadWord(ap,i));
+ }
+ obj = ap->fun;
+#ifndef LAZY_BLACKHOLING
+ {
+ /* superfluous - but makes debugging easier */
+ StgBlackHole* bh = stgCast(StgBlackHole*,ap);
+ SET_INFO(bh,&BLACKHOLE_info);
+ bh->blocking_queue = EndTSOQueue;
+ IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
+ /*printObj(bh); */
+ }
+#endif /* LAZY_BLACKHOLING */
+ goto enterLoop;
+ }
+ case PAP:
+ {
+ StgPAP* pap = stgCast(StgPAP*,obj);
+ int i = pap->n_args; /* ToDo: stack check */
+ /* ToDo: if PAP is in whnf, we can update any update frames
+ * on top of stack.
+ */
+ while (--i >= 0) {
+ PushWord(payloadWord(pap,i));
+ }
+ obj = pap->fun;
+ goto enterLoop;
+ }
+ case IND:
+ {
+ obj = stgCast(StgInd*,obj)->indirectee;
+ goto enterLoop;
+ }
+ case CONSTR:
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ {
+ while (1) {
+ switch (get_itbl(stgCast(StgClosure*,Sp))->type) {
+ case CATCH_FRAME:
+ PopCatchFrame();
+ break;
+ case UPDATE_FRAME:
+ PopUpdateFrame(obj);
+ break;
+ case SEQ_FRAME:
+ PopSeqFrame();
+ break;
+ case STOP_FRAME:
+ {
+ ASSERT(Sp==(P_)Su);
+ IF_DEBUG(evaluator,
+ printObj(obj);
+ /*fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);*/
+ /*printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);*/
+ );
+ PopStopFrame(obj);
+ return ThreadFinished;
+ }
+ case RET_BCO:
+ {
+ StgClosure* ret;
+ PopPtr();
+ ret = PopCPtr();
+ PushPtr((P_)obj);
+ obj = ret;
+ goto enterLoop;
+ }
+ case RET_SMALL: /* return to GHC */
+ case RET_VEC_SMALL:
+ case RET_BIG:
+ case RET_VEC_BIG:
+ barf("todo: RET_[VEC_]{BIG,SMALL}");
+ default:
+ belch("entered CONSTR with invalid continuation on stack");
+ IF_DEBUG(evaluator,
+ printObj(stgCast(StgClosure*,Sp))
+ );
+ barf("bailing out");
+ }
+ }
+ }
+ default:
+ {
+ CurrentTSO->whatNext = ThreadEnterGHC;
+ PushCPtr(obj); /* code to restart with */
+ return ThreadYielding;
+ }
+ }
+ barf("Ran off the end of enter - yoiks");
+}
+
+/* -----------------------------------------------------------------------------
+ * ccall support code:
+ * marshall moves args from C stack to Haskell stack
+ * unmarshall moves args from Haskell stack to C stack
+ * argSize calculates how much space you need on the C stack
+ * ---------------------------------------------------------------------------*/
+
+/* Pop arguments off the C stack and Push them onto the Hugs stack.
+ * Used when preparing for C calling Haskell or in response to
+ * Haskell calling C.
+ */
+nat marshall(char arg_ty, void* arg)
+{
+ switch (arg_ty) {
+ case INT_REP:
+ PushTaggedInt(*((int*)arg));
+ return ARG_SIZE(INT_TAG);
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ PushTaggedInt64(*((StgInt64*)arg));
+ return ARG_SIZE(INT64_TAG);
+#endif
+#ifdef TODO_PROVIDE_INTEGER
+ case INTEGER_REP:
+ PushTaggedInteger(*((mpz_ptr*)arg));
+ return ARG_SIZE(INTEGER_TAG);
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ PushTaggedWord(*((unsigned int*)arg));
+ return ARG_SIZE(WORD_TAG);
+#endif
+ case CHAR_REP:
+ PushTaggedChar(*((char*)arg));
+ return ARG_SIZE(CHAR_TAG);
+ case FLOAT_REP:
+ PushTaggedFloat(*((float*)arg));
+ return ARG_SIZE(FLOAT_TAG);
+ case DOUBLE_REP:
+ PushTaggedDouble(*((double*)arg));
+ return ARG_SIZE(DOUBLE_TAG);
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ PushTaggedAddr(*((void**)arg));
+ return ARG_SIZE(ADDR_TAG);
+#endif
+ case STABLE_REP:
+ PushTaggedStablePtr(*((StgStablePtr*)arg));
+ return ARG_SIZE(STABLE_TAG);
+ case FOREIGN_REP:
+ /* Not allowed in this direction - you have to
+ * call makeForeignPtr explicitly
+ */
+ barf("marshall: ForeignPtr#\n");
+ break;
+#ifdef PROVIDE_ARRAY
+ case BARR_REP:
+ case MUTBARR_REP:
+#endif
+ /* Not allowed in this direction */
+ barf("marshall: [Mutable]ByteArray#\n");
+ break;
+ default:
+ barf("marshall: unrecognised arg type %d\n",arg_ty);
+ break;
+ }
+}
+
+/* Pop arguments off the Hugs stack and Push them onto the C stack.
+ * Used when preparing for Haskell calling C or in response to
+ * C calling Haskell.
+ */
+nat unmarshall(char res_ty, void* res)
+{
+ switch (res_ty) {
+ case INT_REP:
+ *((int*)res) = PopTaggedInt();
+ return ARG_SIZE(INT_TAG);
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ *((StgInt64*)res) = PopTaggedInt64();
+ return ARG_SIZE(INT64_TAG);
+#endif
+#ifdef TODO_PROVIDE_INTEGER
+ case INTEGER_REP:
+ *((mpz_ptr*)res) = PopTaggedInteger();
+ return ARG_SIZE(INTEGER_TAG);
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ *((unsigned int*)res) = PopTaggedWord();
+ return ARG_SIZE(WORD_TAG);
+#endif
+ case CHAR_REP:
+ *((int*)res) = PopTaggedChar();
+ return ARG_SIZE(CHAR_TAG);
+ case FLOAT_REP:
+ *((float*)res) = PopTaggedFloat();
+ return ARG_SIZE(FLOAT_TAG);
+ case DOUBLE_REP:
+ *((double*)res) = PopTaggedDouble();
+ return ARG_SIZE(DOUBLE_TAG);
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ *((void**)res) = PopTaggedAddr();
+ return ARG_SIZE(ADDR_TAG);
+#endif
+ case STABLE_REP:
+ *((StgStablePtr*)res) = PopTaggedStablePtr();
+ return ARG_SIZE(STABLE_TAG);
+ case FOREIGN_REP:
+ {
+ StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
+ *((void**)res) = result->data;
+ return sizeofW(StgPtr);
+ }
+#ifdef PROVIDE_ARRAY
+ case BARR_REP:
+ case MUTBARR_REP:
+#endif
+ {
+ StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ *((void**)res) = stgCast(void*,&(arr->payload));
+ return sizeofW(StgPtr);
+ }
+ default:
+ barf("unmarshall: unrecognised result type %d\n",res_ty);
+ }
+}
+
+nat argSize( const char* ks )
+{
+ nat sz = 0;
+ for( ; *ks != '\0'; ++ks) {
+ switch (*ks) {
+ case INT_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
+ break;
+#ifdef PROVIDE_INT64
+ case INT64_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(INT64_TAG);
+ break;
+#endif
+#ifdef TODO_PROVIDE_INTEGER
+ case INTEGER_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
+ break;
+#endif
+#ifdef PROVIDE_WORD
+ case WORD_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
+ break;
+#endif
+ case CHAR_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
+ break;
+ case FLOAT_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
+ break;
+ case DOUBLE_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
+ break;
+#ifdef PROVIDE_ADDR
+ case ADDR_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
+ break;
+#endif
+#ifdef PROVIDE_STABLE
+ case STABLE_REP:
+ sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
+ break;
+#endif
+#ifdef PROVIDE_FOREIGN
+ case FOREIGN_REP:
+#endif
+#ifdef PROVIDE_ARRAY
+ case BARR_REP:
+ case MUTBARR_REP:
+#endif
+ sz += sizeof(StgPtr);
+ break;
+ default:
+ barf("argSize: unrecognised result type %d\n",*ks);
+ break;
+ }
+ }
+ return sz;
+}
+
+#endif /* INTERPRETER */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Evaluator.h,v 1.2 1998/12/02 13:28:21 simonm Exp $
+ *
+ * Prototypes for functions in Evaluator.c
+ *
+ * ---------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Sizes of objects it constructs
+ * (used by Assembler)
+ * ------------------------------------------------------------------------*/
+
+#define IZh_sizeW CONSTR_sizeW(0,sizeofW(StgInt))
+#define I64Zh_sizeW CONSTR_sizeW(0,sizeofW(StgInt64))
+#define WZh_sizeW CONSTR_sizeW(0,sizeofW(StgWord))
+#define AZh_sizeW CONSTR_sizeW(0,sizeofW(StgAddr))
+#define CZh_sizeW CONSTR_sizeW(0,sizeofW(StgWord))
+#define FZh_sizeW CONSTR_sizeW(0,sizeofW(StgFloat))
+#define DZh_sizeW CONSTR_sizeW(0,sizeofW(StgDouble))
+#define StableZh_sizeW CONSTR_sizeW(0,sizeofW(StgStablePtr))
+#define GenericZh_sizeW CONSTR_sizeW(1,0)
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+extern StgThreadReturnCode enter ( StgClosurePtr obj );
+
+extern nat marshall ( char arg_ty, void* arg );
+extern nat unmarshall ( char res_ty, void* res );
+extern nat argSize ( const char* ks );
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* -----------------------------------------------------------------------------
+ * Foreign Function calls
+ *
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: ForeignCall.c,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:28:21 $
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef INTERPRETER
+
+#include "Assembler.h" /* for CFun stuff */
+#include "Evaluator.h"
+#include "ForeignCall.h"
+
+/* the assymetry here seem to come from the caller-allocates
+ * calling convention. But does the caller really allocate
+ * result??
+ */
+
+void hcall( HFunDescriptor* d, StablePtr fun, void* as, void* rs)
+{
+#if 0
+ /* out of date - ADR */
+ marshall(d->arg_tys,as);
+ prim_hcall(fun);
+ unmarshall(d->result_tys,rs);
+#else
+ assert(0);
+#endif
+}
+
+/* By experiment on an x86 box, we found that gcc's
+ * __builtin_apply(fun,as,size) expects *as to look like this:
+ * as[0] = &first arg = &as[1]
+ * as[1] = arg1
+ * as[2] = arg2
+ * ...
+ *
+ * on an x86, it returns a pointer to a struct containing an
+ * int/int64/ptr in its first 4-8 bytes and a float/double in the next
+ * 8 bytes.
+ *
+ * On a sparc:
+ * as[0] = &first arg = &as[2]
+ * as[1] = where structures should be returned
+ * as[2] = arg1
+ * as[3] = arg2
+ * ...
+ *
+ * This is something of a hack - but seems to be more portable than
+ * hacking it up in assembly language which is how I did it before - ADR
+ */
+void ccall( CFunDescriptor* d, void (*fun)(void) )
+{
+ void *rs;
+ char* tys = d->arg_tys;
+ /* ToDo: the use of ARG_SIZE is based on the assumption that Hugs
+ * obeys the same alignment restrictions as C.
+ * But this is almost certainly wrong!
+ * We could use gcc's __va_rounded_size macro (see varargs.h) to do a
+ * better job.
+ */
+#if i386_TARGET_ARCH
+ void *as=alloca(4 + d->arg_size);
+ StgWord* args = (StgWord*) as;
+ *(void**)(args++) = 4 + (char*)as; /* incoming args ptr */
+ for(; *tys; ++tys) {
+ args += unmarshall(*tys,args);
+ }
+ rs = __builtin_apply(fun,as,(char*)args-(char*)as-4);
+#elif sparc_TARGET_ARCH
+ void *as=alloca(8 + d->arg_size);
+ StgWord* args = (StgWord*) as;
+ int argcount;
+ *(void**)(args++) = (char*)as; /* incoming args ptr */
+ *(void**)(args++) = 0; /* structure value address - I think this is the address of a block of memory where structures are returned - in which case we should initialise with rs or something like that*/
+ for(; *tys; ++tys) {
+ args += unmarshall(*tys,args);
+ }
+ argcount = ((void*)args - as);
+ ASSERT(8 + d->arg_size == argcount);
+ if (argcount <= 8) {
+ argcount = 0;
+ } else {
+ argcount -= 4;
+ }
+ rs = __builtin_apply(fun,as,argcount);
+#else
+#error Cant do ccall for this architecture
+#endif
+
+ /* ToDo: can't handle multiple return values at the moment
+ * - it's hard enough to get single return values working
+ */
+ if (*(d->result_tys)) {
+ char ty = *(d->result_tys);
+ ASSERT(d->result_tys[1] == '\0');
+ switch (ty) {
+ case 'F':
+ case 'D':
+ /* ToDo: is this right? */
+ marshall(ty,(char*)rs+8);
+ return;
+ default:
+ marshall(ty,rs);
+ return;
+ }
+ }
+}
+
+CFunDescriptor* mkDescriptor( char* as, char* rs )
+{
+ /* ToDo: don't use malloc */
+ CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
+ assert(d);
+ d->arg_tys = as;
+ d->arg_size = argSize(as);
+ d->result_tys = rs;
+ d->result_size = argSize(rs);
+ return d;
+}
+
+#endif /* INTERPRETER */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: ForeignCall.h,v 1.2 1998/12/02 13:28:23 simonm Exp $
+ *
+ * Prototypes for functions in ForeignCall.c
+ *
+ * ---------------------------------------------------------------------------*/
+
+typedef int StablePtr;
+
+extern void ccall ( CFunDescriptor* descriptor, void (*fun)(void) );
+extern void hcall ( HFunDescriptor* descriptor, StablePtr fun, void* as, void* rs );
+
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: GC.c,v 1.2 1998/12/02 13:28:23 simonm Exp $
+ *
+ * Two-space garbage collector
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "Storage.h"
+#include "StoragePriv.h"
+#include "Stats.h"
+#include "Schedule.h"
+#include "SchedAPI.h" /* for ReverCAFs prototype */
+#include "Sanity.h"
+#include "GC.h"
+#include "BlockAlloc.h"
+#include "Main.h"
+#include "DebugProf.h"
+#include "SchedAPI.h"
+#include "Weak.h"
+
+StgCAF* enteredCAFs;
+
+static P_ toHp; /* to-space heap pointer */
+static P_ toHpLim; /* end of current to-space block */
+static bdescr *toHp_bd; /* descriptor of current to-space block */
+static nat blocks = 0; /* number of to-space blocks allocated */
+static bdescr *old_to_space = NULL; /* to-space from the last GC */
+static nat old_to_space_blocks = 0; /* size of previous to-space */
+
+/* STATIC OBJECT LIST.
+ *
+ * We maintain a linked list of static objects that are still live.
+ * The requirements for this list are:
+ *
+ * - we need to scan the list while adding to it, in order to
+ * scavenge all the static objects (in the same way that
+ * breadth-first scavenging works for dynamic objects).
+ *
+ * - we need to be able to tell whether an object is already on
+ * the list, to break loops.
+ *
+ * Each static object has a "static link field", which we use for
+ * linking objects on to the list. We use a stack-type list, consing
+ * objects on the front as they are added (this means that the
+ * scavenge phase is depth-first, not breadth-first, but that
+ * shouldn't matter).
+ *
+ * A separate list is kept for objects that have been scavenged
+ * already - this is so that we can zero all the marks afterwards.
+ *
+ * An object is on the list if its static link field is non-zero; this
+ * means that we have to mark the end of the list with '1', not NULL.
+ */
+#define END_OF_STATIC_LIST stgCast(StgClosure*,1)
+static StgClosure* static_objects;
+static StgClosure* scavenged_static_objects;
+
+/* WEAK POINTERS
+ */
+static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
+static rtsBool weak_done; /* all done for this pass */
+
+/* LARGE OBJECTS.
+ */
+static bdescr *new_large_objects; /* large objects evacuated so far */
+static bdescr *scavenged_large_objects; /* large objects scavenged */
+
+/* -----------------------------------------------------------------------------
+ Static function declarations
+ -------------------------------------------------------------------------- */
+
+static StgClosure *evacuate(StgClosure *q);
+static void zeroStaticObjectList(StgClosure* first_static);
+static void scavenge_stack(StgPtr p, StgPtr stack_end);
+static void scavenge_static(void);
+static void scavenge_large(void);
+static StgPtr scavenge(StgPtr to_scan);
+static rtsBool traverse_weak_ptr_list(void);
+static void revertDeadCAFs(void);
+
+#ifdef DEBUG
+static void gcCAFs(void);
+#endif
+
+/* -----------------------------------------------------------------------------
+ GarbageCollect
+
+ This function performs a full copying garbage collection.
+ -------------------------------------------------------------------------- */
+
+void GarbageCollect(void (*get_roots)(void))
+{
+ bdescr *bd, *scan_bd, *to_space;
+ StgPtr scan;
+ lnat allocated, live;
+ nat old_nursery_blocks = nursery_blocks; /* for stats */
+ nat old_live_blocks = old_to_space_blocks; /* ditto */
+#ifdef PROFILING
+ CostCentreStack *prev_CCS;
+#endif
+
+ /* tell the stats department that we've started a GC */
+ stat_startGC();
+
+ /* attribute any costs to CCS_GC */
+#ifdef PROFILING
+ prev_CCS = CCCS;
+ CCCS = CCS_GC;
+#endif
+
+ /* We might have been called from Haskell land by _ccall_GC, in
+ * which case we need to call threadPaused() because the scheduler
+ * won't have done it.
+ */
+ if (CurrentTSO)
+ threadPaused(CurrentTSO);
+
+ /* Approximate how much we allocated: number of blocks in the
+ * nursery + blocks allocated via allocate() - unused nusery blocks.
+ * This leaves a little slop at the end of each block, and doesn't
+ * take into account large objects (ToDo).
+ */
+ allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
+ for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
+ allocated -= BLOCK_SIZE_W;
+ }
+
+ /* check stack sanity *before* GC (ToDo: check all threads) */
+ /*IF_DEBUG(sanity, checkTSO(MainTSO,0)); */
+ IF_DEBUG(sanity, checkFreeListSanity());
+
+ static_objects = END_OF_STATIC_LIST;
+ scavenged_static_objects = END_OF_STATIC_LIST;
+
+ new_large_objects = NULL;
+ scavenged_large_objects = NULL;
+
+ /* Get a free block for to-space. Extra blocks will be chained on
+ * as necessary.
+ */
+ bd = allocBlock();
+ bd->step = 1; /* step 1 identifies to-space */
+ toHp = bd->start;
+ toHpLim = toHp + BLOCK_SIZE_W;
+ toHp_bd = bd;
+ to_space = bd;
+ blocks = 0;
+
+ scan = toHp;
+ scan_bd = bd;
+
+ /* follow all the roots that the application knows about */
+ get_roots();
+
+ /* And don't forget to mark the TSO if we got here direct from
+ * Haskell! */
+ if (CurrentTSO) {
+ CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
+ }
+
+ /* Mark the weak pointer list, and prepare to detect dead weak
+ * pointers.
+ */
+ markWeakList();
+ old_weak_ptr_list = weak_ptr_list;
+ weak_ptr_list = NULL;
+ weak_done = rtsFalse;
+
+#ifdef INTERPRETER
+ {
+ /* ToDo: To fix the caf leak, we need to make the commented out
+ * parts of this code do something sensible - as described in
+ * the CAF document.
+ */
+ extern void markHugsObjects(void);
+#if 0
+ /* ToDo: This (undefined) function should contain the scavenge
+ * loop immediately below this block of code - but I'm not sure
+ * enough of the details to do this myself.
+ */
+ scavengeEverything();
+ /* revert dead CAFs and update enteredCAFs list */
+ revertDeadCAFs();
+#endif
+ markHugsObjects();
+#if 0
+ /* This will keep the CAFs and the attached BCOs alive
+ * but the values will have been reverted
+ */
+ scavengeEverything();
+#endif
+ }
+#endif
+
+ /* Then scavenge all the objects we picked up on the first pass.
+ * We may require multiple passes to find all the static objects,
+ * large objects and normal objects.
+ */
+ {
+ loop:
+ if (static_objects != END_OF_STATIC_LIST) {
+ scavenge_static();
+ }
+ if (toHp_bd != scan_bd || scan < toHp) {
+ scan = scavenge(scan);
+ scan_bd = Bdescr(scan);
+ goto loop;
+ }
+ if (new_large_objects != NULL) {
+ scavenge_large();
+ goto loop;
+ }
+ /* must be last... */
+ if (traverse_weak_ptr_list()) { /* returns rtsTrue if evaced something */
+ goto loop;
+ }
+ }
+
+ /* tidy up the end of the to-space chain */
+ toHp_bd->free = toHp;
+ toHp_bd->link = NULL;
+
+ /* revert dead CAFs and update enteredCAFs list */
+ revertDeadCAFs();
+
+ /* mark the garbage collected CAFs as dead */
+#ifdef DEBUG
+ gcCAFs();
+#endif
+
+ zeroStaticObjectList(scavenged_static_objects);
+
+ /* approximate amount of live data (doesn't take into account slop
+ * at end of each block). ToDo: this more accurately.
+ */
+ live = blocks * BLOCK_SIZE_W + ((lnat)toHp_bd->free -
+ (lnat)toHp_bd->start) / sizeof(W_);
+
+ /* Free the to-space from the last GC, as it has now been collected.
+ * we may be able to re-use these blocks in creating a new nursery,
+ * below. If not, the blocks will probably be re-used for to-space
+ * in the next GC.
+ */
+ if (old_to_space != NULL) {
+ freeChain(old_to_space);
+ }
+ old_to_space = to_space;
+ old_to_space_blocks = blocks;
+
+ /* Free the small objects allocated via allocate(), since this will
+ * all have been copied into to-space now.
+ */
+ if (small_alloc_list != NULL) {
+ freeChain(small_alloc_list);
+ }
+ small_alloc_list = NULL;
+ alloc_blocks = 0;
+ alloc_blocks_lim = stg_max(blocks,RtsFlags.GcFlags.minAllocAreaSize);
+
+ /* LARGE OBJECTS. The current live large objects are chained on
+ * scavenged_large_objects, having been moved during garbage
+ * collection from large_alloc_list. Any objects left on
+ * large_alloc list are therefore dead, so we free them here.
+ */
+ {
+ bdescr *bd, *next;
+ bd = large_alloc_list;
+ while (bd != NULL) {
+ next = bd->link;
+ freeGroup(bd);
+ bd = next;
+ }
+ large_alloc_list = scavenged_large_objects;
+ }
+
+
+ /* check sanity after GC */
+ IF_DEBUG(sanity, checkHeap(to_space,1));
+ /*IF_DEBUG(sanity, checkTSO(MainTSO,1)); */
+ IF_DEBUG(sanity, checkFreeListSanity());
+
+#ifdef DEBUG
+ /* symbol-table based profiling */
+ heapCensus(to_space);
+#endif
+
+ /* set up a new nursery. Allocate a nursery size based on a
+ * function of the amount of live data (currently a factor of 2,
+ * should be configurable (ToDo)). Use the blocks from the old
+ * nursery if possible, freeing up any left over blocks.
+ *
+ * If we get near the maximum heap size, then adjust our nursery
+ * size accordingly. If the nursery is the same size as the live
+ * data (L), then we need 3L bytes. We can reduce the size of the
+ * nursery to bring the required memory down near 2L bytes.
+ *
+ * A normal 2-space collector would need 4L bytes to give the same
+ * performance we get from 3L bytes, reducing to the same
+ * performance at 2L bytes.
+ */
+ if ( blocks * 4 > RtsFlags.GcFlags.maxHeapSize ) {
+ int adjusted_blocks; /* signed on purpose */
+ int pc_free;
+
+ adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks);
+ IF_DEBUG(gc, fprintf(stderr, "Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %d\n", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks));
+ pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize;
+ if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ {
+ heapOverflow();
+ }
+ blocks = adjusted_blocks;
+
+ } else {
+ blocks *= 2;
+ if (blocks < RtsFlags.GcFlags.minAllocAreaSize) {
+ blocks = RtsFlags.GcFlags.minAllocAreaSize;
+ }
+ }
+
+ if (nursery_blocks < blocks) {
+ IF_DEBUG(gc, fprintf(stderr, "Increasing size of nursery to %d blocks\n",
+ blocks));
+ nursery = allocNursery(nursery,blocks-nursery_blocks);
+ } else {
+ bdescr *next_bd = nursery;
+
+ IF_DEBUG(gc, fprintf(stderr, "Decreasing size of nursery to %d blocks\n",
+ blocks));
+ for (bd = nursery; nursery_blocks > blocks; nursery_blocks--) {
+ next_bd = bd->link;
+ freeGroup(bd);
+ bd = next_bd;
+ }
+ nursery = bd;
+ }
+
+ current_nursery = nursery;
+ nursery_blocks = blocks;
+
+ /* set the step number for each block in the nursery to zero */
+ for (bd = nursery; bd != NULL; bd = bd->link) {
+ bd->step = 0;
+ bd->free = bd->start;
+ }
+ for (bd = to_space; bd != NULL; bd = bd->link) {
+ bd->step = 0;
+ }
+ for (bd = large_alloc_list; bd != NULL; bd = bd->link) {
+ bd->step = 0;
+ }
+
+#ifdef DEBUG
+ /* check that we really have the right number of blocks in the
+ * nursery, or things could really get screwed up.
+ */
+ {
+ nat i = 0;
+ for (bd = nursery; bd != NULL; bd = bd->link) {
+ ASSERT(bd->free == bd->start);
+ ASSERT(bd->step == 0);
+ i++;
+ }
+ ASSERT(i == nursery_blocks);
+ }
+#endif
+
+ /* start any pending finalisers */
+ scheduleFinalisers(old_weak_ptr_list);
+
+ /* restore enclosing cost centre */
+#ifdef PROFILING
+ CCCS = prev_CCS;
+#endif
+
+ /* ok, GC over: tell the stats department what happened. */
+ stat_endGC(allocated,
+ (old_nursery_blocks + old_live_blocks) * BLOCK_SIZE_W,
+ live, "");
+}
+
+/* -----------------------------------------------------------------------------
+ Weak Pointers
+
+ traverse_weak_ptr_list is called possibly many times during garbage
+ collection. It returns a flag indicating whether it did any work
+ (i.e. called evacuate on any live pointers).
+
+ Invariant: traverse_weak_ptr_list is called when the heap is in an
+ idempotent state. That means that there are no pending
+ evacuate/scavenge operations. This invariant helps the weak
+ pointer code decide which weak pointers are dead - if there are no
+ new live weak pointers, then all the currently unreachable ones are
+ dead.
+ -------------------------------------------------------------------------- */
+
+static rtsBool
+traverse_weak_ptr_list(void)
+{
+ StgWeak *w, **last_w, *next_w;
+ StgClosure *target;
+ const StgInfoTable *info;
+ rtsBool flag = rtsFalse;
+
+ if (weak_done) { return rtsFalse; }
+
+ last_w = &old_weak_ptr_list;
+ for (w = old_weak_ptr_list; w; w = next_w) {
+ target = w->key;
+ loop:
+ info = get_itbl(target);
+ switch (info->type) {
+
+ case IND:
+ case IND_STATIC:
+ case IND_PERM:
+ case IND_OLDGEN:
+ case IND_OLDGEN_PERM:
+ /* follow indirections */
+ target = ((StgInd *)target)->indirectee;
+ goto loop;
+
+ case EVACUATED:
+ /* If key is alive, evacuate value and finaliser and
+ * place weak ptr on new weak ptr list.
+ */
+ IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p\n", w));
+ w->key = ((StgEvacuated *)target)->evacuee;
+ w->value = evacuate(w->value);
+ w->finaliser = evacuate(w->finaliser);
+
+ /* remove this weak ptr from the old_weak_ptr list */
+ *last_w = w->link;
+
+ /* and put it on the new weak ptr list */
+ next_w = w->link;
+ w->link = weak_ptr_list;
+ weak_ptr_list = w;
+ flag = rtsTrue;
+ break;
+
+ default: /* key is dead */
+ last_w = &(w->link);
+ next_w = w->link;
+ break;
+ }
+ }
+
+ /* If we didn't make any changes, then we can go round and kill all
+ * the dead weak pointers. The old_weak_ptr list is used as a list
+ * of pending finalisers later on.
+ */
+ if (flag == rtsFalse) {
+ for (w = old_weak_ptr_list; w; w = w->link) {
+ w->value = evacuate(w->value);
+ w->finaliser = evacuate(w->finaliser);
+ }
+ weak_done = rtsTrue;
+ }
+
+ return rtsTrue;
+}
+
+StgClosure *MarkRoot(StgClosure *root)
+{
+ root = evacuate(root);
+ return root;
+}
+
+static __inline__ StgClosure *copy(StgClosure *src, W_ size)
+{
+ P_ to, from, dest;
+
+ if (toHp + size >= toHpLim) {
+ bdescr *bd = allocBlock();
+ toHp_bd->free = toHp;
+ toHp_bd->link = bd;
+ bd->step = 1; /* step 1 identifies to-space */
+ toHp = bd->start;
+ toHpLim = toHp + BLOCK_SIZE_W;
+ toHp_bd = bd;
+ blocks++;
+ }
+
+ dest = toHp;
+ toHp += size;
+ for(to = dest, from = (P_)src; size>0; --size) {
+ *to++ = *from++;
+ }
+ return (StgClosure *)dest;
+}
+
+static __inline__ void upd_evacuee(StgClosure *p, StgClosure *dest)
+{
+ StgEvacuated *q = (StgEvacuated *)p;
+
+ SET_INFO(q,&EVACUATED_info);
+ q->evacuee = dest;
+}
+
+/* -----------------------------------------------------------------------------
+ Evacuate a large object
+
+ This just consists of removing the object from the (doubly-linked)
+ large_alloc_list, and linking it on to the (singly-linked)
+ new_large_objects list, from where it will be scavenged later.
+ -------------------------------------------------------------------------- */
+
+static inline void evacuate_large(StgPtr p)
+{
+ bdescr *bd = Bdescr(p);
+
+ /* should point to the beginning of the block */
+ ASSERT(((W_)p & BLOCK_MASK) == 0);
+
+ /* already evacuated? */
+ if (bd->step == 1) {
+ return;
+ }
+
+ /* remove from large_alloc_list */
+ if (bd->back) {
+ bd->back->link = bd->link;
+ } else { /* first object in the list */
+ large_alloc_list = bd->link;
+ }
+ if (bd->link) {
+ bd->link->back = bd->back;
+ }
+
+ /* link it on to the evacuated large object list */
+ bd->link = new_large_objects;
+ new_large_objects = bd;
+ bd->step = 1;
+}
+
+/* -----------------------------------------------------------------------------
+ Evacuate
+
+ This is called (eventually) for every live object in the system.
+ -------------------------------------------------------------------------- */
+
+static StgClosure *evacuate(StgClosure *q)
+{
+ StgClosure *to;
+ const StgInfoTable *info;
+
+loop:
+ /* make sure the info pointer is into text space */
+ ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
+ || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
+
+ info = get_itbl(q);
+ switch (info -> type) {
+
+ case BCO:
+ to = copy(q,bco_sizeW(stgCast(StgBCO*,q)));
+ upd_evacuee(q,to);
+ return to;
+
+ case FUN:
+ case THUNK:
+ case CONSTR:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case CAF_UNENTERED:
+ case CAF_ENTERED:
+ case WEAK:
+ case FOREIGN:
+ case MUT_VAR:
+ case MVAR:
+ to = copy(q,sizeW_fromITBL(info));
+ upd_evacuee(q,to);
+ return to;
+
+ case CAF_BLACKHOLE:
+ case BLACKHOLE:
+ to = copy(q,BLACKHOLE_sizeW());
+ upd_evacuee(q,to);
+ return to;
+
+ case THUNK_SELECTOR:
+ {
+ const StgInfoTable* selectee_info;
+ StgClosure* selectee = stgCast(StgSelector*,q)->selectee;
+
+ selector_loop:
+ selectee_info = get_itbl(selectee);
+ switch (selectee_info->type) {
+ case CONSTR:
+ case CONSTR_STATIC:
+ {
+ StgNat32 offset = info->layout.selector_offset;
+
+ /* check that the size is in range */
+ ASSERT(offset <
+ (StgNat32)(selectee_info->layout.payload.ptrs +
+ selectee_info->layout.payload.nptrs));
+
+ /* perform the selection! */
+ q = selectee->payload[offset];
+
+ /* if we're already in to-space, there's no need to continue
+ * with the evacuation, just update the source address with
+ * a pointer to the (evacuated) constructor field.
+ */
+ if (IS_USER_PTR(q) && Bdescr((P_)q)->step == 1) {
+ return q;
+ }
+
+ /* otherwise, carry on and evacuate this constructor field,
+ * (but not the constructor itself)
+ */
+ goto loop;
+ }
+
+ case IND:
+ case IND_STATIC:
+ case IND_PERM:
+ case IND_OLDGEN:
+ case IND_OLDGEN_PERM:
+ selectee = stgCast(StgInd *,selectee)->indirectee;
+ goto selector_loop;
+
+ case CAF_ENTERED:
+ selectee = stgCast(StgCAF *,selectee)->value;
+ goto selector_loop;
+
+ case EVACUATED:
+ selectee = stgCast(StgEvacuated*,selectee)->evacuee;
+ goto selector_loop;
+
+ case THUNK:
+ case THUNK_STATIC:
+ case THUNK_SELECTOR:
+ /* aargh - do recursively???? */
+ case CAF_UNENTERED:
+ case CAF_BLACKHOLE:
+ case BLACKHOLE:
+ /* not evaluated yet */
+ break;
+
+ default:
+ barf("evacuate: THUNK_SELECTOR: strange selectee");
+ }
+ }
+ to = copy(q,THUNK_SELECTOR_sizeW());
+ upd_evacuee(q,to);
+ return to;
+
+ case IND:
+ case IND_OLDGEN:
+ /* follow chains of indirections, don't evacuate them */
+ q = stgCast(StgInd*,q)->indirectee;
+ goto loop;
+
+ case CONSTR_STATIC:
+ case THUNK_STATIC:
+ case FUN_STATIC:
+ case IND_STATIC:
+ /* don't want to evacuate these, but we do want to follow pointers
+ * from SRTs - see scavenge_static.
+ */
+
+ /* put the object on the static list, if necessary.
+ */
+ if (STATIC_LINK(info,(StgClosure *)q) == NULL) {
+ STATIC_LINK(info,(StgClosure *)q) = static_objects;
+ static_objects = (StgClosure *)q;
+ }
+ /* fall through */
+
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_NOCAF_STATIC:
+ /* no need to put these on the static linked list, they don't need
+ * to be scavenged.
+ */
+ return q;
+
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ case RET_BIG:
+ case RET_VEC_BIG:
+ case RET_DYN:
+ case UPDATE_FRAME:
+ case STOP_FRAME:
+ case CATCH_FRAME:
+ case SEQ_FRAME:
+ /* shouldn't see these */
+ barf("evacuate: stack frame\n");
+
+ case AP_UPD:
+ case PAP:
+ /* these are special - the payload is a copy of a chunk of stack,
+ tagging and all. */
+ to = copy(q,pap_sizeW(stgCast(StgPAP*,q)));
+ upd_evacuee(q,to);
+ return to;
+
+ case EVACUATED:
+ /* Already evacuated, just return the forwarding address */
+ return stgCast(StgEvacuated*,q)->evacuee;
+
+ case MUT_ARR_WORDS:
+ case ARR_WORDS:
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ case ARR_PTRS:
+ {
+ nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
+
+ if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
+ evacuate_large((P_)q);
+ return q;
+ } else {
+ /* just copy the block */
+ to = copy(q,size);
+ upd_evacuee(q,to);
+ return to;
+ }
+ }
+
+ case TSO:
+ {
+ StgTSO *tso = stgCast(StgTSO *,q);
+ nat size = tso_sizeW(tso);
+ int diff;
+
+ /* Large TSOs don't get moved, so no relocation is required.
+ */
+ if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
+ evacuate_large((P_)q);
+ return q;
+
+ /* To evacuate a small TSO, we need to relocate the update frame
+ * list it contains.
+ */
+ } else {
+ StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso));
+
+ diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
+
+ /* relocate the stack pointers... */
+ new_tso->su = (StgUpdateFrame *) ((StgPtr)new_tso->su + diff);
+ new_tso->sp = (StgPtr)new_tso->sp + diff;
+ new_tso->splim = (StgPtr)new_tso->splim + diff;
+
+ relocate_TSO(tso, new_tso);
+ upd_evacuee(q,(StgClosure *)new_tso);
+ return (StgClosure *)new_tso;
+ }
+ }
+
+ case BLOCKED_FETCH:
+ case FETCH_ME:
+ fprintf(stderr,"evacuate: unimplemented/strange closure type\n");
+ return q;
+
+ default:
+ barf("evacuate: strange closure type");
+ }
+
+ barf("evacuate");
+}
+
+/* -----------------------------------------------------------------------------
+ relocate_TSO is called just after a TSO has been copied from src to
+ dest. It adjusts the update frame list for the new location.
+ -------------------------------------------------------------------------- */
+
+StgTSO *
+relocate_TSO(StgTSO *src, StgTSO *dest)
+{
+ StgUpdateFrame *su;
+ StgCatchFrame *cf;
+ StgSeqFrame *sf;
+ int diff;
+
+ diff = (StgPtr)dest->sp - (StgPtr)src->sp; /* In *words* */
+
+ su = dest->su;
+
+ while ((P_)su < dest->stack + dest->stack_size) {
+ switch (get_itbl(su)->type) {
+
+ /* GCC actually manages to common up these three cases! */
+
+ case UPDATE_FRAME:
+ su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
+ su = su->link;
+ continue;
+
+ case CATCH_FRAME:
+ cf = (StgCatchFrame *)su;
+ cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
+ su = cf->link;
+ continue;
+
+ case SEQ_FRAME:
+ sf = (StgSeqFrame *)su;
+ sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
+ su = sf->link;
+ continue;
+
+ case STOP_FRAME:
+ /* all done! */
+ break;
+
+ default:
+ barf("relocate_TSO");
+ }
+ break;
+ }
+
+ return dest;
+}
+
+static inline void
+evacuate_srt(const StgInfoTable *info)
+{
+ StgClosure **srt, **srt_end;
+
+ /* evacuate the SRT. If srt_len is zero, then there isn't an
+ * srt field in the info table. That's ok, because we'll
+ * never dereference it.
+ */
+ srt = stgCast(StgClosure **,info->srt);
+ srt_end = srt + info->srt_len;
+ for (; srt < srt_end; srt++) {
+ evacuate(*srt);
+ }
+}
+
+static StgPtr
+scavenge(StgPtr to_scan)
+{
+ StgPtr p;
+ const StgInfoTable *info;
+ bdescr *bd;
+
+ p = to_scan;
+ bd = Bdescr((P_)p);
+
+ /* scavenge phase - standard breadth-first scavenging of the
+ * evacuated objects
+ */
+
+ while (bd != toHp_bd || p < toHp) {
+
+ /* If we're at the end of this block, move on to the next block */
+ if (bd != toHp_bd && p == bd->free) {
+ bd = bd->link;
+ p = bd->start;
+ continue;
+ }
+
+ ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
+ || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
+
+ info = get_itbl((StgClosure *)p);
+ switch (info -> type) {
+
+ case BCO:
+ {
+ StgBCO* bco = stgCast(StgBCO*,p);
+ nat i;
+ for (i = 0; i < bco->n_ptrs; i++) {
+ bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
+ }
+ p += bco_sizeW(bco);
+ continue;
+ }
+
+ case FUN:
+ case THUNK:
+ evacuate_srt(info);
+ /* fall through */
+
+ case CONSTR:
+ case WEAK:
+ case FOREIGN:
+ case MVAR:
+ case MUT_VAR:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case CAF_UNENTERED:
+ case CAF_ENTERED:
+ {
+ StgPtr end;
+
+ end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs;
+ for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ p += info->layout.payload.nptrs;
+ continue;
+ }
+
+ case CAF_BLACKHOLE:
+ case BLACKHOLE:
+ {
+ StgBlackHole *bh = (StgBlackHole *)p;
+ (StgClosure *)bh->blocking_queue =
+ evacuate((StgClosure *)bh->blocking_queue);
+ p += BLACKHOLE_sizeW();
+ continue;
+ }
+
+ case THUNK_SELECTOR:
+ {
+ StgSelector *s = (StgSelector *)p;
+ s->selectee = evacuate(s->selectee);
+ p += THUNK_SELECTOR_sizeW();
+ continue;
+ }
+
+ case IND:
+ case IND_OLDGEN:
+ barf("scavenge:IND???\n");
+
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ case THUNK_STATIC:
+ case FUN_STATIC:
+ case IND_STATIC:
+ /* Shouldn't see a static object here. */
+ barf("scavenge: STATIC object\n");
+
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ case RET_BIG:
+ case RET_VEC_BIG:
+ case RET_DYN:
+ case UPDATE_FRAME:
+ case STOP_FRAME:
+ case CATCH_FRAME:
+ case SEQ_FRAME:
+ /* Shouldn't see stack frames here. */
+ barf("scavenge: stack frame\n");
+
+ case AP_UPD: /* same as PAPs */
+ case PAP:
+ /* Treat a PAP just like a section of stack, not forgetting to
+ * evacuate the function pointer too...
+ */
+ {
+ StgPAP* pap = stgCast(StgPAP*,p);
+
+ pap->fun = evacuate(pap->fun);
+ scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
+ p += pap_sizeW(pap);
+ continue;
+ }
+
+ case ARR_WORDS:
+ case MUT_ARR_WORDS:
+ /* nothing to follow */
+ p += arr_words_sizeW(stgCast(StgArrWords*,p));
+ continue;
+
+ case ARR_PTRS:
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ /* follow everything */
+ {
+ StgPtr next;
+
+ next = p + arr_ptrs_sizeW(stgCast(StgArrPtrs*,p));
+ for (p = (P_)((StgArrPtrs *)p)->payload; p < next; p++) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ continue;
+ }
+
+ case TSO:
+ {
+ StgTSO *tso;
+
+ tso = (StgTSO *)p;
+ /* chase the link field for any TSOs on the same queue */
+ (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
+ /* scavenge this thread's stack */
+ scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+ p += tso_sizeW(tso);
+ continue;
+ }
+
+ case BLOCKED_FETCH:
+ case FETCH_ME:
+ case EVACUATED:
+ barf("scavenge: unimplemented/strange closure type\n");
+
+ default:
+ barf("scavenge");
+ }
+ }
+ return (P_)p;
+}
+
+/* scavenge_static is the scavenge code for a static closure.
+ */
+
+static void
+scavenge_static(void)
+{
+ StgClosure* p = static_objects;
+ const StgInfoTable *info;
+
+ /* keep going until we've scavenged all the objects on the linked
+ list... */
+ while (p != END_OF_STATIC_LIST) {
+
+ /* make sure the info pointer is into text space */
+ ASSERT(p && LOOKS_LIKE_GHC_INFO(GET_INFO(p)));
+ ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
+ || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
+
+ info = get_itbl(p);
+
+ /* Take this object *off* the static_objects list,
+ * and put it on the scavenged_static_objects list.
+ */
+ static_objects = STATIC_LINK(info,p);
+ STATIC_LINK(info,p) = scavenged_static_objects;
+ scavenged_static_objects = p;
+
+ switch (info -> type) {
+
+ case IND_STATIC:
+ {
+ StgInd *ind = (StgInd *)p;
+ ind->indirectee = evacuate(ind->indirectee);
+ break;
+ }
+
+ case THUNK_STATIC:
+ case FUN_STATIC:
+ evacuate_srt(info);
+ /* fall through */
+
+ case CONSTR_STATIC:
+ {
+ StgPtr q, next;
+
+ next = (P_)p->payload + info->layout.payload.ptrs;
+ /* evacuate the pointers */
+ for (q = (P_)p->payload; q < next; q++) {
+ (StgClosure *)*q = evacuate((StgClosure *)*q);
+ }
+ break;
+ }
+
+ default:
+ barf("scavenge_static");
+ }
+
+ /* get the next static object from the list. Remeber, there might
+ * be more stuff on this list now that we've done some evacuating!
+ * (static_objects is a global)
+ */
+ p = static_objects;
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ scavenge_stack walks over a section of stack and evacuates all the
+ objects pointed to by it. We can use the same code for walking
+ PAPs, since these are just sections of copied stack.
+ -------------------------------------------------------------------------- */
+
+static void
+scavenge_stack(StgPtr p, StgPtr stack_end)
+{
+ StgPtr q;
+ const StgInfoTable* info;
+ StgNat32 bitmap;
+
+ /*
+ * Each time around this loop, we are looking at a chunk of stack
+ * that starts with either a pending argument section or an
+ * activation record.
+ */
+
+ while (p < stack_end) {
+ q = *stgCast(StgPtr*,p);
+
+ /* If we've got a tag, skip over that many words on the stack */
+ if (IS_ARG_TAG(stgCast(StgWord,q))) {
+ p += ARG_SIZE(q);
+ p++; continue;
+ }
+
+ /* Is q a pointer to a closure?
+ */
+ if (! LOOKS_LIKE_GHC_INFO(q)) {
+
+#ifdef DEBUG
+ if (LOOKS_LIKE_STATIC(q)) { /* Is it a static closure? */
+ ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
+ }
+ /* otherwise, must be a pointer into the allocation space.
+ */
+#endif
+
+ (StgClosure *)*p = evacuate((StgClosure *)q);
+ p++;
+ continue;
+ }
+
+ /*
+ * Otherwise, q must be the info pointer of an activation
+ * record. All activation records have 'bitmap' style layout
+ * info.
+ */
+ info = get_itbl(stgCast(StgClosure*,p));
+
+ switch (info->type) {
+
+ /* Dynamic bitmap: the mask is stored on the stack */
+ case RET_DYN:
+ bitmap = stgCast(StgRetDyn*,p)->liveness;
+ p = &payloadWord(stgCast(StgRetDyn*,p),0);
+ goto small_bitmap;
+
+ /* probably a slow-entry point return address: */
+ case FUN:
+ case FUN_STATIC:
+ p++;
+ goto follow_srt;
+
+ /* Specialised code for update frames, since they're so common.
+ * We *know* the updatee points to a BLACKHOLE or CAF_BLACKHOLE,
+ * so just inline the code to evacuate it here.
+ */
+ case UPDATE_FRAME:
+ {
+ StgUpdateFrame *frame = (StgUpdateFrame *)p;
+ StgClosure *to;
+ StgClosureType type = get_itbl(frame->updatee)->type;
+
+ if (type == EVACUATED) {
+ frame->updatee = evacuate(frame->updatee);
+ p += sizeofW(StgUpdateFrame);
+ continue;
+ } else {
+ ASSERT(type == BLACKHOLE || type == CAF_BLACKHOLE);
+ to = copy(frame->updatee, BLACKHOLE_sizeW());
+ upd_evacuee(frame->updatee,to);
+ frame->updatee = to;
+ p += sizeofW(StgUpdateFrame);
+ continue;
+ }
+ }
+
+ /* small bitmap (< 32 entries) */
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ case STOP_FRAME:
+ case CATCH_FRAME:
+ case SEQ_FRAME:
+ bitmap = info->layout.bitmap;
+ p++;
+ small_bitmap:
+ while (bitmap != 0) {
+ if ((bitmap & 1) == 0) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ }
+
+ follow_srt:
+ evacuate_srt(info);
+ continue;
+
+ /* large bitmap (> 32 entries) */
+ case RET_BIG:
+ case RET_VEC_BIG:
+ {
+ StgLargeBitmap *large_bitmap;
+ nat i;
+
+ large_bitmap = info->layout.large_bitmap;
+ p++;
+
+ for (i=0; i<large_bitmap->size; i++) {
+ bitmap = large_bitmap->bitmap[i];
+ while (bitmap != 0) {
+ if ((bitmap & 1) == 0) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ }
+ }
+
+ /* and don't forget to follow the SRT */
+ goto follow_srt;
+ }
+
+ default:
+ barf("scavenge_stack: weird activation record found on stack.\n");
+ }
+ }
+}
+
+/*-----------------------------------------------------------------------------
+ scavenge the large object list.
+ --------------------------------------------------------------------------- */
+
+static void
+scavenge_large(void)
+{
+ bdescr *bd;
+ StgPtr p;
+ const StgInfoTable* info;
+
+ bd = new_large_objects;
+
+ for (; bd != NULL; bd = new_large_objects) {
+
+ /* take this object *off* the large objects list and put it on
+ * the scavenged large objects list. This is so that we can
+ * treat new_large_objects as a stack and push new objects on
+ * the front when evacuating.
+ */
+ new_large_objects = bd->link;
+ /* scavenged_large_objects is doubly linked */
+ bd->link = scavenged_large_objects;
+ bd->back = NULL;
+ if (scavenged_large_objects) {
+ scavenged_large_objects->back = bd;
+ }
+ scavenged_large_objects = bd;
+
+ p = bd->start;
+ info = get_itbl(stgCast(StgClosure*,p));
+
+ switch (info->type) {
+
+ /* only certain objects can be "large"... */
+
+ case ARR_WORDS:
+ case MUT_ARR_WORDS:
+ /* nothing to follow */
+ continue;
+
+ case ARR_PTRS:
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ /* follow everything */
+ {
+ StgPtr next;
+
+ next = p + arr_ptrs_sizeW(stgCast(StgArrPtrs*,p));
+ for (p = (P_)((StgArrPtrs *)p)->payload; p < next; p++) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ continue;
+ }
+
+ case BCO:
+ {
+ StgBCO* bco = stgCast(StgBCO*,p);
+ nat i;
+ for (i = 0; i < bco->n_ptrs; i++) {
+ bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
+ }
+ continue;
+ }
+
+ case TSO:
+ {
+ StgTSO *tso;
+
+ tso = (StgTSO *)p;
+ /* chase the link field for any TSOs on the same queue */
+ (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
+ /* scavenge this thread's stack */
+ scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+ continue;
+ }
+
+ default:
+ barf("scavenge_large: unknown/strange object");
+ }
+ }
+}
+static void
+zeroStaticObjectList(StgClosure* first_static)
+{
+ StgClosure* p;
+ StgClosure* link;
+ const StgInfoTable *info;
+
+ for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
+ info = get_itbl(p);
+ link = STATIC_LINK(info, p);
+ STATIC_LINK(info,p) = NULL;
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Reverting CAFs
+
+ -------------------------------------------------------------------------- */
+
+void RevertCAFs(void)
+{
+ while (enteredCAFs != END_CAF_LIST) {
+ StgCAF* caf = enteredCAFs;
+ const StgInfoTable *info = get_itbl(caf);
+
+ enteredCAFs = caf->link;
+ ASSERT(get_itbl(caf)->type == CAF_ENTERED);
+ SET_INFO(caf,&CAF_UNENTERED_info);
+ caf->value = stgCast(StgClosure*,0xdeadbeef);
+ caf->link = stgCast(StgCAF*,0xdeadbeef);
+ }
+}
+
+void revertDeadCAFs(void)
+{
+ StgCAF* caf = enteredCAFs;
+ enteredCAFs = END_CAF_LIST;
+ while (caf != END_CAF_LIST) {
+ StgCAF* next = caf->link;
+
+ switch(GET_INFO(caf)->type) {
+ case EVACUATED:
+ {
+ /* This object has been evacuated, it must be live. */
+ StgCAF* new = stgCast(StgCAF*,stgCast(StgEvacuated*,caf)->evacuee);
+ new->link = enteredCAFs;
+ enteredCAFs = new;
+ break;
+ }
+ case CAF_ENTERED:
+ {
+ SET_INFO(caf,&CAF_UNENTERED_info);
+ caf->value = stgCast(StgClosure*,0xdeadbeef);
+ caf->link = stgCast(StgCAF*,0xdeadbeef);
+ break;
+ }
+ default:
+ barf("revertDeadCAFs: enteredCAFs list corrupted");
+ }
+ caf = next;
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Sanity code for CAF garbage collection.
+
+ With DEBUG turned on, we manage a CAF list in addition to the SRT
+ mechanism. After GC, we run down the CAF list and blackhole any
+ CAFs which have been garbage collected. This means we get an error
+ whenever the program tries to enter a garbage collected CAF.
+
+ Any garbage collected CAFs are taken off the CAF list at the same
+ time.
+ -------------------------------------------------------------------------- */
+
+#ifdef DEBUG
+static void
+gcCAFs(void)
+{
+ StgClosure* p;
+ StgClosure** pp;
+ const StgInfoTable *info;
+ nat i;
+
+ i = 0;
+ p = caf_list;
+ pp = &caf_list;
+
+ while (p != NULL) {
+
+ info = get_itbl(p);
+
+ ASSERT(info->type == IND_STATIC);
+
+ if (STATIC_LINK(info,p) == NULL) {
+ IF_DEBUG(gccafs, fprintf(stderr, "CAF gc'd at 0x%04x\n", (int)p));
+ /* black hole it */
+ SET_INFO(p,&BLACKHOLE_info);
+ p = STATIC_LINK2(info,p);
+ *pp = p;
+ }
+ else {
+ pp = &STATIC_LINK2(info,p);
+ p = *pp;
+ i++;
+ }
+
+ }
+
+ /* fprintf(stderr, "%d CAFs live\n", i); */
+}
+#endif
+
+/* -----------------------------------------------------------------------------
+ Lazy black holing.
+
+ Whenever a thread returns to the scheduler after possibly doing
+ some work, we have to run down the stack and black-hole all the
+ closures referred to by update frames.
+ -------------------------------------------------------------------------- */
+
+static void
+threadLazyBlackHole(StgTSO *tso)
+{
+ StgUpdateFrame *update_frame;
+ StgBlackHole *bh;
+ StgPtr stack_end;
+
+ stack_end = &tso->stack[tso->stack_size];
+ update_frame = tso->su;
+
+ while (1) {
+ switch (get_itbl(update_frame)->type) {
+
+ case CATCH_FRAME:
+ update_frame = stgCast(StgCatchFrame*,update_frame)->link;
+ break;
+
+ case UPDATE_FRAME:
+ bh = stgCast(StgBlackHole*,update_frame->updatee);
+
+ /* if the thunk is already blackholed, it means we've also
+ * already blackholed the rest of the thunks on this stack,
+ * so we can stop early.
+ */
+
+ /* Don't for now: when we enter a CAF, we create a black hole on
+ * the heap and make the update frame point to it. Thus the
+ * above optimisation doesn't apply.
+ */
+ if (bh->header.info != &BLACKHOLE_info
+ && bh->header.info != &CAF_BLACKHOLE_info) {
+ SET_INFO(bh,&BLACKHOLE_info);
+ bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
+ }
+
+ update_frame = update_frame->link;
+ break;
+
+ case SEQ_FRAME:
+ update_frame = stgCast(StgSeqFrame*,update_frame)->link;
+ break;
+
+ case STOP_FRAME:
+ return;
+ default:
+ barf("threadPaused");
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ * Stack squeezing
+ *
+ * Code largely pinched from old RTS, then hacked to bits. We also do
+ * lazy black holing here.
+ *
+ * -------------------------------------------------------------------------- */
+
+static void
+threadSqueezeStack(StgTSO *tso)
+{
+ lnat displacement = 0;
+ StgUpdateFrame *frame;
+ StgUpdateFrame *next_frame; /* Temporally next */
+ StgUpdateFrame *prev_frame; /* Temporally previous */
+ StgPtr bottom;
+ rtsBool prev_was_update_frame;
+
+ bottom = &(tso->stack[tso->stack_size]);
+ frame = tso->su;
+
+ /* There must be at least one frame, namely the STOP_FRAME.
+ */
+ ASSERT((P_)frame < bottom);
+
+ /* Walk down the stack, reversing the links between frames so that
+ * we can walk back up as we squeeze from the bottom. Note that
+ * next_frame and prev_frame refer to next and previous as they were
+ * added to the stack, rather than the way we see them in this
+ * walk. (It makes the next loop less confusing.)
+ *
+ * Could stop if we find an update frame pointing to a black hole,
+ * but see comment in threadLazyBlackHole().
+ */
+
+ next_frame = NULL;
+ while ((P_)frame < bottom - 1) { /* bottom - 1 is the STOP_FRAME */
+ prev_frame = frame->link;
+ frame->link = next_frame;
+ next_frame = frame;
+ frame = prev_frame;
+ }
+
+ /* Now, we're at the bottom. Frame points to the lowest update
+ * frame on the stack, and its link actually points to the frame
+ * above. We have to walk back up the stack, squeezing out empty
+ * update frames and turning the pointers back around on the way
+ * back up.
+ *
+ * The bottom-most frame (the STOP_FRAME) has not been altered, and
+ * we never want to eliminate it anyway. Just walk one step up
+ * before starting to squeeze. When you get to the topmost frame,
+ * remember that there are still some words above it that might have
+ * to be moved.
+ */
+
+ prev_frame = frame;
+ frame = next_frame;
+
+ prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
+
+ /*
+ * Loop through all of the frames (everything except the very
+ * bottom). Things are complicated by the fact that we have
+ * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
+ * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
+ */
+ while (frame != NULL) {
+ StgPtr sp;
+ StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
+ rtsBool is_update_frame;
+
+ next_frame = frame->link;
+ is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
+
+ /* Check to see if
+ * 1. both the previous and current frame are update frames
+ * 2. the current frame is empty
+ */
+ if (prev_was_update_frame && is_update_frame &&
+ (P_)prev_frame == frame_bottom + displacement) {
+
+ /* Now squeeze out the current frame */
+ StgClosure *updatee_keep = prev_frame->updatee;
+ StgClosure *updatee_bypass = frame->updatee;
+
+#if 0 /* DEBUG */
+ fprintf(stderr, "squeezing frame at %p\n", frame);
+#endif
+
+ /* Deal with blocking queues. If both updatees have blocked
+ * threads, then we should merge the queues into the update
+ * frame that we're keeping.
+ *
+ * Alternatively, we could just wake them up: they'll just go
+ * straight to sleep on the proper blackhole! This is less code
+ * and probably less bug prone, although it's probably much
+ * slower --SDM
+ */
+#if 0 /* do it properly... */
+ if (GET_INFO(updatee_bypass) == BLACKHOLE_info
+ || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
+ ) {
+ /* Sigh. It has one. Don't lose those threads! */
+ if (GET_INFO(updatee_keep) == BLACKHOLE_info
+ || GET_INFO(updatee_keep) == CAF_BLACKHOLE_info
+ ) {
+ /* Urgh. Two queues. Merge them. */
+ P_ keep_tso = ((StgBlackHole *)updatee_keep)->blocking_queue;
+
+ while (keep_tso->link != END_TSO_QUEUE) {
+ keep_tso = keep_tso->link;
+ }
+ keep_tso->link = ((StgBlackHole *)updatee_bypass)->blocking_queue;
+
+ } else {
+ /* For simplicity, just swap the BQ for the BH */
+ P_ temp = updatee_keep;
+
+ updatee_keep = updatee_bypass;
+ updatee_bypass = temp;
+
+ /* Record the swap in the kept frame (below) */
+ prev_frame->updatee = updatee_keep;
+ }
+ }
+#endif
+
+ TICK_UPD_SQUEEZED();
+ UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
+
+ sp = (P_)frame - 1; /* sp = stuff to slide */
+ displacement += sizeofW(StgUpdateFrame);
+
+ } else {
+ /* No squeeze for this frame */
+ sp = frame_bottom - 1; /* Keep the current frame */
+
+ /* Do lazy black-holing.
+ */
+ if (is_update_frame) {
+ StgBlackHole *bh = (StgBlackHole *)frame->updatee;
+ if (bh->header.info != &BLACKHOLE_info
+ && bh->header.info != &CAF_BLACKHOLE_info
+ ) {
+ SET_INFO(bh,&BLACKHOLE_info);
+ bh->blocking_queue = stgCast(StgTSO*,&END_TSO_QUEUE_closure);
+ }
+ }
+
+ /* Fix the link in the current frame (should point to the frame below) */
+ frame->link = prev_frame;
+ prev_was_update_frame = is_update_frame;
+ }
+
+ /* Now slide all words from sp up to the next frame */
+
+ if (displacement > 0) {
+ P_ next_frame_bottom;
+
+ if (next_frame != NULL)
+ next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
+ else
+ next_frame_bottom = tso->sp - 1;
+
+#if 0 /* DEBUG */
+ fprintf(stderr, "sliding [%p, %p] by %ld\n", sp, next_frame_bottom,
+ displacement);
+#endif
+
+ while (sp >= next_frame_bottom) {
+ sp[displacement] = *sp;
+ sp -= 1;
+ }
+ }
+ (P_)prev_frame = (P_)frame + displacement;
+ frame = next_frame;
+ }
+
+ tso->sp += displacement;
+ tso->su = prev_frame;
+}
+
+/* -----------------------------------------------------------------------------
+ * Pausing a thread
+ *
+ * We have to prepare for GC - this means doing lazy black holing
+ * here. We also take the opportunity to do stack squeezing if it's
+ * turned on.
+ * -------------------------------------------------------------------------- */
+
+void
+threadPaused(StgTSO *tso)
+{
+ if ( RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue )
+ threadSqueezeStack(tso); /* does black holing too */
+ else
+ threadLazyBlackHole(tso);
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: GC.h,v 1.2 1998/12/02 13:28:25 simonm Exp $
+ *
+ * Prototypes for functions in GC.c
+ *
+ * ---------------------------------------------------------------------------*/
+
+void threadPaused(StgTSO *);
--- /dev/null
+EXTFUN(stg_gc_entertop);
+EXTFUN(stg_gc_enter_1);
+EXTFUN(stg_gc_enter_2);
+EXTFUN(stg_gc_enter_3);
+EXTFUN(stg_gc_enter_4);
+EXTFUN(stg_gc_enter_5);
+EXTFUN(stg_gc_enter_6);
+EXTFUN(stg_gc_enter_7);
+EXTFUN(stg_gc_enter_8);
+EXTFUN(stg_gc_seq_1);
+EXTFUN(stg_gc_noregs);
+EXTFUN(stg_gc_unpt_r1_entry);
+EXTFUN(stg_gc_unpt_r1);
+EXTFUN(stg_gc_unbx_r1_entry);
+EXTFUN(stg_gc_unbx_r1);
+EXTFUN(stg_gc_f1_entry);
+EXTFUN(stg_gc_f1);
+EXTFUN(stg_gc_d1_entry);
+EXTFUN(stg_gc_d1);
+EXTFUN(stg_gc_ut_1_0_entry);
+EXTFUN(stg_gc_ut_1_0);
+EXTFUN(stg_gc_ut_0_1_entry);
+EXTFUN(stg_gc_ut_0_1);
+EXTFUN(stg_chk_0);
+EXTFUN(stg_chk_1);
+EXTFUN(stg_chk_1n);
+EXTFUN(stg_chk_2);
+EXTFUN(stg_chk_3);
+EXTFUN(stg_chk_4);
+EXTFUN(stg_chk_5);
+EXTFUN(stg_chk_6);
+EXTFUN(stg_chk_7);
+EXTFUN(stg_chk_8);
+EXTFUN(stg_gen_chk_ret);
+EXTFUN(stg_gen_chk);
+EXTFUN(stg_gen_hp);
+EXTFUN(stg_gen_yield);
+EXTFUN(stg_yield_to_Hugs);
+EXTFUN(stg_gen_block);
+EXTFUN(stg_block_1);
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: HeapStackCheck.hc,v 1.2 1998/12/02 13:28:26 simonm Exp $
+ *
+ * Canned Heap-Check and Stack-Check sequences.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "Storage.h" /* for CurrentTSO */
+#include "StgRun.h" /* for StgReturn and register saving */
+#include "Schedule.h" /* for context_switch */
+#include "HeapStackCheck.h"
+
+/* Stack/Heap Check Failure
+ * ------------------------
+ *
+ * On discovering that a stack or heap check has failed, we do the following:
+ *
+ * - If the context_switch flag is set, indicating that there are more
+ * threads waiting to run, we yield to the scheduler
+ * (return ThreadYeilding).
+ *
+ * - If Hp > HpLim, we've had a heap check failure. This means we've
+ * come to the end of the current heap block, so we try to chain
+ * another block on with ExtendNursery().
+ *
+ * - If this succeeds, we carry on without returning to the
+ * scheduler.
+ *
+ * - If it fails, we return to the scheduler claiming HeapOverflow
+ * so that a garbage collection can be performed.
+ *
+ * - If Hp <= HpLim, it must have been a stack check that failed. In
+ * which case, we return to the scheduler claiming StackOverflow, the
+ * scheduler will either increase the size of our stack, or flag
+ * an error if the stack is already too big.
+ *
+ * The effect of checking for context switch only in the heap/stack check
+ * failure code is that we'll switch threads after the current thread has
+ * reached the end of its heap block. If a thread isn't allocating
+ * at all, it won't yield. Hopefully this won't be a problem in practice.
+ */
+
+/* Remember that the return address is *removed* when returning to a
+ * ThreadRunGHC thread.
+ */
+
+
+#define GC_GENERIC \
+ if (Hp > HpLim) { \
+ if (ExtendNursery(Hp,HpLim)) { \
+ if (context_switch) { \
+ R1.i = ThreadYielding; \
+ } else { \
+ Sp++; \
+ JMP_(ENTRY_CODE(Sp[-1])); \
+ } \
+ } else { \
+ R1.i = HeapOverflow; \
+ } \
+ } else { \
+ R1.i = StackOverflow; \
+ } \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadRunGHC; \
+ JMP_(StgReturn);
+
+#define GC_ENTER \
+ if (Hp > HpLim) { \
+ if (ExtendNursery(Hp,HpLim)) { \
+ if (context_switch) { \
+ R1.i = ThreadYielding; \
+ } else { \
+ R1.w = *Sp; \
+ Sp++; \
+ JMP_(ENTRY_CODE(*R1.p)); \
+ } \
+ } else { \
+ R1.i = HeapOverflow; \
+ } \
+ } else { \
+ R1.i = StackOverflow; \
+ } \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadEnterGHC; \
+ JMP_(StgReturn);
+
+#define HP_GENERIC \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadRunGHC; \
+ R1.i = HeapOverflow; \
+ JMP_(StgReturn);
+
+#define STK_GENERIC \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadRunGHC; \
+ R1.i = StackOverflow; \
+ JMP_(StgReturn);
+
+#define YIELD_GENERIC \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadRunGHC; \
+ R1.i = ThreadYielding; \
+ JMP_(StgReturn);
+
+#define YIELD_TO_HUGS \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadEnterHugs; \
+ R1.i = ThreadYielding; \
+ JMP_(StgReturn);
+
+#define BLOCK_GENERIC \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadRunGHC; \
+ R1.i = ThreadBlocked; \
+ JMP_(StgReturn);
+
+#define BLOCK_ENTER \
+ SaveThreadState(); \
+ CurrentTSO->whatNext = ThreadEnterGHC;\
+ R1.i = ThreadBlocked; \
+ JMP_(StgReturn);
+
+/* -----------------------------------------------------------------------------
+ Heap Checks
+ -------------------------------------------------------------------------- */
+
+/*
+ * This one is used when we want to *enter* the top thing on the stack
+ * when we return, instead of the just returning to an address. See
+ * UpdatePAP for an example.
+ */
+
+EXTFUN(stg_gc_entertop)
+{
+ FB_
+ GC_ENTER
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Heap checks in non-top-level thunks/functions.
+
+ In these cases, node always points to the function closure. This gives
+ us an easy way to return to the function: just leave R1 on the top of
+ the stack, and have the scheduler enter it to return.
+
+ There are canned sequences for 'n' pointer values in registers.
+ -------------------------------------------------------------------------- */
+
+EXTFUN(stg_gc_enter_1)
+{
+ FB_
+ Sp -= 1;
+ Sp[0] = R1.w;
+ GC_ENTER
+ FE_
+}
+
+/*- 2 Regs--------------------------------------------------------------------*/
+
+EXTFUN(stg_gc_enter_2)
+{
+ FB_
+ Sp -= 2;
+ Sp[1] = R2.w;
+ Sp[0] = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/*- 3 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_gc_enter_3)
+{
+ FB_
+ Sp -= 3;
+ Sp[2] = R3.w;
+ Sp[1] = R2.w;
+ Sp[0] = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/*- 4 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_gc_enter_4)
+{
+ FB_
+ Sp -= 4;
+ Sp[3] = R4.w;
+ Sp[2] = R3.w;
+ Sp[1] = R2.w;
+ Sp[0] = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/*- 5 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_gc_enter_5)
+{
+ FB_
+ Sp -= 5;
+ Sp[4] = R5.w;
+ Sp[3] = R4.w;
+ Sp[2] = R3.w;
+ Sp[1] = R2.w;
+ Sp[0] = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/*- 6 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_gc_enter_6)
+{
+ FB_
+ Sp -= 6;
+ Sp[5] = R6.w;
+ Sp[4] = R5.w;
+ Sp[3] = R4.w;
+ Sp[2] = R3.w;
+ Sp[1] = R2.w;
+ Sp[0] = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/*- 7 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_gc_enter_7)
+{
+ FB_
+ Sp -= 7;
+ Sp[6] = R7.w;
+ Sp[5] = R6.w;
+ Sp[4] = R5.w;
+ Sp[3] = R4.w;
+ Sp[2] = R3.w;
+ Sp[1] = R2.w;
+ Sp[0] = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/*- 8 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_gc_enter_8)
+{
+ FB_
+ Sp -= 8;
+ Sp[7] = R8.w;
+ Sp[6] = R7.w;
+ Sp[5] = R6.w;
+ Sp[4] = R5.w;
+ Sp[3] = R4.w;
+ Sp[2] = R3.w;
+ Sp[1] = R2.w;
+ Sp[0] = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ For a case expression on a polymorphic or function-typed object, if
+ the default branch (there can only be one branch) of the case fails
+ a heap-check, instead of using stg_gc_enter_1 as normal, we must
+ push a new SEQ frame on the stack, followed by the object returned.
+
+ Otherwise, if the object is a function, it won't return to the
+ correct activation record on returning from garbage collection. It will
+ assume it has some arguments and apply itself.
+ -------------------------------------------------------------------------- */
+
+EXTFUN(stg_gc_seq_1)
+{
+ FB_
+ Sp -= 1 + sizeofW(StgSeqFrame);
+ PUSH_SEQ_FRAME(Sp+1);
+ *Sp = R1.w;
+ GC_ENTER;
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Heap checks in Primitive case alternatives
+
+ A primitive case alternative is entered with a value either in
+ R1, FloatReg1 or D1 depending on the return convention. All the
+ cases are covered below.
+ -------------------------------------------------------------------------- */
+
+/*-- No regsiters live, return address already on the stack: ---------------- */
+
+EXTFUN(stg_gc_noregs)
+{
+ FB_
+ GC_GENERIC
+ FE_
+}
+
+/*-- R1 is boxed/unpointed -------------------------------------------------- */
+
+INFO_TABLE_SRT_BITMAP(stg_gc_unpt_r1_info, stg_gc_unpt_r1_entry, 0/*BITMAP*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL, const, EF_, 0, 0);
+
+EXTFUN(stg_gc_unpt_r1_entry)
+{
+ FB_
+ R1.w = Sp[0];
+ Sp += 1;
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+EXTFUN(stg_gc_unpt_r1)
+{
+ FB_
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_gc_unpt_r1_info;
+ GC_GENERIC
+ FE_
+}
+
+/*-- R1 is unboxed -------------------------------------------------- */
+
+INFO_TABLE_SRT_BITMAP(stg_gc_unbx_r1_info, stg_gc_unbx_r1_entry, 1/*BITMAP*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL, const, EF_, 0, 0);
+/* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */
+
+EXTFUN(stg_gc_unbx_r1_entry)
+{
+ FB_
+ R1.w = Sp[0];
+ Sp += 1;
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+EXTFUN(stg_gc_unbx_r1)
+{
+ FB_
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_gc_unbx_r1_info;
+ GC_GENERIC
+ FE_
+}
+
+/*-- F1 contains a float ------------------------------------------------- */
+
+INFO_TABLE_SRT_BITMAP(stg_gc_f1_info, stg_gc_f1_entry, 1/*BITMAP*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL, const, EF_, 0, 0);
+
+EXTFUN(stg_gc_f1_entry)
+{
+ FB_
+ F1 = PK_FLT(Sp);
+ Sp += 1;
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+EXTFUN(stg_gc_f1)
+{
+ FB_
+ Sp -= 2;
+ ASSIGN_FLT(Sp+1, F1);
+ Sp[0] = (W_)&stg_gc_f1_info;
+ GC_GENERIC
+ FE_
+}
+
+/*-- D1 contains a double ------------------------------------------------- */
+
+/* we support doubles of either 1 or 2 words in size */
+
+#if SIZEOF_DOUBLE == SIZEOF_VOID_P
+# define DBL_BITMAP 1
+#else
+# define DBL_BITMAP 3
+#endif
+
+INFO_TABLE_SRT_BITMAP(stg_gc_d1_info, stg_gc_d1_entry, DBL_BITMAP,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL, const, EF_, 0, 0);
+
+EXTFUN(stg_gc_d1_entry)
+{
+ FB_
+ D1 = PK_DBL(Sp);
+ Sp += sizeofW(StgDouble);
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+EXTFUN(stg_gc_d1)
+{
+ FB_
+ Sp -= 1 + sizeofW(StgDouble);
+ ASSIGN_DBL(Sp+1,D1);
+ Sp[0] = (W_)&stg_gc_d1_info;
+ GC_GENERIC
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Heap checks for unboxed tuple case alternatives
+
+ The story is:
+
+ - for an unboxed tuple with n components, we rearrange the components
+ with pointers first followed by non-pointers. (NB: not done yet)
+
+ - The first k components are allocated registers, where k is the
+ number of components that will fit in real registers.
+
+ - The rest are placed on the stack, with space left for tagging
+ of the non-pointer block if necessary.
+
+ - On failure of a heap check:
+ - the tag is filled in if necessary,
+ - we load Ri with the address of the continuation,
+ where i is the lowest unused vanilla register.
+ - jump to 'stg_gc_ut_x_y' where x is the number of pointer
+ registers and y the number of non-pointers.
+ - if the required canned sequence isn't available, it will
+ have to be generated at compile-time by the code
+ generator (this will probably happen if there are
+ floating-point values, for instance).
+
+ For now, just deal with R1, hence R2 contains the sequel address.
+ -------------------------------------------------------------------------- */
+
+/*---- R1 contains a pointer: ------ */
+
+INFO_TABLE_SRT_BITMAP(stg_gc_ut_1_0_info, stg_gc_ut_1_0_entry, 1/*BITMAP*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL, const, EF_, 0, 0);
+
+EXTFUN(stg_gc_ut_1_0_entry)
+{
+ FB_
+ R1.w = Sp[1];
+ Sp += 2;
+ JMP_(Sp[-2]);
+ FE_
+}
+
+EXTFUN(stg_gc_ut_1_0)
+{
+ FB_
+ Sp -= 3;
+ Sp[2] = R1.w;
+ Sp[1] = R2.w;
+ Sp[0] = (W_)&stg_gc_ut_1_0_info;
+ GC_GENERIC
+ FE_
+}
+
+/*---- R1 contains a non-pointer: ------ */
+
+INFO_TABLE_SRT_BITMAP(stg_gc_ut_0_1_info, stg_gc_ut_0_1_entry, 3/*BITMAP*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL, const, EF_, 0, 0);
+
+EXTFUN(stg_gc_ut_0_1_entry)
+{
+ FB_
+ R1.w = Sp[1];
+ Sp += 2;
+ JMP_(Sp[-2]);
+ FE_
+}
+
+EXTFUN(stg_gc_ut_0_1)
+{
+ FB_
+ Sp -= 3;
+ Sp[0] = (W_)&stg_gc_ut_0_1_info;
+ Sp[1] = R2.w;
+ Sp[2] = R1.w;
+ GC_GENERIC
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Standard top-level fast-entry heap checks.
+
+ - we want to make the stack look like it should at the slow entry
+ point for the function. That way we can just push the slow
+ entry point on the stack and return using ThreadRunGHC.
+
+ - The compiler will generate code to fill in any tags on the stack,
+ in case we arrived directly at the fast entry point and these tags
+ aren't present.
+
+ - The rest is hopefully handled by jumping to a canned sequence.
+ We currently have canned sequences for 0-8 pointer registers. If
+ any registers contain non-pointers, we must reduce to an all-pointers
+ situation by pushing as many registers on the stack as necessary.
+
+ eg. if R1, R2 contain pointers and R3 contains a word, the heap check
+ failure sequence looks like this:
+
+ Sp[-1] = R3.w;
+ Sp[-2] = WORD_TAG;
+ Sp -= 2;
+ JMP_(stg_chk_2)
+
+ after pushing R3, we have pointers in R1 and R2 which corresponds
+ to the 2-pointer canned sequence.
+
+ -------------------------------------------------------------------------- */
+
+/*- 0 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_0)
+{
+ FB_
+ Sp -= 1;
+ Sp[0] = R1.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 1 Reg --------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_1)
+{
+ FB_
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = R2.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 1 Reg (non-ptr) ----------------------------------------------------------*/
+
+EXTFUN(stg_chk_1n)
+{
+ FB_
+ Sp -= 3;
+ Sp[2] = R1.w;
+ Sp[1] = WORD_TAG; /* ToDo: or maybe its an int? */
+ Sp[0] = R2.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 2 Regs--------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_2)
+{
+ FB_
+ Sp -= 3;
+ Sp[2] = R2.w;
+ Sp[1] = R1.w;
+ Sp[0] = R3.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 3 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_3)
+{
+ FB_
+ Sp -= 4;
+ Sp[3] = R3.w;
+ Sp[2] = R2.w;
+ Sp[1] = R1.w;
+ Sp[0] = R4.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 4 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_4)
+{
+ FB_
+ Sp -= 5;
+ Sp[4] = R4.w;
+ Sp[3] = R3.w;
+ Sp[2] = R2.w;
+ Sp[1] = R1.w;
+ Sp[0] = R5.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 5 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_5)
+{
+ FB_
+ Sp -= 6;
+ Sp[5] = R5.w;
+ Sp[4] = R4.w;
+ Sp[3] = R3.w;
+ Sp[2] = R2.w;
+ Sp[1] = R1.w;
+ Sp[0] = R6.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 6 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_6)
+{
+ FB_
+ Sp -= 7;
+ Sp[6] = R6.w;
+ Sp[5] = R5.w;
+ Sp[4] = R4.w;
+ Sp[3] = R3.w;
+ Sp[2] = R2.w;
+ Sp[1] = R1.w;
+ Sp[0] = R7.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 7 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_7)
+{
+ FB_
+ Sp -= 8;
+ Sp[7] = R7.w;
+ Sp[6] = R6.w;
+ Sp[5] = R5.w;
+ Sp[4] = R4.w;
+ Sp[3] = R3.w;
+ Sp[2] = R2.w;
+ Sp[1] = R1.w;
+ Sp[0] = R8.w;
+ GC_GENERIC;
+ FE_
+}
+
+/*- 8 Regs -------------------------------------------------------------------*/
+
+EXTFUN(stg_chk_8)
+{
+ FB_
+ Sp -= 9;
+ Sp[8] = R8.w;
+ Sp[7] = R7.w;
+ Sp[6] = R6.w;
+ Sp[5] = R5.w;
+ Sp[4] = R4.w;
+ Sp[3] = R3.w;
+ Sp[2] = R2.w;
+ Sp[1] = R1.w;
+ Sp[0] = R9.w;
+ GC_GENERIC;
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Generic Heap Check Code.
+
+ Called with Liveness mask in R9, Return address in R10.
+ Stack must be consistent (tagged, and containing all necessary info pointers
+ to relevant SRTs).
+
+ We also define an stg_gen_yield here, because it's very similar.
+ -------------------------------------------------------------------------- */
+
+#if SIZEOF_DOUBLE > SIZEOF_VOID_P
+
+#define RESTORE_EVERYTHING \
+ D2 = PK_DBL(Sp+16); \
+ D1 = PK_DBL(Sp+14); \
+ F4 = PK_FLT(Sp+13); \
+ F3 = PK_FLT(Sp+12); \
+ F2 = PK_FLT(Sp+11); \
+ F1 = PK_FLT(Sp+10); \
+ R8.w = Sp[9]; \
+ R7.w = Sp[8]; \
+ R6.w = Sp[7]; \
+ R5.w = Sp[6]; \
+ R4.w = Sp[5]; \
+ R3.w = Sp[4]; \
+ R2.w = Sp[3]; \
+ R1.w = Sp[2]; \
+ Sp += 18;
+
+#define RET_OFFSET (-17)
+
+#define SAVE_EVERYTHING \
+ ASSIGN_DBL(Sp-2,D2); \
+ ASSIGN_DBL(Sp-4,D1); \
+ ASSIGN_FLT(Sp-5,F4); \
+ ASSIGN_FLT(Sp-6,F3); \
+ ASSIGN_FLT(Sp-7,F2); \
+ ASSIGN_FLT(Sp-8,F1); \
+ Sp[-9] = R8.w; \
+ Sp[-10] = R7.w; \
+ Sp[-11] = R6.w; \
+ Sp[-12] = R5.w; \
+ Sp[-13] = R4.w; \
+ Sp[-14] = R3.w; \
+ Sp[-15] = R2.w; \
+ Sp[-16] = R1.w; \
+ Sp[-17] = R10.w; /* return address */ \
+ Sp[-18] = R9.w; /* liveness mask */ \
+ Sp[-19] = (W_)&stg_gen_chk_info; \
+ Sp -= 19;
+
+#else
+
+#define RESTORE_EVERYTHING \
+ D2 = PK_DBL(Sp+15); \
+ D1 = PK_DBL(Sp+14); \
+ F4 = PK_FLT(Sp+13); \
+ F3 = PK_FLT(Sp+12); \
+ F2 = PK_FLT(Sp+11); \
+ F1 = PK_FLT(Sp+10); \
+ R8.w = Sp[9]; \
+ R7.w = Sp[8]; \
+ R6.w = Sp[7]; \
+ R5.w = Sp[6]; \
+ R4.w = Sp[5]; \
+ R3.w = Sp[4]; \
+ R2.w = Sp[3]; \
+ R1.w = Sp[2]; \
+ Sp += 16;
+
+#define RET_OFFSET (-15)
+
+#define SAVE_EVERYTHING \
+ ASSIGN_DBL(Sp-1,D2); \
+ ASSIGN_DBL(Sp-2,D1); \
+ ASSIGN_FLT(Sp-3,F4); \
+ ASSIGN_FLT(Sp-4,F3); \
+ ASSIGN_FLT(Sp-5,F2); \
+ ASSIGN_FLT(Sp-6,F1); \
+ Sp[-7] = R8.w; \
+ Sp[-8] = R7.w; \
+ Sp[-9] = R6.w; \
+ Sp[-10] = R5.w; \
+ Sp[-11] = R4.w; \
+ Sp[-12] = R3.w; \
+ Sp[-13] = R2.w; \
+ Sp[-14] = R1.w; \
+ Sp[-15] = R10.w; /* return address */ \
+ Sp[-16] = R9.w; /* liveness mask */ \
+ Sp[-17] = (W_)&stg_gen_chk_info; \
+ Sp -= 17;
+
+#endif
+
+INFO_TABLE_SRT_BITMAP(stg_gen_chk_info, stg_gen_chk_ret, 0,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_DYN, const, EF_, 0, 0);
+
+/* bitmap in the above info table is unused, the real one is on the stack.
+ */
+
+FN_(stg_gen_chk_ret)
+{
+ FB_
+ RESTORE_EVERYTHING;
+ JMP_(Sp[RET_OFFSET]);
+ FE_
+}
+
+FN_(stg_gen_chk)
+{
+ FB_
+ SAVE_EVERYTHING;
+ GC_GENERIC
+ FE_
+}
+
+/*
+ * stg_gen_hp is used by MAYBE_GC, where we can't use GC_GENERIC
+ * because we've just failed doYouWantToGC(), not a standard heap
+ * check. GC_GENERIC would end up returning StackOverflow.
+ */
+FN_(stg_gen_hp)
+{
+ FB_
+ SAVE_EVERYTHING;
+ HP_GENERIC
+ FE_
+}
+
+FN_(stg_gen_yield)
+{
+ FB_
+ SAVE_EVERYTHING;
+ YIELD_GENERIC
+ FE_
+}
+
+FN_(stg_yield_to_Hugs)
+{
+ FB_
+ /* No need to save everything - no live registers */
+ YIELD_TO_HUGS
+ FE_
+}
+
+FN_(stg_gen_block)
+{
+ FB_
+ SAVE_EVERYTHING;
+ BLOCK_GENERIC
+ FE_
+}
+
+FN_(stg_block_1)
+{
+ FB_
+ Sp--;
+ Sp[0] = R1.w;
+ BLOCK_ENTER;
+ FE_
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Itimer.c,v 1.2 1998/12/02 13:28:27 simonm Exp $
+ *
+ * (c) The GHC Team, 1995-1998
+ *
+ * Interval timer for profiling and pre-emptive scheduling.
+ *
+ * ---------------------------------------------------------------------------*/
+
+/*
+ * The interval timer is used for profiling and for context switching in the
+ * threaded build. Though POSIX 1003.1b includes a standard interface for
+ * such things, no one really seems to be implementing them yet. Even
+ * Solaris 2.3 only seems to provide support for @CLOCK_REAL@, whereas we're
+ * keen on getting access to @CLOCK_VIRTUAL@.
+ *
+ * Hence, we use the old-fashioned @setitimer@ that just about everyone seems
+ * to support. So much for standards.
+ */
+
+#if !defined(_AIX)
+# define NON_POSIX_SOURCE
+#endif
+
+#include "Rts.h"
+#include "Itimer.h"
+
+/* As recommended in the autoconf manual */
+# ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+# else
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+# endif
+
+/*
+ * Handling timer events under cygwin32 is not done with signal/setitimer.
+ * Instead of the two steps of first registering a signal handler to handle
+ * \tr{SIGVTALRM} and then start generating them via @setitimer()@, we use
+ * the Multimedia API (MM) and its @timeSetEvent@. (Internally, the MM API
+ * creates a separate thread that will notify the main thread of timer
+ * expiry). -- SOF 7/96
+ *
+ * 11/98: if the cygwin DLL supports setitimer(), then use it instead.
+ */
+
+#if defined(cygwin32_TARGET_OS) && !defined(HAVE_SETITIMER)
+
+#include <windows.h> /* OK, bring it all in... */
+
+/*
+ vtalrm_handler is assigned and set up in
+ main/Signals.lc.
+
+ vtalrm_id (defined in main/Signals.lc) holds
+ the system id for the current timer (used to
+ later block/kill the timer)
+*/
+extern nat vtalrm_id;
+extern TIMECALLBACK *vtalrm_cback;
+
+nat
+initialize_virtual_timer(nat ms)
+{
+ /* VTALRM is currently not supported by cygwin32,
+ so we use the Timer support provided by the
+ MultiMedia API that is part of Win32. The
+ parameters to timeSetEvent may require some tweaking.
+ */
+ unsigned int delay,vtalrm_id;
+
+ delay = timeBeginPeriod(1);
+ if (delay == TIMERR_NOCANDO) { /* error of some sort. */
+ return delay;
+ }
+ vtalrm_id =
+ timeSetEvent(ms, /* event every `delay' milliseconds. */
+ 1, /* precision is within 5 millisecs. */
+ (LPTIMECALLBACK)vtalrm_cback,
+ 0,
+ TIME_PERIODIC);
+ return 0;
+}
+
+#else
+
+nat
+initialize_virtual_timer(nat ms)
+{
+# ifndef HAVE_SETITIMER
+ fprintf(stderr, "No virtual timer on this system\n");
+ return -1;
+# else
+ struct itimerval it;
+
+ it.it_value.tv_sec = ms / 1000;
+ it.it_value.tv_usec = 1000 * (ms - (1000 * it.it_value.tv_sec));
+ it.it_interval = it.it_value;
+ return (setitimer(ITIMER_VIRTUAL, &it, NULL));
+# endif
+}
+
+#endif /* !cygwin32_TARGET_OS */
+
+# if 0
+/* This is a potential POSIX version */
+nat
+initialize_virtual_timer(nat ms)
+{
+ struct sigevent se;
+ struct itimerspec it;
+ timer_t tid;
+
+ se.sigev_notify = SIGEV_SIGNAL;
+ se.sigev_signo = SIGVTALRM;
+ se.sigev_value.sival_int = SIGVTALRM;
+ if (timer_create(CLOCK_VIRTUAL, &se, &tid)) {
+ fprintf(stderr, "Can't create virtual timer.\n");
+ EXIT(EXIT_FAILURE);
+ }
+ it.it_value.tv_sec = ms / 1000;
+ it.it_value.tv_nsec = 1000000 * (ms - 1000 * it.it_value.tv_sec);
+ it.it_interval = it.it_value;
+ timer_settime(tid, TIMER_RELTIME, &it, NULL);
+}
+# endif
+
+int
+install_vtalrm_handler(void (*handler)(int))
+{
+ struct sigaction action;
+
+ action.sa_handler = handler;
+
+ sigemptyset(&action.sa_mask);
+ action.sa_flags = 0;
+
+ return sigaction(SIGVTALRM, &action, NULL);
+}
+
+void
+block_vtalrm_signal(void)
+{
+ sigset_t signals;
+
+ sigemptyset(&signals);
+ sigaddset(&signals, SIGVTALRM);
+
+ (void) sigprocmask(SIG_BLOCK, &signals, NULL);
+}
+
+void
+unblock_vtalrm_signal(void)
+{
+ sigset_t signals;
+
+ sigemptyset(&signals);
+ sigaddset(&signals, SIGVTALRM);
+
+ (void) sigprocmask(SIG_UNBLOCK, &signals, NULL);
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Itimer.h,v 1.2 1998/12/02 13:28:28 simonm Exp $
+ *
+ * (c) The GHC Team 1998
+ *
+ * Interval timer for profiling and pre-emptive scheduling.
+ *
+ * ---------------------------------------------------------------------------*/
+
+nat initialize_virtual_timer ( nat ms );
+int install_vtalrm_handler ( void (*handler)(int) );
+void block_vtalrm_signal ( void );
+void unblock_vtalrm_signal ( void );
+
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: MBlock.c,v 1.2 1998/12/02 13:28:28 simonm Exp $
+ *
+ * MegaBlock Allocator Interface. This file contains all the dirty
+ * architecture-dependent hackery required to get a chunk of aligned
+ * memory from the operating system.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#define NON_POSIX_SOURCE
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+#include "MBlock.h"
+#include "BlockAlloc.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_MMAN_H
+#include <sys/mman.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+#if cygwin32_TARGET_OS
+#include <windows.h>
+#endif
+
+#if freebsd2_TARGET_OS || freebsd3_TARGET_OS
+/* Executable is loaded from 0x0
+ * Shared libraries are loaded at 0x2000000
+ * Stack is at the top of the address space. The kernel probably owns
+ * 0x8000000 onwards, so we'll pick 0x5000000.
+ */
+#define ASK_FOR_MEM_AT 0x50000000
+
+#elif linux_TARGET_OS
+/* Any ideas?
+ */
+#define ASK_FOR_MEM_AT 0x50000000
+
+#elif cygwin32_TARGET_OS
+/* Any ideas?
+ */
+#define ASK_FOR_MEM_AT 0x50000000
+
+#elif solaris2_TARGET_OS
+/* guess */
+#define ASK_FOR_MEM_AT 0x50000000
+
+#else
+#error Dont know where to get memory from on this architecture
+/* ToDo: memory locations on other architectures */
+#endif
+
+void *
+getMBlock(void)
+{
+ return getMBlocks(1);
+}
+
+void *
+getMBlocks(nat n)
+{
+ static caddr_t next_request = (caddr_t)ASK_FOR_MEM_AT;
+ caddr_t ret;
+ lnat size = MBLOCK_SIZE * n;
+
+#ifdef solaris2_TARGET_OS
+ {
+ int fd = open("/dev/zero",O_RDONLY);
+ ret = mmap(next_request, size, PROT_READ | PROT_WRITE,
+ MAP_FIXED | MAP_PRIVATE, fd, 0);
+ close(fd);
+ }
+#else
+# ifdef _WIN32
+ {
+ /* avoid using cygwin32's mmap implementation, it's buggy and
+ it's just as easy to do what we want to do directly.
+ */
+ HANDLE hFile = (HANDLE)0xFFFFFFFF;
+ SECURITY_ATTRIBUTES sa;
+ HANDLE h;
+
+ sa.nLength = sizeof (SECURITY_ATTRIBUTES);
+ sa.bInheritHandle = TRUE;
+ sa.lpSecurityDescriptor = 0;
+
+ h = CreateFileMapping(hFile, &sa, PAGE_READWRITE, 0, size, NULL);
+ if ( h == 0 ) {
+# ifdef DEBUG
+ fprintf(stderr, "getMBlocks: CreateFileMapping failed with: %d\n", GetLastError());
+# endif
+ ret=(void*)-1;
+ } else {
+ ret = MapViewOfFileEx (h, FILE_MAP_WRITE, 0, 0, size, next_request);
+ if ( ret != next_request ) {
+# ifdef DEBUG
+ fprintf(stderr, "getMBlocks: MapViewOfFileEx failed with: %d\n", GetLastError());
+# endif
+ ret =(void*)-1;
+ }
+ }
+ }
+# else
+ ret = mmap(next_request, size, PROT_READ | PROT_WRITE,
+ MAP_ANON | MAP_PRIVATE, -1, 0);
+# endif
+#endif
+
+ if (ret == (void *)-1) {
+ if (errno == ENOMEM) {
+ barf("getMBlock: out of memory");
+ } else {
+ barf("GetMBlock: mmap failed");
+ }
+ }
+
+ if (((W_)ret & MBLOCK_MASK) != 0) {
+ barf("GetMBlock: misaligned block returned");
+ }
+
+ IF_DEBUG(gc,fprintf(stderr,"Allocated %d megablock(s) at %x\n",n,(nat)ret));
+
+ next_request += size;
+
+ return ret;
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: MBlock.h,v 1.2 1998/12/02 13:28:30 simonm Exp $
+ *
+ * MegaBlock Allocator interface.
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern void * getMBlock(void);
+extern void * getMBlocks(nat n);
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Main.c,v 1.2 1998/12/02 13:28:30 simonm Exp $
+ *
+ * Main function for a standalone Haskell program.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "Schedule.h" /* for MainTSO */
+#include "RtsUtils.h"
+
+#ifdef DEBUG
+#include "RtsFlags.h" /* for debugging flags */
+#include "Printer.h" /* for printing */
+#endif
+
+#ifdef INTERPRETER
+#include "Assembler.h"
+#endif
+
+#ifdef PAR
+#include "ParInit.h"
+#include "Parallel.h"
+#include "LLC.h"
+#endif
+
+/* Hack: we assume that we're building a batch-mode system unless
+ * INTERPRETER is set
+ */
+#ifndef INTERPRETER /* Hack */
+int main(int argc, char *argv[])
+{
+ SchedulerStatus status;
+ startupHaskell(argc,argv);
+
+#ifndef PAR
+ MainTSO = createIOThread(BLOCK_SIZE_W,(StgClosure *)&mainIO_closure);
+ status = schedule(MainTSO,NULL);
+#else
+ if (IAmMainThread == rtsTrue) {
+ /*Just to show we're alive */
+ fprintf(stderr, "Main Thread Started ...\n");
+
+ MainTSO = createIOThread(BLOCK_SIZE_W,(StgClosure *)&mainIO_closure);
+ status = schedule(MainTSO,NULL);
+ } else {
+ WaitForPEOp(PP_FINISH,SysManTask);
+ exit(EXIT_SUCCESS);
+ }
+#endif /* PAR */
+ switch (status) {
+ case AllBlocked:
+ barf("Scheduler stopped, all threads blocked");
+ case Deadlock:
+ shutdownHaskell();
+ barf("No threads to run! Deadlock?");
+ case Killed:
+ belch("%s: warning: main thread killed", prog_argv[0]);
+ case Success:
+ case Interrupted:
+ /* carry on */
+ }
+ shutdownHaskell();
+ stg_exit(EXIT_SUCCESS);
+}
+#endif /* BATCH_MODE */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Main.h,v 1.2 1998/12/02 13:28:31 simonm Exp $
+ *
+ * Prototypes for functions in Main.c
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifdef INTERPRETER
+extern void eval( StgClosure* closure );
+#endif
--- /dev/null
+#-----------------------------------------------------------------------------
+# $Id: Makefile,v 1.2 1998/12/02 13:28:32 simonm Exp $
+
+# This is the Makefile for the runtime-system stuff.
+# This stuff is written in C (and cannot be written in Haskell).
+#
+# We create two libraries. One, libHSrts<tag>.a, is built separately
+# for each "way". The other, libHSclib.a is built once: it is just
+# .lc files that end up the same no matter what, i.e. completely
+# ordinary C.
+
+# Other sorta independent, compile-once subdirs are:
+
+# gmp -- GNU multi-precision library (for Integer)
+
+#-----------------------------------------------------------------------------
+
+TOP=..
+DoingRTS=YES
+include $(TOP)/mk/boilerplate.mk
+
+WAYS=$(GhcLibWays)
+
+SRCS_RTS_C = $(wildcard *.c) $(wildcard hooks/*.c) $(filter-out gum/SysMan.c,$(wildcard gum/*.c))
+SRCS_RTS_S = $(wildcard *.S)
+SRCS_RTS_HC = $(wildcard *.hc)
+
+#-----------------------------------------------------------------------------
+# creating and installing libHSrts.a (in its many flavors)
+#
+LIBRARY = libHSrts$(_way).a
+LIBOBJS = $(patsubst %.c,%.$(way_)o,$(SRCS_RTS_C)) \
+ $(patsubst %.hc,%.$(way_)o,$(SRCS_RTS_HC)) \
+ $(patsubst %.S,%.$(way_)o,$(SRCS_RTS_S))
+
+# gcc provides lots of useful warnings if you ask it.
+# This is a pretty good list to start with - use a # to comment out
+# any you don't like.
+WARNING_OPTS += -optc-Wall
+WARNING_OPTS += -optc-W
+WARNING_OPTS += -optc-Wstrict-prototypes
+WARNING_OPTS += -optc-Wmissing-prototypes
+WARNING_OPTS += -optc-Wmissing-declarations
+WARNING_OPTS += -optc-Winline
+WARNING_OPTS += -optc-Waggregate-return
+WARNING_OPTS += -optc-Wpointer-arith
+WARNING_OPTS += -optc-Wbad-function-cast
+#WARNING_OPTS += -optc-Wcast-align
+#WARNING_OPTS += -optc-Wnested-externs
+#WARNING_OPTS += -optc-Wshadow
+#WARNING_OPTS += -optc-Wcast-qual
+#WARNING_OPTS += -optc-Wno-unused
+#WARNING_OPTS += -optc-Wredundant-decls
+#WARNING_OPTS += -optc-Wconversion
+
+SRC_HC_OPTS += -I../includes -I. -Igum $(WARNING_OPTS) $(GhcRtsHcOpts)
+SRC_CC_OPTS += -I../includes -I. -Igum $(WARNING_OPTS) $(GhcRtsCcOpts)
+
+ifeq "$(way)" "mp"
+SRC_HC_OPTS += -I$$PVM_ROOT/include
+SRC_CC_OPTS += -I$$PVM_ROOT/include
+endif
+
+C_SRCS = $(SRCS_RTS_C) $(SRCS_RTS_HC) # $(SRCS_RTS_S)???
+
+SRC_MKDEPENDC_OPTS += -I. -I../includes
+
+#-----------------------------------------------------------------------------
+#
+# Compiling the individual files
+#
+# Rules for building various types of objects from C files,
+# override the default suffix rule here, as we want to use
+# ../driver/ghc (a better C compiler :-) to compile the
+# different RTS pieces
+#
+CC=$(HC) $($*_HC_OPTS)
+
+# prevent this value from leaking into the GMP makefile
+unexport CC
+
+# -----------------------------------------------------------------------------
+# Compile GMP only if we don't have it already
+#
+# We use GMP's own configuration stuff, because it's all rather hairy
+# and not worth re-implementing in our Makefile framework.
+
+ifneq "$(HaveLibGmp)" "YES"
+boot ::
+ cd gmp && ./configure
+
+all :: gmp/libgmp.a
+
+install :: gmp/libgmp.a
+
+ifeq "$(way)" ""
+INSTALL_LIBS += gmp/libgmp.a
+endif
+
+gmp/libgmp.a ::
+ $(MAKE) -C gmp MAKEFLAGS=
+endif
+
+#-----------------------------------------------------------------------------
+#
+# Building the GUM SysMan
+#
+
+ifeq "$(way)" "mp"
+all :: gum/SysMan
+
+ifdef solaris2_TARGET_OS
+__socket_libs = -lsocket -lnsl
+else
+__socket_libs =
+endif
+
+gum/SysMan : gum/SysMan.mp_o gum/LLComms.mp_o
+ $(RM) $@
+ gcc -o $@ gum/SysMan.mp_o gum/LLComms.mp_o -L$$PVM_ROOT/lib/$$PVM_ARCH -lgpvm3 -lpvm3 $(__socket_libs)
+
+CLEAN_FILES += gum/SysMan.mp_o gum/SysMan
+INSTALL_LIBEXECS += gum/SysMan
+endif
+
+#-----------------------------------------------------------------------------
+#
+# Files to install
+#
+# Just libHSrts is installed uniformly across ways
+#
+INSTALL_LIBS += $(LIBRARY)
+
+include $(TOP)/mk/target.mk
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: PrimOps.hc,v 1.2 1998/12/02 13:28:32 simonm Exp $
+ *
+ * Primitive functions / data
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef COMPILER
+
+#include "RtsFlags.h"
+#include "StgStartup.h"
+#include "SchedAPI.h"
+#include "Schedule.h"
+#include "RtsUtils.h"
+#include "Storage.h"
+#include "BlockAlloc.h" /* tmp */
+#include "StablePtr.h"
+
+/* ** temporary **
+
+ classes CCallable and CReturnable don't really exist, but the
+ compiler insists on generating dictionaries containing references
+ to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
+ for these.
+*/
+
+W_ GHC_ZcCCallable_static_info[0];
+W_ GHC_ZcCReturnable_static_info[0];
+
+#ifndef aix_TARGET_OS /* AIX gives link errors with this as a const (RO assembler section) */
+const
+#endif
+ StgClosure *PrelBase_Bool_closure_tbl[] = {
+ &False_closure,
+ &True_closure
+};
+
+/* -----------------------------------------------------------------------------
+ Macros for Hand-written primitives.
+ -------------------------------------------------------------------------- */
+
+/*
+ * Horrible macros for returning unboxed tuples.
+ *
+ * How an unboxed tuple is returned depends on two factors:
+ * - the number of real registers we have available
+ * - the boxedness of the returned fields.
+ *
+ * To return an unboxed tuple from a primitive operation, we have macros
+ * RET_<layout> where <layout> describes the boxedness of each field of the
+ * unboxed tuple: N indicates a non-pointer field, and P indicates a pointer.
+ *
+ * We only define the cases actually used, to avoid having too much
+ * garbage in this section. Warning: any bugs in here will be hard to
+ * track down.
+ */
+
+/*------ All Regs available */
+#ifdef REG_R8
+# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
+# define RET_N(a) RET_P(a)
+
+# define RET_PP(a,b) R1.w = (W_)(a); R2.w = (W_)(b); JMP_(ENTRY_CODE(Sp[0]));
+# define RET_NN(a,b) RET_PP(a,b)
+# define RET_NP(a,b) RET_PP(a,b)
+
+# define RET_PPP(a,b,c) \
+ R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); JMP_(ENTRY_CODE(Sp[0]));
+# define RET_NNP(a,b,c) RET_PPP(a,b,c)
+
+# define RET_NNNP(a,b,c,d) \
+ R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
+ JMP_(ENTRY_CODE(Sp[0]));
+
+# define RET_NNPNNP(a,b,c,d,e,f) \
+ R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
+ R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
+ JMP_(ENTRY_CODE(Sp[0]));
+
+#else
+
+#if defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
+ defined(REG_R4) || defined(REG_R3) || defined(REG_R2)
+# error RET_n macros not defined for this setup.
+#else
+
+/*------ 1 Register available */
+#ifdef REG_R1
+# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
+# define RET_N(a) RET_P(a)
+
+# define RET_PP(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
+ JMP_(ENTRY_CODE(Sp[1]));
+# define RET_NN(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
+ JMP_(ENTRY_CODE(Sp[2]));
+# define RET_NP(a,b) RET_PP(a,b)
+
+# define RET_PPP(a,b,c) \
+ R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
+ JMP_(ENTRY_CODE(Sp[2]));
+# define RET_NNP(a,b,c) \
+ R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
+ JMP_(ENTRY_CODE(Sp[3]));
+
+# define RET_NNNP(a,b,c,d) \
+ R1.w = (W_)(a); \
+ /* Sp[-5] = ARGTAG(1); */ \
+ Sp[-4] = (W_)(b); \
+ /* Sp[-3] = ARGTAG(1); */ \
+ Sp[-2] = (W_)(c); \
+ Sp[-1] = (W_)(d); \
+ Sp -= 5; \
+ JMP_(ENTRY_CODE(Sp[5]));
+
+# define RET_NNPNNP(a,b,c,d,e,f) \
+ R1.w = (W_)(a); \
+ Sp[-1] = (W_)(f); \
+ Sp[-2] = (W_)(e); \
+ /* Sp[-3] = ARGTAG(1); */ \
+ Sp[-4] = (W_)(d); \
+ /* Sp[-5] = ARGTAG(1); */ \
+ Sp[-6] = (W_)(c); \
+ Sp[-7] = (W_)(b); \
+ /* Sp[-8] = ARGTAG(1); */ \
+ Sp -= 8; \
+ JMP_(ENTRY_CODE(Sp[8]));
+
+#else /* 0 Regs available */
+
+#define PUSH_P(o,x) Sp[-o] = (W_)(x)
+#define PUSH_N(o,x) Sp[1-o] = (W_)(x); /* Sp[-o] = ARGTAG(1) */
+#define PUSHED(m) Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
+
+/* Here's how to construct these macros:
+ *
+ * N = number of N's in the name;
+ * P = number of P's in the name;
+ * s = N * 2 + P;
+ * while (nonNull(name)) {
+ * if (nextChar == 'P') {
+ * PUSH_P(s,_);
+ * s -= 1;
+ * } else {
+ * PUSH_N(s,_);
+ * s -= 2
+ * }
+ * }
+ * PUSHED(N * 2 + P);
+ */
+
+# define RET_P(a) PUSH_P(1,a); PUSHED(1)
+# define RET_N(a) PUSH_N(2,a); PUSHED(2)
+
+# define RET_PP(a,b) PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
+# define RET_NN(a,b) PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
+# define RET_NP(a,b) PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
+
+# define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
+# define RET_NNP(a,b,c) PUSH_N(6,a); PUSH_N(4,b); PUSH_N(2,c); PUSHED(6)
+
+# define RET_NNNP(a,b,c,d) PUSH_N(7,a); PUSH_N(5,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(7)
+# define RET_NNPNNP(a,b,c,d,e,f) PUSH_N(10,a); PUSH_N(8,b); PUSH_P(6,c); PUSH_N(5,d); PUSH_N(3,e); PUSH_P(1,f); PUSHED(10)
+
+#endif
+
+#endif
+#endif
+
+/*-----------------------------------------------------------------------------
+ Array Primitives
+
+ Basically just new*Array - the others are all inline macros.
+
+ The size arg is always passed in R1, and the result returned in R1.
+
+ The slow entry point is for returning from a heap check, the saved
+ size argument must be re-loaded from the stack.
+ -------------------------------------------------------------------------- */
+
+/* for objects that are *less* than the size of a word, make sure we
+ * round up to the nearest word for the size of the array.
+ */
+
+#define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
+
+#define newByteArray(ty,scale) \
+ FN_(new##ty##ArrayZh_fast) \
+ { \
+ W_ stuff_size, size, n; \
+ StgArrWords* p; \
+ FB_ \
+ MAYBE_GC(NO_PTRS,new##ty##ArrayZh_fast); \
+ n = R1.w; \
+ stuff_size = BYTES_TO_STGWORDS(n*scale); \
+ size = sizeofW(StgArrWords)+ stuff_size; \
+ p = (StgArrWords *)allocate(size); \
+ SET_HDR(p, &MUT_ARR_WORDS_info, CCCS); \
+ p->words = stuff_size; \
+ RET_P(p); \
+ FE_ \
+ }
+
+newByteArray(Char, sizeof(C_))
+newByteArray(Int, sizeof(I_));
+newByteArray(Word, sizeof(W_));
+newByteArray(Addr, sizeof(P_));
+newByteArray(Float, sizeof(StgFloat));
+newByteArray(Double, sizeof(StgDouble));
+newByteArray(StablePtr, sizeof(StgStablePtr));
+
+FN_(newArrayZh_fast)
+{
+ W_ size, n, init;
+ StgArrPtrs* arr;
+ StgPtr p;
+ FB_
+ n = R1.w;
+
+ MAYBE_GC(R2_PTR,newArrayZh_fast);
+
+ size = sizeofW(StgArrPtrs) + n;
+ arr = (StgArrPtrs *)allocate(size);
+
+ SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
+ arr->ptrs = n;
+
+ init = R2.w;
+ for (p = (P_)arr + sizeofW(StgArrPtrs);
+ p < (P_)arr + size; p++) {
+ *p = (W_)init;
+ }
+
+ RET_P(arr);
+ FE_
+}
+
+FN_(newMutVarZh_fast)
+{
+ StgMutVar* mv;
+ /* Args: R1.p = initialisation value */
+ FB_
+
+ HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarZh_fast,);
+ TICK_ALLOC_PRIM(sizeofW(StgMutVar),wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgMutVar));
+
+ mv = stgCast(StgMutVar*,Hp-sizeofW(StgMutVar)+1);
+ SET_HDR(mv,&MUT_VAR_info,CCCS);
+ mv->var = R1.cl;
+
+ RET_P(mv);
+
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Foreign Object Primitives
+
+ -------------------------------------------------------------------------- */
+
+#ifndef PAR
+FN_(makeForeignObjZh_fast)
+{
+ /* R1.p = ptr to foreign object,
+ */
+ StgForeignObj *result;
+ FB_
+
+ HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjZh_fast,);
+ TICK_ALLOC_PRIM(sizeofW(StgForeignObj),wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
+
+ result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
+ SET_HDR(result,&FOREIGN_info,CCCS);
+ result->data = R1.p;
+
+ /* returns (# s#, ForeignObj# #) */
+ RET_P(result);
+ FE_
+}
+#endif
+
+/* -----------------------------------------------------------------------------
+ Weak Pointer Primitives
+ -------------------------------------------------------------------------- */
+
+#ifndef PAR
+
+FN_(mkWeakZh_fast)
+{
+ /* R1.p = key
+ R2.p = value
+ R3.p = finaliser
+ */
+ StgWeak *w;
+ FB_
+
+ HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakZh_fast,);
+ TICK_ALLOC_PRIM(sizeofW(StgWeak),wibble,wibble,wibble);
+ CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
+
+ w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
+ SET_HDR(w, &WEAK_info, CCCS);
+
+ w->key = R1.cl;
+ w->value = R2.cl;
+ w->finaliser = R3.cl;
+
+ w->link = weak_ptr_list;
+ weak_ptr_list = w;
+ IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
+
+ RET_P(w);
+ FE_
+}
+
+FN_(deRefWeakZh_fast)
+{
+ /* R1.p = weak ptr
+ */
+ StgWeak *w;
+ FB_
+
+ w = (StgWeak *)R1.p;
+ if (w->header.info == &WEAK_info) {
+ RET_NP(1, w->value);
+ } else {
+ RET_NP(0, w);
+ }
+ FE_
+}
+
+#endif /* !PAR */
+
+/* -----------------------------------------------------------------------------
+ Arbitrary-precision Integer operations.
+ -------------------------------------------------------------------------- */
+
+FN_(int2IntegerZh_fast)
+{
+ /* arguments: R1 = Int# */
+
+ I_ val, s; /* to avoid aliasing */
+ StgArrWords* p; /* address of array result */
+ FB_
+
+ val = R1.i;
+ HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2IntegerZh_fast,)
+ TICK_ALLOC_PRIM(sizeofW(StgArrWords)+1,wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
+
+ p = stgCast(StgArrWords*,Hp)-1;
+ SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
+
+ /* mpz_set_si is inlined here, makes things simpler */
+ if (val < 0) {
+ s = -1;
+ *Hp = -val;
+ } else if (val > 0) {
+ s = 1;
+ *Hp = val;
+ } else {
+ s = 0;
+ }
+
+ /* returns (# alloc :: Int#,
+ size :: Int#,
+ data :: ByteArray#
+ #)
+ */
+ RET_NNP(1,s,p);
+ FE_
+}
+
+FN_(word2IntegerZh_fast)
+{
+ /* arguments: R1 = Word# */
+
+ W_ val; /* to avoid aliasing */
+ I_ s;
+ StgArrWords* p; /* address of array result */
+ FB_
+
+ val = R1.w;
+ HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2IntegerZh_fast,)
+ TICK_ALLOC_PRIM(sizeofW(StgArrWords)+1,wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
+
+ p = stgCast(StgArrWords*,Hp)-1;
+ SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
+
+ if (val != 0) {
+ s = 1;
+ *Hp = val;
+ } else {
+ s = 0;
+ }
+
+ /* returns (# alloc :: Int#,
+ size :: Int#,
+ data :: ByteArray#
+ #)
+ */
+ RET_NNP(1,s,p);
+ FE_
+}
+
+FN_(addr2IntegerZh_fast)
+{
+ MP_INT result;
+ char *str;
+ FB_
+
+ MAYBE_GC(NO_PTRS,addr2IntegerZh_fast);
+
+ /* args: R1 :: Addr# */
+ str = R1.a;
+
+ /* Perform the operation */
+ if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
+ abort();
+
+ RET_NNP(result._mp_alloc, result._mp_size,
+ result._mp_d - sizeofW(StgArrWords));
+ FE_
+}
+
+/*
+ * 'long long' primops for converting to/from Integers.
+ */
+
+#ifdef SUPPORT_LONG_LONGS
+
+FN_(int64ToIntegerZh_fast)
+{
+ /* arguments: L1 = Int64# */
+
+ StgInt64 val; /* to avoid aliasing */
+ W_ hi;
+ I_ s,a, neg, words_needed;
+ StgArrWords* p; /* address of array result */
+ FB_
+
+ /* ToDo: extend StgUnion?? */
+ val = (LI_)L1;
+ neg = 0;
+ if ((LW_)(val) >= 0x100000000ULL) {
+ words_needed = 2;
+ } else {
+ /* minimum is one word */
+ words_needed = 1;
+ }
+ HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerZh_fast,)
+ TICK_ALLOC_PRIM(sizeofW(StgArrWords)+words_needed,wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
+
+ p = stgCast(StgArrWords*,Hp)-1;
+ SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
+
+ if ( val < 0LL ) {
+ neg = 1;
+ val = -val;
+ }
+ hi = (W_)((LW_)val / 0x100000000ULL);
+ if ((LW_)(val) >= 0x100000000ULL) {
+ s = 2;
+ a = 2;
+ Hp[0] = (W_)val;
+ Hp[1] = hi;
+ } else if ( val != 0 ) {
+ s = 1;
+ a = 1;
+ Hp[0] = (W_)val;
+ } else /* val==0 */ {
+ s = 0;
+ a = 1;
+ }
+ s = ( neg ? -s : s );
+
+ /* returns (# alloc :: Int#,
+ size :: Int#,
+ data :: ByteArray#
+ #)
+ */
+ RET_NNP(a,s,p);
+ FE_
+}
+
+FN_(word64ToIntegerZh_fast)
+{
+ /* arguments: L1 = Word64# */
+
+ StgNat64 val; /* to avoid aliasing */
+ StgWord hi;
+ I_ s,a,words_needed;
+ StgArrWords* p; /* address of array result */
+ FB_
+
+ val = (LW_)L1;
+ if ( val >= 0x100000000ULL ) {
+ words_needed = 2;
+ } else {
+ words_needed = 1;
+ }
+ HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerZh_fast,)
+ TICK_ALLOC_PRIM(sizeofW(StgArrWords)+words_needed,wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
+
+ p = stgCast(StgArrWords*,Hp)-1;
+ SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
+
+ hi = (W_)((LW_)val / 0x100000000ULL);
+ if ( val >= 0x100000000ULL ) {
+ s = 2;
+ a = 2;
+ Hp[0] = ((W_)val);
+ Hp[1] = (hi);
+ } else if ( val != 0 ) {
+ s = 1;
+ a = 1;
+ Hp[0] = ((W_)val);
+ } else /* val==0 */ {
+ s = 0;
+ a = 1;
+ }
+
+ /* returns (# alloc :: Int#,
+ size :: Int#,
+ data :: ByteArray#
+ #)
+ */
+ RET_NNP(a,s,p);
+ FE_
+}
+
+
+#endif /* HAVE_LONG_LONG */
+
+/* ToDo: this is shockingly inefficient */
+
+#define GMP_TAKE2_RET1(name,mp_fun) \
+FN_(name) \
+{ \
+ MP_INT arg1, arg2, result; \
+ I_ a1, s1, a2, s2; \
+ StgArrWords* d1; \
+ StgArrWords* d2; \
+ FB_ \
+ \
+ /* call doYouWantToGC() */ \
+ MAYBE_GC(R3_PTR | R6_PTR, name); \
+ \
+ a1 = R1.i; \
+ s1 = R2.i; \
+ d1 = stgCast(StgArrWords*,R3.p); \
+ a2 = R4.i; \
+ s2 = R5.i; \
+ d2 = stgCast(StgArrWords*,R6.p); \
+ \
+ arg1._mp_alloc = (a1); \
+ arg1._mp_size = (s1); \
+ arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
+ arg2._mp_alloc = (a2); \
+ arg2._mp_size = (s2); \
+ arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
+ \
+ STGCALL1(mpz_init,&result); \
+ \
+ /* Perform the operation */ \
+ STGCALL3(mp_fun,&result,&arg1,&arg2); \
+ \
+ RET_NNP(result._mp_alloc, \
+ result._mp_size, \
+ result._mp_d-sizeofW(StgArrWords)); \
+ FE_ \
+}
+
+#define GMP_TAKE2_RET2(name,mp_fun) \
+FN_(name) \
+{ \
+ MP_INT arg1, arg2, result1, result2; \
+ I_ a1, s1, a2, s2; \
+ StgArrWords* d1; \
+ StgArrWords* d2; \
+ FB_ \
+ \
+ /* call doYouWantToGC() */ \
+ MAYBE_GC(R3_PTR | R6_PTR, name); \
+ \
+ a1 = R1.i; \
+ s1 = R2.i; \
+ d1 = stgCast(StgArrWords*,R3.p); \
+ a2 = R4.i; \
+ s2 = R5.i; \
+ d2 = stgCast(StgArrWords*,R6.p); \
+ \
+ arg1._mp_alloc = (a1); \
+ arg1._mp_size = (s1); \
+ arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
+ arg2._mp_alloc = (a2); \
+ arg2._mp_size = (s2); \
+ arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
+ \
+ STGCALL1(mpz_init,&result1); \
+ STGCALL1(mpz_init,&result2); \
+ \
+ /* Perform the operation */ \
+ STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2); \
+ \
+ RET_NNPNNP(result1._mp_alloc, \
+ result1._mp_size, \
+ result1._mp_d-sizeofW(StgArrWords), \
+ result2._mp_alloc, \
+ result2._mp_size, \
+ result2._mp_d-sizeofW(StgArrWords)); \
+ FE_ \
+}
+
+GMP_TAKE2_RET1(plusIntegerZh_fast, mpz_add);
+GMP_TAKE2_RET1(minusIntegerZh_fast, mpz_sub);
+GMP_TAKE2_RET1(timesIntegerZh_fast, mpz_mul);
+GMP_TAKE2_RET1(gcdIntegerZh_fast, mpz_gcd);
+
+GMP_TAKE2_RET2(quotRemIntegerZh_fast, mpz_tdiv_qr);
+GMP_TAKE2_RET2(divModIntegerZh_fast, mpz_fdiv_qr);
+
+#ifndef FLOATS_AS_DOUBLES
+FN_(decodeFloatZh_fast)
+{
+ MP_INT mantissa;
+ I_ exponent;
+ StgArrWords* p;
+ StgFloat arg;
+ FB_
+
+ /* arguments: F1 = Float# */
+ arg = F1;
+
+ HP_CHK_GEN(sizeof(StgArrWords)+1, NO_PTRS, decodeFloatZh_fast,);
+ TICK_ALLOC_PRIM(sizeofW(StgArrWords)+1,wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
+
+ /* Be prepared to tell Lennart-coded __decodeFloat */
+ /* where mantissa._mp_d can be put (it does not care about the rest) */
+ p = stgCast(StgArrWords*,Hp)-1;
+ SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
+ mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
+
+ /* Perform the operation */
+ STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
+
+ /* returns: (R1 = Int# (expn), R2 = Int#, R3 = Int#, R4 = ByteArray#) */
+ RET_NNNP(exponent,mantissa._mp_alloc,mantissa._mp_size,p);
+ FE_
+}
+#endif /* !FLOATS_AS_DOUBLES */
+
+#define DOUBLE_MANTISSA_SIZE (sizeof(StgDouble)/sizeof(W_))
+#define ARR_SIZE (sizeof(StgArrWords) + DOUBLE_MANTISSA_SIZE)
+
+FN_(decodeDoubleZh_fast)
+{ MP_INT mantissa;
+ I_ exponent;
+ StgDouble arg;
+ StgArrWords* p;
+ FB_
+
+ /* arguments: D1 = Double# */
+ arg = D1;
+
+ HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoubleZh_fast,);
+ TICK_ALLOC_PRIM(ARR_SIZE,wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
+
+ /* Be prepared to tell Lennart-coded __decodeDouble */
+ /* where mantissa.d can be put (it does not care about the rest) */
+ p = stgCast(StgArrWords*,Hp-ARR_SIZE+1);
+ SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
+ mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
+
+ /* Perform the operation */
+ STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
+
+ /* returns: (R1 = Int# (expn), R2 = Int#, R3 = Int#, R4 = ByteArray#) */
+ RET_NNNP(exponent,mantissa._mp_alloc,mantissa._mp_size,p);
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ * Concurrency primitives
+ * -------------------------------------------------------------------------- */
+
+FN_(forkZh_fast)
+{
+ FB_
+ /* args: R1 = closure to spark */
+
+ if (closure_SHOULD_SPARK(stgCast(StgClosure*,R1.p))) {
+
+ MAYBE_GC(R1_PTR, forkZh_fast);
+
+ /* create it right now, return ThreadID in R1 */
+ R1.t = RET_STGCALL2(StgTSO *, createIOThread,
+ RtsFlags.GcFlags.initialStkSize, R1.cl);
+
+ /* switch at the earliest opportunity */
+ context_switch = 1;
+ }
+
+ JMP_(*Sp);
+
+ FE_
+}
+
+FN_(killThreadZh_fast)
+{
+ FB_
+ /* args: R1.p = TSO to kill */
+
+ /* The thread is dead, but the TSO sticks around for a while. That's why
+ * we don't have to explicitly remove it from any queues it might be on.
+ */
+ STGCALL1(deleteThread, (StgTSO *)R1.p);
+
+ /* We might have killed ourselves. In which case, better return to the
+ * scheduler...
+ */
+ if ((StgTSO *)R1.p == CurrentTSO) {
+ JMP_(stg_stop_thread_entry); /* leave semi-gracefully */
+ }
+
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+FN_(newMVarZh_fast)
+{
+ StgMVar *mvar;
+
+ FB_
+ /* args: none */
+
+ HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarZh_fast,);
+ TICK_ALLOC_PRIM(sizeofW(StgMVar),wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
+
+ mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+ mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+ mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+
+ R1.p = (P_)mvar;
+
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+FN_(takeMVarZh_fast)
+{
+ StgMVar *mvar;
+
+ FB_
+ /* args: R1 = MVar closure */
+
+ mvar = (StgMVar *)R1.p;
+
+ /* If the MVar is empty, put ourselves on its blocking queue,
+ * and wait until we're woken up.
+ */
+ if (GET_INFO(mvar) != &FULL_MVAR_info) {
+ if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+ mvar->head = CurrentTSO;
+ } else {
+ mvar->tail->link = CurrentTSO;
+ }
+ CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ mvar->tail = CurrentTSO;
+
+ BLOCK(R1_PTR, takeMVarZh_fast);
+ }
+
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+ R1.cl = mvar->value;
+ mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+FN_(putMVarZh_fast)
+{
+ StgMVar *mvar;
+ StgTSO *tso;
+
+ FB_
+ /* args: R1 = MVar, R2 = value */
+
+ mvar = (StgMVar *)R1.p;
+ if (GET_INFO(mvar) == &FULL_MVAR_info) {
+ fflush(stdout);
+ fprintf(stderr, "putMVar#: MVar already full.\n");
+ stg_exit(EXIT_FAILURE);
+ }
+
+ SET_INFO(mvar,&FULL_MVAR_info);
+ mvar->value = R2.cl;
+
+ /* wake up the first thread on the queue,
+ * it will continue with the takeMVar operation and mark the MVar
+ * empty again.
+ */
+ tso = mvar->head;
+ if (tso != (StgTSO *)&END_TSO_QUEUE_closure) {
+ PUSH_ON_RUN_QUEUE(tso);
+ mvar->head = tso->link;
+ tso->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+ mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+ }
+ }
+
+ /* ToDo: yield here for better communication performance? */
+ JMP_(ENTRY_CODE(*Sp));
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Stable pointer primitives
+ ------------------------------------------------------------------------- */
+
+FN_(makeStablePtrZh_fast)
+{
+ StgInt stable_ptr;
+ FB_
+
+ if (stable_ptr_free == NULL) {
+ enlargeStablePtrTable();
+ }
+
+ stable_ptr = stable_ptr_free - stable_ptr_table;
+ (P_)stable_ptr_free = *stable_ptr_free;
+ stable_ptr_table[stable_ptr] = R1.p;
+
+ R1.i = stable_ptr;
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+#endif /* COMPILER */
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* -----------------------------------------------------------------------------
+ * $Id: Printer.c,v 1.2 1998/12/02 13:28:33 simonm Exp $
+ *
+ * Copyright (c) 1994-1998.
+ *
+ * Heap printer
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef DEBUG
+
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+#include "Bytecodes.h" /* for InstrPtr */
+#include "Disassembler.h"
+
+#include "Printer.h"
+
+/* --------------------------------------------------------------------------
+ * local function decls
+ * ------------------------------------------------------------------------*/
+
+static void printStdObject( StgClosure *obj, char* tag );
+static void reset_table ( int size );
+static void prepare_table ( void );
+static void insert ( unsigned value, const char *name );
+#if 0 /* unused but might be useful sometime */
+static rtsBool lookup_name ( char *name, unsigned *result );
+static void enZcode ( char *in, char *out );
+#endif
+static char unZcode ( char ch );
+rtsBool lookupGHCName ( StgPtr addr, const char **result );
+static void printZcoded ( const char *raw );
+
+/* --------------------------------------------------------------------------
+ * Printer
+ * ------------------------------------------------------------------------*/
+
+extern void printPtr( StgPtr p )
+{
+ const char *raw;
+ if (lookupGHCName( p, &raw )) {
+ printZcoded(raw);
+#ifdef INTERPRETER
+ } else if ((raw = lookupHugsName(p)) != 0) {
+ fprintf(stderr, "%s", raw);
+#endif
+ } else {
+ fprintf(stderr, "%p", p);
+ }
+}
+
+void printObj( StgClosure *obj )
+{
+ fprintf(stderr,"Object "); printPtr((StgPtr)obj); fprintf(stderr," = ");
+ printClosure(obj);
+}
+
+static void printStdObject( StgClosure *obj, char* tag )
+{
+ StgWord i, j;
+ const StgInfoTable* info = get_itbl(obj);
+ fprintf(stderr,"%s(",tag);
+ printPtr((StgPtr)info);
+ for (i = 0; i < info->layout.payload.ptrs; ++i) {
+ fprintf(stderr,", ");
+ printPtr(payloadPtr(obj,i));
+ }
+ for (j = 0; j < info->layout.payload.nptrs; ++j) {
+ fprintf(stderr,", %xd#",payloadWord(obj,i+j));
+ }
+ fprintf(stderr,")\n");
+}
+
+void printClosure( StgClosure *obj )
+{
+ switch ( get_itbl(obj)->type ) {
+ case INVALID_OBJECT:
+ barf("Invalid object");
+#ifdef INTERPRETER
+ case BCO:
+ fprintf(stderr,"BCO\n");
+ disassemble(stgCast(StgBCO*,obj),"\t");
+ break;
+#endif
+ case AP_UPD:
+ {
+ StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
+ StgWord i;
+ fprintf(stderr,"AP_UPD("); printPtr((StgPtr)ap->fun);
+ for (i = 0; i < ap->n_args; ++i) {
+ fprintf(stderr,", ");
+ printPtr(payloadPtr(ap,i));
+ }
+ fprintf(stderr,")\n");
+ break;
+ }
+ case PAP:
+ {
+ StgPAP* pap = stgCast(StgPAP*,obj);
+ StgWord i;
+ fprintf(stderr,"AP_NUPD("); printPtr((StgPtr)pap->fun);
+ for (i = 0; i < pap->n_args; ++i) {
+ fprintf(stderr,", ");
+ printPtr(payloadPtr(pap,i));
+ }
+ fprintf(stderr,")\n");
+ break;
+ }
+ case IND:
+ fprintf(stderr,"IND(");
+ printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+ fprintf(stderr,")\n");
+ break;
+ case CAF_UNENTERED:
+ {
+ StgCAF* caf = stgCast(StgCAF*,obj);
+ fprintf(stderr,"CAF_UNENTERED(");
+ printPtr((StgPtr)caf->body);
+ fprintf(stderr,", ");
+ printPtr((StgPtr)caf->value); /* should be null */
+ fprintf(stderr,", ");
+ printPtr((StgPtr)caf->link); /* should be null */
+ fprintf(stderr,")\n");
+ break;
+ }
+ case CAF_ENTERED:
+ {
+ StgCAF* caf = stgCast(StgCAF*,obj);
+ fprintf(stderr,"CAF_ENTERED(");
+ printPtr((StgPtr)caf->body);
+ fprintf(stderr,", ");
+ printPtr((StgPtr)caf->value);
+ fprintf(stderr,", ");
+ printPtr((StgPtr)caf->link);
+ fprintf(stderr,")\n");
+ break;
+ }
+ case CAF_BLACKHOLE:
+ fprintf(stderr,"CAF_BH(");
+ printPtr((StgPtr)stgCast(StgBlackHole*,obj)->blocking_queue);
+ fprintf(stderr,")\n");
+ break;
+ case BLACKHOLE:
+ fprintf(stderr,"BH(");
+ printPtr((StgPtr)stgCast(StgBlackHole*,obj)->blocking_queue);
+ fprintf(stderr,")\n");
+ break;
+ case CONSTR:
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ {
+ /* We can't use printStdObject because we want to print the
+ * tag as well.
+ */
+ StgWord i, j;
+ const StgInfoTable* info = get_itbl(obj);
+ fprintf(stderr,"PACK(");
+ printPtr((StgPtr)info);
+ fprintf(stderr,"(tag=%d)",info->srt_len);
+ for (i = 0; i < info->layout.payload.ptrs; ++i) {
+ fprintf(stderr,", ");
+ printPtr(payloadPtr(obj,i));
+ }
+ for (j = 0; j < info->layout.payload.nptrs; ++j) {
+ fprintf(stderr,", %x#",payloadWord(obj,i+j));
+ }
+ fprintf(stderr,")\n");
+ break;
+ }
+ case FUN:
+ case FUN_STATIC:
+ printStdObject(obj,"FUN");
+ break;
+ case THUNK:
+ case THUNK_STATIC:
+ /* ToDo: will this work for THUNK_STATIC too? */
+ printStdObject(obj,"THUNK");
+ break;
+#if 0
+ case ARR_WORDS:
+ {
+ StgWord i;
+ fprintf(stderr,"ARR_WORDS(\"");
+ /* ToDo: we can't safely assume that this is a string! */
+ for (i = 0; arrWordsGetChar(obj,i); ++i) {
+ putchar(arrWordsGetChar(obj,i));
+ }
+ fprintf(stderr,"\")\n");
+ break;
+ }
+#endif
+ case UPDATE_FRAME:
+ {
+ StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
+ fprintf(stderr,"UpdateFrame(");
+ printPtr((StgPtr)GET_INFO(u));
+ fprintf(stderr,",");
+ printPtr((StgPtr)u->updatee);
+ fprintf(stderr,",");
+ printPtr((StgPtr)u->link);
+ fprintf(stderr,")\n");
+ break;
+ }
+ case CATCH_FRAME:
+ {
+ StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
+ fprintf(stderr,"CatchFrame(");
+ printPtr((StgPtr)GET_INFO(u));
+ fprintf(stderr,",");
+ printPtr((StgPtr)u->handler);
+ fprintf(stderr,",");
+ printPtr((StgPtr)u->link);
+ fprintf(stderr,")\n");
+ break;
+ }
+ case SEQ_FRAME:
+ {
+ StgSeqFrame* u = stgCast(StgSeqFrame*,obj);
+ fprintf(stderr,"SeqFrame(");
+ printPtr((StgPtr)GET_INFO(u));
+ fprintf(stderr,",");
+ printPtr((StgPtr)u->link);
+ fprintf(stderr,")\n");
+ break;
+ }
+ case STOP_FRAME:
+ {
+ StgStopFrame* u = stgCast(StgStopFrame*,obj);
+ fprintf(stderr,"StopFrame(");
+ printPtr((StgPtr)GET_INFO(u));
+ fprintf(stderr,")\n");
+ break;
+ }
+ default:
+ barf("printClosure %d",get_itbl(obj)->type);
+ return;
+ }
+}
+
+StgPtr printStackObj( StgPtr sp )
+{
+ /*fprintf(stderr,"Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
+
+ if (IS_ARG_TAG(*sp)) {
+
+#ifdef DEBUG_EXTRA
+ StackTag tag = (StackTag)*sp;
+ switch ( tag ) {
+ case ILLEGAL_TAG:
+ barf("printStackObj: ILLEGAL_TAG");
+ break;
+ case REALWORLD_TAG:
+ fprintf(stderr,"RealWorld#\n");
+ break;
+ case INT_TAG:
+ fprintf(stderr,"Int# %d\n", *(StgInt*)(sp+1));
+ break;
+ case INT64_TAG:
+ fprintf(stderr,"Int64# %lld\n", *(StgInt64*)(sp+1));
+ break;
+ case WORD_TAG:
+ fprintf(stderr,"Word# %d\n", *(StgWord*)(sp+1));
+ break;
+ case ADDR_TAG:
+ fprintf(stderr,"Addr# "); printPtr(*(StgAddr*)(sp+1)); fprintf(stderr,"\n");
+ break;
+ case CHAR_TAG:
+ fprintf(stderr,"Char# %d\n", *(StgChar*)(sp+1));
+ break;
+ case FLOAT_TAG:
+ fprintf(stderr,"Float# %f\n", PK_FLT(sp+1));
+ break;
+ case DOUBLE_TAG:
+ fprintf(stderr,"Double# %f\n", PK_DBL(sp+1));
+ break;
+ default:
+ barf("printStackObj: unrecognised ARGTAG %d",tag);
+ }
+ sp += 1 + ARG_SIZE(tag);
+
+#else /* !DEBUG_EXTRA */
+ {
+ StgWord tag = *sp++;
+ nat i;
+ fprintf(stderr,"Tag: %d words\n", tag);
+ for (i = 0; i < tag; i++) {
+ fprintf(stderr,"Word# %d\n", *sp++);
+ }
+ }
+#endif
+
+ } else {
+ printPtr((StgPtr)*sp);
+ fprintf(stderr,"\n");
+ sp += 1;
+ }
+ return sp;
+
+}
+
+void printStackChunk( StgPtr sp, StgPtr spBottom )
+{
+ StgNat32 bitmap;
+ const StgInfoTable *info;
+
+ ASSERT(sp <= spBottom);
+ while (sp < spBottom) {
+ if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO(*sp)) {
+ info = get_itbl((StgClosure *)sp);
+ switch (info->type) {
+
+ case UPDATE_FRAME:
+ printObj( stgCast(StgClosure*,sp) );
+ sp += sizeofW(StgUpdateFrame);
+ continue;
+
+ case SEQ_FRAME:
+ printObj( stgCast(StgClosure*,sp) );
+ sp += sizeofW(StgSeqFrame);
+ continue;
+
+ case CATCH_FRAME:
+ printObj( stgCast(StgClosure*,sp) );
+ sp += sizeofW(StgCatchFrame);
+ continue;
+
+ case STOP_FRAME:
+ /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
+ printObj( stgCast(StgClosure*,sp) );
+ continue;
+
+ case RET_DYN:
+ fprintf(stderr, "RET_DYN (%p)\n", sp);
+ bitmap = *++sp;
+ ++sp;
+ fprintf(stderr, "Bitmap: 0x%x\n", bitmap);
+ goto small_bitmap;
+
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ fprintf(stderr, "RET_SMALL (%p)\n", sp);
+ bitmap = info->layout.bitmap;
+ sp++;
+ small_bitmap:
+ while (bitmap != 0) {
+ fprintf(stderr,"Stack[%d] (%p) = ", spBottom-sp, sp);
+ if ((bitmap & 1) == 0) {
+ printPtr((P_)*sp);
+ fprintf(stderr,"\n");
+ } else {
+ fprintf(stderr,"Word# %d\n", *sp++);
+ }
+ sp++;
+ bitmap = bitmap >> 1;
+ }
+ continue;
+
+ case RET_BIG:
+ case RET_VEC_BIG:
+ barf("todo");
+
+ default:
+ break;
+ }
+ }
+ fprintf(stderr,"Stack[%d] (%p) = ", spBottom-sp, sp);
+ sp = printStackObj(sp);
+ }
+}
+
+void printStack( StgPtr sp, StgPtr spBottom, StgUpdateFrame* su )
+{
+ /* check everything down to the first update frame */
+ printStackChunk( sp, stgCast(StgPtr,su) );
+ while ( stgCast(StgPtr,su) < spBottom) {
+ sp = stgCast(StgPtr,su);
+ switch (get_itbl(su)->type) {
+ case UPDATE_FRAME:
+ printObj( stgCast(StgClosure*,su) );
+ sp += sizeofW(StgUpdateFrame);
+ su = su->link;
+ break;
+ case SEQ_FRAME:
+ printObj( stgCast(StgClosure*,su) );
+ sp += sizeofW(StgSeqFrame);
+ su = stgCast(StgSeqFrame*,su)->link;
+ break;
+ case CATCH_FRAME:
+ printObj( stgCast(StgClosure*,su) );
+ sp += sizeofW(StgCatchFrame);
+ su = stgCast(StgCatchFrame*,su)->link;
+ break;
+ case STOP_FRAME:
+ /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
+ printObj( stgCast(StgClosure*,su) );
+ return;
+ default:
+ barf("printStack: weird record found on update frame list.");
+ }
+ printStackChunk( sp, stgCast(StgPtr,su) );
+ }
+ ASSERT(stgCast(StgPtr,su) == spBottom);
+}
+
+void printTSO( StgTSO *tso )
+{
+ printStack( tso->sp, tso->stack+tso->stack_size,tso->su);
+ /* printStackChunk( tso->sp, tso->stack+tso->stack_size); */
+}
+
+
+/* --------------------------------------------------------------------------
+ * Address printing code
+ *
+ * Uses symbol table in (unstripped executable)
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Simple lookup table
+ *
+ * Current implementation is pretty dumb!
+ * ------------------------------------------------------------------------*/
+
+struct entry {
+ nat value;
+ const char *name;
+};
+
+static nat max_table_size;
+static nat table_size;
+static struct entry* table;
+
+static void reset_table( int size )
+{
+ max_table_size = size;
+ table_size = 0;
+ table = (struct entry *) malloc(size * sizeof(struct entry));
+}
+
+static void prepare_table( void )
+{
+ /* Could sort it... */
+}
+
+static void insert( unsigned value, const char *name )
+{
+ if ( table_size >= max_table_size ) {
+ barf( "Symbol table overflow\n" );
+ }
+ table[table_size].value = value;
+ table[table_size].name = name;
+ table_size = table_size + 1;
+}
+
+
+#if 0
+static rtsBool lookup_name( char *name, unsigned *result )
+{
+ int i;
+ for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
+ }
+ if (i < table_size) {
+ *result = table[i].value;
+ return rtsTrue;
+ } else {
+ return rtsFalse;
+ }
+}
+#endif
+
+/* Code from somewhere inside GHC (circa 1994)
+ * * Z-escapes:
+ * "std"++xs -> "Zstd"++xs
+ * char_to_c 'Z' = "ZZ"
+ * char_to_c '&' = "Za"
+ * char_to_c '|' = "Zb"
+ * char_to_c ':' = "Zc"
+ * char_to_c '/' = "Zd"
+ * char_to_c '=' = "Ze"
+ * char_to_c '>' = "Zg"
+ * char_to_c '#' = "Zh"
+ * char_to_c '<' = "Zl"
+ * char_to_c '-' = "Zm"
+ * char_to_c '!' = "Zn"
+ * char_to_c '.' = "Zo"
+ * char_to_c '+' = "Zp"
+ * char_to_c '\'' = "Zq"
+ * char_to_c '*' = "Zt"
+ * char_to_c '_' = "Zu"
+ * char_to_c c = "Z" ++ show (ord c)
+ */
+static char unZcode( char ch )
+{
+ switch (ch) {
+ case 'a' : return ('&');
+ case 'b' : return ('|');
+ case 'c' : return (':');
+ case 'd' : return ('/');
+ case 'e' : return ('=');
+ case 'g' : return ('>');
+ case 'h' : return ('#');
+ case 'l' : return ('<');
+ case 'm' : return ('-');
+ case 'n' : return ('!');
+ case 'o' : return ('.');
+ case 'p' : return ('+');
+ case 'q' : return ('\'');
+ case 't' : return ('*');
+ case 'u' : return ('_');
+ case 'Z' :
+ case '\0' : return ('Z');
+ default : return (ch);
+ }
+}
+
+#if 0
+/* Precondition: out big enough to handle output (about twice length of in) */
+static void enZcode( char *in, char *out )
+{
+ int i, j;
+
+ j = 0;
+ out[ j++ ] = '_';
+ for( i = 0; in[i] != '\0'; ++i ) {
+ switch (in[i]) {
+ case 'Z' :
+ out[j++] = 'Z';
+ out[j++] = 'Z';
+ break;
+ case '&' :
+ out[j++] = 'Z';
+ out[j++] = 'a';
+ break;
+ case '|' :
+ out[j++] = 'Z';
+ out[j++] = 'b';
+ break;
+ case ':' :
+ out[j++] = 'Z';
+ out[j++] = 'c';
+ break;
+ case '/' :
+ out[j++] = 'Z';
+ out[j++] = 'd';
+ break;
+ case '=' :
+ out[j++] = 'Z';
+ out[j++] = 'e';
+ break;
+ case '>' :
+ out[j++] = 'Z';
+ out[j++] = 'g';
+ break;
+ case '#' :
+ out[j++] = 'Z';
+ out[j++] = 'h';
+ break;
+ case '<' :
+ out[j++] = 'Z';
+ out[j++] = 'l';
+ break;
+ case '-' :
+ out[j++] = 'Z';
+ out[j++] = 'm';
+ break;
+ case '!' :
+ out[j++] = 'Z';
+ out[j++] = 'n';
+ break;
+ case '.' :
+ out[j++] = 'Z';
+ out[j++] = 'o';
+ break;
+ case '+' :
+ out[j++] = 'Z';
+ out[j++] = 'p';
+ break;
+ case '\'' :
+ out[j++] = 'Z';
+ out[j++] = 'q';
+ break;
+ case '*' :
+ out[j++] = 'Z';
+ out[j++] = 't';
+ break;
+ case '_' :
+ out[j++] = 'Z';
+ out[j++] = 'u';
+ break;
+ default :
+ out[j++] = in[i];
+ break;
+ }
+ }
+ out[j] = '\0';
+}
+#endif
+
+rtsBool lookupGHCName( StgPtr addr, const char **result )
+{
+ nat i;
+ for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
+ }
+ if (i < table_size) {
+ *result = table[i].name;
+ return rtsTrue;
+ } else {
+ return rtsFalse;
+ }
+}
+
+static void printZcoded( const char *raw )
+{
+ nat j = 0;
+
+ while ( raw[j] != '\0' ) {
+ if (raw[j] == 'Z') {
+ fputc(unZcode(raw[j+1]),stderr);
+ j = j + 2;
+ } else {
+ fputc(raw[j],stderr);
+ j = j + 1;
+ }
+ }
+}
+
+/* --------------------------------------------------------------------------
+ * Symbol table loading
+ * ------------------------------------------------------------------------*/
+
+#ifdef HAVE_BFD_H
+
+#include <bfd.h>
+
+/* Fairly ad-hoc piece of code that seems to filter out a lot of
+ * rubbish like the obj-splitting symbols
+ */
+
+static rtsBool isReal( flagword flags, const char *name )
+{
+#if 0
+ /* ToDo: make this work on BFD */
+ int tp = type & N_TYPE;
+ if (tp == N_TEXT || tp == N_DATA) {
+ return (name[0] == '_' && name[1] != '_');
+ } else {
+ return rtsFalse;
+ }
+#else
+ if (*name == '\0' ||
+ (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
+ (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
+ return rtsFalse;
+ }
+ return rtsTrue;
+#endif
+}
+
+extern void DEBUG_LoadSymbols( char *name )
+{
+ bfd* abfd;
+ char **matching;
+
+ bfd_init();
+ abfd = bfd_openr(name, "default");
+ if (abfd == NULL) {
+ barf("can't open executable %s to get symbol table", name);
+ }
+ if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
+ barf("mismatch");
+ }
+
+ {
+ long storage_needed;
+ asymbol **symbol_table;
+ long number_of_symbols;
+ long num_real_syms = 0;
+ long i;
+
+ storage_needed = bfd_get_symtab_upper_bound (abfd);
+
+ if (storage_needed < 0) {
+ barf("can't read symbol table");
+ }
+#if 0
+ if (storage_needed == 0) {
+ belch("no storage needed");
+ }
+#endif
+ symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
+
+ number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
+
+ if (number_of_symbols < 0) {
+ barf("can't canonicalise symbol table");
+ }
+
+ for( i = 0; i != number_of_symbols; ++i ) {
+ symbol_info info;
+ bfd_get_symbol_info(abfd,symbol_table[i],&info);
+ /*fprintf(stderr,"\t%c\t0x%x \t%s\n",info.type,(nat)info.value,info.name); */
+ if (isReal(info.type, info.name)) {
+ num_real_syms += 1;
+ }
+ }
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"Loaded %ld symbols. Of which %ld are real symbols\n",
+ number_of_symbols, num_real_syms)
+ );
+
+ reset_table( num_real_syms );
+
+ for( i = 0; i != number_of_symbols; ++i ) {
+ symbol_info info;
+ bfd_get_symbol_info(abfd,symbol_table[i],&info);
+ if (isReal(info.type, info.name)) {
+ insert( info.value, info.name );
+ }
+ }
+
+ free(symbol_table);
+ }
+ prepare_table();
+}
+
+#else /* HAVE_BFD_H */
+
+extern void DEBUG_LoadSymbols( char *name )
+{
+ /* nothing, yet */
+}
+
+#endif /* HAVE_BFD_H */
+
+#endif /* DEBUG */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Printer.h,v 1.2 1998/12/02 13:28:34 simonm Exp $
+ *
+ * Prototypes for functions in Printer.c
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern void printPtr ( StgPtr p );
+extern void printObj ( StgClosure *obj );
+extern void printClosure ( StgClosure *obj );
+extern StgStackPtr printStackObj ( StgStackPtr sp );
+extern void printStackChunk ( StgStackPtr sp, StgStackPtr spLim );
+extern void printStack ( StgStackPtr sp, StgStackPtr spLim,
+ StgUpdateFrame* su );
+extern void printTSO ( StgTSO *tso );
+
+
+extern void DEBUG_LoadSymbols( char *name );
+
+extern rtsBool lookupGHCName( StgPtr addr, const char **result );
+
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: ProfRts.h,v 1.2 1998/12/02 13:28:35 simonm Exp $
+ *
+ * (c) The GHC Team, 1998
+ *
+ * Support for profiling
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifdef PROFILING
+
+void report_ccs_profiling ( void );
+void heap_profile_finish (void);
+
+void initProfiling ( void );
+void endProfiling ( void );
+
+void heapCensus ( bdescr *bd );
+
+void PrintNewStackDecls ( void );
+
+void print_ccs (FILE *, CostCentreStack *);
+
+void report_ccs_profiling( void );
+
+# define TICK_FREQUENCY 50 /* ticks per second */
+# define TICK_MILLISECS (1000/TICK_FREQUENCY) /* ms per tick */
+
+# define DEFAULT_INTERVAL TICK_FREQUENCY
+
+extern rtsBool time_profiling;
+
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Profiling.c,v 1.2 1998/12/02 13:28:35 simonm Exp $
+ *
+ * (c) The GHC Team, 1998
+ *
+ * Support for profiling
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifdef PROFILING
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+#include "ProfRts.h"
+#include "StgRun.h"
+#include "StgStartup.h"
+#include "Storage.h"
+#include "Proftimer.h"
+#include "Itimer.h"
+
+/*
+ * Global variables used to assign unique IDs to cc's, ccs's, and
+ * closure_cats
+ */
+
+unsigned int CC_ID;
+unsigned int CCS_ID;
+unsigned int HP_ID;
+
+/* Table sizes from old profiling system. Not sure if we'll need
+ * these.
+ */
+nat time_intervals = 0;
+nat earlier_ticks = 0;
+nat max_cc_no = 0;
+nat max_mod_no = 0;
+nat max_grp_no = 0;
+nat max_descr_no = 0;
+nat max_type_no = 0;
+
+/* Are we time-profiling?
+ */
+rtsBool time_profiling = rtsFalse;
+
+/* figures for the profiling report.
+ */
+static lnat total_alloc, total_ticks;
+
+/* Globals for opening the profiling log file
+ */
+static char *prof_filename; /* prof report file name = <program>.prof */
+static FILE *prof_file;
+
+/* The Current Cost Centre Stack (for attributing costs)
+ */
+CostCentreStack *CCCS;
+
+/* Linked lists to keep track of cc's and ccs's that haven't
+ * been declared in the log file yet
+ */
+CostCentre *CC_LIST;
+CostCentreStack *CCS_LIST;
+CCSDecList *New_CCS_LIST;
+
+/*
+ * Built-in cost centres and cost-centre stacks:
+ *
+ * MAIN is the root of the cost-centre stack tree. If there are
+ * no _scc_s in the program, all costs will be attributed
+ * to MAIN.
+ *
+ * SYSTEM is the RTS in general (scheduler, etc.). All costs for
+ * RTS operations apart from garbage collection are attributed
+ * to SYSTEM.
+ *
+ * GC is the storage manager / garbage collector.
+ *
+ * OVERHEAD gets all costs generated by the profiling system
+ * itself. These are costs that would not be incurred
+ * during non-profiled execution of the program.
+ *
+ * SUBSUMED is the one-and-only CCS placed on top-level functions.
+ * It indicates that all costs are to be attributed to the
+ * enclosing cost centre stack. SUBSUMED never accumulates
+ * any costs.
+ *
+ * DONT_CARE is a placeholder cost-centre we assign to static
+ * constructors. It should *never* accumulate any costs.
+ */
+
+CC_DECLARE(CC_MAIN, "MAIN", "MAIN", "MAIN", CC_IS_BORING,);
+CC_DECLARE(CC_SYSTEM, "SYSTEM", "MAIN", "MAIN", CC_IS_BORING,);
+CC_DECLARE(CC_GC, "GC", "GC", "GC", CC_IS_BORING,);
+CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", "PROFILING", CC_IS_CAF,);
+CC_DECLARE(CC_SUBSUMED, "SUBSUMED", "MAIN", "MAIN", CC_IS_SUBSUMED,);
+CC_DECLARE(CC_DONTZuCARE,"DONT_CARE", "MAIN", "MAIN", CC_IS_BORING,);
+
+CCS_DECLARE(CCS_MAIN, CC_MAIN, CC_IS_BORING, );
+CCS_DECLARE(CCS_SYSTEM, CC_SYSTEM, CC_IS_BORING, );
+CCS_DECLARE(CCS_GC, CC_GC, CC_IS_BORING, );
+CCS_DECLARE(CCS_OVERHEAD, CC_OVERHEAD, CC_IS_CAF, );
+CCS_DECLARE(CCS_SUBSUMED, CC_SUBSUMED, CC_IS_SUBSUMED, );
+CCS_DECLARE(CCS_DONTZuCARE, CC_DONTZuCARE, CC_IS_BORING, );
+
+/*
+ * Static Functions
+ */
+
+static CostCentreStack * ActualPush_ ( CostCentreStack *ccs, CostCentre *cc,
+ CostCentreStack *new_ccs );
+
+static void registerCostCentres ( void );
+static rtsBool ccs_to_ignore ( CostCentreStack *ccs );
+static void count_ticks ( CostCentreStack *ccs );
+static void reportCCS ( CostCentreStack *ccs, nat indent );
+static void DecCCS ( CostCentreStack *ccs );
+
+/* -----------------------------------------------------------------------------
+ Initialise the profiling environment
+ -------------------------------------------------------------------------- */
+
+void
+initProfiling (void)
+{
+ CostCentreStack *ccs, *next;
+
+ /* for the benefit of allocate()... */
+ CCCS = CCS_SYSTEM;
+
+ if (!RtsFlags.CcFlags.doCostCentres)
+ return;
+
+ time_profiling = rtsTrue;
+
+ /* Initialise the log file name */
+ prof_filename = stgMallocBytes(strlen(prog_argv[0]) + 6, "initProfiling");
+ sprintf(prof_filename, "%s.prof", prog_argv[0]);
+
+ /* Initialize counters for IDs */
+ CC_ID = 0;
+ CCS_ID = 0;
+ HP_ID = 0;
+
+ /* Initialize Declaration lists to NULL */
+ CC_LIST = NULL;
+ CCS_LIST = NULL;
+
+ /* Register all the cost centres / stacks in the program
+ * CC_MAIN gets link = 0, all others have non-zero link.
+ */
+ REGISTER_CC(CC_MAIN);
+ REGISTER_CC(CC_SYSTEM);
+ REGISTER_CC(CC_GC);
+ REGISTER_CC(CC_OVERHEAD);
+ REGISTER_CC(CC_SUBSUMED);
+ REGISTER_CC(CC_DONTZuCARE);
+ REGISTER_CCS(CCS_MAIN);
+ REGISTER_CCS(CCS_SYSTEM);
+ REGISTER_CCS(CCS_GC);
+ REGISTER_CCS(CCS_OVERHEAD);
+ REGISTER_CCS(CCS_SUBSUMED);
+ REGISTER_CCS(CCS_DONTZuCARE);
+
+ CCCS = CCS_OVERHEAD;
+ registerCostCentres();
+
+ /* find all the "special" cost centre stacks, and make them children
+ * of CCS_MAIN.
+ */
+ ASSERT(CCS_MAIN->prevStack == 0);
+ for (ccs = CCS_LIST; ccs != CCS_MAIN; ) {
+ next = ccs->prevStack;
+ ccs->prevStack = 0;
+ ActualPush_(CCS_MAIN,ccs->cc,ccs);
+ ccs = next;
+ }
+
+ /* profiling is the only client of the VTALRM system at the moment,
+ * so just install the profiling tick handler. */
+ install_vtalrm_handler(handleProfTick);
+ startProfTimer();
+};
+
+void
+endProfiling ( void )
+{
+ stopProfTimer();
+}
+
+void
+heapCensus ( bdescr *bd )
+{
+ /* nothing yet */
+}
+
+/* -----------------------------------------------------------------------------
+ Register Cost Centres
+
+ At the moment, this process just supplies a unique integer to each
+ statically declared cost centre and cost centre stack in the
+ program.
+
+ The code generator inserts a small function "reg<moddule>" in each
+ module which registers any cost centres from that module and calls
+ the registration functions in each of the modules it imports. So,
+ if we call "regMain", each reachable module in the program will be
+ registered.
+
+ The reg* functions are compiled in the same way as STG code,
+ i.e. without normal C call/return conventions. Hence we must use
+ StgRun to call this stuff.
+ -------------------------------------------------------------------------- */
+
+/* The registration functions use an explicit stack...
+ */
+#define REGISTER_STACK_SIZE (BLOCK_SIZE * 4)
+F_ *register_stack;
+
+static void
+registerCostCentres ( void )
+{
+ /* this storage will be reclaimed by the garbage collector,
+ * as a large block.
+ */
+ register_stack = (F_ *)allocate(REGISTER_STACK_SIZE / sizeof(W_));
+
+ StgRun((StgFunPtr)stg_register);
+}
+
+
+/* -----------------------------------------------------------------------------
+ Cost-centre stack manipulation
+ -------------------------------------------------------------------------- */
+
+CostCentreStack *
+PushCostCentre ( CostCentreStack *ccs, CostCentre *cc )
+{
+ CostCentreStack *temp_ccs;
+
+ if (ccs == EMPTY_STACK)
+ return ActualPush(ccs,cc);
+ else {
+ if (ccs->cc == cc)
+ return ccs;
+ else {
+ /* check if we've already memoized this stack */
+ temp_ccs = IsInIndexTable(ccs->indexTable,cc);
+
+ if (temp_ccs != EMPTY_STACK)
+ return temp_ccs;
+ else {
+ /* remove the CC to avoid loops */
+ ccs = RemoveCC(ccs,cc);
+ /* have a different stack now, need to check the memo table again */
+ temp_ccs = IsInIndexTable(ccs->indexTable,cc);
+ if (temp_ccs != EMPTY_STACK)
+ return temp_ccs;
+ else
+ return ActualPush(ccs,cc);
+ }
+ }
+ }
+}
+
+
+CostCentreStack *
+ActualPush ( CostCentreStack *ccs, CostCentre *cc )
+{
+ CostCentreStack *new_ccs;
+
+ /* allocate space for a new CostCentreStack */
+ new_ccs = (CostCentreStack *) stgMallocBytes(sizeof(CostCentreStack), "Error allocating space for CostCentreStack");
+
+ return ActualPush_(ccs, cc, new_ccs);
+}
+
+static CostCentreStack *
+ActualPush_ ( CostCentreStack *ccs, CostCentre *cc, CostCentreStack *new_ccs )
+{
+ /* assign values to each member of the structure */
+ ASSIGN_CCS_ID(new_ccs->ccsID);
+
+ new_ccs->cc = cc;
+ new_ccs->prevStack = ccs;
+
+ new_ccs->indexTable = EMPTY_TABLE;
+
+ /* Initialise the various _scc_ counters to zero
+ */
+ new_ccs->scc_count = 0;
+ new_ccs->sub_scc_count = 0;
+ new_ccs->sub_cafcc_count = 0;
+ new_ccs->sub_dictcc_count = 0;
+
+ /* Initialize all other stats here. There should be a quick way
+ * that's easily used elsewhere too
+ */
+ new_ccs->time_ticks = 0;
+ new_ccs->mem_alloc = 0;
+
+ /* stacks are subsumed only if their top CostCentres are subsumed */
+ new_ccs->is_subsumed = cc->is_subsumed;
+
+ /* update the memoization table for the parent stack */
+ if (ccs != EMPTY_STACK)
+ ccs->indexTable = AddToIndexTable(ccs->indexTable, new_ccs, cc);
+
+ /* make sure this CC is decalred at the next heap/time sample */
+ DecCCS(new_ccs);
+
+ /* return a pointer to the new stack */
+ return new_ccs;
+}
+
+
+CostCentreStack *
+RemoveCC(CostCentreStack *ccs, CostCentre *cc)
+{
+ CostCentreStack *del_ccs;
+
+ if (ccs == EMPTY_STACK) {
+ return EMPTY_STACK;
+ } else {
+ if (ccs->cc == cc) {
+ return ccs->prevStack;
+ } else {
+ {
+ del_ccs = RemoveCC(ccs->prevStack, cc);
+
+ if (del_ccs == EMPTY_STACK)
+ return ccs;
+ else
+ return PushCostCentre(del_ccs,ccs->cc);
+ }
+ }
+ }
+}
+
+
+CostCentreStack *
+IsInIndexTable(IndexTable *it, CostCentre *cc)
+{
+ while (it!=EMPTY_TABLE)
+ {
+ if (it->cc==cc)
+ return it->ccs;
+ else
+ it = it->next;
+ }
+
+ /* otherwise we never found it so return EMPTY_TABLE */
+ return EMPTY_TABLE;
+}
+
+
+IndexTable *
+AddToIndexTable(IndexTable *it, CostCentreStack *new_ccs, CostCentre *cc)
+{
+ IndexTable *new_it;
+
+ new_it = stgMallocBytes(sizeof(IndexTable), "AddToIndexTable");
+
+ new_it->cc = cc;
+ new_it->ccs = new_ccs;
+ new_it->next = it;
+ return new_it;
+}
+
+
+void
+print_ccs (FILE *fp, CostCentreStack *ccs)
+{
+ if (ccs == CCCS) {
+ fprintf(fp, "Cost-Centre Stack: ");
+ }
+
+ if (ccs != CCS_MAIN)
+ {
+ print_ccs(fp, ccs->prevStack);
+ fprintf(fp, "->[%s,%s,%s]",
+ ccs->cc->label, ccs->cc->module, ccs->cc->group);
+ } else {
+ fprintf(fp, "[%s,%s,%s]",
+ ccs->cc->label, ccs->cc->module, ccs->cc->group);
+ }
+
+ if (ccs == CCCS) {
+ fprintf(fp, "\n");
+ }
+}
+
+
+static void
+DecCCS(CostCentreStack *ccs)
+{
+ CCSDecList *temp_list;
+
+ temp_list =
+ (CCSDecList *) stgMallocBytes(sizeof(CCSDecList),
+ "Error allocating space for CCSDecList");
+ temp_list->ccs = ccs;
+ temp_list->nextList = New_CCS_LIST;
+
+ New_CCS_LIST = temp_list;
+}
+
+/* -----------------------------------------------------------------------------
+ Generating a time & allocation profiling report.
+ -------------------------------------------------------------------------- */
+
+static FILE *prof_file;
+
+void
+report_ccs_profiling( void )
+{
+ nat count;
+ char temp[128]; /* sigh: magic constant */
+ rtsBool do_groups = rtsFalse;
+
+ if (!RtsFlags.CcFlags.doCostCentres)
+ return;
+
+ stopProfTimer();
+
+ total_ticks = 0;
+ total_alloc = 0;
+ count_ticks(CCS_MAIN);
+
+ /* open profiling output file */
+ if ((prof_file = fopen(prof_filename, "w")) == NULL) {
+ fprintf(stderr, "Can't open profiling report file %s\n", prof_filename);
+ return;
+ }
+ fprintf(prof_file, "\t%s Time and Allocation Profiling Report (%s)\n",
+ time_str(), "Final");
+
+ fprintf(prof_file, "\n\t ");
+ fprintf(prof_file, " %s", prog_argv[0]);
+ fprintf(prof_file, " +RTS");
+ for (count = 0; rts_argv[count]; count++)
+ fprintf(prof_file, " %s", rts_argv[count]);
+ fprintf(prof_file, " -RTS");
+ for (count = 1; prog_argv[count]; count++)
+ fprintf(prof_file, " %s", prog_argv[count]);
+ fprintf(prof_file, "\n\n");
+
+ fprintf(prof_file, "\ttotal time = %11.2f secs (%lu ticks @ %d ms)\n",
+ total_ticks / (StgFloat) TICK_FREQUENCY,
+ total_ticks, TICK_MILLISECS);
+
+ fprintf(prof_file, "\ttotal alloc = %11s bytes",
+ ullong_format_string((ullong) total_alloc * sizeof(W_),
+ temp, rtsTrue/*commas*/));
+ /* ToDo: 64-bit error! */
+
+#if defined(PROFILING_DETAIL_COUNTS)
+ fprintf(prof_file, " (%lu closures)", total_allocs);
+#endif
+ fprintf(prof_file, " (excludes profiling overheads)\n\n");
+
+ fprintf(prof_file, "%-24s %-10s", "COST CENTRE", "MODULE");
+
+#ifdef NOT_YET
+ do_groups = have_interesting_groups(Registered_CC);
+ if (do_groups) fprintf(prof_file, " %-11.11s", "GROUP");
+#endif
+
+ fprintf(prof_file, "%8s %5s %5s %8s %5s %5s", "scc", "%time", "%alloc", "inner", "cafs", "dicts");
+
+ if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
+ fprintf(prof_file, " %5s %9s", "ticks", "bytes");
+#if defined(PROFILING_DETAIL_COUNTS)
+ fprintf(prof_file, " %8s %8s %8s %8s %8s %8s %8s",
+ "closures", "thunks", "funcs", "PAPs", "subfuns", "subcafs", "cafssub");
+#endif
+ }
+ fprintf(prof_file, "\n\n");
+
+ reportCCS(CCS_MAIN, 0);
+
+ fclose(prof_file);
+}
+
+static void
+reportCCS(CostCentreStack *ccs, nat indent)
+{
+ CostCentre *cc;
+ IndexTable *i;
+
+ cc = ccs->cc;
+ ASSERT(cc == CC_MAIN || cc->link != 0);
+
+ /* Only print cost centres with non 0 data ! */
+
+ if ( (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL
+ /* force printing of *all* cost centres if -P -P */ )
+
+ || ( ccs->indexTable != 0 )
+ || ( ! ccs_to_ignore(ccs)
+ && (ccs->scc_count || ccs->sub_scc_count ||
+ ccs->time_ticks || ccs->mem_alloc
+ || (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
+ && (ccs->sub_cafcc_count || ccs->sub_dictcc_count
+#if defined(PROFILING_DETAIL_COUNTS)
+ || cc->thunk_count || cc->function_count || cc->pap_count
+#endif
+ ))))) {
+ fprintf(prof_file, "%-*s%-*s %-10s",
+ indent, "", 24-indent, cc->label, cc->module);
+
+#ifdef NOT_YET
+ if (do_groups) fprintf(prof_file, " %-11.11s",cc->group);
+#endif
+
+ fprintf(prof_file, "%8ld %4.1f %4.1f %8ld %5ld %5ld",
+ ccs->scc_count,
+ total_ticks == 0 ? 0.0 : (ccs->time_ticks / (StgFloat) total_ticks * 100),
+ total_alloc == 0 ? 0.0 : (ccs->mem_alloc / (StgFloat) total_alloc * 100),
+ ccs->sub_scc_count, ccs->sub_cafcc_count, ccs->sub_dictcc_count);
+
+ if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
+ fprintf(prof_file, " %5ld %9ld", ccs->time_ticks, ccs->mem_alloc*sizeof(W_));
+#if defined(PROFILING_DETAIL_COUNTS)
+ fprintf(prof_file, " %8ld %8ld %8ld %8ld %8ld %8ld %8ld",
+ ccs->mem_allocs, ccs->thunk_count,
+ ccs->function_count, ccs->pap_count,
+ ccs->subsumed_fun_count, ccs->subsumed_caf_count,
+ ccs->caffun_subsumed);
+#endif
+ }
+ fprintf(prof_file, "\n");
+ }
+
+ for (i = ccs->indexTable; i != 0; i = i->next) {
+ reportCCS(i->ccs, indent+1);
+ }
+}
+
+/* Traverse the cost centre stack tree and accumulate
+ * ticks/allocations.
+ */
+static void
+count_ticks(CostCentreStack *ccs)
+{
+ IndexTable *i;
+
+ if (!ccs_to_ignore(ccs)) {
+ total_alloc += ccs->mem_alloc;
+ total_ticks += ccs->time_ticks;
+ }
+ for (i = ccs->indexTable; i != NULL; i = i->next)
+ count_ticks(i->ccs);
+}
+
+/* return rtsTrue if it is one of the ones that
+ * should not be reported normally (because it confuses
+ * the users)
+ */
+static rtsBool
+ccs_to_ignore (CostCentreStack *ccs)
+{
+ if ( ccs == CCS_OVERHEAD
+ || ccs == CCS_DONTZuCARE
+ || ccs == CCS_GC
+ || ccs == CCS_SYSTEM) {
+ return rtsTrue;
+ } else {
+ return rtsFalse;
+ }
+}
+
+#endif /* PROFILING */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Proftimer.c,v 1.2 1998/12/02 13:28:36 simonm Exp $
+ *
+ * (c) The GHC Team, 1998
+ *
+ * Profiling interval timer
+ *
+ * ---------------------------------------------------------------------------*/
+
+/* Only have cost centres etc if PROFILING defined */
+
+#if defined (PROFILING)
+
+#include "Rts.h"
+#include "ProfRts.h"
+#include "Itimer.h"
+#include "Proftimer.h"
+
+lnat total_ticks = 0;
+
+nat current_interval = 1; /* Current interval number --
+ stored in AGE */
+
+nat interval_ticks = DEFAULT_INTERVAL; /* No of ticks in an interval */
+
+nat previous_ticks = 0; /* ticks in previous intervals */
+nat current_ticks = 0; /* ticks in current interval */
+
+void
+initProfTimer(nat ms)
+{
+ if (initialize_virtual_timer(ms)) {
+ fflush(stdout);
+ fprintf(stderr, "Can't initialize virtual timer.\n");
+ stg_exit(EXIT_FAILURE);
+ }
+};
+
+void
+stopProfTimer(void)
+{ /* Stops time profile */
+ if (time_profiling) {
+ initProfTimer(0);
+ }
+};
+
+void
+startProfTimer(void)
+{ /* Starts time profile */
+ if (time_profiling) {
+ initProfTimer(TICK_MILLISECS);
+ }
+};
+
+void
+handleProfTick(void)
+{
+ CCS_TICK(CCCS);
+ total_ticks++;
+};
+
+#endif /* PROFILING */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Proftimer.h,v 1.2 1998/12/02 13:28:37 simonm Exp $
+ *
+ * (c) The GHC Team, 1998
+ *
+ * Profiling interval timer
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern void initProfTimer(nat ms);
+extern void stopProfTimer(void);
+extern void startProfTimer(void);
+extern void handleProfTick(void);
+
--- /dev/null
+/* -*- mode: hugs-c; -*- */
+/* --------------------------------------------------------------------------
+ * Template for generating queues of various types
+ *
+ * #define Queue##ChunkSize, Queue and Type before #including this file
+ * to define the following:
+ *
+ * typedef { ...; nat len } Queue;
+ * static void insertQueue( Queue* q, Type i );
+ * static void initQueue ( Queue* q );
+ * static void setQueue ( Queue* q, nat i, Type x );
+ *
+ * Copyright (c) 1994-1998.
+ *
+ * $RCSfile: QueueTemplate.h,v $
+ * $Revision: 1.2 $
+ * $Date: 1998/12/02 13:28:37 $
+ *
+ * ------------------------------------------------------------------------*/
+
+/* These macros are rather delicate - read a good ANSI C book carefully
+ * before meddling.
+ */
+#define mystr(x) #x
+#define mycat(x,y) x##y
+#define mycat2(x,y) mycat(x,y)
+#define mycat3(x,y,z) mycat2(x,mycat2(y,z))
+
+typedef struct mycat3(_,Queue,Chunk) {
+ struct mycat3(_,Queue,Chunk)* next;
+ Type xs[mycat2(Queue,ChunkSize)];
+} mycat2(Queue,Chunk);
+
+static mycat2(Queue,Chunk)* mycat3(alloc,Queue,Chunk)( void )
+{
+ mycat2(Queue,Chunk)* new = malloc(sizeof(mycat2(Queue,Chunk)));
+ if (new == NULL) {
+ barf("Can't allomycate " mystr(Queue) "Chunk");
+ }
+ new->next = NULL;
+ return new;
+}
+
+typedef struct {
+ mycat2(Queue,Chunk)* head;
+ mycat2(Queue,Chunk)* tail;
+ nat len; /* position of next free instruction */
+} Queue;
+
+static void mycat2(insert,Queue)( Queue* q, Type i )
+{
+ if (q->len == 0) {
+ mycat2(Queue,Chunk)* new = mycat3(alloc,Queue,Chunk)();
+ new->next = NULL;
+ q->head = new;
+ q->tail = new;
+ } else if (q->len % mycat2(Queue,ChunkSize) == 0) {
+ mycat2(Queue,Chunk)* new = mycat3(alloc,Queue,Chunk)();
+ new->next = NULL;
+ q->tail->next = new;
+ q->tail = new;
+ }
+ q->tail->xs[q->len % mycat2(Queue,ChunkSize)] = i;
+ q->len++;
+}
+
+static inline void mycat2(init,Queue)( Queue* q )
+{
+ q->head = q->tail = NULL;
+ q->len = 0;
+}
+
+static void mycat2(set,Queue)( Queue* q, nat i, Type x )
+{
+ mycat2(Queue,Chunk)* chunk = q->head;
+ ASSERT(i <= q->len);
+ /* ToDo: optimise case where i is in the last chunk in the list */
+ for(; i >= mycat2(Queue,ChunkSize); i -= mycat2(Queue,ChunkSize)) {
+ ASSERT(chunk);
+ chunk = chunk->next;
+ }
+ ASSERT(chunk);
+ chunk->xs[i] = x;
+}
+
+/* evaluate a statement s once for every element in a queue q.
+ * i and x are usually free in s
+ * queueTy and eltTy are the types of the container and element respectively
+ */
+#define mapQueue(queueTy,eltTy,q,s) \
+do { \
+ mycat2(queueTy,Chunk)* chunk = (q).head; \
+ nat i = 0; \
+ eltTy x; \
+ while( i < (q).len ) { \
+ ASSERT(chunk); \
+ x = chunk->xs[i % mycat2(queueTy,ChunkSize)]; \
+ s; \
+ ++i; \
+ if (i % mycat2(queueTy,ChunkSize) == 0) { \
+ chunk = chunk->next; \
+ } \
+ } \
+} while (0)
+
+/* --------------------------------------------------------------------------
+ * End of Queue template
+ * ------------------------------------------------------------------------*/
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: RtsAPI.c,v 1.2 1998/12/02 13:28:38 simonm Exp $
+ *
+ * API for invoking Haskell functions via the RTS
+ *
+ * --------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "Storage.h"
+#include "RtsAPI.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+
+/* ----------------------------------------------------------------------------
+ Building Haskell objects from C datatypes.
+ ------------------------------------------------------------------------- */
+HaskellObj
+rts_mkChar (char c)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ p->header.info = &CZh_con_info;
+ p->payload[0] = (StgClosure *)((StgInt)c);
+ return p;
+}
+
+HaskellObj
+rts_mkInt (int i)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ p->header.info = &IZh_con_info;
+ p->payload[0] = (StgClosure *)(StgInt)i;
+ return p;
+}
+
+HaskellObj
+rts_mkInt8 (int i)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ /* This is a 'cheat', using the static info table for Ints,
+ instead of the one for Int8, but the types have identical
+ representation.
+ */
+ p->header.info = &IZh_con_info;
+ /* Make sure we mask out the bits above the lowest 8 */
+ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
+ return p;
+}
+
+HaskellObj
+rts_mkInt16 (int i)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ /* This is a 'cheat', using the static info table for Ints,
+ instead of the one for Int8, but the types have identical
+ representation.
+ */
+ p->header.info = &IZh_con_info;
+ /* Make sure we mask out the relevant bits */
+ p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
+ return p;
+}
+
+HaskellObj
+rts_mkInt32 (int i)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ /* see mk_Int8 comment */
+ p->header.info = &IZh_con_info;
+ p->payload[0] = (StgClosure *)(StgInt)i;
+ return p;
+}
+
+HaskellObj
+rts_mkInt64 (long long int i)
+{
+ long long *tmp;
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
+ /* see mk_Int8 comment */
+ p->header.info = &I64Zh_con_info;
+ tmp = (long long*)&(p->payload[0]);
+ *tmp = (StgInt64)i;
+ return p;
+}
+
+HaskellObj
+rts_mkWord (unsigned int i)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ p->header.info = &WZh_con_info;
+ p->payload[0] = (StgClosure *)(StgWord)i;
+ return p;
+}
+
+HaskellObj
+rts_mkWord8 (unsigned int w)
+{
+ /* see rts_mkInt* comments */
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ p->header.info = &WZh_con_info;
+ p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
+ return p;
+}
+
+HaskellObj
+rts_mkWord16 (unsigned int w)
+{
+ /* see rts_mkInt* comments */
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ p->header.info = &WZh_con_info;
+ p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
+ return p;
+}
+
+HaskellObj
+rts_mkWord32 (unsigned int w)
+{
+ /* see rts_mkInt* comments */
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ p->header.info = &WZh_con_info;
+ p->payload[0] = (StgClosure *)(StgWord)w;
+ return p;
+}
+
+HaskellObj
+rts_mkWord64 (unsigned long long w)
+{
+ unsigned long long *tmp;
+ extern StgInfoTable W64Zh_con_info;
+
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
+ /* see mk_Int8 comment */
+ p->header.info = &W64Zh_con_info;
+ tmp = (unsigned long long*)&(p->payload[0]);
+ *tmp = (StgNat64)w;
+ return p;
+}
+
+HaskellObj
+rts_mkFloat (float f)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
+ p->header.info = &FZh_con_info;
+ ASSIGN_FLT((P_)p->payload, (StgFloat)f);
+ return p;
+}
+
+HaskellObj
+rts_mkDouble (double d)
+{
+ StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,sizeofW(StgDouble)));
+ p->header.info = &DZh_con_info;
+ ASSIGN_DBL((P_)p->payload, (StgDouble)d);
+ return p;
+}
+
+HaskellObj
+rts_mkStablePtr (StgStablePtr s)
+{
+ StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
+ p->header.info = &StablePtr_con_info;
+ p->payload[0] = (StgClosure *)s;
+ return p;
+}
+
+HaskellObj
+rts_mkAddr (void *a)
+{
+ StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
+ p->header.info = &AZh_con_info;
+ p->payload[0] = (StgClosure *)a;
+ return p;
+}
+
+#ifdef COMPILER /* GHC has em, Hugs doesn't */
+HaskellObj
+rts_mkBool (int b)
+{
+ if (b) {
+ return (StgClosure *)&True_closure;
+ } else {
+ return (StgClosure *)&False_closure;
+ }
+}
+
+HaskellObj
+rts_mkString (char *s)
+{
+ return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
+}
+
+HaskellObj
+rts_apply (HaskellObj f, HaskellObj arg)
+{
+ StgAP_UPD *ap = (StgAP_UPD *)allocate(AP_sizeW(1));
+ ap->header.info = &AP_UPD_info;
+ ap->n_args = 1;
+ ap->fun = f;
+ ap->payload[0] = (P_)arg;
+ return (StgClosure *)ap;
+}
+#endif /* COMPILER */
+
+/* ----------------------------------------------------------------------------
+ Deconstructing Haskell objects
+ ------------------------------------------------------------------------- */
+
+char
+rts_getChar (HaskellObj p)
+{
+ if (p->header.info == &CZh_con_info || p->header.info == &CZh_static_info) {
+ return (char)(StgWord)(p->payload[0]);
+ } else {
+ barf("getChar: not a Char");
+ }
+}
+
+int
+rts_getInt (HaskellObj p)
+{
+ if (p->header.info == &IZh_con_info || p->header.info == &IZh_static_info) {
+ return (int)(p->payload[0]);
+ } else {
+ barf("getInt: not an Int");
+ }
+}
+
+unsigned int
+rts_getWord (HaskellObj p)
+{
+ if (p->header.info == &WZh_con_info || p->header.info == &WZh_static_info) {
+ return (unsigned int)(p->payload[0]);
+ } else {
+ barf("getWord: not a Word");
+ }
+}
+
+float
+rts_getFloat (HaskellObj p)
+{
+ if (p->header.info == &FZh_con_info || p->header.info == &FZh_static_info) {
+ return (float)(PK_FLT((P_)p->payload));
+ } else {
+ barf("getFloat: not a Float");
+ }
+}
+
+double
+rts_getDouble (HaskellObj p)
+{
+ if (p->header.info == &DZh_con_info || p->header.info == &DZh_static_info) {
+ return (double)(PK_DBL((P_)p->payload));
+ } else {
+ barf("getDouble: not a Double");
+ }
+}
+
+StgStablePtr
+rts_getStablePtr (HaskellObj p)
+{
+ if (p->header.info == &StablePtr_con_info ||
+ p->header.info == &StablePtr_static_info) {
+ return (StgStablePtr)(p->payload[0]);
+ } else {
+ barf("getStablePtr: not a StablePtr");
+ }
+}
+
+void *
+rts_getAddr (HaskellObj p)
+{
+ if (p->header.info == &AZh_con_info || p->header.info == &AZh_static_info) {
+ return (void *)(p->payload[0]);
+ } else {
+ barf("getAddr: not an Addr");
+ }
+}
+
+#ifdef COMPILER /* GHC has em, Hugs doesn't */
+int
+rts_getBool (HaskellObj p)
+{
+ if (p == &True_closure) {
+ return 1;
+ } else if (p == &False_closure) {
+ return 0;
+ } else {
+ barf("getBool: not a Bool");
+ }
+}
+#endif /* COMPILER */
+
+/* ----------------------------------------------------------------------------
+ Evaluating Haskell expressions
+ ------------------------------------------------------------------------- */
+SchedulerStatus
+rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
+{
+ StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
+ return schedule(tso, ret);
+}
+
+SchedulerStatus
+rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
+{
+ StgTSO *tso = createGenThread(stack_size, p);
+ return schedule(tso, ret);
+}
+
+SchedulerStatus
+rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
+{
+ StgTSO *tso = createIOThread(RtsFlags.GcFlags.initialStkSize, p);
+ return schedule(tso, ret);
+}
+
+SchedulerStatus
+rts_evalIO_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
+{
+ StgTSO *tso = createIOThread(stack_size, p);
+ return schedule(tso, ret);
+}
+
+/* Convenience function for decoding the returned status. */
+
+void rts_checkSchedStatus ( char* site, SchedulerStatus rc )
+{
+ if ( rc == Success ) {
+ return;
+ } else {
+ barf("%s: Return code (%d) not ok",(site),(rc));
+ }
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: RtsFlags.c,v 1.2 1998/12/02 13:28:39 simonm Exp $
+ *
+ * Functions for parsing the argument list.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "BlockAlloc.h"
+#include "ProfRts.h"
+
+#if HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+extern struct RTS_FLAGS RtsFlags;
+
+/*
+ * Split argument lists
+ */
+int prog_argc; /* an "int" so as to match normal "argc" */
+char **prog_argv = NULL;
+int rts_argc; /* ditto */
+char *rts_argv[MAX_RTS_ARGS];
+
+/*
+ * constants, used later
+ */
+#define RTS 1
+#define PGM 0
+
+/* -----------------------------------------------------------------------------
+ Static function decls
+ -------------------------------------------------------------------------- */
+
+static FILE * /* return NULL on error */
+open_stats_file (
+ I_ arg,
+ int argc, char *argv[],
+ int rts_argc, char *rts_argv[],
+ const char *FILENAME_FMT);
+
+static I_ decode(const char *s);
+static void bad_option(const char *s);
+
+/* -----------------------------------------------------------------------------
+ * Command-line option parsing routines.
+ * ---------------------------------------------------------------------------*/
+
+void initRtsFlagsDefaults(void)
+{
+ RtsFlags.GcFlags.statsFile = NULL;
+ RtsFlags.GcFlags.giveStats = NO_GC_STATS;
+
+ RtsFlags.GcFlags.maxStkSize = (1024 * 1024) / sizeof(W_);
+ RtsFlags.GcFlags.initialStkSize = 1024 / sizeof(W_);
+
+ RtsFlags.GcFlags.minAllocAreaSize = (256 * 1024) / BLOCK_SIZE;
+ RtsFlags.GcFlags.maxHeapSize = (64 * 1024 * 1024) / BLOCK_SIZE;
+ RtsFlags.GcFlags.pcFreeHeap = 3; /* 3% */
+
+ RtsFlags.GcFlags.force2s = rtsFalse;
+ RtsFlags.GcFlags.forceGC = rtsFalse;
+ RtsFlags.GcFlags.forcingInterval = 5000000; /* 5MB (or words?) */
+ RtsFlags.GcFlags.ringBell = rtsFalse;
+
+ RtsFlags.GcFlags.squeezeUpdFrames = rtsTrue;
+
+#if defined(PROFILING) || defined(PAR)
+ RtsFlags.CcFlags.doCostCentres = 0;
+ RtsFlags.CcFlags.sortBy = SORTCC_TIME;
+#endif /* PROFILING or PAR */
+
+#ifdef PROFILING
+ RtsFlags.ProfFlags.doHeapProfile = rtsFalse;
+
+ RtsFlags.ProfFlags.ccSelector = NULL;
+ RtsFlags.ProfFlags.modSelector = NULL;
+ RtsFlags.ProfFlags.grpSelector = NULL;
+ RtsFlags.ProfFlags.descrSelector = NULL;
+ RtsFlags.ProfFlags.typeSelector = NULL;
+ RtsFlags.ProfFlags.kindSelector = NULL;
+#elif defined(DEBUG)
+ RtsFlags.ProfFlags.doHeapProfile = rtsFalse;
+#endif
+
+/* there really shouldn't be a threads limit for concurrent mandatory threads.
+ For now, unlimitied means less than 64k (there's a storage overhead) -- SOF
+*/
+#if defined(CONCURRENT) && !defined(GRAN)
+ RtsFlags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
+ RtsFlags.ConcFlags.maxThreads = 65536;
+ RtsFlags.ConcFlags.stkChunkSize = 1024;
+ RtsFlags.ConcFlags.maxLocalSparks = 65536;
+#endif /* CONCURRENT only */
+
+#if GRAN
+ RtsFlags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
+ RtsFlags.ConcFlags.maxThreads = 32;
+ RtsFlags.ConcFlags.stkChunkSize = 1024;
+ RtsFlags.ConcFlags.maxLocalSparks = 500;
+#endif /* GRAN */
+
+#ifdef PAR
+ RtsFlags.ParFlags.parallelStats = rtsFalse;
+ RtsFlags.ParFlags.granSimStats = rtsFalse;
+ RtsFlags.ParFlags.granSimStats_Binary = rtsFalse;
+
+ RtsFlags.ParFlags.outputDisabled = rtsFalse;
+
+ RtsFlags.ParFlags.packBufferSize = 1024;
+ RtsFlags.ParFlags.maxLocalSparks = 4096;
+#endif /* PAR */
+
+#ifdef GRAN
+ RtsFlags.GranFlags.granSimStats = rtsFalse;
+ RtsFlags.GranFlags.granSimStats_suppressed = rtsFalse;
+ RtsFlags.GranFlags.granSimStats_Binary = rtsFalse;
+ RtsFlags.GranFlags.granSimStats_Sparks = rtsFalse;
+ RtsFlags.GranFlags.granSimStats_Heap = rtsFalse;
+ RtsFlags.GranFlags.labelling = rtsFalse;
+ RtsFlags.GranFlags.packBufferSize = 1024;
+ RtsFlags.GranFlags.packBufferSize_internal = GRANSIM_DEFAULT_PACK_BUFFER_SIZE;
+
+ RtsFlags.GranFlags.proc = MAX_PROC;
+ RtsFlags.GranFlags.max_fishes = MAX_FISHES;
+ RtsFlags.GranFlags.time_slice = GRAN_TIME_SLICE;
+ RtsFlags.GranFlags.Light = rtsFalse;
+
+ RtsFlags.GranFlags.gran_latency = LATENCY;
+ RtsFlags.GranFlags.gran_additional_latency = ADDITIONAL_LATENCY;
+ RtsFlags.GranFlags.gran_fetchtime = FETCHTIME;
+ RtsFlags.GranFlags.gran_lunblocktime = LOCALUNBLOCKTIME;
+ RtsFlags.GranFlags.gran_gunblocktime = GLOBALUNBLOCKTIME;
+ RtsFlags.GranFlags.gran_mpacktime = MSGPACKTIME;
+ RtsFlags.GranFlags.gran_munpacktime = MSGUNPACKTIME;
+ RtsFlags.GranFlags.gran_mtidytime = MSGTIDYTIME;
+
+ RtsFlags.GranFlags.gran_threadcreatetime = THREADCREATETIME;
+ RtsFlags.GranFlags.gran_threadqueuetime = THREADQUEUETIME;
+ RtsFlags.GranFlags.gran_threaddescheduletime = THREADDESCHEDULETIME;
+ RtsFlags.GranFlags.gran_threadscheduletime = THREADSCHEDULETIME;
+ RtsFlags.GranFlags.gran_threadcontextswitchtime = THREADCONTEXTSWITCHTIME;
+
+ RtsFlags.GranFlags.gran_arith_cost = ARITH_COST;
+ RtsFlags.GranFlags.gran_branch_cost = BRANCH_COST;
+ RtsFlags.GranFlags.gran_load_cost = LOAD_COST;
+ RtsFlags.GranFlags.gran_store_cost = STORE_COST;
+ RtsFlags.GranFlags.gran_float_cost = FLOAT_COST;
+
+ RtsFlags.GranFlags.gran_heapalloc_cost = HEAPALLOC_COST;
+
+ RtsFlags.GranFlags.gran_pri_spark_overhead = PRI_SPARK_OVERHEAD;
+ RtsFlags.GranFlags.gran_pri_sched_overhead = PRI_SCHED_OVERHEAD;
+
+ RtsFlags.GranFlags.DoFairSchedule = rtsFalse;
+ RtsFlags.GranFlags.DoReScheduleOnFetch = rtsFalse;
+ RtsFlags.GranFlags.DoStealThreadsFirst = rtsFalse;
+ RtsFlags.GranFlags.SimplifiedFetch = rtsFalse;
+ RtsFlags.GranFlags.DoAlwaysCreateThreads = rtsFalse;
+ RtsFlags.GranFlags.DoGUMMFetching = rtsFalse;
+ RtsFlags.GranFlags.DoThreadMigration = rtsFalse;
+ RtsFlags.GranFlags.FetchStrategy = 2;
+ RtsFlags.GranFlags.PreferSparksOfLocalNodes = rtsFalse;
+ RtsFlags.GranFlags.DoPrioritySparking = rtsFalse;
+ RtsFlags.GranFlags.DoPriorityScheduling = rtsFalse;
+ RtsFlags.GranFlags.SparkPriority = 0;
+ RtsFlags.GranFlags.SparkPriority2 = 0;
+ RtsFlags.GranFlags.RandomPriorities = rtsFalse;
+ RtsFlags.GranFlags.InversePriorities = rtsFalse;
+ RtsFlags.GranFlags.IgnorePriorities = rtsFalse;
+ RtsFlags.GranFlags.ThunksToPack = 0;
+ RtsFlags.GranFlags.RandomSteal = rtsTrue;
+ RtsFlags.GranFlags.NoForward = rtsFalse;
+ RtsFlags.GranFlags.PrintFetchMisses = rtsFalse;
+
+ RtsFlags.GranFlags.debug = 0x0;
+ RtsFlags.GranFlags.event_trace = rtsFalse;
+ RtsFlags.GranFlags.event_trace_all = rtsFalse;
+#endif
+
+#ifdef TICKY_TICKY
+ RtsFlags.TickyFlags.showTickyStats = rtsFalse;
+ RtsFlags.TickyFlags.tickyFile = NULL;
+
+ AllFlags.doUpdEntryCounts = rtsTrue; /*ToDo:move? */
+#endif
+}
+
+static const char *
+usage_text[] = {
+"",
+"Usage: <prog> <args> [+RTS <rtsopts> | -RTS <args>] ... --RTS <args>",
+"",
+" +RTS Indicates run time system options follow",
+" -RTS Indicates program arguments follow",
+" --RTS Indicates that ALL subsequent arguments will be given to the",
+" program (including any of these RTS flags)",
+"",
+"The following run time system options are available:",
+"",
+" -? -f Prints this message and exits; the program is not executed",
+"",
+" -K<size> Sets the maximum stack size (default 1M) Egs: -K32k -K512k",
+" -k<size> Sets the initial thread stack size (default 1k) Egs: -K4k -K2m",
+"",
+" -A<size> Sets the minimum allocation area size (default 256k) Egs: -A1m -A10k",
+" -M<size> Sets the maximum heap size (default 64M) Egs: -H256k -H1G",
+" -m<n>% Minimum % of heap which must be available (default 3%)",
+" -s<file> Summary GC statistics (default file: <program>.stat)",
+" -S<file> Detailed GC statistics (with -Sstderr going to stderr)",
+"",
+"",
+" -Z Don't squeeze out update frames on stack overflow",
+" -B Sound the bell at the start of each garbage collection",
+#if defined(PROFILING) || defined(PAR)
+"",
+" -p<sort> Produce cost centre time profile (output file <program>.prof)",
+" sort: T = time (default), A = alloc, C = cost centre label",
+" -P<sort> Produce serial time profile (output file <program>.time)",
+" and a -p profile with detailed tick/alloc info",
+# if defined(PROFILING)
+"",
+" -h<break-down> Heap residency profile (output file <program>.hp)",
+" break-down: C = cost centre (default), M = module, G = group",
+" D = closure description, Y = type description",
+" T<ints>,<start> = time closure created",
+" ints: no. of interval bands plotted (default 18)",
+" start: seconds after which intervals start (default 0.0)",
+" A subset of closures may be selected by the attached cost centre using:",
+" -c{mod:lab,mod:lab...}, specific module:label cost centre(s)",
+" -m{mod,mod...} all cost centres from the specified modules(s)",
+" -g{grp,grp...} all cost centres from the specified group(s)",
+" Selections can also be made by description, type, kind and age:",
+" -d{des,des...} closures with specified closure descriptions",
+" -y{typ,typ...} closures with specified type descriptions",
+" -k{knd,knd...} closures of the specified kinds",
+" -a<age> closures which survived <age> complete intervals",
+" The selection logic used is summarised as follows:",
+" ([-c] or [-m] or [-g]) and ([-d] or [-y] or [-k]) and [-a]",
+" where an option is true if not specified",
+# endif
+"",
+" -z<tbl><size> set hash table <size> for <tbl> (C, M, G, D or Y)",
+"",
+" -i<secs> Number of seconds in a profiling interval (default 1.0):",
+" heap profile (-h) and/or serial time profile (-P) frequency",
+#endif /* PROFILING or PAR */
+#if !defined(PROFILING) && defined(DEBUG)
+"",
+" -h<break-down> Debugging Heap residency profile",
+" (output file <program>.hp)",
+" break-down: L = closure label (default)",
+" T = closure type (constructor, thunk etc.)",
+#endif
+"",
+#if defined(TICKY_TICKY)
+" -r<file> Produce reduction profiling statistics (with -rstderr for stderr)",
+"",
+#endif
+" -T<level> Trace garbage collection execution (debugging)",
+"",
+# ifdef PAR
+" -N<n> Use <n> PVMish processors in parallel (default: 2)",
+/* NB: the -N<n> is implemented by the driver!! */
+# endif
+" -C<secs> Context-switch interval in seconds",
+" (0 or no argument means switch as often as possible)",
+" the default is .01 sec; resolution is .01 sec",
+" -e<size> Size of spark pools (default 100)",
+# ifdef PAR
+" -q Enable activity profile (output files in ~/<program>*.gr)",
+" -qb Enable binary activity profile (output file /tmp/<program>.gb)",
+" -Q<size> Set pack-buffer size (default: 1024)",
+# else
+" -q[v] Enable quasi-parallel profile (output file <program>.qp)",
+# endif
+" -t<num> Set maximum number of advisory threads per PE (default 32)",
+" -o<num> Set stack chunk size (default 1024)",
+# ifdef PAR
+" -d Turn on PVM-ish debugging",
+" -O Disable output for performance measurement",
+# endif /* PAR */
+# ifdef GRAN /* ToDo: fill in decent Docu here */
+" -b... All GranSim options start with -b; see GranSim User's Guide for details",
+# endif
+"",
+"Other RTS options may be available for programs compiled a different way.",
+"The GHC User's Guide has full details.",
+"",
+0
+};
+
+static __inline__ rtsBool
+strequal(const char *a, const char * b)
+{
+ return(strcmp(a, b) == 0);
+}
+
+void
+setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
+{
+ rtsBool error = rtsFalse;
+ I_ mode;
+ I_ arg, total_arg;
+ char *last_slash;
+
+ /* Remove directory from argv[0] -- default files in current directory */
+
+ if ((last_slash = (char *) strrchr(argv[0], '/')) != NULL)
+ strcpy(argv[0], last_slash+1);
+
+ /* Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts */
+ /* argv[0] must be PGM argument -- leave in argv */
+
+ total_arg = *argc;
+ arg = 1;
+
+ *argc = 1;
+ *rts_argc = 0;
+
+ for (mode = PGM; arg < total_arg && ! strequal("--RTS", argv[arg]); arg++) {
+ if (strequal("+RTS", argv[arg])) {
+ mode = RTS;
+ }
+ else if (strequal("-RTS", argv[arg])) {
+ mode = PGM;
+ }
+ else if (mode == RTS && *rts_argc < MAX_RTS_ARGS-1) {
+ rts_argv[(*rts_argc)++] = argv[arg];
+ }
+ else if (mode == PGM) {
+ argv[(*argc)++] = argv[arg];
+ }
+ else {
+ barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
+ }
+ }
+ if (arg < total_arg) {
+ /* arg must be --RTS; process remaining program arguments */
+ while (++arg < total_arg) {
+ argv[(*argc)++] = argv[arg];
+ }
+ }
+ argv[*argc] = (char *) 0;
+ rts_argv[*rts_argc] = (char *) 0;
+
+ /* Process RTS (rts_argv) part: mainly to determine statsfile */
+
+ for (arg = 0; arg < *rts_argc; arg++) {
+ if (rts_argv[arg][0] != '-') {
+ fflush(stdout);
+ fprintf(stderr, "setupRtsFlags: Unexpected RTS argument: %s\n",
+ rts_argv[arg]);
+ error = rtsTrue;
+
+ } else {
+ switch(rts_argv[arg][1]) {
+
+ /* process: general args, then PROFILING-only ones,
+ then CONCURRENT-only, PARallel-only, GRAN-only,
+ TICKY-only (same order as defined in RtsFlags.lh);
+ within those groups, mostly in case-insensitive
+ alphabetical order.
+ */
+
+#ifdef TICKY_TICKY
+# define TICKY_BUILD_ONLY(x) x
+#else
+# define TICKY_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: ticky-ticky stats\n"); \
+error = rtsTrue;
+#endif
+
+#if defined(PROFILING)
+# define COST_CENTRE_USING_BUILD_ONLY(x) x
+#else
+# define COST_CENTRE_USING_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -prof or -parallel\n"); \
+error = rtsTrue;
+#endif
+
+#ifdef PROFILING
+# define PROFILING_BUILD_ONLY(x) x
+#else
+# define PROFILING_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -prof\n"); \
+error = rtsTrue;
+#endif
+
+#ifdef PAR
+# define PAR_BUILD_ONLY(x) x
+#else
+# define PAR_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -parallel\n"); \
+error = rtsTrue;
+#endif
+
+#ifdef GRAN
+# define GRAN_BUILD_ONLY(x) x
+#else
+# define GRAN_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -gransim\n"); \
+error = rtsTrue;
+#endif
+
+ /* =========== GENERAL ========================== */
+ case '?':
+ case 'f':
+ error = rtsTrue;
+ break;
+
+ case 'A':
+ RtsFlags.GcFlags.minAllocAreaSize
+ = decode(rts_argv[arg]+2) / BLOCK_SIZE;
+ if (RtsFlags.GcFlags.minAllocAreaSize <= 0) {
+ bad_option(rts_argv[arg]);
+ }
+ break;
+
+ case 'B':
+ RtsFlags.GcFlags.ringBell = rtsTrue;
+ break;
+
+#ifdef DEBUG
+ case 'D':
+ /* hack warning: interpret the flags as a binary number */
+ *(int*)(&RtsFlags.DebugFlags) = decode(rts_argv[arg]+2);
+ break;
+#endif
+
+ case 'F':
+ if (strequal(rts_argv[arg]+2, "2s")) {
+ RtsFlags.GcFlags.force2s = rtsTrue;
+ } else {
+ bad_option( rts_argv[arg] );
+ }
+ break;
+
+ case 'K':
+ RtsFlags.GcFlags.maxStkSize =
+ decode(rts_argv[arg]+2) / sizeof(W_);
+
+ if (RtsFlags.GcFlags.maxStkSize == 0)
+ bad_option( rts_argv[arg] );
+ break;
+
+ case 'k':
+ RtsFlags.GcFlags.initialStkSize =
+ decode(rts_argv[arg]+2) / sizeof(W_);
+
+ if (RtsFlags.GcFlags.initialStkSize == 0)
+ bad_option( rts_argv[arg] );
+ break;
+
+ case 'M':
+ RtsFlags.GcFlags.maxHeapSize =
+ decode(rts_argv[arg]+2) / BLOCK_SIZE;
+ /* user give size in *bytes* but "maxHeapSize" is in *blocks* */
+
+ if (RtsFlags.GcFlags.maxHeapSize <= 0) {
+ bad_option(rts_argv[arg]);
+ }
+ break;
+
+ case 'm':
+ RtsFlags.GcFlags.pcFreeHeap = atof(rts_argv[arg]+2);
+
+ if (RtsFlags.GcFlags.pcFreeHeap < 0 ||
+ RtsFlags.GcFlags.pcFreeHeap > 100)
+ bad_option( rts_argv[arg] );
+ break;
+
+ case 'H':
+ /* ignore for compatibility with older versions */
+ break;
+
+ case 'j': /* force GC option */
+ RtsFlags.GcFlags.forceGC = rtsTrue;
+ if (rts_argv[arg][2]) {
+ RtsFlags.GcFlags.forcingInterval
+ = decode(rts_argv[arg]+2) / sizeof(W_);
+ }
+ break;
+
+ case 'S': /* NB: no difference at present ! */
+ case 's':
+ RtsFlags.GcFlags.giveStats ++; /* will be VERBOSE_GC_STATS */
+#ifdef PAR
+ /* Opening all those files would almost certainly fail... */
+ RtsFlags.ParFlags.parallelStats = rtsTrue;
+ RtsFlags.GcFlags.statsFile = stderr; /* temporary; ToDo: rm */
+#else
+ RtsFlags.GcFlags.statsFile
+ = open_stats_file(arg, *argc, argv,
+ *rts_argc, rts_argv, STAT_FILENAME_FMT);
+
+ if (RtsFlags.GcFlags.statsFile == NULL) error = rtsTrue;
+#endif
+ break;
+
+ case 'Z':
+ RtsFlags.GcFlags.squeezeUpdFrames = rtsFalse;
+ break;
+
+ /* =========== PROFILING ========================== */
+
+ case 'P': /* detailed cost centre profiling (time/alloc) */
+ COST_CENTRE_USING_BUILD_ONLY(
+ RtsFlags.CcFlags.doCostCentres++;
+ )
+ case 'p': /* cost centre profiling (time/alloc) */
+ COST_CENTRE_USING_BUILD_ONLY(
+ RtsFlags.CcFlags.doCostCentres++;
+
+ switch (rts_argv[arg][2]) {
+ case SORTCC_LABEL:
+ case SORTCC_TIME:
+ case SORTCC_ALLOC:
+ RtsFlags.CcFlags.sortBy = rts_argv[arg][2];
+ break;
+ default:
+ RtsFlags.CcFlags.sortBy = SORTCC_TIME;
+ break;
+ }
+ ) break;
+
+ case 'i': /* serial profiling -- initial timer interval */
+ COST_CENTRE_USING_BUILD_ONLY(
+ interval_ticks = (I_) ((atof(rts_argv[arg]+2) * TICK_FREQUENCY));
+ if (interval_ticks <= 0)
+ interval_ticks = 1;
+ ) break;
+
+ case 'h': /* serial heap profile */
+#if !defined(PROFILING) && defined(DEBUG)
+ switch (rts_argv[arg][2]) {
+ case '\0':
+ case 'L':
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_INFOPTR;
+ break;
+ case 'T':
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_CLOSURE_TYPE;
+ break;
+ default:
+ fprintf(stderr, "Invalid heap profile option: %s\n",
+ rts_argv[arg]);
+ error = rtsTrue;
+ }
+#else
+ PROFILING_BUILD_ONLY(
+ switch (rts_argv[arg][2]) {
+ case '\0':
+ case CCchar:
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_CC;
+ break;
+ case MODchar:
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_MOD;
+ break;
+ case GRPchar:
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_GRP;
+ break;
+ case DESCRchar:
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_DESCR;
+ break;
+ case TYPEchar:
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_TYPE;
+ break;
+ case TIMEchar:
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_TIME;
+ if (rts_argv[arg][3]) {
+ char *start_str = strchr(rts_argv[arg]+3, ',');
+ I_ intervals;
+ if (start_str) *start_str = '\0';
+
+ if ((intervals = decode(rts_argv[arg]+3)) != 0) {
+ time_intervals = (hash_t) intervals;
+ /* ToDo: and what if it *is* zero intervals??? */
+ }
+ if (start_str) {
+ earlier_ticks = (I_)((atof(start_str + 1) * TICK_FREQUENCY));
+ }
+ }
+ break;
+ default:
+ fprintf(stderr, "Invalid heap profile option: %s\n",
+ rts_argv[arg]);
+ error = rtsTrue;
+ }
+ )
+#endif
+ break;
+
+ case 'z': /* size of index tables */
+ PROFILING_BUILD_ONLY(
+ switch (rts_argv[arg][2]) {
+ case CCchar:
+ max_cc_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_cc_no == 0) {
+ fprintf(stderr, "Bad number of cost centres %s\n", rts_argv[arg]);
+ error = rtsTrue;
+ }
+ break;
+ case MODchar:
+ max_mod_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_mod_no == 0) {
+ fprintf(stderr, "Bad number of modules %s\n", rts_argv[arg]);
+ error = rtsTrue;
+ }
+ break;
+ case GRPchar:
+ max_grp_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_grp_no == 0) {
+ fprintf(stderr, "Bad number of groups %s\n", rts_argv[arg]);
+ error = rtsTrue;
+ }
+ break;
+ case DESCRchar:
+ max_descr_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_descr_no == 0) {
+ fprintf(stderr, "Bad number of closure descriptions %s\n", rts_argv[arg]);
+ error = rtsTrue;
+ }
+ break;
+ case TYPEchar:
+ max_type_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_type_no == 0) {
+ fprintf(stderr, "Bad number of type descriptions %s\n", rts_argv[arg]);
+ error = rtsTrue;
+ }
+ break;
+ default:
+ fprintf(stderr, "Invalid index table size option: %s\n",
+ rts_argv[arg]);
+ error = rtsTrue;
+ }
+ ) break;
+
+ case 'c': /* cost centre label select */
+ case 'g': /* cost centre group select */
+ case 'd': /* closure descr select */
+ case 'y': /* closure type select */
+ PROFILING_BUILD_ONLY(
+ {char *left = strchr(rts_argv[arg], '{');
+ char *right = strrchr(rts_argv[arg], '}');
+
+ if (! left || ! right ||
+ strrchr(rts_argv[arg], '{') != left ||
+ strchr(rts_argv[arg], '}') != right) {
+ fprintf(stderr, "Invalid heap profiling selection bracketing\n %s\n", rts_argv[arg]);
+ error = rtsTrue;
+ } else {
+ *right = '\0';
+ switch (rts_argv[arg][1]) {
+ case 'c': /* cost centre label select */
+ RtsFlags.ProfFlags.ccSelector = left + 1;
+ break;
+ case 'm': /* cost centre module select */
+ RtsFlags.ProfFlags.modSelector = left + 1;
+ break;
+ case 'g': /* cost centre group select */
+ RtsFlags.ProfFlags.grpSelector = left + 1;
+ break;
+ case 'd': /* closure descr select */
+ RtsFlags.ProfFlags.descrSelector = left + 1;
+ break;
+ case 'y': /* closure type select */
+ RtsFlags.ProfFlags.typeSelector = left + 1;
+ break;
+ case 'k': /* closure kind select */
+ RtsFlags.ProfFlags.kindSelector = left + 1;
+ break;
+ }
+ }}
+ ) break;
+
+ /* =========== CONCURRENT ========================= */
+ case 'C': /* context switch interval */
+ if (rts_argv[arg][2] == '\0')
+ RtsFlags.ConcFlags.ctxtSwitchTime = 0;
+ else {
+ I_ cst; /* tmp */
+
+ /* Convert to milliseconds */
+ cst = (I_) ((atof(rts_argv[arg]+2) * 1000));
+ cst = (cst / CS_MIN_MILLISECS) * CS_MIN_MILLISECS;
+ if (cst < CS_MIN_MILLISECS)
+ cst = CS_MIN_MILLISECS;
+
+ RtsFlags.ConcFlags.ctxtSwitchTime = cst;
+ }
+ break;
+
+ case 't':
+ if (rts_argv[arg][2] != '\0') {
+ RtsFlags.ConcFlags.maxThreads
+ = strtol(rts_argv[arg]+2, (char **) NULL, 10);
+ } else {
+ fprintf(stderr, "setupRtsFlags: missing size for -t\n");
+ error = rtsTrue;
+ }
+ break;
+
+ /* =========== PARALLEL =========================== */
+ case 'e':
+ PAR_BUILD_ONLY(
+ if (rts_argv[arg][2] != '\0') { /* otherwise, stick w/ the default */
+
+ RtsFlags.ParFlags.maxLocalSparks
+ = strtol(rts_argv[arg]+2, (char **) NULL, 10);
+
+ if (RtsFlags.ParFlags.maxLocalSparks <= 0) {
+ fprintf(stderr, "setupRtsFlags: bad value for -e\n");
+ error = rtsTrue;
+ }
+ }
+ ) break;
+
+ case 'O':
+ PAR_BUILD_ONLY(
+ RtsFlags.ParFlags.outputDisabled = rtsTrue;
+ ) break;
+
+ case 'q': /* activity profile option */
+ PAR_BUILD_ONLY(
+ if (rts_argv[arg][2] == 'b')
+ RtsFlags.ParFlags.granSimStats_Binary = rtsTrue;
+ else
+ RtsFlags.ParFlags.granSimStats = rtsTrue;
+ ) break;
+
+#if 0 /* or??? */
+ case 'q': /* quasi-parallel profile option */
+ GRAN_BUILD_ONLY (
+ if (rts_argv[arg][2] == 'v')
+ do_qp_prof = 2;
+ else
+ do_qp_prof++;
+ ) break;
+#endif /* 0??? */
+
+ case 'Q': /* Set pack buffer size */
+ PAR_BUILD_ONLY(
+ if (rts_argv[arg][2] != '\0') {
+ RtsFlags.ParFlags.packBufferSize = decode(rts_argv[arg]+2);
+ } else {
+ fprintf(stderr, "setupRtsFlags: missing size of PackBuffer (for -Q)\n");
+ error = rtsTrue;
+ }
+ ) break;
+
+ /* =========== GRAN =============================== */
+
+ case 'b':
+ GRAN_BUILD_ONLY(
+ process_gran_option(arg, rts_argc, rts_argv, &error);
+ ) break;
+
+ /* =========== TICKY ============================== */
+
+ case 'r': /* Basic profiling stats */
+ TICKY_BUILD_ONLY(
+
+ RtsFlags.TickyFlags.showTickyStats = rtsTrue;
+ RtsFlags.TickyFlags.tickyFile
+ = open_stats_file(arg, *argc, argv,
+ *rts_argc, rts_argv, TICKY_FILENAME_FMT);
+
+ if (RtsFlags.TickyFlags.tickyFile == NULL) error = rtsTrue;
+ ) break;
+
+ /* =========== OH DEAR ============================ */
+ default:
+ fprintf(stderr, "setupRtsFlags: Unknown RTS option: %s\n",rts_argv[arg]);
+ error = rtsTrue;
+ break;
+ }
+ }
+ }
+ if (error) {
+ const char **p;
+
+ fflush(stdout);
+ for (p = usage_text; *p; p++)
+ fprintf(stderr, "%s\n", *p);
+ stg_exit(EXIT_FAILURE);
+ }
+
+}
+
+static FILE * /* return NULL on error */
+open_stats_file (
+ I_ arg,
+ int argc, char *argv[],
+ int rts_argc, char *rts_argv[],
+ const char *FILENAME_FMT)
+{
+ FILE *f = NULL;
+
+ if (strequal(rts_argv[arg]+2, "stderr")) /* use real stderr */
+ f = stderr;
+ else if (rts_argv[arg][2] != '\0') /* stats file specified */
+ f = fopen(rts_argv[arg]+2,"w");
+ else {
+ char stats_filename[STATS_FILENAME_MAXLEN]; /* default <program>.<ext> */
+ sprintf(stats_filename, FILENAME_FMT, argv[0]);
+ f = fopen(stats_filename,"w");
+ }
+ if (f == NULL) {
+ fprintf(stderr, "Can't open stats file %s\n", rts_argv[arg]+2);
+ } else {
+ /* Write argv and rtsv into start of stats file */
+ I_ count;
+ for(count = 0; count < argc; count++)
+ fprintf(f, "%s ", argv[count]);
+ fprintf(f, "+RTS ");
+ for(count = 0; count < rts_argc; count++)
+ fprintf(f, "%s ", rts_argv[count]);
+ fprintf(f, "\n");
+ }
+
+ return(f);
+}
+
+static I_
+decode(const char *s)
+{
+ I_ c;
+ StgDouble m;
+
+ if (!*s)
+ return 0;
+
+ m = atof(s);
+ c = s[strlen(s)-1];
+
+ if (c == 'g' || c == 'G')
+ m *= 1000*1000*1000; /* UNchecked! */
+ else if (c == 'm' || c == 'M')
+ m *= 1000*1000; /* We do not use powers of 2 (1024) */
+ else if (c == 'k' || c == 'K') /* to avoid possible bad effects on */
+ m *= 1000; /* a direct-mapped cache. */
+ else if (c == 'w' || c == 'W')
+ m *= sizeof(W_);
+
+ return (I_)m;
+}
+
+static void
+bad_option(const char *s)
+{
+ fflush(stdout);
+ fprintf(stderr, "initSM: Bad RTS option: %s\n", s);
+ stg_exit(EXIT_FAILURE);
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: RtsFlags.h,v 1.2 1998/12/02 13:28:40 simonm Exp $
+ *
+ * Datatypes that holds the command-line flag settings.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef RTSFLAGS_H
+#define RTSFLAGS_H
+
+/* For defaults, see the @initRtsFlagsDefaults@ routine. */
+
+struct GC_FLAGS {
+ FILE *statsFile;
+ nat giveStats; /* ToDo: replace with enum type? */
+#define NO_GC_STATS 0
+#define VERBOSE_GC_STATS 1
+
+ nat maxStkSize; /* in *words* */
+ nat initialStkSize; /* in *words* */
+
+ nat maxHeapSize; /* in *blocks* */
+ nat minAllocAreaSize; /* in *blocks* */
+ double pcFreeHeap;
+
+ rtsBool force2s; /* force the use of 2-space copying collection;
+ forced to rtsTrue if we do *heap* profiling.
+ */
+ rtsBool forceGC; /* force a major GC every <interval> bytes */
+ int forcingInterval; /* actually, stored as a number of *words* */
+ rtsBool ringBell;
+
+ rtsBool squeezeUpdFrames;
+};
+
+/* Hack: this struct uses bitfields so that we can use a binary arg
+ * with the -D flag
+ */
+struct DEBUG_FLAGS {
+ /* flags to control debugging output in various subsystems */
+ rtsBool scheduler : 1; /* 1 */
+ rtsBool evaluator : 1; /* 2 */
+ rtsBool codegen : 1; /* 4 */
+ rtsBool weak : 1; /* 8 */
+ rtsBool gccafs : 1; /* 16 */
+ rtsBool gc : 1; /* 32 */
+ rtsBool block_alloc : 1; /* 64 */
+
+ /* flags to control consistency checking (often very expensive!) */
+ rtsBool sanity : 1; /* 128 */
+};
+
+#if defined(PROFILING) || defined(PAR)
+ /* with PROFILING, full cost-centre stuff (also PROFILING_FLAGS);
+ with PAR, just the four fixed cost-centres.
+ */
+struct COST_CENTRE_FLAGS {
+ unsigned int doCostCentres;
+# define COST_CENTRES_SUMMARY 1
+# define COST_CENTRES_VERBOSE 2 /* incl. serial time profile */
+# define COST_CENTRES_ALL 3
+
+ char sortBy;
+# define SORTCC_LABEL 'C'
+# define SORTCC_TIME 'T'
+# define SORTCC_ALLOC 'A'
+
+ int ctxtSwitchTicks; /* derived */
+ int profilerTicks; /* derived */
+ int msecsPerTick; /* derived */
+};
+#endif
+
+#ifdef PROFILING
+struct PROFILING_FLAGS {
+ unsigned int doHeapProfile;
+# define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */
+# define HEAP_BY_CC 1
+# define HEAP_BY_MOD 2
+# define HEAP_BY_GRP 3
+# define HEAP_BY_DESCR 4
+# define HEAP_BY_TYPE 5
+# define HEAP_BY_TIME 6
+
+# define CCchar 'C'
+# define MODchar 'M'
+# define GRPchar 'G'
+# define DESCRchar 'D'
+# define TYPEchar 'Y'
+# define TIMEchar 'T'
+
+ char *ccSelector;
+ char *modSelector;
+ char *grpSelector;
+ char *descrSelector;
+ char *typeSelector;
+ char *kindSelector;
+};
+#elif defined(DEBUG)
+# define NO_HEAP_PROFILING 0
+# define HEAP_BY_INFOPTR 1
+# define HEAP_BY_CLOSURE_TYPE 2
+struct PROFILING_FLAGS {
+ unsigned int doHeapProfile; /* heap profile using symbol table */
+};
+#endif /* DEBUG || PROFILING */
+
+struct CONCURRENT_FLAGS {
+ int ctxtSwitchTime; /* in milliseconds */
+ int maxThreads;
+};
+
+#ifdef PAR
+struct PAR_FLAGS {
+ rtsBool parallelStats; /* Gather parallel statistics */
+ rtsBool granSimStats; /* Full .gr profile (rtsTrue) or only END events? */
+ rtsBool granSimStats_Binary;
+
+ rtsBool outputDisabled; /* Disable output for performance purposes */
+
+ unsigned int packBufferSize;
+ unsigned int maxLocalSparks;
+};
+
+#endif /* PAR */
+
+#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;
+ unsigned int packBufferSize;
+ unsigned int packBufferSize_internal;
+
+ int proc; /* number of processors */
+ int 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 */
+ unsigned int gran_latency; /* Latency for single packet */
+ unsigned int gran_additional_latency; /* Latency for additional packets */
+ unsigned int gran_fetchtime;
+ unsigned int gran_lunblocktime; /* Time for local unblock */
+ unsigned int gran_gunblocktime; /* Time for global unblock */
+ unsigned int gran_mpacktime; /* Cost of creating a packet */
+ unsigned int gran_munpacktime; /* Cost of receiving a packet */
+ unsigned int gran_mtidytime; /* Cost of cleaning up after send */
+
+ unsigned int gran_threadcreatetime; /* Thread creation costs */
+ unsigned int gran_threadqueuetime; /* Cost of adding a thread to the running/runnable queue */
+ unsigned int gran_threaddescheduletime; /* Cost of descheduling a thread */
+ unsigned int gran_threadscheduletime; /* Cost of scheduling a thread */
+ unsigned int gran_threadcontextswitchtime; /* Cost of context switch */
+
+ /* Instruction Costs */
+ unsigned int gran_arith_cost; /* arithmetic instructions (+,i,< etc) */
+ unsigned int gran_branch_cost; /* branch instructions */
+ unsigned int gran_load_cost; /* load into register */
+ unsigned int gran_store_cost; /* store into memory */
+ unsigned int gran_float_cost; /* floating point operations */
+
+ unsigned int gran_heapalloc_cost; /* heap allocation costs */
+
+ /* Overhead for granularity control mechanisms */
+ /* overhead per elem of spark queue */
+ unsigned int gran_pri_spark_overhead;
+ /* overhead per elem of thread queue */
+ unsigned int 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 */
+ int 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 */
+ int SparkPriority; /* threshold for cut-off mechanism */
+ int SparkPriority2;
+ rtsBool RandomPriorities;
+ rtsBool InversePriorities;
+ rtsBool IgnorePriorities;
+ int 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 */
+
+ unsigned int debug;
+ rtsBool event_trace;
+ rtsBool event_trace_all;
+
+};
+#endif /* GRAN */
+
+#ifdef TICKY_TICKY
+struct TICKY_FLAGS {
+ rtsBool showTickyStats;
+ FILE *tickyFile;
+
+ /* see also: doUpdEntryCounts in AllFlags */
+};
+#endif /* TICKY_TICKY */
+
+
+/* Put them together: */
+
+struct RTS_FLAGS {
+ struct GC_FLAGS GcFlags;
+ struct DEBUG_FLAGS DebugFlags; /* unused at present */
+ struct CONCURRENT_FLAGS ConcFlags;
+
+#if defined(PROFILING) || defined(PAR)
+ struct COST_CENTRE_FLAGS CcFlags;
+#endif
+#if defined(PROFILING) || defined(DEBUG)
+ struct PROFILING_FLAGS ProfFlags;
+#endif
+#ifdef PAR
+ struct PAR_FLAGS ParFlags;
+#endif
+#ifdef GRAN
+ struct GRAN_FLAGS GranFlags;
+#endif
+#ifdef TICKY_TICKY
+ struct TICKY_FLAGS TickyFlags;
+#endif
+};
+
+extern struct RTS_FLAGS RtsFlags;
+
+/* Routines that operate-on/to-do-with RTS flags: */
+
+void initRtsFlagsDefaults(void);
+void setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]);
+
+/*
+ * The printf formats are here, so we are less likely to make
+ * overly-long filenames (with disastrous results). No more than 128
+ * chars, please!
+ */
+
+#define STATS_FILENAME_MAXLEN 128
+
+#define GR_FILENAME_FMT "%0.124s.gr"
+#define GR_FILENAME_FMT_GUM "%0.120s.%03d.%s"
+#define HP_FILENAME_FMT "%0.124s.hp"
+#define LIFE_FILENAME_FMT "%0.122s.life"
+#define PROF_FILENAME_FMT "%0.122s.prof"
+#define PROF_FILENAME_FMT_GUM "%0.118s.%03d.prof"
+#define QP_FILENAME_FMT "%0.124s.qp"
+#define STAT_FILENAME_FMT "%0.122s.stat"
+#define TICKY_FILENAME_FMT "%0.121s.ticky"
+#define TIME_FILENAME_FMT "%0.122s.time"
+#define TIME_FILENAME_FMT_GUM "%0.118s.%03d.time"
+
+extern int prog_argc; /* an "int" so as to match normal "argc" */
+extern char **prog_argv;
+extern int rts_argc; /* ditto */
+extern char *rts_argv[];
+
+#endif /* RTSFLAGS_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: RtsStartup.c,v 1.2 1998/12/02 13:28:41 simonm Exp $
+ *
+ * Main function for a standalone Haskell program.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+#include "Storage.h" /* initStorage, exitStorage */
+#include "StablePtr.h" /* initStablePtrTable */
+#include "Schedule.h" /* initScheduler */
+#include "Stats.h" /* initStats */
+#include "Weak.h"
+
+#if defined(PROFILING)
+# include "ProfRTS.h"
+#elif defined(DEBUG)
+# include "DebugProf.h"
+#endif
+
+#ifdef PAR
+#include "ParInit.h"
+#include "Parallel.h"
+#include "LLC.h"
+#endif
+
+/*
+ * Flag Structure
+ */
+struct RTS_FLAGS RtsFlags;
+
+extern void startupHaskell(int argc, char *argv[])
+{
+#if defined(PAR)
+ int nPEs = 0; /* Number of PEs */
+#endif
+
+ /* The very first thing we do is grab the start time...just in case we're
+ * collecting timing statistics.
+ */
+ start_time();
+
+#ifdef PAR
+/*
+ *The parallel system needs to be initialised and synchronised before
+ *the program is run.
+ */
+ if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
+ IAmMainThread = rtsTrue;
+ argv++; argc--; /* Strip off flag argument */
+/* fprintf(stderr, "I am Main Thread\n"); */
+ }
+ /*
+ * Grab the number of PEs out of the argument vector, and
+ * eliminate it from further argument processing.
+ */
+ nPEs = atoi(argv[1]);
+ argv[1] = argv[0];
+ argv++; argc--;
+ initEachPEHook(); /* HWL: hook to be execed on each PE */
+ SynchroniseSystem();
+#endif
+
+ /* Set the RTS flags to default values. */
+ initRtsFlagsDefaults();
+
+ /* Call the user hook to reset defaults, if present */
+ defaultsHook();
+
+ /* Parse the flags, separating the RTS flags from the programs args */
+ setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
+ prog_argc = argc;
+ prog_argv = argv;
+
+#if defined(PAR)
+ /* Initialise the parallel system -- before initHeap! */
+ initParallelSystem();
+ /* And start GranSim profiling if required: omitted for now
+ *if (Rtsflags.ParFlags.granSimStats)
+ *init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
+ */
+#endif /* PAR */
+
+ /* initialize the storage manager */
+ initStorage();
+
+ /* initialise the stable pointer table */
+ initStablePtrTable();
+
+#if defined(PROFILING) || defined(DEBUG)
+ initProfiling();
+#endif
+
+ /* Initialise the scheduler */
+ initScheduler();
+
+ /* Initialise the stats department */
+ initStats();
+
+#if 0
+ initUserSignals();
+#endif
+
+ /* Record initialization times */
+ end_init();
+}
+
+void
+shutdownHaskell(void)
+{
+ /* Finalise any remaining weak pointers */
+ finaliseWeakPointersNow();
+
+#if defined(GRAN)
+ #error FixMe.
+ if (!RTSflags.GranFlags.granSimStats_suppressed)
+ end_gr_simulation();
+#endif
+
+ /* clean up things from the storage manager's point of view */
+ exitStorage();
+
+#if defined(PROFILING) || defined(DEBUG)
+ endProfiling();
+#endif
+
+#if defined(PROFILING)
+ report_ccs_profiling( );
+#endif
+
+#if defined(TICKY_TICKY)
+ #error FixMe.
+ if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
+#endif
+
+ /*
+ This fflush is important, because: if "main" just returns,
+ then we will end up in pre-supplied exit code that will close
+ streams and flush buffers. In particular we have seen: it
+ will close fd 0 (stdin), then flush fd 1 (stdout), then <who
+ cares>...
+
+ But if you're playing with sockets, that "close fd 0" might
+ suggest to the daemon that all is over, only to be presented
+ with more stuff on "fd 1" at the flush.
+
+ The fflush avoids this sad possibility.
+ */
+ fflush(stdout);
+}
+
+
+/*
+ * called from STG-land to exit the program cleanly
+ */
+
+void
+stg_exit(I_ n)
+{
+#ifdef PAR
+ par_exit(n);
+#else
+ OnExitHook();
+ exit(n);
+#endif
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: RtsUtils.c,v 1.2 1998/12/02 13:28:41 simonm Exp $
+ *
+ * General utility functions used in the RTS.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "RtsFlags.h"
+#include "Hooks.h"
+#include "Main.h"
+#include "RtsUtils.h"
+
+#ifdef HAVE_TIME_H
+#include <time.h>
+#endif
+
+#include <stdarg.h>
+
+/* variable-argument error function. */
+
+void barf(char *s, ...)
+{
+ va_list ap;
+ va_start(ap,s);
+ fflush(stdout);
+ if (prog_argv != NULL && prog_argv[0] != NULL) {
+ fprintf(stderr, "%s: fatal error: ", prog_argv[0]);
+ } else {
+ fprintf(stderr, "fatal error: ");
+ }
+ vfprintf(stderr, s, ap);
+ fprintf(stderr, "\n");
+ stg_exit(EXIT_FAILURE);
+}
+
+void belch(char *s, ...)
+{
+ va_list ap;
+ va_start(ap,s);
+ fflush(stdout);
+ vfprintf(stderr, s, ap);
+ fprintf(stderr, "\n");
+}
+
+/* result-checking malloc wrappers. */
+
+void *
+stgMallocBytes (int n, char *msg)
+{
+ char *space;
+
+ if ((space = (char *) malloc((size_t) n)) == NULL) {
+ fflush(stdout);
+ MallocFailHook((W_) n, msg); /*msg*/
+ stg_exit(EXIT_FAILURE);
+ }
+ return space;
+}
+
+void *
+stgReallocBytes (void *p, int n, char *msg)
+{
+ char *space;
+
+ if ((space = (char *) realloc(p, (size_t) n)) == NULL) {
+ fflush(stdout);
+ MallocFailHook((W_) n, msg); /*msg*/
+ exit(EXIT_FAILURE);
+ }
+ return space;
+}
+
+void *
+stgMallocWords (int n, char *msg)
+{
+ return(stgMallocBytes(n * sizeof(W_), msg));
+}
+
+void *
+stgReallocWords (void *p, int n, char *msg)
+{
+ return(stgReallocBytes(p, n * sizeof(W_), msg));
+}
+
+void
+_stgAssert (char *filename, nat linenum)
+{
+ fflush(stdout);
+ fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
+ abort();
+}
+
+StgStablePtr errorHandler = -1; /* -1 indicates no handler installed */
+
+void
+raiseError( StgStablePtr handler STG_UNUSED )
+{
+ shutdownHaskell();
+ stg_exit(EXIT_FAILURE);
+}
+
+/* -----------------------------------------------------------------------------
+ Stack overflow
+
+ Not sure if this belongs here.
+ -------------------------------------------------------------------------- */
+
+void
+stackOverflow(nat max_stack_size)
+{
+ fflush(stdout);
+ StackOverflowHook(max_stack_size * sizeof(W_)); /*msg*/
+
+#if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
+#endif
+
+ stg_exit(EXIT_FAILURE);
+}
+
+void
+heapOverflow(void)
+{
+ fflush(stdout);
+ OutOfHeapHook(0/*unknown request size*/,
+ RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
+
+#if defined(TICKY_TICKY)
+ if (Rtsflags.TickyFlags.showTickyStats) PrintTickyInfo();
+#endif
+
+ stg_exit(EXIT_FAILURE);
+}
+
+/* -----------------------------------------------------------------------------
+ Out-of-line strlen.
+
+ Used in addr2Integer because the C compiler on x86 chokes on
+ strlen, trying to inline it with not enough registers available.
+ -------------------------------------------------------------------------- */
+
+nat stg_strlen(char *s)
+{
+ char *p = s;
+
+ while (*p) p++;
+ return p-s;
+}
+
+
+/* -----------------------------------------------------------------------------
+ genSym stuff, used by GHC itself for its splitting unique supply.
+
+ ToDo: put this somewhere sensible.
+ ------------------------------------------------------------------------- */
+
+I_ __GenSymCounter = 0;
+
+I_
+genSymZh(void)
+{
+ return(__GenSymCounter++);
+}
+I_
+resetGenSymZh(void) /* it's your funeral */
+{
+ __GenSymCounter=0;
+ return(__GenSymCounter);
+}
+
+/* -----------------------------------------------------------------------------
+ Get the current time as a string. Used in profiling reports.
+ -------------------------------------------------------------------------- */
+
+#if defined(PROFILING) || defined(DEBUG)
+char *
+time_str(void)
+{
+ static time_t now = 0;
+ static char nowstr[26];
+
+ if (now == 0) {
+ time(&now);
+ strcpy(nowstr, ctime(&now));
+ strcpy(nowstr+16,nowstr+19);
+ nowstr[21] = '\0';
+ }
+ return nowstr;
+}
+#endif
+
+/* -----------------------------------------------------------------------------
+ Print large numbers, with punctuation.
+ -------------------------------------------------------------------------- */
+
+char *
+ullong_format_string(ullong x, char *s, rtsBool with_commas)
+{
+ if (x < (ullong)1000)
+ sprintf(s, "%d", (nat)x);
+ else if (x < (ullong)1000000)
+ sprintf(s, (with_commas) ? "%ld,%3.3ld" : "%ld%3.3ld",
+ (nat)((x)/(ullong)1000),
+ (nat)((x)%(ullong)1000));
+ else if (x < (ullong)1000000000)
+ sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld",
+ (nat)((x)/(ullong)1000000),
+ (nat)((x)/(ullong)1000%(ullong)1000),
+ (nat)((x)%(ullong)1000));
+ else
+ sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld%3.3ld",
+ (nat)((x)/(ullong)1000000000),
+ (nat)((x)/(ullong)1000000%(ullong)1000),
+ (nat)((x)/(ullong)1000%(ullong)1000),
+ (nat)((x)%(ullong)1000));
+ return s;
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: RtsUtils.h,v 1.2 1998/12/02 13:28:42 simonm Exp $
+ *
+ * General utility functions used in the RTS.
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern void *stgMallocBytes(int n, char *msg);
+extern void *stgMallocWords(int n, char *msg);
+extern void *stgReallocBytes(void *p, int n, char *msg);
+extern void *stgReallocWords(void *p, int n, char *msg);
+extern void barf(char *s, ...) __attribute__((__noreturn__)) ;
+extern void belch(char *s, ...);
+
+extern void _stgAssert (char *filename, unsigned int linenum);
+
+extern StgStablePtr errorHandler;
+extern void raiseError( StgStablePtr handler );
+
+extern void stackOverflow(nat stk_size);
+extern void heapOverflow(void);
+
+extern nat stg_strlen(char *str);
+
+/*Defined in Main.c, but made visible here*/
+extern void stg_exit(I_ n) __attribute__((noreturn));
+
+char * time_str(void);
+
+char *ullong_format_string(ullong, char *, rtsBool);
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Sanity.c,v 1.2 1998/12/02 13:28:43 simonm Exp $
+ *
+ * Sanity checking code for the heap and stack.
+ *
+ * Used when debugging: check that the stack looks reasonable.
+ *
+ * - All things that are supposed to be pointers look like pointers.
+ *
+ * - Objects in text space are marked as static closures, those
+ * in the heap are dynamic.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef DEBUG
+
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "BlockAlloc.h"
+#include "Sanity.h"
+
+static nat heap_step;
+
+#define LOOKS_LIKE_PTR(r) \
+ (IS_DATA_PTR(r) || ((IS_USER_PTR(r) && Bdescr((P_)r)->step == heap_step)))
+
+/* -----------------------------------------------------------------------------
+ Check stack sanity
+ -------------------------------------------------------------------------- */
+
+StgOffset checkStackClosure( StgClosure* c );
+
+StgOffset checkStackObject( StgPtr sp );
+
+void checkStackChunk( StgPtr sp, StgPtr stack_end );
+
+static StgOffset checkSmallBitmap( StgPtr payload, StgNat32 bitmap );
+
+static StgOffset checkLargeBitmap( StgPtr payload,
+ StgLargeBitmap* large_bitmap );
+
+void checkClosureShallow( StgClosure* p );
+
+static StgOffset
+checkSmallBitmap( StgPtr payload, StgNat32 bitmap )
+{
+ StgOffset i;
+
+ i = 0;
+ for(; bitmap != 0; ++i, bitmap >>= 1 ) {
+ if ((bitmap & 1) == 0) {
+ checkClosure(stgCast(StgClosure*,payload[i]));
+ }
+ }
+ return i;
+}
+
+
+static StgOffset
+checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap )
+{
+ StgNat32 bmp;
+ StgOffset i;
+
+ i = 0;
+ for (bmp=0; bmp<large_bitmap->size; bmp++) {
+ StgNat32 bitmap = large_bitmap->bitmap[bmp];
+ for(; bitmap != 0; ++i, bitmap >>= 1 ) {
+ if ((bitmap & 1) == 0) {
+ checkClosure(stgCast(StgClosure*,payload[i]));
+ }
+ }
+ }
+ return i;
+}
+
+StgOffset
+checkStackClosure( StgClosure* c )
+{
+ const StgInfoTable* info = get_itbl(c);
+
+ /* All activation records have 'bitmap' style layout info. */
+ switch (info->type) {
+ case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
+ {
+ StgRetDyn* r = stgCast(StgRetDyn*,c);
+ return sizeofW(StgRetDyn) +
+ checkSmallBitmap(r->payload,r->liveness);
+ }
+ case RET_BCO: /* small bitmap (<= 32 entries) */
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ case UPDATE_FRAME:
+ case CATCH_FRAME:
+ case STOP_FRAME:
+ case SEQ_FRAME:
+ return sizeofW(StgClosure) +
+ checkSmallBitmap((StgPtr)c->payload,info->layout.bitmap);
+ case RET_BIG: /* large bitmap (> 32 entries) */
+ case RET_VEC_BIG:
+ return sizeofW(StgClosure) +
+ checkLargeBitmap((StgPtr)c->payload,
+ info->layout.large_bitmap);
+ case FUN:
+ case FUN_STATIC: /* probably a slow-entry point return address: */
+ return 1;
+ default:
+ /* if none of the above, maybe it's a closure which looks a
+ * little like an infotable
+ */
+ checkClosureShallow(*stgCast(StgClosure**,c));
+ return 1;
+ /* barf("checkStackClosure: weird activation record found on stack (%p).",c); */
+ }
+}
+
+/*
+ * check that it looks like a valid closure - without checking its payload
+ * used to avoid recursion between checking PAPs and checking stack
+ * chunks.
+ */
+
+void
+checkClosureShallow( StgClosure* p )
+{
+ ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
+
+ /* Is it a static closure (i.e. in the data segment)? */
+ if (LOOKS_LIKE_STATIC(p)) {
+ ASSERT(closure_STATIC(p));
+ } else {
+ ASSERT(!closure_STATIC(p));
+ ASSERT(LOOKS_LIKE_PTR(p));
+ }
+}
+
+/* check an individual stack object */
+StgOffset
+checkStackObject( StgPtr sp )
+{
+ if (IS_ARG_TAG(*sp)) {
+ /* Tagged words might be "stubbed" pointers, so there's no
+ * point checking to see whether they look like pointers or
+ * not (some of them will).
+ */
+ return ARG_SIZE(*sp) + 1;
+ } else if (LOOKS_LIKE_GHC_INFO(*stgCast(StgPtr*,sp))) {
+ return checkStackClosure(stgCast(StgClosure*,sp));
+ } else { /* must be an untagged closure pointer in the stack */
+ checkClosureShallow(*stgCast(StgClosure**,sp));
+ return 1;
+ }
+}
+
+/* check sections of stack between update frames */
+void
+checkStackChunk( StgPtr sp, StgPtr stack_end )
+{
+ StgPtr p;
+
+ p = sp;
+ while (p < stack_end) {
+ p += checkStackObject( p );
+ }
+ ASSERT( p == stack_end );
+}
+
+StgOffset
+checkClosure( StgClosure* p )
+{
+ const StgInfoTable *info;
+
+#ifndef INTERPRETER
+ ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
+#endif
+
+ /* Is it a static closure (i.e. in the data segment)? */
+ if (LOOKS_LIKE_STATIC(p)) {
+ ASSERT(closure_STATIC(p));
+ } else {
+ ASSERT(!closure_STATIC(p));
+ ASSERT(LOOKS_LIKE_PTR(p));
+ }
+
+ info = get_itbl(p);
+ switch (info->type) {
+ case BCO:
+ {
+ StgBCO* bco = stgCast(StgBCO*,p);
+ nat i;
+ for(i=0; i < bco->n_ptrs; ++i) {
+ ASSERT(LOOKS_LIKE_PTR(bcoConstPtr(bco,i)));
+ }
+ return bco_sizeW(bco);
+ }
+ case FUN:
+ case THUNK:
+ case CONSTR:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case CAF_UNENTERED:
+ case CAF_ENTERED:
+ case CAF_BLACKHOLE:
+ case BLACKHOLE:
+ case FOREIGN:
+ case MVAR:
+ case MUT_VAR:
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ case THUNK_STATIC:
+ case FUN_STATIC:
+ case IND_STATIC:
+ {
+ nat i;
+ for (i = 0; i < info->layout.payload.ptrs; i++) {
+ ASSERT(LOOKS_LIKE_PTR(payloadPtr(p,i)));
+ }
+ return sizeW_fromITBL(info);
+ }
+
+ case WEAK:
+ /* deal with these specially - the info table isn't
+ * representative of the actual layout.
+ */
+ { StgWeak *w = (StgWeak *)p;
+ ASSERT(LOOKS_LIKE_PTR(w->key));
+ ASSERT(LOOKS_LIKE_PTR(w->value));
+ ASSERT(LOOKS_LIKE_PTR(w->finaliser));
+ if (w->link) {
+ ASSERT(LOOKS_LIKE_PTR(w->link));
+ }
+ return sizeW_fromITBL(info);
+ }
+
+ case THUNK_SELECTOR:
+ ASSERT(LOOKS_LIKE_PTR(stgCast(StgSelector*,p)->selectee));
+ return sizeofW(StgHeader) + MIN_UPD_SIZE;
+
+ case IND:
+ case IND_OLDGEN:
+ {
+ /* we don't expect to see any of these after GC
+ * but they might appear during execution
+ */
+ StgInd *ind = stgCast(StgInd*,p);
+ ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
+ return sizeofW(StgInd);
+ }
+
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ case RET_BIG:
+ case RET_VEC_BIG:
+ case RET_DYN:
+ case UPDATE_FRAME:
+ case STOP_FRAME:
+ case CATCH_FRAME:
+ case SEQ_FRAME:
+ barf("checkClosure: stack frame");
+
+ case AP_UPD: /* we can treat this as being the same as a PAP */
+ case PAP:
+ {
+ StgPAP *pap = stgCast(StgPAP*,p);
+ ASSERT(LOOKS_LIKE_PTR(pap->fun));
+ checkStackChunk((StgPtr)pap->payload,
+ (StgPtr)pap->payload + pap->n_args
+ );
+ return pap_sizeW(pap);
+ }
+
+ case ARR_WORDS:
+ case MUT_ARR_WORDS:
+ return arr_words_sizeW(stgCast(StgArrWords*,p));
+
+ case ARR_PTRS:
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ {
+ StgArrPtrs* a = stgCast(StgArrPtrs*,p);
+ nat i;
+ for (i = 0; i < a->ptrs; i++) {
+ ASSERT(LOOKS_LIKE_PTR(payloadPtr(a,i)));
+ }
+ return arr_ptrs_sizeW(a);
+ }
+
+ case TSO:
+ checkTSO((StgTSO *)p, heap_step);
+ return tso_sizeW((StgTSO *)p);
+
+ case BLOCKED_FETCH:
+ case FETCH_ME:
+ case EVACUATED:
+ barf("checkClosure: unimplemented/strange closure type");
+ default:
+ barf("checkClosure");
+ }
+#undef LOOKS_LIKE_PTR
+}
+
+/* -----------------------------------------------------------------------------
+ Check Heap Sanity
+
+ After garbage collection, the live heap is in a state where we can
+ run through and check that all the pointers point to the right
+ place.
+ -------------------------------------------------------------------------- */
+
+extern void
+checkHeap(bdescr *bd, nat step)
+{
+ StgPtr p;
+
+ heap_step = step;
+
+ while (bd != NULL) {
+ p = bd->start;
+ while (p < bd->free) {
+ nat size = checkClosure(stgCast(StgClosure*,p));
+ /* This is the smallest size of closure that can live in the heap. */
+ ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ p += size;
+ }
+ bd = bd->link;
+ }
+}
+
+/* check stack - making sure that update frames are linked correctly */
+void
+checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
+{
+ /* check everything down to the first update frame */
+ checkStackChunk( sp, stgCast(StgPtr,su) );
+ while ( stgCast(StgPtr,su) < stack_end) {
+ sp = stgCast(StgPtr,su);
+ switch (get_itbl(su)->type) {
+ case UPDATE_FRAME:
+ su = su->link;
+ break;
+ case SEQ_FRAME:
+ su = stgCast(StgSeqFrame*,su)->link;
+ break;
+ case CATCH_FRAME:
+ su = stgCast(StgCatchFrame*,su)->link;
+ break;
+ case STOP_FRAME:
+ /* not quite: ASSERT(stgCast(StgPtr,su) == stack_end); */
+ return;
+ default:
+ barf("checkStack: weird record found on update frame list.");
+ }
+ checkStackChunk( sp, stgCast(StgPtr,su) );
+ }
+ ASSERT(stgCast(StgPtr,su) == stack_end);
+}
+
+extern void
+checkTSO(StgTSO *tso, nat step)
+{
+ StgPtr sp = tso->sp;
+ StgPtr stack = tso->stack;
+ StgUpdateFrame* su = tso->su;
+ StgOffset stack_size = tso->stack_size;
+ StgPtr stack_end = stack + stack_size;
+
+ heap_step = step;
+
+ ASSERT(stack <= sp && sp < stack_end);
+ ASSERT(sp <= stgCast(StgPtr,su));
+
+ checkStack(sp, stack_end, su);
+}
+
+/* -----------------------------------------------------------------------------
+ Check Blackhole Sanity
+
+ Test whether an object is already on the update list.
+ It isn't necessarily an rts error if it is - it might be a programming
+ error.
+
+ Future versions might be able to test for a blackhole without traversing
+ the update frame list.
+
+ -------------------------------------------------------------------------- */
+rtsBool isBlackhole( StgTSO* tso, StgClosure* p )
+{
+ StgUpdateFrame* su = tso->su;
+ do {
+ switch (get_itbl(su)->type) {
+ case UPDATE_FRAME:
+ if (su->updatee == p) {
+ return rtsTrue;
+ } else {
+ su = su->link;
+ }
+ break;
+ case SEQ_FRAME:
+ su = stgCast(StgSeqFrame*,su)->link;
+ break;
+ case CATCH_FRAME:
+ su = stgCast(StgCatchFrame*,su)->link;
+ break;
+ case STOP_FRAME:
+ return rtsFalse;
+ default:
+ barf("isBlackhole: weird record found on update frame list.");
+ }
+ } while (1);
+}
+
+#endif /* DEBUG */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Sanity.h,v 1.2 1998/12/02 13:28:44 simonm Exp $
+ *
+ * Prototypes for functions in Sanity.c
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifdef DEBUG
+/* debugging routines */
+extern void checkHeap ( bdescr *bd, nat step );
+extern void checkStack ( StgPtr sp, StgPtr stack_end, StgUpdateFrame* su );
+extern void checkTSO ( StgTSO* tso, nat step );
+
+extern StgOffset checkClosure( StgClosure* p );
+
+/* test whether an object is already on update list */
+extern rtsBool isBlackhole( StgTSO* tso, StgClosure* p );
+
+#endif /* DEBUG */
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Schedule.c,v 1.2 1998/12/02 13:28:44 simonm Exp $
+ *
+ * Scheduler
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "SchedAPI.h"
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+#include "Storage.h"
+#include "StgRun.h"
+#include "StgStartup.h"
+#include "GC.h"
+#include "Hooks.h"
+#include "Schedule.h"
+#include "StgMiscClosures.h"
+#include "Storage.h"
+#include "Evaluator.h"
+#include "Printer.h"
+#include "Main.h"
+#include "Signals.h"
+#include "StablePtr.h"
+#include "Profiling.h"
+#include "Sanity.h"
+
+StgTSO *run_queue_hd, *run_queue_tl;
+StgTSO *blocked_queue_hd, *blocked_queue_tl;
+StgTSO *ccalling_threads;
+
+#define MAX_SCHEDULE_NESTING 256
+nat next_main_thread;
+StgTSO *main_threads[MAX_SCHEDULE_NESTING];
+
+static void GetRoots(void);
+static StgTSO *threadStackOverflow(StgTSO *tso);
+
+/* flag set by signal handler to precipitate a context switch */
+nat context_switch;
+/* if this flag is set as well, give up execution */
+static nat interrupted;
+
+/* Next thread ID to allocate */
+StgThreadID next_thread_id = 1;
+
+/*
+ * Pointers to the state of the current thread.
+ * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
+ * thread. If CurrentTSO == NULL, then we're at the scheduler level.
+ */
+StgTSO *CurrentTSO;
+StgRegTable MainRegTable;
+
+/*
+ * The thread state for the main thread.
+ */
+StgTSO *MainTSO;
+
+/* The smallest stack size that makes any sense is:
+ * RESERVED_STACK_WORDS (so we can get back from the stack overflow)
+ * + sizeofW(StgStopFrame) (the stg_stop_thread_info frame)
+ * + 1 (the realworld token for an IO thread)
+ * + 1 (the closure to enter)
+ *
+ * A thread with this stack will bomb immediately with a stack
+ * overflow, which will increase its stack size.
+ */
+
+#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
+
+/* -----------------------------------------------------------------------------
+ Create a new thread.
+
+ The new thread starts with the given stack size. Before the
+ scheduler can run, however, this thread needs to have a closure
+ (and possibly some arguments) pushed on its stack. See
+ pushClosure() in Schedule.h.
+
+ createGenThread() and createIOThread() (in Schedule.h) are
+ convenient packaged versions of this function.
+ -------------------------------------------------------------------------- */
+
+StgTSO *
+createThread(nat stack_size)
+{
+ StgTSO *tso;
+
+ tso = (StgTSO *)allocate(stack_size);
+
+ initThread(tso, stack_size);
+ return tso;
+}
+
+void
+initThread(StgTSO *tso, nat stack_size)
+{
+ stack_size -= TSO_STRUCT_SIZEW;
+
+ /* catch ridiculously small stack sizes */
+ if (stack_size < MIN_STACK_WORDS) {
+ stack_size = MIN_STACK_WORDS;
+ }
+
+ SET_INFO(tso,&TSO_info);
+ tso->whatNext = ThreadEnterGHC;
+ tso->state = tso_state_runnable;
+ tso->id = next_thread_id++;
+
+ tso->splim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
+ tso->stack_size = stack_size;
+ tso->max_stack_size = RtsFlags.GcFlags.maxStkSize - TSO_STRUCT_SIZEW;
+ tso->sp = (P_)&(tso->stack) + stack_size;
+
+#ifdef PROFILING
+ tso->prof.CCCS = CCS_MAIN;
+#endif
+
+ /* put a stop frame on the stack */
+ tso->sp -= sizeofW(StgStopFrame);
+ SET_HDR(stgCast(StgClosure*,tso->sp),
+ (StgInfoTable *)&stg_stop_thread_info,
+ CCS_MAIN);
+ tso->su = stgCast(StgUpdateFrame*,tso->sp);
+
+ IF_DEBUG(scheduler,belch("Initialised thread %lld, stack size = %lx words\n",
+ tso->id, tso->stack_size));
+
+ /* Put the new thread on the head of the runnable queue.
+ * The caller of createThread better push an appropriate closure
+ * on this thread's stack before the scheduler is invoked.
+ */
+ tso->link = run_queue_hd;
+ run_queue_hd = tso;
+ if (run_queue_tl == END_TSO_QUEUE) {
+ run_queue_tl = tso;
+ }
+
+ IF_DEBUG(scheduler,printTSO(tso));
+}
+
+/* -----------------------------------------------------------------------------
+ Delete a thread - reverting all blackholes to (something
+ equivalent to) their former state.
+
+ We create an AP_UPD for every UpdateFrame on the stack.
+ Entering one of these AP_UPDs pushes everything from the corresponding
+ update frame upwards onto the stack. (Actually, it pushes everything
+ up to the next update frame plus a pointer to the next AP_UPD
+ object. Entering the next AP_UPD object pushes more onto the
+ stack until we reach the last AP_UPD object - at which point
+ the stack should look exactly as it did when we killed the TSO
+ and we can continue execution by entering the closure on top of
+ the stack.
+ -------------------------------------------------------------------------- */
+
+void deleteThread(StgTSO *tso)
+{
+ StgUpdateFrame* su = tso->su;
+ StgPtr sp = tso->sp;
+
+ /* Thread already dead? */
+ if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
+ return;
+ }
+
+ IF_DEBUG(scheduler, belch("Killing thread %lld.", tso->id));
+
+ tso->whatNext = ThreadKilled; /* changed to ThreadComplete in schedule() */
+ tso->link = END_TSO_QUEUE; /* Just to be on the safe side... */
+
+ /* Threads that finish normally leave Su pointing to the word
+ * beyond the top of the stack, and Sp pointing to the last word
+ * on the stack, which is the return value of the thread.
+ */
+ if ((P_)tso->su >= tso->stack + tso->stack_size
+ || get_itbl(tso->su)->type == STOP_FRAME) {
+ return;
+ }
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Freezing TSO stack\n");
+ printTSO(tso);
+ );
+
+ /* The stack freezing code assumes there's a closure pointer on
+ * the top of the stack. This isn't always the case with compiled
+ * code, so we have to push a dummy closure on the top which just
+ * returns to the next return address on the stack.
+ */
+ if (LOOKS_LIKE_GHC_INFO(*sp)) {
+ *(--sp) = (W_)&dummy_ret_closure;
+ }
+
+ while (1) {
+ int words = (stgCast(StgPtr,su) - stgCast(StgPtr,sp)) - 1;
+ nat i;
+ StgAP_UPD* ap = stgCast(StgAP_UPD*,allocate(AP_sizeW(words)));
+
+ /* First build an AP_UPD consisting of the stack chunk above the
+ * current update frame, with the top word on the stack as the
+ * fun field.
+ */
+ ASSERT(words >= 0);
+
+ /* if (words == 0) { -- optimisation
+ ap = stgCast(StgAP_UPD*,*stgCast(StgPtr*,sp)++);
+ } else */ {
+ ap->n_args = words;
+ ap->fun = stgCast(StgClosure*,*stgCast(StgPtr*,sp)++);
+ for(i=0; i < (nat)words; ++i) {
+ payloadWord(ap,i) = *sp++;
+ }
+ }
+
+ switch (get_itbl(su)->type) {
+
+ case UPDATE_FRAME:
+ {
+ SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Updating ");
+ printPtr(stgCast(StgPtr,su->updatee));
+ fprintf(stderr, " with ");
+ printObj(stgCast(StgClosure*,ap));
+ );
+
+ /* Replace the updatee with an indirection - happily
+ * this will also wake up any threads currently
+ * waiting on the result.
+ */
+ UPD_IND(su->updatee,ap); /* revert the black hole */
+ su = su->link;
+ sp += sizeofW(StgUpdateFrame) -1;
+ sp[0] = stgCast(StgWord,ap); /* push onto stack */
+ break;
+ }
+
+ case CATCH_FRAME:
+ {
+ StgCatchFrame *cf = (StgCatchFrame *)su;
+ StgClosure* o;
+
+ /* We want a PAP, not an AP_UPD. Fortunately, the
+ * layout's the same.
+ */
+ SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
+
+ /* now build o = FUN(catch,ap,handler) */
+ o = stgCast(StgClosure*, allocate(sizeofW(StgClosure)+2));
+ SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
+ payloadCPtr(o,0) = stgCast(StgClosure*,ap);
+ payloadCPtr(o,1) = cf->handler;
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Built ");
+ printObj(stgCast(StgClosure*,o));
+ );
+
+ /* pop the old handler and put o on the stack */
+ su = cf->link;
+ sp += sizeofW(StgCatchFrame) - 1;
+ sp[0] = (W_)o;
+ break;
+ }
+
+ case SEQ_FRAME:
+ {
+ StgSeqFrame *sf = (StgSeqFrame *)su;
+ StgClosure* o;
+
+ SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
+
+ /* now build o = FUN(seq,ap) */
+ o = stgCast(StgClosure*, allocate(sizeofW(StgClosure)+1));
+ SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
+ payloadCPtr(o,0) = stgCast(StgClosure*,ap);
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Built ");
+ printObj(stgCast(StgClosure*,o));
+ );
+
+ /* pop the old handler and put o on the stack */
+ su = sf->link;
+ sp += sizeofW(StgSeqFrame) - 1;
+ sp[0] = (W_)o;
+ break;
+ }
+
+ case STOP_FRAME:
+ return;
+
+ default:
+ barf("freezeTSO");
+ }
+ }
+}
+
+void initScheduler(void)
+{
+ run_queue_hd = END_TSO_QUEUE;
+ run_queue_tl = END_TSO_QUEUE;
+ blocked_queue_hd = END_TSO_QUEUE;
+ blocked_queue_tl = END_TSO_QUEUE;
+ ccalling_threads = END_TSO_QUEUE;
+ next_main_thread = 0;
+
+ context_switch = 0;
+ interrupted = 0;
+
+ enteredCAFs = END_CAF_LIST;
+}
+
+/* -----------------------------------------------------------------------------
+ Main scheduling loop.
+
+ We use round-robin scheduling, each thread returning to the
+ scheduler loop when one of these conditions is detected:
+
+ * stack overflow
+ * out of heap space
+ * timer expires (thread yields)
+ * thread blocks
+ * thread ends
+ -------------------------------------------------------------------------- */
+
+SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
+{
+ StgTSO *t;
+ StgThreadReturnCode ret;
+ StgTSO **MainTSO;
+ rtsBool in_ccall_gc;
+
+ /* Return value is NULL by default, it is only filled in if the
+ * main thread completes successfully.
+ */
+ if (ret_val) { *ret_val = NULL; }
+
+ /* Save away a pointer to the main thread so that we can keep track
+ * of it should a garbage collection happen. We keep a stack of
+ * main threads in order to support scheduler re-entry. We can't
+ * use the normal TSO linkage for this stack, because the main TSO
+ * may need to be linked onto other queues.
+ */
+ main_threads[next_main_thread] = main;
+ MainTSO = &main_threads[next_main_thread];
+ next_main_thread++;
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Scheduler entered: nesting = %d\n",
+ next_main_thread););
+
+ /* Are we being re-entered?
+ */
+ if (CurrentTSO != NULL) {
+ /* This happens when a _ccall_gc from Haskell ends up re-entering
+ * the scheduler.
+ *
+ * Block the current thread (put it on the ccalling_queue) and
+ * continue executing. The calling thread better have stashed
+ * away its state properly and left its stack with a proper stack
+ * frame on the top.
+ */
+ threadPaused(CurrentTSO);
+ CurrentTSO->link = ccalling_threads;
+ ccalling_threads = CurrentTSO;
+ in_ccall_gc = rtsTrue;
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Re-entry, thread %lld did a _ccall_gc\n",
+ CurrentTSO->id););
+ } else {
+ in_ccall_gc = rtsFalse;
+ }
+
+ /* Take a thread from the run queue.
+ */
+ t = run_queue_hd;
+ if (t != END_TSO_QUEUE) {
+ run_queue_hd = t->link;
+ t->link = END_TSO_QUEUE;
+ if (run_queue_hd == END_TSO_QUEUE) {
+ run_queue_tl = END_TSO_QUEUE;
+ }
+ }
+
+ while (t != END_TSO_QUEUE) {
+ CurrentTSO = t;
+
+ /* If we have more threads on the run queue, set up a context
+ * switch at some point in the future.
+ */
+ if (run_queue_hd != END_TSO_QUEUE) {
+ context_switch = 1;
+ } else {
+ context_switch = 0;
+ }
+ IF_DEBUG(scheduler, belch("Running thread %lld...\n", t->id));
+
+ /* Run the current thread */
+ switch (t->whatNext) {
+ case ThreadKilled:
+ case ThreadComplete:
+ /* thread already killed. Drop it and carry on. */
+ goto next_thread;
+ case ThreadEnterGHC:
+ ret = StgRun((StgFunPtr) stg_enterStackTop);
+ break;
+ case ThreadRunGHC:
+ ret = StgRun((StgFunPtr) stg_returnToStackTop);
+ break;
+ case ThreadEnterHugs:
+#ifdef INTERPRETER
+ {
+ IF_DEBUG(scheduler,belch("entering Hugs"));
+ LoadThreadState();
+ /* CHECK_SENSIBLE_REGS(); */
+ {
+ StgClosure* c = stgCast(StgClosure*,*Sp);
+ Sp += 1;
+ ret = enter(c);
+ }
+ SaveThreadState();
+ break;
+ }
+#else
+ barf("Panic: entered a BCO but no bytecode interpreter in this build");
+#endif
+ default:
+ barf("schedule: invalid whatNext field");
+ }
+
+ /* We may have garbage collected while running the thread
+ * (eg. something nefarious like _ccall_GC_ performGC), and hence
+ * CurrentTSO may have moved. Update t to reflect this.
+ */
+ t = CurrentTSO;
+ CurrentTSO = NULL;
+
+ /* Costs for the scheduler are assigned to CCS_SYSTEM */
+#ifdef PROFILING
+ CCCS = CCS_SYSTEM;
+#endif
+
+ switch (ret) {
+
+ case HeapOverflow:
+ IF_DEBUG(scheduler,belch("Thread %lld stopped: HeapOverflow\n", t->id));
+ threadPaused(t);
+ PUSH_ON_RUN_QUEUE(t);
+ GarbageCollect(GetRoots);
+ break;
+
+ case StackOverflow:
+ IF_DEBUG(scheduler,belch("Thread %lld stopped, StackOverflow\n", t->id));
+ {
+ nat i;
+ /* enlarge the stack */
+ StgTSO *new_t = threadStackOverflow(t);
+
+ /* This TSO has moved, so update any pointers to it from the
+ * main thread stack. It better not be on any other queues...
+ * (it shouldn't be)
+ */
+ for (i = 0; i < next_main_thread; i++) {
+ if (main_threads[i] == t) {
+ main_threads[i] = new_t;
+ }
+ }
+ t = new_t;
+ }
+ PUSH_ON_RUN_QUEUE(t);
+ break;
+
+ case ThreadYielding:
+ IF_DEBUG(scheduler,
+ if (t->whatNext == ThreadEnterHugs) {
+ /* ToDo: or maybe a timer expired when we were in Hugs?
+ * or maybe someone hit ctrl-C
+ */
+ belch("Thread %lld stopped to switch to Hugs\n", t->id);
+ } else {
+ belch("Thread %lld stopped, timer expired\n", t->id);
+ }
+ );
+ threadPaused(t);
+ if (interrupted) {
+ IF_DEBUG(scheduler,belch("Scheduler interrupted - returning"));
+ deleteThread(t);
+ while (run_queue_hd != END_TSO_QUEUE) {
+ run_queue_hd = t->link;
+ deleteThread(t);
+ }
+ run_queue_tl = END_TSO_QUEUE;
+ /* ToDo: should I do the same with blocked queues? */
+ return Interrupted;
+ }
+
+ /* Put the thread back on the run queue, at the end.
+ * t->link is already set to END_TSO_QUEUE.
+ */
+ ASSERT(t->link == END_TSO_QUEUE);
+ if (run_queue_tl != END_TSO_QUEUE) {
+ ASSERT(get_itbl(run_queue_tl)->type == TSO);
+ if (run_queue_hd == run_queue_tl) {
+ run_queue_hd->link = t;
+ run_queue_tl = t;
+ } else {
+ run_queue_tl->link = t;
+ }
+ } else {
+ run_queue_hd = run_queue_tl = t;
+ }
+ break;
+
+ case ThreadBlocked:
+ IF_DEBUG(scheduler,belch("Thread %lld stopped, blocking\n", t->id));
+ threadPaused(t);
+ /* assume the thread has put itself on some blocked queue
+ * somewhere.
+ */
+ break;
+
+ case ThreadFinished:
+ IF_DEBUG(scheduler,belch("Thread %lld finished\n", t->id));
+ deleteThread(t);
+ t->whatNext = ThreadComplete;
+ break;
+
+ default:
+ barf("schedule: invalid thread return code");
+ }
+
+ /* check for signals each time around the scheduler */
+ if (signals_pending()) {
+ start_signal_handlers();
+ }
+
+ /* If our main thread has finished or been killed, return.
+ * If we were re-entered as a result of a _ccall_gc, then
+ * pop the blocked thread off the ccalling_threads stack back
+ * into CurrentTSO.
+ */
+ if ((*MainTSO)->whatNext == ThreadComplete
+ || (*MainTSO)->whatNext == ThreadKilled) {
+ next_main_thread--;
+ if (in_ccall_gc) {
+ CurrentTSO = ccalling_threads;
+ ccalling_threads = ccalling_threads->link;
+ }
+ if ((*MainTSO)->whatNext == ThreadComplete) {
+ /* we finished successfully, fill in the return value */
+ if (ret_val) { *ret_val = (StgClosure *)(*MainTSO)->sp[0]; };
+ return Success;
+ } else {
+ return Killed;
+ }
+ }
+
+ next_thread:
+ t = run_queue_hd;
+ if (t != END_TSO_QUEUE) {
+ run_queue_hd = t->link;
+ t->link = END_TSO_QUEUE;
+ if (run_queue_hd == END_TSO_QUEUE) {
+ run_queue_tl = END_TSO_QUEUE;
+ }
+ }
+ }
+
+ if (blocked_queue_hd != END_TSO_QUEUE) {
+ return AllBlocked;
+ } else {
+ return Deadlock;
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Where are the roots that we know about?
+
+ - all the threads on the runnable queue
+ - all the threads on the blocked queue
+ - all the thread currently executing a _ccall_GC
+ - all the "main threads"
+
+ -------------------------------------------------------------------------- */
+
+static void GetRoots(void)
+{
+ nat i;
+
+ run_queue_hd = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
+ run_queue_tl = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
+
+ blocked_queue_hd = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
+ blocked_queue_tl = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
+
+ ccalling_threads = (StgTSO *)MarkRoot((StgClosure *)ccalling_threads);
+
+ for (i = 0; i < next_main_thread; i++) {
+ main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
+ }
+
+ markStablePtrTable();
+}
+
+/* -----------------------------------------------------------------------------
+ performGC
+
+ This is the interface to the garbage collector from Haskell land.
+ We provide this so that external C code can allocate and garbage
+ collect when called from Haskell via _ccall_GC.
+
+ It might be useful to provide an interface whereby the programmer
+ can specify more roots (ToDo).
+ -------------------------------------------------------------------------- */
+
+void (*extra_roots)(void);
+
+void
+performGC(void)
+{
+ GarbageCollect(GetRoots);
+}
+
+static void
+AllRoots(void)
+{
+ GetRoots(); /* the scheduler's roots */
+ extra_roots(); /* the user's roots */
+}
+
+void
+performGCWithRoots(void (*get_roots)(void))
+{
+ extra_roots = get_roots;
+
+ GarbageCollect(AllRoots);
+}
+
+/* -----------------------------------------------------------------------------
+ Stack overflow
+
+ If the thread has reached its maximum stack size,
+ then bomb out. Otherwise relocate the TSO into a larger chunk of
+ memory and adjust its stack size appropriately.
+ -------------------------------------------------------------------------- */
+
+static StgTSO *
+threadStackOverflow(StgTSO *tso)
+{
+ nat new_stack_size, new_tso_size, diff, stack_words;
+ StgPtr new_sp;
+ StgTSO *dest;
+
+ if (tso->stack_size >= tso->max_stack_size) {
+ /* ToDo: just kill this thread? */
+#ifdef DEBUG
+ /* If we're debugging, just print out the top of the stack */
+ printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
+ tso->sp+64));
+#endif
+ stackOverflow(tso->max_stack_size);
+ }
+
+ /* Try to double the current stack size. If that takes us over the
+ * maximum stack size for this thread, then use the maximum instead.
+ * Finally round up so the TSO ends up as a whole number of blocks.
+ */
+ new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
+ new_tso_size = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
+ TSO_STRUCT_SIZE)/sizeof(W_);
+ new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
+
+ IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
+
+ dest = (StgTSO *)allocate(new_tso_size);
+
+ /* copy the TSO block and the old stack into the new area */
+ memcpy(dest,tso,TSO_STRUCT_SIZE);
+ stack_words = tso->stack + tso->stack_size - tso->sp;
+ new_sp = (P_)dest + new_tso_size - stack_words;
+ memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
+
+ /* relocate the stack pointers... */
+ diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
+ dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
+ dest->sp = new_sp;
+ dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
+ dest->stack_size = new_stack_size;
+
+ /* and relocate the update frame list */
+ relocate_TSO(tso, dest);
+
+ IF_DEBUG(sanity,checkTSO(tso,0)); /* Step 0 because we're not GC'ing. */
+#if 0
+ IF_DEBUG(scheduler,printTSO(dest));
+#endif
+ if (tso == MainTSO) { /* hack */
+ MainTSO = dest;
+ }
+ return dest;
+}
+
+/* -----------------------------------------------------------------------------
+ Wake up a queue that was blocked on some resource (usually a
+ computation in progress).
+ -------------------------------------------------------------------------- */
+
+void awaken_blocked_queue(StgTSO *q)
+{
+ StgTSO *tso;
+
+ while (q != END_TSO_QUEUE) {
+ ASSERT(get_itbl(q)->type == TSO);
+ tso = q;
+ q = tso->link;
+ PUSH_ON_RUN_QUEUE(tso);
+ IF_DEBUG(scheduler,belch("Waking up thread %lld", tso->id));
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Interrupt execution
+ - usually called inside a signal handler so it mustn't do anything fancy.
+ -------------------------------------------------------------------------- */
+
+void interruptStgRts(void)
+{
+ interrupted = 1;
+ context_switch = 1;
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Schedule.h,v 1.2 1998/12/02 13:28:46 simonm Exp $
+ *
+ * (c) The GHC Team 1998
+ *
+ * Prototypes for functions in Schedule.c
+ * (RTS internal scheduler interface)
+ *
+ * ---------------------------------------------------------------------------*/
+
+/*
+ * Initialisation
+ */
+
+void initScheduler(void);
+
+/*
+ * Miscellany
+ */
+
+void awaken_blocked_queue(StgTSO *tso);
+
+void initThread(StgTSO *tso, nat stack_size);
+
+void interruptStgRts(void);
+
+extern nat context_switch;
+
+extern StgTSO *run_queue_hd, *run_queue_tl;
+extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
+
+extern StgTSO *MainTSO; /* temporary hack */
+
+#define END_TSO_QUEUE ((StgTSO *)(void*)&END_TSO_QUEUE_closure)
+
+#define PUSH_ON_RUN_QUEUE(tso) \
+ if (run_queue_hd == END_TSO_QUEUE) { \
+ run_queue_hd = tso; \
+ } else { \
+ run_queue_tl->link = tso; \
+ } \
+ run_queue_tl = tso;
+
+#define END_CAF_LIST stgCast(StgCAF*,(void*)&END_TSO_QUEUE_closure)
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Signals.c,v 1.2 1998/12/02 13:28:46 simonm Exp $
+ *
+ * Signal processing / handling.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "SchedAPI.h"
+#include "Signals.h"
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+#include "StablePtr.h"
+
+#ifndef PAR
+
+static StgInt *handlers = NULL; /* Dynamically grown array of signal handlers */
+static StgInt nHandlers = 0; /* Size of handlers array */
+
+#define N_PENDING_HANDLERS 16
+
+StgPtr pending_handler_buf[N_PENDING_HANDLERS];
+StgPtr *next_pending_handler = pending_handler_buf;
+
+StgInt nocldstop = 0;
+
+/* -----------------------------------------------------------------------------
+ Allocate/resize the table of signal handlers.
+ -------------------------------------------------------------------------- */
+
+static void
+more_handlers(I_ sig)
+{
+ I_ i;
+
+ if (sig < nHandlers)
+ return;
+
+ if (handlers == NULL)
+ handlers = (I_ *) malloc((sig + 1) * sizeof(I_));
+ else
+ handlers = (I_ *) realloc(handlers, (sig + 1) * sizeof(I_));
+
+ if (handlers == NULL) {
+ fflush(stdout);
+ fprintf(stderr, "VM exhausted (in more_handlers)\n");
+ exit(EXIT_FAILURE);
+ }
+ for(i = nHandlers; i <= sig; i++)
+ /* Fill in the new slots with default actions */
+ handlers[i] = STG_SIG_DFL;
+
+ nHandlers = sig + 1;
+}
+
+/* -----------------------------------------------------------------------------
+ Low-level signal handler
+
+ Places the requested handler on a stack of pending handlers to be
+ started up at the next context switch.
+ -------------------------------------------------------------------------- */
+
+static void
+generic_handler(int sig)
+{
+ sigset_t signals;
+
+ /* Can't call allocate from here. Probably can't call malloc
+ either. However, we have to schedule a new thread somehow.
+
+ It's probably ok to request a context switch and allow the
+ scheduler to start the handler thread, but how to we
+ communicate this to the scheduler?
+
+ We need some kind of locking, but with low overhead (i.e. no
+ blocking signals every time around the scheduler).
+
+ Signal Handlers are atomic (i.e. they can't be interrupted), and
+ we can make use of this. We just need to make sure the
+ critical section of the scheduler can't be interrupted - the
+ only way to do this is to block signals. However, we can lower
+ the overhead by only blocking signals when there are any
+ handlers to run, i.e. the set of pending handlers is
+ non-empty.
+ */
+
+ /* We use a stack to store the pending signals. We can't
+ dynamically grow this since we can't allocate any memory from
+ within a signal handler.
+
+ Hence unfortunately we have to bomb out if the buffer
+ overflows. It might be acceptable to carry on in certain
+ circumstances, depending on the signal.
+ */
+
+ *next_pending_handler++ = deRefStablePointer(handlers[sig]);
+
+ /* stack full? */
+ if (next_pending_handler == &pending_handler_buf[N_PENDING_HANDLERS]) {
+ barf("too many pending signals");
+ }
+
+ /* re-establish the signal handler, and carry on */
+ sigemptyset(&signals);
+ sigaddset(&signals, sig);
+ sigprocmask(SIG_UNBLOCK, &signals, NULL);
+}
+
+/* -----------------------------------------------------------------------------
+ Blocking/Unblocking of the user signals
+ -------------------------------------------------------------------------- */
+
+static sigset_t userSignals;
+static sigset_t savedSignals;
+
+void
+initUserSignals(void)
+{
+ sigemptyset(&userSignals);
+}
+
+void
+blockUserSignals(void)
+{
+ sigprocmask(SIG_SETMASK, &userSignals, &savedSignals);
+}
+
+void
+unblockUserSignals(void)
+{
+ sigprocmask(SIG_SETMASK, &savedSignals, NULL);
+}
+
+
+/* -----------------------------------------------------------------------------
+ Install a Haskell signal handler.
+ -------------------------------------------------------------------------- */
+
+StgInt
+sig_install(StgInt sig, StgInt spi, StgStablePtr handler, sigset_t *mask)
+{
+ sigset_t signals;
+ struct sigaction action;
+ StgInt previous_spi;
+
+ /* Block the signal until we figure out what to do */
+ /* Count on this to fail if the signal number is invalid */
+ if(sig < 0 || sigemptyset(&signals) || sigaddset(&signals, sig) ||
+ sigprocmask(SIG_BLOCK, &signals, NULL))
+ return STG_SIG_ERR;
+
+ more_handlers(sig);
+
+ previous_spi = handlers[sig];
+
+ switch(spi) {
+ case STG_SIG_IGN:
+ handlers[sig] = STG_SIG_IGN;
+ sigdelset(&userSignals, sig);
+ action.sa_handler = SIG_IGN;
+ break;
+
+ case STG_SIG_DFL:
+ handlers[sig] = STG_SIG_DFL;
+ sigdelset(&userSignals, sig);
+ action.sa_handler = SIG_DFL;
+ break;
+ case STG_SIG_HAN:
+ handlers[sig] = (I_)handler;
+ sigaddset(&userSignals, sig);
+ action.sa_handler = generic_handler;
+ break;
+ default:
+ barf("sig_install: bad spi");
+ }
+
+ if (mask != 0)
+ action.sa_mask = *mask;
+ else
+ sigemptyset(&action.sa_mask);
+
+ action.sa_flags = sig == SIGCHLD && nocldstop ? SA_NOCLDSTOP : 0;
+
+ if (sigaction(sig, &action, NULL) ||
+ sigprocmask(SIG_UNBLOCK, &signals, NULL))
+ {
+ /* need to return an error code, so avoid a stable pointer leak
+ * by freeing the previous handler if there was one.
+ */
+ if (previous_spi >= 0) {
+ freeStablePointer(handlers[sig]);
+ }
+ return STG_SIG_ERR;
+ }
+
+ return previous_spi;
+}
+
+/* -----------------------------------------------------------------------------
+ Creating new threads for the pending signal handlers.
+ -------------------------------------------------------------------------- */
+
+void
+start_signal_handlers(void)
+{
+ blockUserSignals();
+
+ while (next_pending_handler != pending_handler_buf) {
+
+ next_pending_handler--;
+
+ /* create*Thread puts the thread on the head of the runnable
+ * queue, hence it will be run next. Poor man's priority
+ * scheduling.
+ */
+ createIOThread(RtsFlags.GcFlags.initialStkSize,
+ (StgClosure *) *next_pending_handler);
+ }
+
+ unblockUserSignals();
+}
+
+#else /* PAR */
+StgInt
+sig_install(StgInt sig, StgInt spi, StgStablePtr handler, sigset_t *mask)
+{
+ fflush(stdout);
+ fprintf(stderr,
+ "No signal handling support in a parallel implementation.\n");
+ exit(EXIT_FAILURE);
+}
+
+void
+start_signal_handlers(void)
+{
+}
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Signals.h,v 1.2 1998/12/02 13:28:47 simonm Exp $
+ *
+ * Signal processing / handling.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef PAR
+
+extern StgPtr pending_handler_buf[];
+extern StgPtr *next_pending_handler;
+
+#define signals_pending() (next_pending_handler != pending_handler_buf)
+
+extern void initUserSignals(void);
+extern void blockUserSignals(void);
+extern void unblockUserSignals(void);
+
+/* sig_install declared in PrimOps.h */
+
+extern void start_signal_handlers(void);
+
+#else
+
+#define signals_pending() (rtsFalse)
+
+#endif /* PAR */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StablePtr.c,v 1.2 1998/12/02 13:28:48 simonm Exp $
+ *
+ * Stable pointers
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "StablePtr.h"
+#include "GC.h"
+#include "RtsUtils.h"
+#include "Storage.h"
+#include "RtsAPI.h"
+#include "RtsFlags.h"
+
+/* Comment from ADR's implementation in old RTS:
+
+ This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
+ small change in @HpOverflow.lc@) consists of the changes in the
+ runtime system required to implement "Stable Pointers". But we're
+ getting a bit ahead of ourselves --- what is a stable pointer and what
+ is it used for?
+
+ When Haskell calls C, it normally just passes over primitive integers,
+ floats, bools, strings, etc. This doesn't cause any problems at all
+ for garbage collection because the act of passing them makes a copy
+ from the heap, stack or wherever they are onto the C-world stack.
+ However, if we were to pass a heap object such as a (Haskell) @String@
+ and a garbage collection occured before we finished using it, we'd run
+ into problems since the heap object might have been moved or even
+ deleted.
+
+ So, if a C call is able to cause a garbage collection or we want to
+ store a pointer to a heap object between C calls, we must be careful
+ when passing heap objects. Our solution is to keep a table of all
+ objects we've given to the C-world and to make sure that the garbage
+ collector collects these objects --- updating the table as required to
+ make sure we can still find the object.
+
+
+ Of course, all this rather begs the question: why would we want to
+ pass a boxed value?
+
+ One very good reason is to preserve laziness across the language
+ interface. Rather than evaluating an integer or a string because it
+ {\em might\/} be required by the C function, we can wait until the C
+ function actually wants the value and then force an evaluation.
+
+ Another very good reason (the motivating reason!) is that the C code
+ might want to execute an object of sort $IO ()$ for the side-effects
+ it will produce. For example, this is used when interfacing to an X
+ widgets library to allow a direct implementation of callbacks.
+
+
+ The @makeStablePointer :: a -> IO (StablePtr a)@ function
+ converts a value into a stable pointer. It is part of the @PrimIO@
+ monad, because we want to be sure we don't allocate one twice by
+ accident, and then only free one of the copies.
+
+ \begin{verbatim}
+ makeStablePtr# :: a -> State# RealWorld -> (# RealWorld, a #)
+ freeStablePtr# :: StablePtr# a -> State# RealWorld -> State# RealWorld
+ deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
+ (# State# RealWorld, a #)
+ \end{verbatim}
+ There is also a C procedure @FreeStablePtr@ which frees a stable pointer.
+
+ There may be additional functions on the C side to allow evaluation,
+ application, etc of a stable pointer.
+
+ When Haskell calls C, it normally just passes over primitive integers,
+ floats, bools, strings, etc. This doesn't cause any problems at all
+ for garbage collection because the act of passing them makes a copy
+ from the heap, stack or wherever they are onto the C-world stack.
+ However, if we were to pass a heap object such as a (Haskell) @String@
+ and a garbage collection occured before we finished using it, we'd run
+ into problems since the heap object might have been moved or even
+ deleted.
+
+ So, if a C call is able to cause a garbage collection or we want to
+ store a pointer to a heap object between C calls, we must be careful
+ when passing heap objects. Our solution is to keep a table of all
+ objects we've given to the C-world and to make sure that the garbage
+ collector collects these objects --- updating the table as required to
+ make sure we can still find the object.
+*/
+
+
+StgPtr *stable_ptr_table;
+StgPtr *stable_ptr_free;
+
+static nat SPT_size;
+
+#define INIT_SPT_SIZE 64
+
+static inline void
+initFreeList(StgPtr *table, nat n, StgPtr *free)
+{
+ StgPtr *p;
+
+ for (p = table + n - 1; p >= table; p--) {
+ *p = (P_)free;
+ free = p;
+ }
+ stable_ptr_free = table;
+}
+
+void
+initStablePtrTable(void)
+{
+ SPT_size = INIT_SPT_SIZE;
+ stable_ptr_table = stgMallocWords(SPT_size, "initStablePtrTable");
+
+ initFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);
+}
+
+void
+enlargeStablePtrTable(void)
+{
+ nat old_SPT_size = SPT_size;
+
+ SPT_size *= 2;
+ stable_ptr_table = stgReallocWords(stable_ptr_table, SPT_size,
+ "enlargeStablePtrTable");
+
+ initFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
+}
+
+void
+markStablePtrTable(void)
+{
+ StgPtr *p, q, *end_stable_ptr_table;
+
+ end_stable_ptr_table = &stable_ptr_table[SPT_size];
+
+ for (p = stable_ptr_table; p < end_stable_ptr_table; p++) {
+ q = *p;
+ /* internal pointers or NULL are free slots */
+ if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
+ (StgClosure *)*p = MarkRoot((StgClosure *)q);
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ performIO
+
+ This is a useful function for calling from C land (or Haskell land
+ with _ccall_GC) which runs an arbitrary Haskell IO computation in a
+ new thread.
+
+ The closure to evaluate is passed in as a stable pointer, and
+ should have type StablePtr (IO ()). No checking is done on the
+ type, so be careful!
+
+ The thread will be run in the context of the existing system;
+ ie. running threads will continue to run etc.
+ -------------------------------------------------------------------------- */
+
+void
+performIO(StgStablePtr io)
+{
+ rts_evalIO((StgClosure *)deRefStablePointer(io), NULL);
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StablePtr.h,v 1.2 1998/12/02 13:28:49 simonm Exp $
+ *
+ * Stable pointers
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern StgPtr *stable_ptr_table;
+extern StgPtr *stable_ptr_free;
+
+extern void initStablePtrTable(void);
+extern void markStablePtrTable(void);
+extern void enlargeStablePtrTable(void);
+
+static inline StgPtr
+deRefStablePointer(StgInt stable_ptr)
+{
+ return stable_ptr_table[stable_ptr];
+}
+
+extern void performIO(StgStablePtr stableIndex);
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Stats.c,v 1.2 1998/12/02 13:28:49 simonm Exp $
+ *
+ * Statistics and timing-related functions.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#define NON_POSIX_SOURCE
+
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+
+/**
+ * Ian: For the moment we just want to ignore
+ * these on Nemesis
+ **/
+#ifdef _NEMESIS_OS_
+#ifdef HAVE_SYS_TIMES_H
+#undef HAVE_SYS_TIMES_H /* <sys/times.h> */
+#endif
+#ifdef HAVE_SYS_RESOURCE_H /* <sys/resource.h> */
+#undef HAVE_SYS_RESOURCE_H
+#endif
+#ifdef HAVE_SYS_TIME_H /* <sys/time.h> */
+#undef HAVE_SYS_TIME_H
+#endif
+#ifdef HAVE_SYS_TIMEB_H
+#undef HAVE_SYS_TIMEB_H /* <sys/timeb.h> */
+#endif
+#ifdef HAVE_UNISTD_H
+#undef HAVE_UNISTD_H /* <unistd.h> */
+#endif
+#ifdef HAVE_TIMES
+#undef HAVE_TIMES
+#endif
+#ifdef HAVE_FTIME
+#undef HAVE_FTIME
+#endif
+#ifdef HAVE_GETRUSAGE
+#undef HAVE_GETRUSAGE
+#endif
+#ifdef HAVE_SYSCONF
+#undef HAVE_SYSCONF
+#endif
+#endif /* _NEMESIS_OS_ */
+
+#include "Stats.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TIMES_H
+#include <sys/times.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
+#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS
+#include <sys/resource.h>
+#endif
+
+#ifdef HAVE_SYS_TIMEB_H
+#include <sys/timeb.h>
+#endif
+
+#if HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+/* huh? */
+#define BIG_STRING_LEN 512
+
+static StgDouble ElapsedTimeStart = 0.0;
+static StgDouble TicksPerSecond = 0.0;
+
+static StgDouble InitUserTime = 0.0;
+static StgDouble InitElapsedTime = 0.0;
+
+static ullong GC_tot_alloc = 0;
+
+static StgDouble GC_start_time, GC_tot_time = 0; /* User GC Time */
+static StgDouble GCe_start_time, GCe_tot_time = 0; /* Elapsed GC time */
+
+static StgDouble GC_min_time = 0;
+static StgDouble GCe_min_time = 0;
+static lnat GC_maj_no = 0;
+static lnat GC_min_no = 0;
+static lnat GC_min_since_maj = 0;
+static lnat GC_live_maj = 0; /* Heap live at last major collection */
+static lnat GC_alloc_since_maj = 0; /* Heap alloc since collection major */
+
+lnat MaxResidency = 0; /* in words; for stats only */
+lnat ResidencySamples = 0; /* for stats only */
+
+static lnat GC_start_faults = 0, GC_end_faults = 0;
+
+/* ToDo: convert this to use integers? --SDM */
+
+/* elapsedtime() -- The current elapsed time in seconds */
+
+StgDouble
+elapsedtime(void)
+{
+#if ! (defined(HAVE_TIMES) || defined(HAVE_FTIME))
+ /* We will #ifdef around the fprintf for machines
+ we *know* are unsupported. (WDP 94/05)
+ */
+ fprintf(stderr, "NOTE: `elapsedtime' does nothing!\n");
+ return 0.0;
+
+#else /* not stumped */
+
+/* "ftime" may be nicer, but "times" is more standard;
+ but, on a Sun, if you do not get the SysV one, you are *hosed*...
+ */
+
+# if defined(HAVE_TIMES) && ! sunos4_TARGET_OS
+ struct tms t;
+ clock_t r = times(&t);
+
+ return (((StgDouble)r)/TicksPerSecond - ElapsedTimeStart);
+
+# else /* HAVE_FTIME */
+ struct timeb t;
+
+ ftime(&t);
+ return (fabs(t.time + 1e-3*t.millitm - ElapsedTimeStart));
+
+# endif /* HAVE_FTIME */
+#endif /* not stumped */
+}
+
+static nat
+pagefaults(void)
+{
+# if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS
+ return 0;
+# else
+ struct rusage t;
+
+ getrusage(RUSAGE_SELF, &t);
+ return(t.ru_majflt);
+# endif
+}
+
+/* ToDo: use gettimeofday on systems that support it (u-sec accuracy) */
+
+void
+start_time(void)
+{
+ long ticks;
+ /* Determine TicksPerSecond ... */
+#ifdef HAVE_SYSCONF
+ ticks = sysconf(_SC_CLK_TCK);
+ if ( ticks == -1 ) {
+ fprintf(stderr, "stat_init: bad call to 'sysconf'!\n");
+ stg_exit(EXIT_FAILURE);
+ }
+ TicksPerSecond = (StgDouble) ticks;
+
+#else /* no "sysconf"; had better guess */
+# ifdef HZ
+ TicksPerSecond = (StgDouble) (HZ);
+
+# else /* had better guess wildly */
+ /* We will #ifdef around the fprintf for machines
+ we *know* are unsupported. (WDP 94/05)
+ */
+ fprintf(stderr, "NOTE: Guessing `TicksPerSecond = 60'!\n");
+ TicksPerSecond = 60.0;
+# endif
+#endif
+
+ ElapsedTimeStart = elapsedtime();
+}
+
+
+void
+initStats(void)
+{
+ FILE *sf = RtsFlags.GcFlags.statsFile;
+
+ if (RtsFlags.GcFlags.giveStats) {
+ fprintf(sf, " Alloc Collect Live Resid GC GC TOT TOT Page Flts\n");
+ fprintf(sf, " bytes bytes bytes ency user elap user elap\n");
+ }
+}
+
+
+StgDouble
+usertime(void)
+{
+#if ! (defined(HAVE_GETRUSAGE) || defined(HAVE_TIMES))
+ /* We will #ifdef around the fprintf for machines
+ we *know* are unsupported. (WDP 94/05)
+ */
+ fprintf(stderr, "NOTE: `usertime' does nothing!\n");
+ return 0.0;
+
+#else /* not stumped */
+
+# if defined(HAVE_TIMES)
+ struct tms t;
+
+ times(&t);
+ return(((StgDouble)(t.tms_utime))/TicksPerSecond);
+
+#else /* HAVE_GETRUSAGE */
+ struct rusage t;
+
+ getrusage(RUSAGE_SELF, &t);
+ return(t.ru_utime.tv_sec + 1e-6*t.ru_utime.tv_usec);
+
+# endif /* HAVE_GETRUSAGE */
+#endif /* not stumped */
+}
+
+void
+end_init(void)
+{
+ InitUserTime = usertime();
+ InitElapsedTime = elapsedtime();
+ if (InitElapsedTime < 0.0) {
+ InitElapsedTime = 0.0;
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Called at the beginning of each GC
+ -------------------------------------------------------------------------- */
+
+static nat rub_bell = 0;
+
+void
+stat_startGC(void)
+{
+ FILE *sf = RtsFlags.GcFlags.statsFile;
+
+ nat bell = RtsFlags.GcFlags.ringBell;
+
+ if (bell) {
+ if (bell > 1) {
+ fprintf(stderr, " GC ");
+ rub_bell = 1;
+ } else {
+ fprintf(stderr, "\007");
+ }
+ }
+
+ if (sf != NULL) {
+ GC_start_time = usertime();
+ GCe_start_time = elapsedtime();
+ if (RtsFlags.GcFlags.giveStats) {
+ GC_start_faults = pagefaults();
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Called at the end of each GC
+ -------------------------------------------------------------------------- */
+
+void
+stat_endGC(lnat alloc, lnat collect, lnat live, char *comment)
+{
+ FILE *sf = RtsFlags.GcFlags.statsFile;
+
+ if (sf != NULL) {
+ StgDouble time = usertime();
+ StgDouble etime = elapsedtime();
+
+ if (RtsFlags.GcFlags.giveStats) {
+ nat faults = pagefaults();
+
+ fprintf(sf, "%8ld %7ld %7ld %5.1f%%",
+ alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_), collect == 0 ? 0.0 : (live / (StgDouble) collect * 100));
+ fprintf(sf, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld %s\n",
+ (time-GC_start_time),
+ (etime-GCe_start_time),
+ time,
+ etime,
+ faults - GC_start_faults,
+ GC_start_faults - GC_end_faults,
+ comment);
+
+ GC_end_faults = faults;
+ fflush(sf);
+ }
+
+ GC_maj_no++;
+ GC_tot_alloc += (ullong) alloc;
+ GC_tot_time += time-GC_start_time;
+ GCe_tot_time += etime-GCe_start_time;
+ }
+
+ if (rub_bell) {
+ fprintf(stderr, "\b\b\b \b\b\b");
+ rub_bell = 0;
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Called at the end of execution
+
+ NOTE: number of allocations is not entirely accurate: it doesn't
+ take into account the few bytes at the end of the heap that
+ were left unused when the heap-check failed.
+ -------------------------------------------------------------------------- */
+
+void
+stat_exit(int alloc)
+{
+ FILE *sf = RtsFlags.GcFlags.statsFile;
+
+ if (sf != NULL){
+ char temp[BIG_STRING_LEN];
+ StgDouble time = usertime();
+ StgDouble etime = elapsedtime();
+ StgDouble MutTime, MutElapsedTime;
+
+ /* avoid divide by zero if time is measured as 0.00 seconds -- SDM */
+ if (time == 0.0) time = 0.0001;
+ if (etime == 0.0) etime = 0.0001;
+
+
+ if (RtsFlags.GcFlags.giveStats) {
+ fprintf(sf, "%8d\n\n", alloc*sizeof(W_));
+ }
+
+ else {
+ fprintf(sf, "%8ld %7.7s %6.6s %7.7s %6.6s",
+ (GC_alloc_since_maj + alloc)*sizeof(W_), "", "", "", "");
+ fprintf(sf, " %3ld %5.2f %5.2f\n\n",
+ GC_min_since_maj, GC_min_time, GCe_min_time);
+ }
+ GC_min_no += GC_min_since_maj;
+ GC_tot_time += GC_min_time;
+ GCe_tot_time += GCe_min_time;
+ GC_tot_alloc += GC_alloc_since_maj + alloc;
+ ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s bytes allocated in the heap\n", temp);
+ if ( ResidencySamples > 0 ) {
+ ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
+ temp,
+ MaxResidency / (StgDouble) RtsFlags.GcFlags.maxHeapSize * 100,
+ ResidencySamples);
+ }
+ fprintf(sf, "%11ld garbage collections performed (%ld major, %ld minor)\n\n",
+ GC_maj_no + GC_min_no, GC_maj_no, GC_min_no);
+
+ MutTime = time - GC_tot_time - InitUserTime;
+ if (MutTime < 0) { MutTime = 0; }
+ MutElapsedTime = etime - GCe_tot_time - InitElapsedTime;
+ if (MutElapsedTime < 0) { MutElapsedTime = 0; } /* sometimes -0.00 */
+
+ fprintf(sf, " INIT time %6.2fs (%6.2fs elapsed)\n",
+ InitUserTime, InitElapsedTime);
+ fprintf(sf, " MUT time %6.2fs (%6.2fs elapsed)\n",
+ MutTime, MutElapsedTime);
+ fprintf(sf, " GC time %6.2fs (%6.2fs elapsed)\n",
+ GC_tot_time, GCe_tot_time);
+ fprintf(sf, " Total time %6.2fs (%6.2fs elapsed)\n\n",
+ time, etime);
+
+ fprintf(sf, " %%GC time %5.1f%% (%.1f%% elapsed)\n\n",
+ GC_tot_time*100./time, GCe_tot_time*100./etime);
+
+ if (time - GC_tot_time == 0.0)
+ ullong_format_string(0, temp, rtsTrue/*commas*/);
+ else
+ ullong_format_string((ullong)(GC_tot_alloc*sizeof(W_)/
+ (time - GC_tot_time)),
+ temp, rtsTrue/*commas*/);
+
+ fprintf(sf, " Alloc rate %s bytes per MUT second\n\n", temp);
+
+ fprintf(sf, " Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n",
+ (time - GC_tot_time - InitUserTime) * 100. / time,
+ (time - GC_tot_time - InitUserTime) * 100. / etime);
+ fflush(sf);
+ fclose(sf);
+ }
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Stats.h,v 1.2 1998/12/02 13:28:50 simonm Exp $
+ *
+ * Statistics and timing-related functions.
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern StgDouble elapsedtime(void);
+extern void start_time(void);
+extern StgDouble usertime(void);
+extern void end_init(void);
+extern void stat_exit(int alloc);
+extern void stat_startGC(void);
+extern void stat_endGC(lnat alloc, lnat collect, lnat live,
+ char *comment);
+extern void initStats(void);
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgCRun.c,v 1.2 1998/12/02 13:28:50 simonm Exp $
+ *
+ * STG-to-C glue. Some architectures have this code written in
+ * straight assembler (see StgRun.S), some in C.
+ *
+ * -------------------------------------------------------------------------- */
+
+/* include Stg.h first because we want real machine regs in here: we
+ * have to get the value of R1 back from Stg land to C land intact.
+ */
+#include "Stg.h"
+#include "Rts.h"
+#include "StgRun.h"
+
+#ifdef DEBUG
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "Printer.h"
+#endif
+
+#ifdef USE_MINIINTERPRETER
+
+/* -----------------------------------------------------------------------------
+ any architecture (using miniinterpreter)
+ -------------------------------------------------------------------------- */
+
+/* The static @jmp_environment@ variable allows @miniInterpret@ to
+ * communicate with @StgReturn@.
+ *
+ * Because @StgRun@ may be used recursively, we carefully
+ * save and restore the whole of @jmp_environment@.
+ */
+#include <setjmp.h>
+#include <string.h> /* for memcpy */
+
+static jmp_buf jmp_environment;
+
+extern StgThreadReturnCode StgRun(StgFunPtr f)
+{
+ jmp_buf save_buf;
+ /* Save jmp_environment for previous call to miniInterpret */
+ memcpy((void *) jmp_environment, (void *) save_buf, sizeof(jmp_buf));
+ if (setjmp(jmp_environment) == 0) {
+ while ( 1 ) {
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"Jumping to ");
+ printPtr((P_)f);
+ fprintf(stderr,"\n");
+ );
+ f = (StgFunPtr) (f)();
+ }
+ }
+ /* Restore jmp_environment for previous call */
+ memcpy((void*) save_buf, (void*) jmp_environment, sizeof(jmp_buf));
+
+ return (StgThreadReturnCode)R1.i;
+}
+
+EXTFUN(StgReturn)
+{
+ longjmp(jmp_environment, 1);
+}
+
+#else /* !USE_MINIINTERPRETER */
+
+#ifdef LEADING_UNDERSCORE
+#define STG_RETURN "_StgReturn"
+#else
+#define STG_RETURN "StgReturn"
+#endif
+
+/* -----------------------------------------------------------------------------
+ sparc architecture
+ -------------------------------------------------------------------------- */
+
+#ifdef sparc_TARGET_ARCH
+
+StgThreadReturnCode
+StgRun(StgFunPtr f) {
+
+ StgChar space[RESERVED_C_STACK_BYTES+sizeof(void *)];
+ register void *i7 __asm__("%i7");
+ ((void **)(space))[100] = i7;
+ f();
+ __asm__ volatile (".align 4\n"
+ ".global " STG_RETURN "\n"
+ STG_RETURN ":\n"
+ "\tld %1,%0" : "=r" (i7) : "m" (((void **)(space))[100]));
+ return (StgThreadReturnCode)R1.i;
+}
+
+#endif
+
+/* -----------------------------------------------------------------------------
+ alpha architecture
+ -------------------------------------------------------------------------- */
+
+#ifdef alpha_TARGET_ARCH
+
+StgThreadReturnCode
+StgRun(StgFunPtr f)
+{
+ __asm__ volatile ("stq $9,-8($30)\n\t"
+ "stq $10,-16($30)\n\t"
+ "stq $11,-24($30)\n\t"
+ "stq $12,-32($30)\n\t"
+ "stq $13,-40($30)\n\t"
+ "stq $14,-48($30)\n\t"
+ "stq $15,-56($30)\n\t"
+ "stt $f2,-64($30)\n\t"
+ "stt $f3,-72($30)\n\t"
+ "stt $f4,-80($30)\n\t"
+ "stt $f5,-88($30)\n\t"
+ "stt $f6,-96($30)\n\t"
+ "stt $f7,-104($30)\n\t"
+ "stt $f8,-112($30)\n\t"
+ "stt $f9,-120($30)\n\t"
+ "lda $30,-%0($30)" : :
+ "K" (RESERVED_C_STACK_BYTES+
+ 8*sizeof(double)+8*sizeof(long)));
+
+ f();
+
+ __asm__ volatile (".align 3\n"
+ ".globl " STG_RETURN "\n"
+ STG_RETURN ":\n\t"
+ "lda $30,%0($30)\n\t"
+ "ldq $9,-8($30)\n\t"
+ "ldq $10,-16($30)\n\t"
+ "ldq $11,-24($30)\n\t"
+ "ldq $12,-32($30)\n\t"
+ "ldq $13,-40($30)\n\t"
+ "ldq $14,-48($30)\n\t"
+ "ldq $15,-56($30)\n\t"
+ "ldt $f2,-64($30)\n\t"
+ "ldt $f3,-72($30)\n\t"
+ "ldt $f4,-80($30)\n\t"
+ "ldt $f5,-88($30)\n\t"
+ "ldt $f6,-96($30)\n\t"
+ "ldt $f7,-104($30)\n\t"
+ "ldt $f8,-112($30)\n\t"
+ "ldt $f9,-120($30)" : :
+ "K" (RESERVED_C_STACK_BYTES+
+ 8*sizeof(double)+8*sizeof(long)));
+
+ return (StgThreadReturnCode)R1.i;
+}
+
+#endif /* sparc_TARGET_ARCH */
+
+#endif /* !USE_MINIINTERPRETER */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgLongLong.c,v 1.2 1998/12/02 13:28:51 simonm Exp $
+ *
+ * Primitive operations over (64-bit) long longs
+ * (only used on 32-bit platforms.)
+ *
+ * ---------------------------------------------------------------------------*/
+
+
+/*
+Miscellaneous primitive operations on StgInt64 and StgNat64s.
+
+Instead of going the normal (boring) route of making the list
+of primitive operations even longer to cope with operations
+over 64-bit entities, we implement them instead 'out-of-line'.
+
+The primitive ops get their own routine (in C) that implements
+the operation, requiring the caller to _ccall_ out. This has
+performance implications of course, but we currently don't
+expect intensive use of either Int64 or Word64 types.
+
+The exceptions to the rule are primops that cast to and from
+64-bit entities (these are defined in PrimOps.h)
+
+NOTE: We prefix all these primops with "stg_". No particular
+reason why.
+*/
+
+#include "Rts.h"
+
+#ifdef SUPPORT_LONG_LONGS
+StgInt
+stg_gtWord64(StgNat64 l1, StgNat64 l2)
+{ return ( l1 > l2); }
+
+StgInt
+stg_geWord64(StgNat64 l1, StgNat64 l2)
+{ return ( l1 >= l2); }
+
+StgInt
+stg_eqWord64(StgNat64 l1, StgNat64 l2)
+{ return ( l1 == l2); }
+
+StgInt
+stg_neWord64(StgNat64 l1, StgNat64 l2)
+{ return ( l1 != l2); }
+
+StgInt
+stg_ltWord64(StgNat64 l1, StgNat64 l2)
+{ return ( l1 < l2); }
+
+StgInt
+stg_leWord64(StgNat64 l1, StgNat64 l2)
+{ return ( l1 <= l2); }
+
+/* ------------------ */
+
+StgInt
+stg_gtInt64(StgInt64 l1, StgInt64 l2)
+{ return ( l1 > l2); }
+
+StgInt
+stg_geInt64(StgInt64 l1, StgInt64 l2)
+{ return ( l1 >= l2); }
+
+StgInt
+stg_eqInt64(StgInt64 l1, StgInt64 l2)
+{ return ( l1 == l2); }
+
+StgInt
+stg_neInt64(StgInt64 l1, StgInt64 l2)
+{ return ( l1 != l2); }
+
+StgInt
+stg_ltInt64(StgInt64 l1, StgInt64 l2)
+{ return ( l1 < l2); }
+
+StgInt
+stg_leInt64(StgInt64 l1, StgInt64 l2)
+{ return ( l1 <= l2); }
+
+/* Arithmetic operators */
+
+StgNat64
+stg_remWord64(StgNat64 a, StgNat64 b)
+{ return (a%b); }
+
+StgNat64
+stg_quotWord64(StgNat64 a, StgNat64 b)
+{ return (a/b); }
+
+StgInt64
+stg_remInt64(StgInt64 a, StgInt64 b)
+{ return (a%b); }
+
+StgInt64
+stg_quotInt64(StgInt64 a, StgInt64 b)
+{ return (a/b); }
+
+StgInt64
+stg_negateInt64(StgInt64 a)
+{ return (-a); }
+
+StgInt64
+stg_plusInt64(StgInt64 a, StgInt64 b)
+{ return (a+b); }
+
+StgInt64
+stg_minusInt64(StgInt64 a, StgInt64 b)
+{ return (a-b); }
+
+StgInt64
+stg_timesInt64(StgInt64 a, StgInt64 b)
+{ return (a*b); }
+
+/* Logical operators: */
+
+StgNat64
+stg_and64(StgNat64 a, StgNat64 b)
+{ return (a&b); }
+
+StgNat64
+stg_or64(StgNat64 a, StgNat64 b)
+{ return (a|b); }
+
+StgNat64
+stg_xor64(StgNat64 a, StgNat64 b)
+{ return (a^b); }
+
+StgNat64
+stg_not64(StgNat64 a)
+{ return (~a); }
+
+StgNat64
+stg_shiftL64(StgNat64 a, StgInt b)
+{ return (a << b); }
+
+StgNat64
+stg_shiftRL64(StgNat64 a, StgInt b)
+{ return (a >> b); }
+
+StgInt64
+stg_iShiftL64(StgInt64 a, StgInt b)
+{ return ( a<<b ); }
+
+/* Right shifting of signed quantities is not portable in C, so
+ the behaviour you'll get from using these primops depends
+ on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98
+*/
+
+StgInt64
+stg_iShiftRA64(StgInt64 a, StgInt b)
+{ return ( a>>b ); }
+
+StgInt64
+stg_iShiftRL64(StgInt64 a, StgInt b)
+{ return ( a>>b ); }
+
+/*
+Casting between longs and longer longs:
+(the primops that cast from to/from Integers and long longs are
+expressed as macros, since these may cause some heap allocation).
+*/
+
+StgInt64
+stg_intToInt64(StgInt i)
+{ return ( (StgInt64)i ); }
+
+StgInt
+stg_int64ToInt(StgInt64 i)
+{ return ( (StgInt)i ); }
+
+StgNat64
+stg_int64ToWord64(StgInt64 i)
+{ return ( (StgNat64)i ); }
+
+StgNat64
+stg_wordToWord64(StgWord w)
+{ return ( (StgNat64)w ); }
+
+StgWord
+stg_word64ToWord(StgNat64 w)
+{ return ( (StgWord)w ); }
+
+StgInt64
+stg_word64ToInt64(StgNat64 w)
+{ return ( (StgInt64)w ); }
+
+#endif /* SUPPORT_LONG_LONGS */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgMiscClosures.hc,v 1.2 1998/12/02 13:28:52 simonm Exp $
+ *
+ * Entry code for various built-in closure types.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "StgMiscClosures.h"
+#include "HeapStackCheck.h" /* for stg_gen_yield */
+
+#ifdef HAVE_STDIO_H
+#include <stdio.h>
+#endif
+
+/* -----------------------------------------------------------------------------
+ Entry code for an indirection.
+
+ This code assumes R1 is in a register for now.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(IND_info,IND_entry,1,0,IND,const,EF_,0,0);
+STGFUN(IND_entry)
+{
+ FB_
+ TICK_ENT_IND(Node); /* tick */
+
+ R1.p = (P_) ((StgInd*)R1.p)->indirectee;
+ TICK_ENT_VIA_NODE();
+ JMP_(*R1.p);
+ FE_
+}
+
+INFO_TABLE(IND_STATIC_info,IND_STATIC_entry,1,0,IND_STATIC,const,EF_,0,0);
+STGFUN(IND_STATIC_entry)
+{
+ FB_
+ TICK_ENT_IND(Node); /* tick */
+
+ R1.p = (P_) ((StgIndStatic*)R1.p)->indirectee;
+ TICK_ENT_VIA_NODE();
+ JMP_(*R1.p);
+ FE_
+}
+
+INFO_TABLE(IND_PERM_info,IND_PERM_entry,1,0,IND_PERM,const,EF_,0,0);
+STGFUN(IND_PERM_entry)
+{
+ FB_
+ /* Don't add INDs to granularity cost */
+
+ /* Dont: ENT_IND(Node); for ticky-ticky; this ind is here only to help profi
+ling */
+
+ /* Enter PAP cost centre -- lexical scoping only */
+ ENTER_CCS_PAP_CL(R1.cl);
+
+ R1.p = (P_) ((StgInd*)R1.p)->indirectee;
+
+ /* Dont: TICK_ENT_VIA_NODE(); for ticky-ticky; as above */
+
+ JMP_(*R1.p);
+ FE_
+}
+
+INFO_TABLE(IND_OLDGEN_info,IND_OLDGEN_entry,1,0,IND_OLDGEN,const,EF_,0,0);
+STGFUN(IND_OLDGEN_entry)
+{
+ FB_
+ TICK_ENT_IND(Node); /* tick */
+
+ R1.p = (P_) ((StgInd*)R1.p)->indirectee;
+ TICK_ENT_VIA_NODE();
+ JMP_(*R1.p);
+ FE_
+}
+
+INFO_TABLE(IND_OLDGEN_PERM_info,IND_OLDGEN_PERM_entry,1,0,IND_OLDGEN_PERM,const,EF_,0,0);
+STGFUN(IND_OLDGEN_PERM_entry)
+{
+ FB_
+ TICK_ENT_IND(Node); /* tick */
+
+ R1.p = (P_) ((StgInd*)R1.p)->indirectee;
+ TICK_ENT_VIA_NODE();
+ JMP_(*R1.p);
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Entry code for CAFs
+
+ This code assumes R1 is in a register for now.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(CAF_UNENTERED_info,CAF_UNENTERED_entry,1,2,CAF_UNENTERED,const,EF_,0,0);
+STGFUN(CAF_UNENTERED_entry)
+{
+ FB_
+ /* ToDo: implement directly in GHC */
+ Sp -= 1;
+ Sp[0] = R1.w;
+ JMP_(stg_yield_to_Hugs);
+ FE_
+}
+
+INFO_TABLE(CAF_ENTERED_info,CAF_ENTERED_entry,2,1,CAF_ENTERED,const,EF_,0,0);
+STGFUN(CAF_ENTERED_entry)
+{
+ FB_
+ TICK_ENT_CAF_ENTERED(Node); /* tick */
+
+ R1.p = (P_) ((StgCAF*)R1.p)->value; /* just a fancy indirection */
+ TICK_ENT_VIA_NODE();
+ JMP_(GET_ENTRY(R1.cl));
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Entry code for a black hole.
+
+ Entering a black hole normally causes a cyclic data dependency, but
+ in the concurrent world, black holes are synchronization points,
+ and they are turned into blocking queues when there are threads
+ waiting for the evaluation of the closure to finish.
+ -------------------------------------------------------------------------- */
+
+/* Note: a black hole must be big enough to be overwritten with an
+ * indirection/evacuee/catch. Thus we claim it has 2 non-pointer words of
+ * payload, which should be big enough for an old-generation
+ * indirection.
+ */
+
+INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,0,2,BLACKHOLE,const,EF_,0,0);
+STGFUN(BLACKHOLE_entry)
+{
+ FB_
+ /* Put ourselves on the blocking queue for this black hole */
+ CurrentTSO->link = ((StgBlackHole *)R1.p)->blocking_queue;
+ ((StgBlackHole *)R1.p)->blocking_queue = CurrentTSO;
+
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ BLOCK_NP(1);
+ FE_
+}
+
+/* identical to BLACKHOLEs except for the infotag */
+INFO_TABLE(CAF_BLACKHOLE_info, CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,const,EF_,0,0);
+STGFUN(CAF_BLACKHOLE_entry)
+{
+ FB_
+ /* Put ourselves on the blocking queue for this black hole */
+ CurrentTSO->link = ((StgBlackHole *)R1.p)->blocking_queue;
+ ((StgBlackHole *)R1.p)->blocking_queue = CurrentTSO;
+
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ BLOCK_NP(1);
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ The code for a BCO returns to the scheduler
+ -------------------------------------------------------------------------- */
+INFO_TABLE(BCO_info,BCO_entry,0,0,BCO,const,EF_,0,0);
+EF_(BCO_entry) {
+ FB_
+ Sp -= 1;
+ Sp[0] = R1.w;
+ JMP_(stg_yield_to_Hugs);
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Some static info tables for things that don't get entered, and
+ therefore don't need entry code (i.e. boxed but unpointed objects)
+ -------------------------------------------------------------------------- */
+
+#define NON_ENTERABLE_ENTRY_CODE(type) \
+STGFUN(type##_entry) \
+{ \
+ FB_ \
+ STGCALL1(fflush,stdout); \
+ STGCALL2(fprintf,stderr,#type " object entered!\n"); \
+ STGCALL1(raiseError, errorHandler); \
+ stg_exit(EXIT_FAILURE); /* not executed */ \
+ FE_ \
+}
+
+INFO_TABLE(TSO_info, TSO_entry, 0,0,TSO,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(TSO);
+
+/* -----------------------------------------------------------------------------
+ Evacuees are left behind by the garbage collector. Any attempt to enter
+ one is a real bug.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(EVACUATED_info,EVACUATED_entry,1,0,EVACUATED,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(EVACUATED);
+
+/* -----------------------------------------------------------------------------
+ Weak pointers
+
+ Live weak pointers have a special closure type. Dead ones are just
+ nullary constructors (although they live on the heap - we overwrite
+ live weak pointers with dead ones).
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(WEAK_info,WEAK_entry,0,4,WEAK,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(WEAK);
+
+INFO_TABLE_CONSTR(DEAD_WEAK_info,DEAD_WEAK_entry,0,1,0,CONSTR,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(DEAD_WEAK);
+
+/* -----------------------------------------------------------------------------
+ Foreign Objects are unlifted and therefore never entered.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(FOREIGN_info,FOREIGN_entry,0,1,FOREIGN,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(FOREIGN);
+
+/* -----------------------------------------------------------------------------
+ MVars
+
+ There are two kinds of these: full and empty. We need an info table
+ and entry code for each type.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(FULL_MVAR_info,FULL_MVAR_entry,3,0,MVAR,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(FULL_MVAR);
+
+INFO_TABLE(EMPTY_MVAR_info,EMPTY_MVAR_entry,3,0,MVAR,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(EMPTY_MVAR);
+
+/* -----------------------------------------------------------------------------
+ END_TSO_QUEUE
+
+ This is a static nullary constructor (like []) that we use to mark the
+ end of a linked TSO queue.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(END_TSO_QUEUE_info,END_TSO_QUEUE_entry,0,0,0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(END_TSO_QUEUE);
+
+SET_STATIC_HDR(END_TSO_QUEUE_closure,END_TSO_QUEUE_info,0/*CC*/,const,EI_)
+};
+
+/* -----------------------------------------------------------------------------
+ Arrays
+
+ These come in two basic flavours: arrays of data (StgArrWords) and arrays of
+ pointers (StgArrPtrs). They all have a similar layout:
+
+ ___________________________
+ | Info | No. of | data....
+ | Ptr | Words |
+ ---------------------------
+
+ These are *unpointed* objects: i.e. they cannot be entered.
+
+ -------------------------------------------------------------------------- */
+
+#define ArrayInfo(type) \
+INFO_TABLE(type##_info, type##_entry, 0, 0, type, const, EF_,0,0); \
+NON_ENTERABLE_ENTRY_CODE(type);
+
+ArrayInfo(ARR_WORDS);
+ArrayInfo(MUT_ARR_WORDS);
+ArrayInfo(ARR_PTRS);
+ArrayInfo(MUT_ARR_PTRS);
+ArrayInfo(MUT_ARR_PTRS_FROZEN);
+
+#undef ArrayInfo
+
+/* -----------------------------------------------------------------------------
+ Mutable Variables
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(MUT_VAR_info, MUT_VAR_entry, 1, 0, MUT_VAR, const, EF_, 0, 0);
+NON_ENTERABLE_ENTRY_CODE(MUT_VAR);
+
+/* -----------------------------------------------------------------------------
+ Standard Error Entry.
+
+ This is used for filling in vector-table entries that can never happen,
+ for instance.
+ -------------------------------------------------------------------------- */
+
+STGFUN(stg_error_entry) \
+{ \
+ FB_ \
+ STGCALL1(fflush,stdout); \
+ STGCALL2(fprintf,stderr,"fatal: stg_error_entry"); \
+ STGCALL1(raiseError, errorHandler); \
+ exit(EXIT_FAILURE); /* not executed */ \
+ FE_ \
+}
+
+/* -----------------------------------------------------------------------------
+ Dummy return closure
+
+ Entering this closure will just return to the address on the top of the
+ stack. Useful for getting a thread in a canonical form where we can
+ just enter the top stack word to start the thread. (see deleteThread)
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(dummy_ret_info, dummy_ret_entry, 0, 0, CONSTR_NOCAF_STATIC, const, EF_, 0, 0);
+FN_(dummy_ret_entry)
+{
+ W_ ret_addr;
+ FB_
+ ret_addr = Sp[0];
+ Sp++;
+ JMP_(ENTRY_CODE(ret_addr));
+}
+SET_STATIC_HDR(dummy_ret_closure,dummy_ret_info,CCS_DONTZuCARE,const,EI_)
+};
+
+/* -----------------------------------------------------------------------------
+ Standard Infotables (for use in interpreter)
+ -------------------------------------------------------------------------- */
+
+#ifdef INTERPRETER
+
+STGFUN(Hugs_CONSTR_entry)
+{
+ Sp -= 1;
+ ((StgPtr*)Sp)[0] = R1.p;
+ /* vectored: JMP_(RET_VEC(((StgPtr*)Sp)[1],constrTag(?))); */
+ JMP_(ENTRY_CODE(((StgPtr*)Sp)[1]));
+}
+
+#define RET_BCO_ENTRY_TEMPLATE(label) \
+ IFN_(label) \
+ { \
+ FB_ \
+ Sp -= 1; \
+ ((StgPtr*)Sp)[0] = R1.p; \
+ JMP_(stg_yield_to_Hugs); \
+ FE_ \
+ }
+
+RET_BCO_ENTRY_TEMPLATE(ret_bco_entry );
+RET_BCO_ENTRY_TEMPLATE(ret_bco_0_entry);
+RET_BCO_ENTRY_TEMPLATE(ret_bco_1_entry);
+RET_BCO_ENTRY_TEMPLATE(ret_bco_2_entry);
+RET_BCO_ENTRY_TEMPLATE(ret_bco_3_entry);
+RET_BCO_ENTRY_TEMPLATE(ret_bco_4_entry);
+RET_BCO_ENTRY_TEMPLATE(ret_bco_5_entry);
+RET_BCO_ENTRY_TEMPLATE(ret_bco_6_entry);
+RET_BCO_ENTRY_TEMPLATE(ret_bco_7_entry);
+
+VEC_POLY_INFO_TABLE(ret_bco,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO);
+
+#endif /* INTERPRETER */
+
+#ifndef COMPILER
+
+INFO_TABLE_CONSTR(CZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(IZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(I64Zh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(FZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(DZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(AZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(WZh_con_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR,const,EF_,0,0);
+INFO_TABLE_CONSTR(StablePtr_con_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR,const,EF_,0,0);
+
+/* These might seem redundant but {I,C}Zh_static_info are used in
+ * {INT,CHAR}LIKE and the rest are used in RtsAPI.c
+ */
+INFO_TABLE_CONSTR(CZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgChar),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(IZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(I64Zh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgInt64),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(FZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgFloat),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(DZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgDouble),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(AZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgAddr),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(WZh_static_info,Hugs_CONSTR_entry,0,sizeofW(StgWord),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+INFO_TABLE_CONSTR(StablePtr_static_info,Hugs_CONSTR_entry,0,sizeofW(StgStablePtr),0,CONSTR_NOCAF_STATIC,const,EF_,0,0);
+
+#endif /* !defined(COMPILER) */
+
+/* -----------------------------------------------------------------------------
+ CHARLIKE and INTLIKE closures.
+
+ These are static representations of Chars and small Ints, so that
+ we can remove dynamic Chars and Ints during garbage collection and
+ replace them with references to the static objects.
+ -------------------------------------------------------------------------- */
+
+#define CHARLIKE_HDR(n) \
+ { \
+ STATIC_HDR(CZh_static_info, /* C# */ \
+ CCS_DONTZuCARE), \
+ data : n \
+ }
+
+#define INTLIKE_HDR(n) \
+ { \
+ STATIC_HDR(IZh_static_info, /* I# */ \
+ CCS_DONTZuCARE), \
+ data : n \
+ }
+
+/* put these in the *data* section, since the garbage collector relies
+ * on the fact that static closures live in the data section.
+ */
+
+/* end the name with _closure, to convince the mangler this is a closure */
+
+StgIntCharlikeClosure CHARLIKE_closure[] = {
+ CHARLIKE_HDR(0),
+ CHARLIKE_HDR(1),
+ CHARLIKE_HDR(2),
+ CHARLIKE_HDR(3),
+ CHARLIKE_HDR(4),
+ CHARLIKE_HDR(5),
+ CHARLIKE_HDR(6),
+ CHARLIKE_HDR(7),
+ CHARLIKE_HDR(8),
+ CHARLIKE_HDR(9),
+ CHARLIKE_HDR(10),
+ CHARLIKE_HDR(11),
+ CHARLIKE_HDR(12),
+ CHARLIKE_HDR(13),
+ CHARLIKE_HDR(14),
+ CHARLIKE_HDR(15),
+ CHARLIKE_HDR(16),
+ CHARLIKE_HDR(17),
+ CHARLIKE_HDR(18),
+ CHARLIKE_HDR(19),
+ CHARLIKE_HDR(20),
+ CHARLIKE_HDR(21),
+ CHARLIKE_HDR(22),
+ CHARLIKE_HDR(23),
+ CHARLIKE_HDR(24),
+ CHARLIKE_HDR(25),
+ CHARLIKE_HDR(26),
+ CHARLIKE_HDR(27),
+ CHARLIKE_HDR(28),
+ CHARLIKE_HDR(29),
+ CHARLIKE_HDR(30),
+ CHARLIKE_HDR(31),
+ CHARLIKE_HDR(32),
+ CHARLIKE_HDR(33),
+ CHARLIKE_HDR(34),
+ CHARLIKE_HDR(35),
+ CHARLIKE_HDR(36),
+ CHARLIKE_HDR(37),
+ CHARLIKE_HDR(38),
+ CHARLIKE_HDR(39),
+ CHARLIKE_HDR(40),
+ CHARLIKE_HDR(41),
+ CHARLIKE_HDR(42),
+ CHARLIKE_HDR(43),
+ CHARLIKE_HDR(44),
+ CHARLIKE_HDR(45),
+ CHARLIKE_HDR(46),
+ CHARLIKE_HDR(47),
+ CHARLIKE_HDR(48),
+ CHARLIKE_HDR(49),
+ CHARLIKE_HDR(50),
+ CHARLIKE_HDR(51),
+ CHARLIKE_HDR(52),
+ CHARLIKE_HDR(53),
+ CHARLIKE_HDR(54),
+ CHARLIKE_HDR(55),
+ CHARLIKE_HDR(56),
+ CHARLIKE_HDR(57),
+ CHARLIKE_HDR(58),
+ CHARLIKE_HDR(59),
+ CHARLIKE_HDR(60),
+ CHARLIKE_HDR(61),
+ CHARLIKE_HDR(62),
+ CHARLIKE_HDR(63),
+ CHARLIKE_HDR(64),
+ CHARLIKE_HDR(65),
+ CHARLIKE_HDR(66),
+ CHARLIKE_HDR(67),
+ CHARLIKE_HDR(68),
+ CHARLIKE_HDR(69),
+ CHARLIKE_HDR(70),
+ CHARLIKE_HDR(71),
+ CHARLIKE_HDR(72),
+ CHARLIKE_HDR(73),
+ CHARLIKE_HDR(74),
+ CHARLIKE_HDR(75),
+ CHARLIKE_HDR(76),
+ CHARLIKE_HDR(77),
+ CHARLIKE_HDR(78),
+ CHARLIKE_HDR(79),
+ CHARLIKE_HDR(80),
+ CHARLIKE_HDR(81),
+ CHARLIKE_HDR(82),
+ CHARLIKE_HDR(83),
+ CHARLIKE_HDR(84),
+ CHARLIKE_HDR(85),
+ CHARLIKE_HDR(86),
+ CHARLIKE_HDR(87),
+ CHARLIKE_HDR(88),
+ CHARLIKE_HDR(89),
+ CHARLIKE_HDR(90),
+ CHARLIKE_HDR(91),
+ CHARLIKE_HDR(92),
+ CHARLIKE_HDR(93),
+ CHARLIKE_HDR(94),
+ CHARLIKE_HDR(95),
+ CHARLIKE_HDR(96),
+ CHARLIKE_HDR(97),
+ CHARLIKE_HDR(98),
+ CHARLIKE_HDR(99),
+ CHARLIKE_HDR(100),
+ CHARLIKE_HDR(101),
+ CHARLIKE_HDR(102),
+ CHARLIKE_HDR(103),
+ CHARLIKE_HDR(104),
+ CHARLIKE_HDR(105),
+ CHARLIKE_HDR(106),
+ CHARLIKE_HDR(107),
+ CHARLIKE_HDR(108),
+ CHARLIKE_HDR(109),
+ CHARLIKE_HDR(110),
+ CHARLIKE_HDR(111),
+ CHARLIKE_HDR(112),
+ CHARLIKE_HDR(113),
+ CHARLIKE_HDR(114),
+ CHARLIKE_HDR(115),
+ CHARLIKE_HDR(116),
+ CHARLIKE_HDR(117),
+ CHARLIKE_HDR(118),
+ CHARLIKE_HDR(119),
+ CHARLIKE_HDR(120),
+ CHARLIKE_HDR(121),
+ CHARLIKE_HDR(122),
+ CHARLIKE_HDR(123),
+ CHARLIKE_HDR(124),
+ CHARLIKE_HDR(125),
+ CHARLIKE_HDR(126),
+ CHARLIKE_HDR(127),
+ CHARLIKE_HDR(128),
+ CHARLIKE_HDR(129),
+ CHARLIKE_HDR(130),
+ CHARLIKE_HDR(131),
+ CHARLIKE_HDR(132),
+ CHARLIKE_HDR(133),
+ CHARLIKE_HDR(134),
+ CHARLIKE_HDR(135),
+ CHARLIKE_HDR(136),
+ CHARLIKE_HDR(137),
+ CHARLIKE_HDR(138),
+ CHARLIKE_HDR(139),
+ CHARLIKE_HDR(140),
+ CHARLIKE_HDR(141),
+ CHARLIKE_HDR(142),
+ CHARLIKE_HDR(143),
+ CHARLIKE_HDR(144),
+ CHARLIKE_HDR(145),
+ CHARLIKE_HDR(146),
+ CHARLIKE_HDR(147),
+ CHARLIKE_HDR(148),
+ CHARLIKE_HDR(149),
+ CHARLIKE_HDR(150),
+ CHARLIKE_HDR(151),
+ CHARLIKE_HDR(152),
+ CHARLIKE_HDR(153),
+ CHARLIKE_HDR(154),
+ CHARLIKE_HDR(155),
+ CHARLIKE_HDR(156),
+ CHARLIKE_HDR(157),
+ CHARLIKE_HDR(158),
+ CHARLIKE_HDR(159),
+ CHARLIKE_HDR(160),
+ CHARLIKE_HDR(161),
+ CHARLIKE_HDR(162),
+ CHARLIKE_HDR(163),
+ CHARLIKE_HDR(164),
+ CHARLIKE_HDR(165),
+ CHARLIKE_HDR(166),
+ CHARLIKE_HDR(167),
+ CHARLIKE_HDR(168),
+ CHARLIKE_HDR(169),
+ CHARLIKE_HDR(170),
+ CHARLIKE_HDR(171),
+ CHARLIKE_HDR(172),
+ CHARLIKE_HDR(173),
+ CHARLIKE_HDR(174),
+ CHARLIKE_HDR(175),
+ CHARLIKE_HDR(176),
+ CHARLIKE_HDR(177),
+ CHARLIKE_HDR(178),
+ CHARLIKE_HDR(179),
+ CHARLIKE_HDR(180),
+ CHARLIKE_HDR(181),
+ CHARLIKE_HDR(182),
+ CHARLIKE_HDR(183),
+ CHARLIKE_HDR(184),
+ CHARLIKE_HDR(185),
+ CHARLIKE_HDR(186),
+ CHARLIKE_HDR(187),
+ CHARLIKE_HDR(188),
+ CHARLIKE_HDR(189),
+ CHARLIKE_HDR(190),
+ CHARLIKE_HDR(191),
+ CHARLIKE_HDR(192),
+ CHARLIKE_HDR(193),
+ CHARLIKE_HDR(194),
+ CHARLIKE_HDR(195),
+ CHARLIKE_HDR(196),
+ CHARLIKE_HDR(197),
+ CHARLIKE_HDR(198),
+ CHARLIKE_HDR(199),
+ CHARLIKE_HDR(200),
+ CHARLIKE_HDR(201),
+ CHARLIKE_HDR(202),
+ CHARLIKE_HDR(203),
+ CHARLIKE_HDR(204),
+ CHARLIKE_HDR(205),
+ CHARLIKE_HDR(206),
+ CHARLIKE_HDR(207),
+ CHARLIKE_HDR(208),
+ CHARLIKE_HDR(209),
+ CHARLIKE_HDR(210),
+ CHARLIKE_HDR(211),
+ CHARLIKE_HDR(212),
+ CHARLIKE_HDR(213),
+ CHARLIKE_HDR(214),
+ CHARLIKE_HDR(215),
+ CHARLIKE_HDR(216),
+ CHARLIKE_HDR(217),
+ CHARLIKE_HDR(218),
+ CHARLIKE_HDR(219),
+ CHARLIKE_HDR(220),
+ CHARLIKE_HDR(221),
+ CHARLIKE_HDR(222),
+ CHARLIKE_HDR(223),
+ CHARLIKE_HDR(224),
+ CHARLIKE_HDR(225),
+ CHARLIKE_HDR(226),
+ CHARLIKE_HDR(227),
+ CHARLIKE_HDR(228),
+ CHARLIKE_HDR(229),
+ CHARLIKE_HDR(230),
+ CHARLIKE_HDR(231),
+ CHARLIKE_HDR(232),
+ CHARLIKE_HDR(233),
+ CHARLIKE_HDR(234),
+ CHARLIKE_HDR(235),
+ CHARLIKE_HDR(236),
+ CHARLIKE_HDR(237),
+ CHARLIKE_HDR(238),
+ CHARLIKE_HDR(239),
+ CHARLIKE_HDR(240),
+ CHARLIKE_HDR(241),
+ CHARLIKE_HDR(242),
+ CHARLIKE_HDR(243),
+ CHARLIKE_HDR(244),
+ CHARLIKE_HDR(245),
+ CHARLIKE_HDR(246),
+ CHARLIKE_HDR(247),
+ CHARLIKE_HDR(248),
+ CHARLIKE_HDR(249),
+ CHARLIKE_HDR(250),
+ CHARLIKE_HDR(251),
+ CHARLIKE_HDR(252),
+ CHARLIKE_HDR(253),
+ CHARLIKE_HDR(254),
+ CHARLIKE_HDR(255)
+};
+
+StgIntCharlikeClosure INTLIKE_closure[] = {
+ INTLIKE_HDR(-16), /* MIN_INTLIKE == -16 */
+ INTLIKE_HDR(-15),
+ INTLIKE_HDR(-14),
+ INTLIKE_HDR(-13),
+ INTLIKE_HDR(-12),
+ INTLIKE_HDR(-11),
+ INTLIKE_HDR(-10),
+ INTLIKE_HDR(-9),
+ INTLIKE_HDR(-8),
+ INTLIKE_HDR(-7),
+ INTLIKE_HDR(-6),
+ INTLIKE_HDR(-5),
+ INTLIKE_HDR(-4),
+ INTLIKE_HDR(-3),
+ INTLIKE_HDR(-2),
+ INTLIKE_HDR(-1),
+ INTLIKE_HDR(0),
+ INTLIKE_HDR(1),
+ INTLIKE_HDR(2),
+ INTLIKE_HDR(3),
+ INTLIKE_HDR(4),
+ INTLIKE_HDR(5),
+ INTLIKE_HDR(6),
+ INTLIKE_HDR(7),
+ INTLIKE_HDR(8),
+ INTLIKE_HDR(9),
+ INTLIKE_HDR(10),
+ INTLIKE_HDR(11),
+ INTLIKE_HDR(12),
+ INTLIKE_HDR(13),
+ INTLIKE_HDR(14),
+ INTLIKE_HDR(15),
+ INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */
+};
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgPrimFloat.c,v 1.2 1998/12/02 13:28:53 simonm Exp $
+ *
+ * Miscellaneous support for floating-point primitives
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+/*
+ * Encoding and decoding Doubles. Code based on the HBC code
+ * (lib/fltcode.c).
+ */
+
+#define GMP_BASE 4294967296.0
+#if FLOATS_AS_DOUBLES /* defined in StgTypes.h */
+#define DNBIGIT 1 /* mantissa of a double will fit in one long */
+#else
+#define DNBIGIT 2 /* mantissa of a double will fit in two longs */
+#endif
+#define FNBIGIT 1 /* for float, one long */
+
+#if IEEE_FLOATING_POINT
+#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
+/* DMINEXP is defined in values.h on Linux (for example) */
+#define DHIGHBIT 0x00100000
+#define DMSBIT 0x80000000
+
+#define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
+#define FHIGHBIT 0x00800000
+#define FMSBIT 0x80000000
+#endif
+
+#ifdef WORDS_BIGENDIAN
+#define L 1
+#define H 0
+#else
+#define L 0
+#define H 1
+#endif
+
+#define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
+
+StgDouble
+__encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */
+{
+ StgDouble r;
+ I_ i;
+
+ /* Convert MP_INT to a double; knows a lot about internal rep! */
+ i = __abs(s->_mp_size)-1;
+ if (i < 0) {
+ r = 0.0;
+ } else {
+ for (r = s->_mp_d[i], i--; i >= 0; i--)
+ r = r * GMP_BASE + s->_mp_d[i];
+ }
+
+ /* Now raise to the exponent */
+ if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
+ r = ldexp(r, e);
+
+ /* sign is encoded in the size */
+ if (s->_mp_size < 0)
+ r = -r;
+
+ return r;
+}
+
+#if ! FLOATS_AS_DOUBLES
+StgFloat
+__encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */
+{
+ StgFloat r;
+ I_ i;
+
+ /* Convert MP_INT to a float; knows a lot about internal rep! */
+ for(r = 0.0, i = __abs(s->_mp_size)-1; i >= 0; i--)
+ r = (r * GMP_BASE) + s->_mp_d[i];
+
+ /* Now raise to the exponent */
+ if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
+ r = ldexp(r, e);
+
+ /* sign is encoded in the size */
+ if (s->_mp_size < 0)
+ r = -r;
+
+ return r;
+}
+#endif /* FLOATS_AS_DOUBLES */
+
+/* This only supports IEEE floating point */
+
+void
+__decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl)
+{
+ /* Do some bit fiddling on IEEE */
+ nat low, high; /* assuming 32 bit ints */
+ int sign, iexp;
+ union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
+
+ u.d = dbl; /* grab chunks of the double */
+ low = u.i[L];
+ high = u.i[H];
+
+ /* we know the MP_INT* passed in has size zero, so we realloc
+ no matter what.
+ */
+ man->_mp_alloc = DNBIGIT;
+
+ if (low == 0 && (high & ~DMSBIT) == 0) {
+ man->_mp_size = 0;
+ *exp = 0L;
+ } else {
+ man->_mp_size = DNBIGIT;
+ iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
+ sign = high;
+
+ high &= DHIGHBIT-1;
+ if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
+ high |= DHIGHBIT;
+ else {
+ iexp++;
+ /* A denorm, normalize the mantissa */
+ while (! (high & DHIGHBIT)) {
+ high <<= 1;
+ if (low & DMSBIT)
+ high++;
+ low <<= 1;
+ iexp--;
+ }
+ }
+ *exp = (I_) iexp;
+#if DNBIGIT == 2
+ man->_mp_d[0] = low;
+ man->_mp_d[1] = high;
+#else
+#if DNBIGIT == 1
+ man->_mp_d[0] = ((unsigned long)high) << 32 | (unsigned long)low;
+#else
+ error : error : error : Cannae cope with DNBIGIT
+#endif
+#endif
+ if (sign < 0)
+ man->_mp_size = -man->_mp_size;
+ }
+}
+
+#if ! FLOATS_AS_DOUBLES
+void
+__decodeFloat (MP_INT *man, I_ *exp, StgFloat flt)
+{
+ /* Do some bit fiddling on IEEE */
+ int high, sign; /* assuming 32 bit ints */
+ union { float f; int i; } u; /* assuming 32 bit float and int */
+
+ u.f = flt; /* grab the float */
+ high = u.i;
+
+ /* we know the MP_INT* passed in has size zero, so we realloc
+ no matter what.
+ */
+ man->_mp_alloc = FNBIGIT;
+
+ if ((high & ~FMSBIT) == 0) {
+ man->_mp_size = 0;
+ *exp = 0;
+ } else {
+ man->_mp_size = FNBIGIT;
+ *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
+ sign = high;
+
+ high &= FHIGHBIT-1;
+ if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
+ high |= FHIGHBIT;
+ else {
+ (*exp)++;
+ /* A denorm, normalize the mantissa */
+ while (! (high & FHIGHBIT)) {
+ high <<= 1;
+ (*exp)--;
+ }
+ }
+#if FNBIGIT == 1
+ man->_mp_d[0] = high;
+#else
+ error : error : error : Cannae cope with FNBIGIT
+#endif
+ if (sign < 0)
+ man->_mp_size = -man->_mp_size;
+ }
+}
+#endif /* FLOATS_AS_DOUBLES */
+
+/* Convenient union types for checking the layout of IEEE 754 types -
+ based on defs in GNU libc <ieee754.h>
+*/
+
+union stg_ieee754_flt
+{
+ float f;
+ struct {
+
+#if WORDS_BIGENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:8;
+ unsigned int mantissa:23;
+#else
+ unsigned int mantissa:23;
+ unsigned int exponent:8;
+ unsigned int negative:1;
+#endif
+ } ieee;
+ struct {
+
+#if WORDS_BIGENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:8;
+ unsigned int quiet_nan:1;
+ unsigned int mantissa:22;
+#else
+ unsigned int mantissa:22;
+ unsigned int quiet_nan:1;
+ unsigned int exponent:8;
+ unsigned int negative:1;
+#endif
+ } ieee_nan;
+};
+
+/*
+
+ To recap, here's the representation of a double precision
+ IEEE floating point number:
+
+ sign 63 sign bit (0==positive, 1==negative)
+ exponent 62-52 exponent (biased by 1023)
+ fraction 51-0 fraction (bits to right of binary point)
+*/
+
+union stg_ieee754_dbl
+{
+ double d;
+ struct {
+
+#if WORDS_BIGENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ unsigned int mantissa0:20;
+ unsigned int mantissa1:32;
+#else
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+#endif
+ } ieee;
+ /* This format makes it easier to see if a NaN is a signalling NaN. */
+ struct {
+
+#if WORDS_BIGENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ unsigned int quiet_nan:1;
+ unsigned int mantissa0:19;
+ unsigned int mantissa1:32;
+#else
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:19;
+ unsigned int quiet_nan:1;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+#endif
+ } ieee_nan;
+};
+
+/*
+ * Predicates for testing for extreme IEEE fp values. Used
+ * by the bytecode evaluator and the Prelude.
+ *
+ */
+
+/* In case you don't suppport IEEE, you'll just get dummy defs.. */
+#ifdef IEEE_FLOATING_POINT
+
+StgInt
+isDoubleNaN(d)
+StgDouble d;
+{
+ union stg_ieee754_dbl u;
+
+ u.d = d;
+
+ return (
+ u.ieee.exponent == 2047 /* 2^11 - 1 */ && /* Is the exponent all ones? */
+ (u.ieee.mantissa0 != 0 || u.ieee.mantissa1 != 0)
+ /* and the mantissa non-zero? */
+ );
+}
+
+StgInt
+isDoubleInfinite(d)
+StgDouble d;
+{
+ union stg_ieee754_dbl u;
+
+ u.d = d;
+
+ /* Inf iff exponent is all ones, mantissa all zeros */
+ return (
+ u.ieee.exponent == 2047 /* 2^11 - 1 */ &&
+ u.ieee.mantissa0 == 0 &&
+ u.ieee.mantissa1 == 0
+ );
+}
+
+StgInt
+isDoubleDenormalized(d)
+StgDouble d;
+{
+ union stg_ieee754_dbl u;
+
+ u.d = d;
+
+ /* A (single/double/quad) precision floating point number
+ is denormalised iff:
+ - exponent is zero
+ - mantissa is non-zero.
+ - (don't care about setting of sign bit.)
+
+ */
+ return (
+ u.ieee.exponent == 0 &&
+ (u.ieee.mantissa0 != 0 ||
+ u.ieee.mantissa1 != 0)
+ );
+
+}
+
+StgInt
+isDoubleNegativeZero(d)
+StgDouble d;
+{
+ union stg_ieee754_dbl u;
+
+ u.d = d;
+ /* sign (bit 63) set (only) => negative zero */
+
+ return (
+ u.ieee.negative == 1 &&
+ u.ieee.exponent == 0 &&
+ u.ieee.mantissa0 == 0 &&
+ u.ieee.mantissa1 == 0);
+}
+
+/* Same tests, this time for StgFloats. */
+
+/*
+ To recap, here's the representation of a single precision
+ IEEE floating point number:
+
+ sign 31 sign bit (0 == positive, 1 == negative)
+ exponent 30-23 exponent (biased by 127)
+ fraction 22-0 fraction (bits to right of binary point)
+*/
+
+
+StgInt
+isFloatNaN(f)
+StgFloat f;
+{
+# ifdef FLOATS_AS_DOUBLES
+ return (isDoubleNaN(f));
+# else
+ union stg_ieee754_flt u;
+ u.f = f;
+
+ /* Floating point NaN iff exponent is all ones, mantissa is
+ non-zero (but see below.) */
+ return (
+ u.ieee.exponent == 255 /* 2^8 - 1 */ &&
+ u.ieee.mantissa != 0);
+
+# endif /* !FLOATS_AS_DOUBLES */
+}
+
+StgInt
+isFloatInfinite(f)
+StgFloat f;
+{
+# ifdef FLOATS_AS_DOUBLES
+ return (isDoubleInfinite(f));
+# else
+ union stg_ieee754_flt u;
+ u.f = f;
+
+ /* A float is Inf iff exponent is max (all ones),
+ and mantissa is min(all zeros.) */
+ return (
+ u.ieee.exponent == 255 /* 2^8 - 1 */ &&
+ u.ieee.mantissa == 0);
+# endif /* !FLOATS_AS_DOUBLES */
+}
+
+StgInt
+isFloatDenormalized(f)
+StgFloat f;
+{
+# ifdef FLOATS_AS_DOUBLES
+ return (isDoubleDenormalized(f));
+# else
+ union stg_ieee754_flt u;
+ u.f = f;
+
+ /* A (single/double/quad) precision floating point number
+ is denormalised iff:
+ - exponent is zero
+ - mantissa is non-zero.
+ - (don't care about setting of sign bit.)
+
+ */
+ return (
+ u.ieee.exponent == 0 &&
+ u.ieee.mantissa != 0);
+#endif /* !FLOATS_AS_DOUBLES */
+}
+
+StgInt
+isFloatNegativeZero(f)
+StgFloat f;
+{
+#ifdef FLOATS_AS_DOUBLES
+ return (isDoubleNegativeZero(f));
+# else
+ union stg_ieee754_flt u;
+ u.f = f;
+
+ /* sign (bit 31) set (only) => negative zero */
+ return (
+ u.ieee.negative &&
+ u.ieee.exponent == 0 &&
+ u.ieee.mantissa == 0);
+# endif /* !FLOATS_AS_DOUBLES */
+}
+
+#else /* ! IEEE_FLOATING_POINT */
+
+/* Dummy definitions of predicates - they all return false */
+StgInt isDoubleNaN(d) StgDouble d; { return 0; }
+StgInt isDoubleInfinite(d) StgDouble d; { return 0; }
+StgInt isDoubleDenormalized(d) StgDouble d; { return 0; }
+StgInt isDoubleNegativeZero(d) StgDouble d; { return 0; }
+StgInt isFloatNaN(f) StgFloat f; { return 0; }
+StgInt isFloatInfinite(f) StgFloat f; { return 0; }
+StgInt isFloatDenormalized(f) StgFloat f; { return 0; }
+StgInt isFloatNegativeZero(f) StgFloat f; { return 0; }
+
+#endif /* ! IEEE_FLOATING_POINT */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgRun.h,v 1.2 1998/12/02 13:28:54 simonm Exp $
+ *
+ * Tiny assembler 'layer' between the C and STG worlds.
+ *
+ ---------------------------------------------------------------------------- */
+
+#ifndef STGRUN_H
+#define STGRUN_H
+
+#include "Storage.h" /* for {Open,Close}Nursery functions */
+
+extern StgThreadReturnCode StgRun(StgFunPtr f);
+EXTFUN(StgReturn);
+
+#endif STGRUN_H
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgStartup.h,v 1.2 1998/12/02 13:28:54 simonm Exp $
+ *
+ * Code for starting, stopping and restarting threads.
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern const StgPolyInfoTable stg_stop_thread_info;
+EXTFUN(stg_stop_thread_entry);
+EXTFUN(stg_returnToStackTop);
+EXTFUN(stg_enterStackTop);
+
+#ifdef PROFILING
+EXTFUN(stg_register_ret);
+EXTFUN(stg_register);
+EXTFUN(regPrelGHC);
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgStartup.hc,v 1.2 1998/12/02 13:28:55 simonm Exp $
+ *
+ * Code for starting, stopping and restarting threads.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "StgRun.h" /* StgReturn */
+#include "StgStartup.h"
+
+/*
+ * This module contains the two entry points and the final exit point
+ * to/from the Haskell world. We can enter either by:
+ *
+ * a) returning to the address on the top of the stack, or
+ * b) entering the closure on the top of the stack
+ *
+ * the function stg_stop_thread_entry is the final exit for a
+ * thread: it is the last return address on the stack. It returns
+ * to the scheduler marking the thread as finished.
+ */
+
+#define CHECK_SENSIBLE_REGS() \
+ ASSERT(Hp != (P_)0); \
+ ASSERT(Sp != (P_)0); \
+ ASSERT(Su != (StgUpdateFrame *)0); \
+ ASSERT(SpLim != (P_)0); \
+ ASSERT(HpLim != (P_)0); \
+ ASSERT(Sp <= (P_)Su); \
+ ASSERT(SpLim - RESERVED_STACK_WORDS <= Sp); \
+ ASSERT(HpLim >= Hp);
+
+/* -----------------------------------------------------------------------------
+ Returning from the STG world.
+
+ This is a polymorphic return address, meaning that any old constructor
+ can be returned, we don't care (actually, it's probably going to be
+ an IOok constructor, which will indirect through the vector table
+ slot 0).
+ -------------------------------------------------------------------------- */
+
+EXTFUN(stg_stop_thread_entry);
+
+#ifdef PROFILING
+#define STOP_THREAD_BITMAP 1
+#else
+#define STOP_THREAD_BITMAP 0
+#endif
+
+/* VEC_POLY_INFO expects to see these names - but they should all be the same. */
+#define stg_stop_thread_0_entry stg_stop_thread_entry
+#define stg_stop_thread_1_entry stg_stop_thread_entry
+#define stg_stop_thread_2_entry stg_stop_thread_entry
+#define stg_stop_thread_3_entry stg_stop_thread_entry
+#define stg_stop_thread_4_entry stg_stop_thread_entry
+#define stg_stop_thread_5_entry stg_stop_thread_entry
+#define stg_stop_thread_6_entry stg_stop_thread_entry
+#define stg_stop_thread_7_entry stg_stop_thread_entry
+
+VEC_POLY_INFO_TABLE(stg_stop_thread,STOP_THREAD_BITMAP,0,0,0,STOP_FRAME);
+
+STGFUN(stg_stop_thread_entry)
+{
+ FB_
+
+ /*
+ * The final exit.
+ *
+ * The top-top-level closures (e.g., "main") are of type "IO a".
+ * When entered, they perform an IO action and return an 'a' in R1.
+ *
+ * We save R1 on top of the stack where the scheduler can find it,
+ * tidy up the registers and return to the scheduler.
+ */
+
+ /* Move Su just off the end of the stack, we're about to spam the
+ * STOP_FRAME with the return value.
+ */
+ Su = stgCast(StgUpdateFrame*,Sp+1);
+ *stgCast(StgClosure**,Sp) = R1.cl;
+
+ SaveThreadState(); /* inline! */
+
+ /* R1 contains the return value of the thread */
+ R1.p = (P_)ThreadFinished;
+
+ JMP_(StgReturn);
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Start a thread from the scheduler by returning to the address on
+ the top of the stack (and popping the address). This is used for
+ returning to the slow entry point of a function after a garbage collection
+ or re-schedule. The slow entry point expects the stack to contain the
+ pending arguments only.
+ -------------------------------------------------------------------------- */
+
+STGFUN(stg_returnToStackTop)
+{
+ FB_
+ LoadThreadState();
+ CHECK_SENSIBLE_REGS();
+ Sp++;
+ JMP_(Sp[-1]);
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Start a thread from the scheduler by entering the closure pointed
+ to by the word on the top of the stack.
+ -------------------------------------------------------------------------- */
+
+STGFUN(stg_enterStackTop)
+{
+ FB_
+ LoadThreadState();
+ CHECK_SENSIBLE_REGS();
+ /* don't count this enter for ticky-ticky profiling */
+ R1.p = (P_)Sp[0];
+ Sp++;
+ JMP_(GET_ENTRY(R1.cl));
+ FE_
+}
+
+
+/* -----------------------------------------------------------------------------
+ Special STG entry points for module registration.
+ -------------------------------------------------------------------------- */
+
+#ifdef PROFILING
+
+STGFUN(stg_register_ret)
+{
+ FB_
+ JMP_(StgReturn);
+ FE_
+}
+
+STGFUN(stg_register)
+{
+ EF_(_regMain);
+ EF_(_regPrelude);
+ FB_
+ PUSH_REGISTER_STACK(stg_register_ret);
+ PUSH_REGISTER_STACK(_regPrelude);
+ JMP_(_regMain);
+ FE_
+}
+
+/* PrelGHC doesn't really exist... */
+
+START_REGISTER_CCS(_regPrelGHC);
+END_REGISTER_CCS();
+
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StgStdThunks.hc,v 1.2 1998/12/02 13:28:56 simonm Exp $
+ *
+ * Canned "Standard Form" Thunks
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Stg.h"
+
+/* -----------------------------------------------------------------------------
+ The code for a thunk that simply extracts a field from a
+ single-constructor datatype depends only on the offset of the field
+ to be selected.
+
+ Here we define some canned "selector" thunks that do just that; any
+ selector thunk appearing in a program will refer to one of these
+ instead of being compiled independently.
+
+ The garbage collector spots selector thunks and reduces them if
+ possible, in order to avoid space leaks resulting from lazy pattern
+ matching.
+ -------------------------------------------------------------------------- */
+
+#define UPD_FRAME_SIZE (sizeofW(StgUpdateFrame)+sizeofW(StgHeader))
+#define NOUPD_FRAME_SIZE (sizeofW(StgHeader))
+
+#ifdef PROFILING
+#define SAVE_CCCS(fs) CCS_HDR(Sp-fs)=CCCS
+#define GET_SAVED_CCCS RESTORE_CCCS(CCS_HDR(Sp))
+#define RET_BITMAP 1
+#else
+#define SAVE_CCCS(fs) /* empty */
+#define GET_SAVED_CCCS /* empty */
+#define RET_BITMAP 0
+#endif
+
+#define SELECTOR_CODE_UPD(offset) \
+ IF_(__sel_ret_##offset##_upd_ret); \
+ INFO_TABLE_SRT_BITMAP(__sel_ret_##offset##_upd_info,__sel_ret_##offset##_upd_ret, RET_BITMAP, 0, 0, 0, RET_SMALL, static const, IF_, 0, 0); \
+ IF_(__sel_ret_##offset##_upd_ret) { \
+ FB_ \
+ R1.p=(P_)R1.cl->payload[offset]; \
+ GET_SAVED_CCCS; \
+ Sp=Sp+sizeofW(StgHeader); \
+ JMP_(ENTRY_CODE(*R1.p)); \
+ FE_ \
+ } \
+ \
+ EF_(__sel_##offset##_upd_entry); \
+ INFO_TABLE_SELECTOR(__sel_##offset##_upd_info, __sel_##offset##_upd_entry, offset, const, EF_, 0,0);\
+ EF_(__sel_##offset##_upd_entry) { \
+ FB_ \
+ STK_CHK_NP(UPD_FRAME_SIZE,1,); \
+ UPD_BH_UPDATABLE(R1.p); \
+ PUSH_UPD_FRAME(R1.p,0); \
+ SAVE_CCCS(UPD_FRAME_SIZE); \
+ Sp[-UPD_FRAME_SIZE]=(W_)__sel_ret_##offset##_upd_ret; \
+ R1.p = (P_)R1.cl->payload[0]; \
+ Sp=Sp-UPD_FRAME_SIZE; \
+ JMP_(ENTRY_CODE(*R1.p)); \
+ FE_ \
+ }
+
+SELECTOR_CODE_UPD(0);
+SELECTOR_CODE_UPD(1);
+SELECTOR_CODE_UPD(2);
+SELECTOR_CODE_UPD(3);
+SELECTOR_CODE_UPD(4);
+SELECTOR_CODE_UPD(5);
+SELECTOR_CODE_UPD(6);
+SELECTOR_CODE_UPD(7);
+SELECTOR_CODE_UPD(8);
+SELECTOR_CODE_UPD(9);
+SELECTOR_CODE_UPD(10);
+SELECTOR_CODE_UPD(11);
+SELECTOR_CODE_UPD(12);
+SELECTOR_CODE_UPD(13);
+SELECTOR_CODE_UPD(14);
+SELECTOR_CODE_UPD(15);
+
+#define SELECTOR_CODE_NOUPD(offset) \
+ IF_(__sel_ret_##offset##_noupd_ret); \
+ INFO_TABLE_SRT_BITMAP(__sel_ret_##offset##_noupd_info, __sel_ret_##offset##_noupd_ret, RET_BITMAP, 0, 0, 0, RET_SMALL, static const, IF_, 0, 0); \
+ IF_(__sel_ret_##offset##_noupd_ret) { \
+ FB_ \
+ R1.p=(P_)R1.cl->payload[offset]; \
+ GET_SAVED_CCCS; \
+ Sp=Sp+sizeofW(StgHeader); \
+ JMP_(ENTRY_CODE(*R1.p)); \
+ FE_ \
+ } \
+ \
+ EF_(__sel_##offset##_noupd_entry); \
+ INFO_TABLE_SELECTOR(__sel_##offset##_noupd_info, __sel_##offset##_noupd_entry, offset, const, EF_, 0,0);\
+ EF_(__sel_##offset##_noupd_entry) { \
+ FB_ \
+ STK_CHK_NP(NOUPD_FRAME_SIZE,1,) \
+ SAVE_CCCS(NOUPD_FRAME_SIZE); \
+ Sp[-NOUPD_FRAME_SIZE]=(W_)__sel_ret_##offset##_noupd_ret; \
+ R1.p = (P_)R1.cl->payload[0]; \
+ Sp=Sp-NOUPD_FRAME_SIZE; \
+ JMP_(ENTRY_CODE(*R1.p)); \
+ FE_ \
+ }
+
+SELECTOR_CODE_NOUPD(0);
+SELECTOR_CODE_NOUPD(1);
+SELECTOR_CODE_NOUPD(2);
+SELECTOR_CODE_NOUPD(3);
+SELECTOR_CODE_NOUPD(4);
+SELECTOR_CODE_NOUPD(5);
+SELECTOR_CODE_NOUPD(6);
+SELECTOR_CODE_NOUPD(7);
+SELECTOR_CODE_NOUPD(8);
+SELECTOR_CODE_NOUPD(9);
+SELECTOR_CODE_NOUPD(10);
+SELECTOR_CODE_NOUPD(11);
+SELECTOR_CODE_NOUPD(12);
+SELECTOR_CODE_NOUPD(13);
+SELECTOR_CODE_NOUPD(14);
+SELECTOR_CODE_NOUPD(15);
+
+/* -----------------------------------------------------------------------------
+ Apply thunks
+
+ An apply thunk is a thunk of the form
+
+ let z = [x1...xn] \u x1...xn
+ in ...
+
+ We pre-compile some of these because the code is always the same.
+
+ These have to be independent of the update frame size, so the code
+ works when profiling etc.
+ -------------------------------------------------------------------------- */
+
+FN_(__ap_1_upd_entry);
+FN_(__ap_2_upd_entry);
+FN_(__ap_3_upd_entry);
+FN_(__ap_4_upd_entry);
+FN_(__ap_5_upd_entry);
+FN_(__ap_6_upd_entry);
+FN_(__ap_7_upd_entry);
+FN_(__ap_8_upd_entry);
+
+/* __ap_1_upd_info is a bit redundant, but there appears to be a bug
+ * in the compiler that means __ap_1 is generated occasionally (ToDo)
+ */
+
+INFO_TABLE_SRT(__ap_1_upd_info,__ap_1_upd_entry,1,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_1_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame),1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp = Sp - sizeofW(StgUpdateFrame);
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+INFO_TABLE_SRT(__ap_2_upd_info,__ap_2_upd_entry,2,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_2_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+1,1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[1]);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp = Sp - (sizeofW(StgUpdateFrame)+1);
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+INFO_TABLE_SRT(__ap_3_upd_info,__ap_3_upd_entry,3,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_3_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+2,1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[2]);
+ Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[1]);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp = Sp - (sizeofW(StgUpdateFrame)+2);
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+INFO_TABLE_SRT(__ap_4_upd_info,__ap_4_upd_entry,4,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_4_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+3,1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[3]);
+ Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[2]);
+ Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[1]);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp = Sp - (sizeofW(StgUpdateFrame)+3);
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+INFO_TABLE_SRT(__ap_5_upd_info,__ap_5_upd_entry,5,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_5_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+4,1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[4]);
+ Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[3]);
+ Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[2]);
+ Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[1]);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp = Sp - (sizeofW(StgUpdateFrame)+4);
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+INFO_TABLE_SRT(__ap_6_upd_info,__ap_6_upd_entry,6,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_6_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+5,1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[5]);
+ Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[4]);
+ Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[3]);
+ Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[2]);
+ Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[1]);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp = Sp - (sizeofW(StgUpdateFrame)+5);
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+INFO_TABLE_SRT(__ap_7_upd_info,__ap_7_upd_entry,7,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_7_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+6,1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[6]);
+ Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[5]);
+ Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[4]);
+ Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[3]);
+ Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[2]);
+ Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[1]);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp = Sp - (sizeofW(StgUpdateFrame)+6);
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+INFO_TABLE_SRT(__ap_8_upd_info,__ap_8_upd_entry,8,0,0,0,0,THUNK, const,EF_,0,0);
+FN_(__ap_8_upd_entry) {
+ FB_
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+7,1,);
+ UPD_BH_UPDATABLE(R1.p);
+ PUSH_UPD_FRAME(R1.p,0);
+ Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[7]);
+ Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[6]);
+ Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[5]);
+ Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[4]);
+ Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[3]);
+ Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[2]);
+ Sp[-UF_SIZE-7]=(W_)(R1.cl->payload[1]);
+ R1.p=(P_)(R1.cl->payload[0]);
+ Sp=Sp-10;
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Storage.c,v 1.2 1998/12/02 13:28:57 simonm Exp $
+ *
+ * Storage manager front end
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+#include "Stats.h"
+#include "Hooks.h"
+#include "BlockAlloc.h"
+#include "gmp.h"
+#include "Weak.h"
+
+#include "Storage.h"
+#include "StoragePriv.h"
+
+bdescr *nursery; /* chained-blocks in the nursery */
+bdescr *current_nursery; /* next available nursery block, or NULL */
+nat nursery_blocks; /* number of blocks in the nursery */
+
+StgClosure *caf_list = NULL;
+
+bdescr *small_alloc_list; /* allocate()d small objects */
+bdescr *large_alloc_list; /* allocate()d large objects */
+nat alloc_blocks; /* number of allocate()d blocks since GC */
+nat alloc_blocks_lim; /* approximate limit on alloc_blocks */
+
+StgPtr alloc_Hp = NULL; /* next free byte in small_alloc_list */
+StgPtr alloc_HpLim = NULL; /* end of block at small_alloc_list */
+
+/*
+ * Forward references
+ */
+static void *stgAllocForGMP (size_t size_in_bytes);
+static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
+static void stgDeallocForGMP (void *ptr, size_t size);
+
+void
+initStorage (void)
+{
+ initBlockAllocator();
+
+ nursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
+
+ weak_ptr_list = NULL;
+ caf_list = NULL;
+
+ /* initialise the allocate() interface */
+ small_alloc_list = NULL;
+ large_alloc_list = NULL;
+ alloc_blocks = 0;
+ alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize;
+
+#ifdef COMPILER
+ /* Tell GNU multi-precision pkg about our custom alloc functions */
+ mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
+#endif
+}
+
+bdescr *
+allocNursery (bdescr *last_bd, nat blocks)
+{
+ bdescr *bd;
+ nat i;
+
+ /* Allocate a nursery */
+ for (i=0; i < blocks; i++) {
+ bd = allocBlock();
+ bd->link = last_bd;
+ bd->step = 0;
+ bd->free = bd->start;
+ last_bd = bd;
+ }
+ nursery_blocks = blocks;
+ current_nursery = last_bd;
+ return last_bd;
+}
+
+void
+exitStorage (void)
+{
+ lnat allocated;
+ bdescr *bd;
+
+ /* Return code ignored for now */
+ /* ToDo: allocation figure is slightly wrong (see also GarbageCollect()) */
+ allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
+ for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
+ allocated -= BLOCK_SIZE_W;
+ }
+ stat_exit(allocated);
+}
+
+void
+newCAF(StgClosure* caf)
+{
+ const StgInfoTable *info = get_itbl(caf);
+
+ ASSERT(info->type == IND_STATIC);
+ STATIC_LINK2(info,caf) = caf_list;
+ caf_list = caf;
+}
+
+/* -----------------------------------------------------------------------------
+ The allocate() interface
+
+ allocate(n) always succeeds, and returns a chunk of memory n words
+ long. n can be larger than the size of a block if necessary, in
+ which case a contiguous block group will be allocated.
+ -------------------------------------------------------------------------- */
+
+StgPtr
+allocate(nat n)
+{
+ bdescr *bd;
+ StgPtr p;
+
+ TICK_ALLOC_PRIM(n,wibble,wibble,wibble)
+ CCS_ALLOC(CCCS,n);
+
+ /* big allocation (>LARGE_OBJECT_THRESHOLD) */
+ if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
+ nat req_blocks = (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
+ bd = allocGroup(req_blocks);
+ bd->link = large_alloc_list;
+ bd->back = NULL;
+ if (large_alloc_list) {
+ large_alloc_list->back = bd; /* double-link the list */
+ }
+ large_alloc_list = bd;
+ bd->step = 0;
+ /* don't add these blocks to alloc_blocks, since we're assuming
+ * that large objects are likely to remain live for quite a while
+ * (eg. running threads), so garbage collecting early won't make
+ * much difference.
+ */
+ return bd->start;
+
+ /* small allocation (<LARGE_OBJECT_THRESHOLD) */
+ } else if (small_alloc_list == NULL || alloc_Hp + n > alloc_HpLim) {
+ if (small_alloc_list) {
+ small_alloc_list->free = alloc_Hp;
+ }
+ bd = allocBlock();
+ bd->link = small_alloc_list;
+ small_alloc_list = bd;
+ bd->step = 0;
+ alloc_Hp = bd->start;
+ alloc_HpLim = bd->start + BLOCK_SIZE_W;
+ alloc_blocks++;
+ }
+
+ p = alloc_Hp;
+ alloc_Hp += n;
+ return p;
+}
+
+lnat allocated_bytes(void)
+{
+ return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
+}
+
+/* -----------------------------------------------------------------------------
+ Allocation functions for GMP.
+
+ These all use the allocate() interface - we can't have any garbage
+ collection going on during a gmp operation, so we use allocate()
+ which always succeeds. The gmp operations which might need to
+ allocate will ask the storage manager (via doYouWantToGC()) whether
+ a garbage collection is required, in case we get into a loop doing
+ only allocate() style allocation.
+ -------------------------------------------------------------------------- */
+
+static void *
+stgAllocForGMP (size_t size_in_bytes)
+{
+ StgArrWords* arr;
+ nat data_size_in_words, total_size_in_words;
+
+ /* should be a multiple of sizeof(StgWord) (whole no. of limbs) */
+ ASSERT(size_in_bytes % sizeof(W_) == 0);
+
+ data_size_in_words = size_in_bytes / sizeof(W_);
+ total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
+
+ /* allocate and fill it in. */
+ arr = (StgArrWords *)allocate(total_size_in_words);
+ SET_ARR_HDR(arr, &ARR_WORDS_info, CCCS, data_size_in_words);
+
+ /* and return a ptr to the goods inside the array */
+ return(BYTE_ARR_CTS(arr));
+}
+
+static void *
+stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
+{
+ void *new_stuff_ptr = stgAllocForGMP(new_size);
+ nat i = 0;
+ char *p = (char *) ptr;
+ char *q = (char *) new_stuff_ptr;
+
+ for (; i < old_size; i++, p++, q++) {
+ *q = *p;
+ }
+
+ return(new_stuff_ptr);
+}
+
+static void
+stgDeallocForGMP (void *ptr STG_UNUSED,
+ size_t size STG_UNUSED)
+{
+ /* easy for us: the garbage collector does the dealloc'n */
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Storage.h,v 1.2 1998/12/02 13:28:58 simonm Exp $
+ *
+ * External Storage Manger Interface
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STORAGE_H
+#define STORAGE_H
+
+#include "Block.h"
+#include "BlockAlloc.h"
+#include "StoragePriv.h"
+
+/* -----------------------------------------------------------------------------
+ Initialisation / De-initialisation
+ -------------------------------------------------------------------------- */
+
+extern void initStorage(void);
+extern void exitStorage(void);
+
+/* -----------------------------------------------------------------------------
+ Generic allocation
+
+ StgPtr allocate(int n) Allocates a chunk of contiguous store
+ n words long, returning a pointer to
+ the first word. Always succeeds.
+
+ rtsBool doYouWantToGC(void) Returns True if the storage manager is
+ ready to perform a GC, False otherwise.
+
+ lnat allocated_bytes(void) Returns the number of bytes allocated
+ via allocate() since the last GC.
+ Used in the reoprting of statistics.
+ -------------------------------------------------------------------------- */
+
+extern StgPtr allocate(nat n);
+static inline rtsBool doYouWantToGC(void)
+{
+ return (alloc_blocks >= alloc_blocks_lim);
+}
+extern lnat allocated_bytes(void);
+
+/* -----------------------------------------------------------------------------
+ ExtendNursery(hp,hplim) When hplim is reached, try to grab
+ some more allocation space. Returns
+ False if the allocation space is
+ exhausted, and the application should
+ call GarbageCollect().
+ -------------------------------------------------------------------------- */
+
+#define ExtendNursery(hp,hplim) \
+ (current_nursery->free = (P_)(hp)+1, \
+ current_nursery->link == NULL ? rtsFalse : \
+ (current_nursery = current_nursery->link, \
+ OpenNursery(hp,hplim), \
+ rtsTrue))
+
+extern void PleaseStopAllocating(void);
+
+/* -----------------------------------------------------------------------------
+ Performing Garbage Collection
+
+ GarbageCollect(get_roots) Performs a garbage collection.
+ 'get_roots' is called to find all the
+ roots that the system knows about.
+
+ StgClosure Called by get_roots on each root.
+ MarkRoot(StgClosure *p) Returns the new location of the root.
+ -------------------------------------------------------------------------- */
+
+extern void GarbageCollect(void (*get_roots)(void));
+extern StgClosure *MarkRoot(StgClosure *p);
+
+/* -----------------------------------------------------------------------------
+ Generational garbage collection support
+
+ RecordMutable(StgPtr p) Informs the garbage collector that a
+ previously immutable object has
+ become (permanently) mutable. Used
+ by thawArray and similar.
+
+ UpdateWithIndirection(p1,p2) Updates the object at p1 with an
+ indirection pointing to p2. This is
+ normally called for objects in an old
+ generation (>0) when they are updated.
+
+ -------------------------------------------------------------------------- */
+
+extern void RecordMutable(StgPtr p);
+extern void UpdateWithIndirection(StgPtr p1, StgPtr p2);
+
+/* -----------------------------------------------------------------------------
+ The CAF list - used to let us revert CAFs
+
+ -------------------------------------------------------------------------- */
+
+StgCAF* enteredCAFs;
+
+#endif STORAGE_H
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StoragePriv.h,v 1.2 1998/12/02 13:28:59 simonm Exp $
+ *
+ * Internal Storage Manger Interface
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern bdescr *allocNursery (bdescr *last_bd, nat blocks);
+extern void newCAF(StgClosure*);
+extern StgTSO *relocate_TSO(StgTSO *src, StgTSO *dest);
+
+extern StgWeak *weak_ptr_list;
+extern StgClosure *caf_list;
+
+extern bdescr *small_alloc_list;
+extern bdescr *large_alloc_list;
+
+extern StgPtr alloc_Hp;
+extern StgPtr alloc_HpLim;
+
+extern bdescr *nursery;
+
+extern nat nursery_blocks;
+extern nat alloc_blocks;
+extern nat alloc_blocks_lim;
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Updates.hc,v 1.2 1998/12/02 13:29:00 simonm Exp $
+ *
+ * Code to perform updates.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "HeapStackCheck.h"
+
+/*
+ The update frame return address must be *polymorphic*, that means
+ we have to cope with both vectored and non-vectored returns. This
+ is done by putting the return vector right before the info table, and
+ having a standard direct return address after the info table (pointed
+ to by the return address itself, as usual).
+
+ Each entry in the vector table points to a specialised entry code fragment
+ that knows how to return after doing the update. It would be possible to
+ use a single generic piece of code that simply entered the return value
+ to return, but it's quicker this way. The direct return code of course
+ just does another direct return when it's finished.
+
+ Why is there necessarily an activation underneath us on the stack?
+ Because if we're returning, that means we've got a constructor in
+ our hands. If there were any arguments to be applied to it, that
+ would be a type error. We don't ever return a PAP to an update frame,
+ the update is handled manually by stg_update_PAP.
+*/
+
+/* on entry to the update code
+ (1) R1 points to the closure being returned
+ (2) R2 contains the tag (if we returned directly, non-vectored)
+ (3) Sp points to the update frame
+ */
+
+/* Why updatee is placed in a temporary variable here: this helps
+ gcc's aliasing by indicating that the location of the updatee
+ doesn't change across assignments. Saves one instruction in the
+ update code.
+ */
+
+#define UPD_FRAME_ENTRY_TEMPLATE(label,ret) \
+ STGFUN(label); \
+ STGFUN(label) \
+ { \
+ StgClosure *updatee; \
+ FB_ \
+ /* tick - ToDo: check this is right */ \
+ TICK_UPD_EXISTING(); \
+ \
+ updatee = ((StgUpdateFrame *)Sp)->updatee; \
+ \
+ /* update the updatee with an indirection to the return value */\
+ UPD_IND(updatee,R1.p); \
+ \
+ /* reset Su to the next update frame */ \
+ Su = ((StgUpdateFrame *)Sp)->link; \
+ \
+ /* remove the update frame from the stack */ \
+ Sp += sizeofW(StgUpdateFrame); \
+ \
+ JMP_(ret); \
+ FE_ \
+ }
+
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_entry,ENTRY_CODE(Sp[0]));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_0_entry,RET_VEC(Sp[0],0));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_1_entry,RET_VEC(Sp[0],1));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_2_entry,RET_VEC(Sp[0],2));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_3_entry,RET_VEC(Sp[0],3));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_4_entry,RET_VEC(Sp[0],4));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_5_entry,RET_VEC(Sp[0],5));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_6_entry,RET_VEC(Sp[0],6));
+UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_7_entry,RET_VEC(Sp[0],7));
+
+
+/*
+ Make sure this table is big enough to handle the maximum vectored
+ return size!
+ */
+
+#ifdef PROFILING
+#define UPD_FRAME_BITMAP 3
+#else
+#define UPD_FRAME_BITMAP 1
+#endif
+
+/* this bitmap indicates that the first word of an update frame is a
+ * non-pointer - this is the update frame link. (for profiling,
+ * there's a cost-centre-stack in there too).
+ */
+
+VEC_POLY_INFO_TABLE(Upd_frame,UPD_FRAME_BITMAP, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, UPDATE_FRAME);
+
+/* -----------------------------------------------------------------------------
+ Entry Code for a PAP.
+
+ The idea is to copy the chunk of stack from the PAP object and then
+ re-enter the function closure that failed it's args check in the
+ first place.
+
+ In fact, we do a little optimisation too, by performing the updates
+ for any update frames sitting on top of the stack. (ToDo: is this
+ really an optimisation? --SDM)
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(PAP_info,PAP_entry,/*special layout*/0,0,PAP,const,EF_,0,0);
+STGFUN(PAP_entry)
+{
+ nat Words;
+#ifdef PROFILING
+ CostCentreStack *CCS_pap;
+#endif
+ P_ p;
+ nat i;
+ StgPAP *pap;
+
+ FB_
+
+ pap = (StgPAP *) R1.p;
+
+ /*
+ * remove any update frames on the top of the stack, by just
+ * performing the update here.
+ */
+ while ((W_)Su - (W_)Sp == 0) {
+
+ switch (get_itbl(Su)->type) {
+
+ case UPDATE_FRAME:
+ /* We're sitting on top of an update frame, so let's do the business */
+ UPD_IND(Su->updatee, pap);
+
+#if defined(PROFILING)
+ /*
+ * Restore the Cost Centre too (if required); again see Sansom
+ * thesis p 183. Take the CC out of the update frame if a
+ * CAF/DICT.
+ */
+
+ CCS_pap = pap->header.prof.ccs;
+ CCCS = (IS_CAF_OR_DICT_OR_SUB_CCS(CCS_pap))
+ ? Su->header.prof.ccs
+ : CCS_pap;
+#endif /* PROFILING */
+
+ Su = Su->link;
+ Sp += sizeofW(StgUpdateFrame);
+ continue;
+
+ case SEQ_FRAME:
+ /* Just pop the seq frame and return to the activation record
+ * underneath us - R1 already contains the address of the PAP.
+ */
+ Su = ((StgSeqFrame *)Su)->link;
+ Sp += sizeofW(StgSeqFrame);
+ JMP_(ENTRY_CODE(*Sp));
+
+ case CATCH_FRAME:
+ /* can't happen, see stg_update_PAP */
+ barf("PAP_entry: CATCH_FRAME");
+
+ default:
+ barf("PAP_entry: strange activation record");
+ }
+
+ }
+
+ Words = pap->n_args;
+
+ /*
+ * Check for stack overflow.
+ */
+ STK_CHK(Words,PAP_entry,R2.p,1,);
+ Sp -= Words;
+
+ TICK_ENT_PAP(pap);
+
+ /* Enter PAP cost centre -- lexical scoping only */
+ ENTER_CCS_PAP_CL(pap);
+
+ R1.cl = pap->fun;
+ p = (P_)(pap->payload);
+
+ /* Reload the stack */
+ for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
+
+ /* Off we go! */
+ TICK_ENT_VIA_NODE();
+ JMP_(GET_ENTRY(R1.cl));
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ stg_update_PAP: Update the current closure with a partial application.
+
+ This function is called whenever an argument satisfaction check fails.
+ -------------------------------------------------------------------------- */
+
+EXTFUN(stg_update_PAP)
+{
+ nat Words, PapSize;
+#ifdef PROFILING
+ CostCentreStack *CCS_pap;
+#endif
+ StgPAP* PapClosure;
+ StgClosure *Fun, *Updatee;
+ P_ p;
+ I_ i;
+
+ FB_
+
+ /* Save the pointer to the function closure that just failed the
+ argument satisfaction check
+ */
+ Fun = R1.cl;
+
+#if defined(GRAN_COUNT)
+#error Fixme.
+ ++nPAPs;
+#endif
+
+ /* Just copy the whole block of stack between the stack pointer
+ * and the update frame pointer for now. This might include some
+ * tagging, which the garbage collector will have to pay attention
+ * to, but it's much easier than sorting the words into pointers
+ * and non-pointers.
+ */
+
+ Words = (P_)Su - (P_)Sp;
+ ASSERT((int)Words >= 0);
+
+#if defined(PROFILING)
+ /* set "CC_pap" to go in the updatee (see Sansom thesis, p 183) */
+
+ CCS_pap = (CostCentreStack *) Fun->header.prof.ccs;
+ if (IS_CAF_OR_DICT_OR_SUB_CCS(CCS_pap)) {
+ CCS_pap = CCCS;
+ }
+#endif
+
+ if (Words == 0) {
+
+ /*
+ * No arguments, only Node. Skip building the PAP and
+ * just plan to update with an indirection.
+ */
+
+ PapClosure = (StgPAP *)Fun;
+
+ } else {
+ /* Build the PAP */
+
+ PapSize = Words + sizeofW(StgPAP);
+
+ /*
+ * First we need to do a heap check, which involves saving
+ * everything on the stack. We only have one live pointer:
+ * Fun, the function closure that was passed to us. If the
+ * heap check fails, we push the function closure on the stack
+ * and instruct the scheduler to try entering it again when
+ * the garbage collector has run.
+ *
+ * It's done this way because there's a possibility that the
+ * garbage collector might have messed around with the stack,
+ * such as removing the update frame.
+ */
+ if ((Hp += PapSize) > HpLim) {
+ Sp -= 1;
+ Sp[0] = (W_)Fun;
+ JMP_(stg_gc_entertop);
+ }
+
+ TICK_ALLOC_UPD_PAP(DYN_HS, NArgWords, 0, PapSize);
+#ifdef PROFILING
+ CCS_ALLOC(CCS_pap, PapSize);
+#endif
+
+ PapClosure = (StgPAP *)(Hp + 1 - PapSize); /* The new PapClosure */
+
+ SET_HDR(PapClosure,&PAP_info,CCS_pap);
+ PapClosure->n_args = Words;
+ PapClosure->fun = Fun;
+
+ /* Now fill in the closure fields */
+
+ p = Hp;
+ for (i = Words-1; i >= 0; i--) {
+ *p-- = (W_) Sp[i];
+ }
+ }
+
+ /*
+ * Finished constructing PAP closure; now update the updatee.
+ */
+
+ /* ToDo: we'd like to just jump to the code for PAP_entry here,
+ * which deals with a stack of update frames in one go. What to
+ * do about the special ticky and profiling stuff here?
+ */
+
+ switch (get_itbl(Su)->type) {
+
+ case SEQ_FRAME:
+ /* Set Sp to just above the SEQ frame (should be an activation rec.)*/
+ Sp = stgCast(StgPtr,Su) + sizeofW(StgSeqFrame);
+
+ /* restore Su */
+ Su = stgCast(StgSeqFrame*,Su)->link;
+
+ /* return to the activation record, with the address of the PAP in R1 */
+ R1.p = (P_)PapClosure;
+ JMP_(ENTRY_CODE(*Sp));
+
+ case CATCH_FRAME:
+ /* Set Sp to just above the CATCH frame (should be an activation rec.)*/
+ Sp = stgCast(StgPtr,Su) + sizeofW(StgCatchFrame);
+
+ /* restore Su */
+ Su = stgCast(StgCatchFrame*,Su)->link;
+
+ /* restart by entering the PAP */
+ R1.p = (P_)PapClosure;
+ JMP_(GET_ENTRY(R1.cl));
+
+ case UPDATE_FRAME:
+ /*
+ * Now we have a standard update frame, so we update the updatee with
+ * either the new PAP or Node.
+ */
+
+ Updatee = Su->updatee;
+ UPD_IND(Updatee,PapClosure);
+
+ if (Words != 0) {
+ TICK_UPD_PAP_IN_NEW(NArgWords);
+
+ } else {
+ TICK_UPD_PAP_IN_PLACE();
+
+#if defined(PROFILING)
+ /*
+ * Lexical scoping requires a *permanent* indirection, and we
+ * also have to set the cost centre for the indirection.
+ */
+ SET_INFO(Updatee, &IND_PERM_info);
+ Updatee->header.prof.ccs = CCS_pap;
+#endif /* PROFILING */
+ }
+
+#if defined(PROFILING)
+ /*
+ * Restore the Cost Centre too (if required); again see Sansom
+ * thesis p 183. Take the CC out of the update frame if a CAF/DICT.
+ */
+ CCCS = IS_CAF_OR_DICT_OR_SUB_CCS(CCS_pap)
+ ? Su->header.prof.ccs
+ : CCS_pap;
+#endif /* PROFILING */
+
+ /* Restore Su */
+ Su = Su->link;
+
+ /*
+ * Squeeze out update frame from stack.
+ */
+ for (i = Words-1; i >= 0; i--) {
+ Sp[i+(sizeofW(StgUpdateFrame))] = Sp[i];
+ }
+ Sp += sizeofW(StgUpdateFrame);
+ break;
+
+ default:
+ barf("stg_update_PAP: strange activation record");
+ }
+
+ /*
+ * All done! Restart by re-entering Node
+ * Don't count this entry for ticky-ticky profiling.
+ */
+ JMP_(GET_ENTRY(R1.cl));
+ FE_
+}
+
+
+/* -----------------------------------------------------------------------------
+ Entry Code for an AP_UPD.
+
+ The idea is to copy the chunk of stack from the AP object and then
+ enter the function closure.
+
+ (This code is a simplified copy of the PAP code - with all the
+ update frame code stripped out.)
+ -------------------------------------------------------------------------- */
+
+
+INFO_TABLE(AP_UPD_info,AP_UPD_entry,/*special layout*/0,0,AP_UPD,const,EF_,0,0);
+STGFUN(AP_UPD_entry)
+{
+ nat Words;
+ P_ p;
+ nat i;
+ StgAP_UPD *ap;
+
+ FB_
+
+ ap = (StgAP_UPD *) R1.p;
+
+ Words = ap->n_args;
+
+ /*
+ * Check for stack overflow.
+ */
+ STK_CHK(Words+sizeofW(StgUpdateFrame),AP_UPD_entry,R2.p,1,);
+
+ PUSH_UPD_FRAME(R1.p, 0);
+ Sp -= sizeofW(StgUpdateFrame) + Words;
+
+ TICK_ENT_PAP(ap); /* ToDo: TICK_ENT_AP_UPD */
+
+ /* Enter PAP cost centre -- lexical scoping only */
+ ENTER_CCS_PAP_CL(ap); /* ToDo: ENTER_CC_AP_UPD_CL */
+
+ R1.cl = ap->fun;
+ p = (P_)(ap->payload);
+
+ /* Reload the stack */
+ for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
+
+ /* Off we go! */
+ TICK_ENT_VIA_NODE();
+ JMP_(GET_ENTRY(R1.cl));
+ FE_
+}
+
+
+/*-----------------------------------------------------------------------------
+ Seq frames
+
+ We don't have a primitive seq# operator: it is just a 'case'
+ expression whose scrutinee has either a polymorphic or function type
+ (constructor types can be handled by normal 'case' expressions).
+
+ To handle a polymorphic/function typed seq, we push a SEQ_FRAME on
+ the stack. This is a polymorphic activation record that just pops
+ itself and returns when entered. The purpose of the SEQ_FRAME is to
+ act as a barrier in case the scrutinee is a partial application - in
+ this way it is just like an update frame, except that it doesn't
+ update anything.
+ -------------------------------------------------------------------------- */
+
+#define SEQ_FRAME_ENTRY_TEMPLATE(label,ret) \
+ IFN_(label) \
+ { \
+ FB_ \
+ Su = stgCast(StgSeqFrame*,Sp)->link; \
+ Sp += sizeofW(StgSeqFrame); \
+ JMP_(ret); \
+ FE_ \
+ }
+
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_entry, ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_0_entry,ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_1_entry,ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_2_entry,ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_3_entry,ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_4_entry,ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_5_entry,ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_6_entry,ENTRY_CODE(Sp[0]));
+SEQ_FRAME_ENTRY_TEMPLATE(seq_frame_7_entry,ENTRY_CODE(Sp[0]));
+
+VEC_POLY_INFO_TABLE(seq_frame,1, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, SEQ_FRAME);
+
+/* -----------------------------------------------------------------------------
+ * The seq infotable
+ *
+ * This closure takes one argument, which it evaluates and returns the
+ * result with a direct return (never a vectored return!) in R1. It
+ * does this by pushing a SEQ_FRAME on the stack and
+ * entering its argument.
+ *
+ * It is used in deleteThread when reverting blackholes.
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(seq_info,seq_entry,1,0,FUN,const,EF_,0,0);
+STGFUN(seq_entry)
+{
+ FB_
+ STK_CHK_GEN(sizeofW(StgSeqFrame), NO_PTRS, seq_entry, );
+ Sp -= sizeof(StgSeqFrame);
+ PUSH_SEQ_FRAME(Sp);
+ R1.cl = R1.cl->payload[0];
+ JMP_(ENTRY_CODE(*R1.p));
+ FE_
+}
+
+
+/* -----------------------------------------------------------------------------
+ Exception Primitives
+ -------------------------------------------------------------------------- */
+
+FN_(catchZh_fast);
+FN_(raiseZh_fast);
+
+#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \
+ FN_(label); \
+ FN_(label) \
+ { \
+ FB_ \
+ Su = ((StgCatchFrame *)Sp)->link; \
+ Sp += sizeofW(StgCatchFrame); \
+ JMP_(ret); \
+ FE_ \
+ }
+
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_entry,ENTRY_CODE(Sp[0]));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_0_entry,RET_VEC(Sp[0],0));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_1_entry,RET_VEC(Sp[0],1));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_2_entry,RET_VEC(Sp[0],2));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_3_entry,RET_VEC(Sp[0],3));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_4_entry,RET_VEC(Sp[0],4));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_5_entry,RET_VEC(Sp[0],5));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_6_entry,RET_VEC(Sp[0],6));
+CATCH_FRAME_ENTRY_TEMPLATE(catch_frame_7_entry,RET_VEC(Sp[0],7));
+
+#ifdef PROFILING
+#define CATCH_FRAME_BITMAP 3
+#else
+#define CATCH_FRAME_BITMAP 1
+#endif
+
+/* Catch frames are very similar to update frames, but when entering
+ * one we just pop the frame off the stack and perform the correct
+ * kind of return to the activation record underneath us on the stack.
+ */
+
+VEC_POLY_INFO_TABLE(catch_frame, CATCH_FRAME_BITMAP, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, CATCH_FRAME);
+
+/* -----------------------------------------------------------------------------
+ * The catch infotable
+ *
+ * This should be exactly the same as would be generated by this STG code
+ *
+ * catch = {x,h} \n {} -> catch#{x,h}
+ *
+ * It is used in deleteThread when reverting blackholes.
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(catch_info,catch_entry,2,0,FUN,const,EF_,0,0);
+STGFUN(catch_entry)
+{
+ FB_
+ R2.cl = payloadCPtr(R1.cl,1); /* h */
+ R1.cl = payloadCPtr(R1.cl,0); /* x */
+ JMP_(catchZh_fast);
+ FE_
+}
+
+FN_(catchZh_fast)
+{
+ StgCatchFrame *fp;
+ FB_
+
+ /* args: R1 = m, R2 = k */
+ STK_CHK_GEN(sizeofW(StgCatchFrame), R1_PTR | R2_PTR, catchZh_fast, );
+ Sp -= sizeofW(StgCatchFrame);
+ fp = stgCast(StgCatchFrame*,Sp);
+ SET_HDR(fp,(StgInfoTable *)&catch_frame_info,CCCS);
+ fp -> handler = R2.cl;
+ fp -> link = Su;
+ Su = stgCast(StgUpdateFrame*,fp);
+ TICK_ENT_VIA_NODE();
+ JMP_(ENTRY_CODE(*R1.p));
+
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ * The raise infotable
+ *
+ * This should be exactly the same as would be generated by this STG code
+ *
+ * raise = {err} \n {} -> raise#{err}
+ *
+ * It is used in raiseZh_fast to update thunks on the update list
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(raise_info,raise_entry,1,0,FUN,const,EF_,0,0);
+STGFUN(raise_entry)
+{
+ FB_
+ R1.cl = payloadCPtr(R1.cl,0);
+ JMP_(raiseZh_fast);
+ FE_
+}
+
+FN_(raiseZh_fast)
+{
+ StgClosure *handler;
+ StgUpdateFrame *p;
+ FB_
+ /* args : R1 = error */
+
+ p = Su;
+
+ while (1) {
+
+ switch (get_itbl(p)->type) {
+
+ case UPDATE_FRAME:
+ UPD_INPLACE1(p->updatee,&raise_info,R1.cl);
+ p = p->link;
+ continue;
+
+ case SEQ_FRAME:
+ p = stgCast(StgSeqFrame*,p)->link;
+ continue;
+
+ case CATCH_FRAME:
+ /* found it! */
+ break;
+
+ case STOP_FRAME:
+ barf("raiseZh_fast: STOP_FRAME");
+
+ default:
+ barf("raiseZh_fast: weird activation record");
+ }
+
+ break;
+
+ }
+
+ /* Ok, p points to the enclosing CATCH_FRAME. Pop everything down to
+ * and including this frame, update Su, push R1, and enter the handler.
+ */
+ Su = ((StgCatchFrame *)p)->link;
+ handler = ((StgCatchFrame *)p)->handler;
+
+ Sp = stgCast(StgPtr,p) + sizeofW(StgCatchFrame) - 1;
+ *Sp = R1.w;
+
+ TICK_ENT_VIA_NODE();
+ R1.cl = handler;
+ JMP_(ENTRY_CODE(handler->header.info));
+
+ FE_
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Weak.c,v 1.2 1998/12/02 13:29:01 simonm Exp $
+ *
+ * Weak pointers / finalisers
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "RtsFlags.h"
+#include "Weak.h"
+#include "Storage.h"
+
+StgWeak *weak_ptr_list;
+
+/*
+ * finaliseWeakPointersNow() is called just before the system is shut
+ * down. It runs the finaliser for each weak pointer still in the
+ * system.
+ */
+
+void
+finaliseWeakPointersNow(void)
+{
+ StgWeak *w;
+
+ for (w = weak_ptr_list; w; w = w->link) {
+ IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p\n", w));
+ w->header.info = &DEAD_WEAK_info;
+ rts_evalIO(w->finaliser,NULL);
+ }
+}
+
+/*
+ * scheduleFinalisers() is called on the list of weak pointers found
+ * to be dead after a garbage collection. It overwrites each object
+ * with DEAD_WEAK, and creates a new thread for the finaliser.
+ */
+
+void
+scheduleFinalisers(StgWeak *list)
+{
+ StgWeak *w;
+
+ for (w = list; w; w = w->link) {
+ IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p\n", w));
+#ifdef INTERPRETER
+ createGenThread(RtsFlags.GcFlags.initialStkSize, w->finaliser);
+#else
+ createIOThread(RtsFlags.GcFlags.initialStkSize, w->finaliser);
+#endif
+ w->header.info = &DEAD_WEAK_info;
+ }
+}
+
+void
+markWeakList(void)
+{
+ StgWeak *w, **last_w;
+
+ last_w = &weak_ptr_list;
+ for (w = weak_ptr_list; w; w = w->link) {
+ w = (StgWeak *)MarkRoot((StgClosure *)w);
+ *last_w = w;
+ last_w = &(w->link);
+ }
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Weak.h,v 1.2 1998/12/02 13:29:01 simonm Exp $
+ *
+ * Weak pointers / finalisers
+ *
+ * ---------------------------------------------------------------------------*/
+
+extern StgWeak *weak_ptr_list;
+
+void finaliseWeakPointersNow(void);
+void scheduleFinalisers(StgWeak *w);
+void markWeakList(void);
+
+
--- /dev/null
+################################################################
+# Start of Makefile
+################################################################
+
+# This rule goes first to make it the default choice
+default :: test
+
+CC = gcc
+
+CPPFLAGS += -I../includes
+CPPFLAGS += -D__HUGS__
+
+CFLAGS += -Wall
+CFLAGS += -W
+CFLAGS += -Wno-unused
+CFLAGS += -Wstrict-prototypes
+CFLAGS += -Wmissing-prototypes
+CFLAGS += -Wmissing-declarations
+#CFLAGS += -Wredundant-decls
+#CFLAGS += -Wnested-externs
+#CFLAGS += -Wshadow
+CFLAGS += -Winline
+CFLAGS += -Waggregate-return
+CFLAGS += -Wpointer-arith
+CFLAGS += -Wbad-function-cast
+#CFLAGS += -Wcast-qual
+#CFLAGS += -Wcast-align
+#CFLAGS += -Wconversion
+
+#CFLAGS += -ggdb3 -O0 # debug with gdb, minimal confusion
+#CFLAGS += -pg -O2 # Profile with gprof
+#CFLAGS += -pg -g # Profile more with gprof
+#CFLAGS += -pg -g -a # Profile basic blocks with gprof (disnae work)
+#CFLAGS += -O2 -g # Run it - but put a little debugging help in
+CFLAGS += -g -DDEBUG
+#CFLAGS += -O6 # Just run it
+
+C_FILES = $(wildcard *.c)
+S_FILES = $(wildcard *.S)
+HC_FILES = $(wildcard *.hc)
+
+LIBOBJS += $(patsubst %.c,%.o,$(C_FILES))
+LIBOBJS += $(patsubst %.S,%.o,$(S_FILES))
+LIBOBJS += $(patsubst %.hc,%.o,$(HC_FILES))
+
+LIBRARY = libHSrts.a
+
+%.o : %.c
+ @echo Compiling $<
+ @$(CC) $(CFLAGS) $(CPPFLAGS) -c $< -o $@
+%.o : %.S
+ @echo Compiling $<
+ @$(CC) $(CFLAGS) $(CPPFLAGS) -c $< -o $@
+%.o : %.hc
+ @echo Compiling $<
+ @ $(CC) $(CFLAGS) $(CPPFLAGS) -xc -c $< -o $@
+
+# We can build an archive
+$(LIBRARY): $(LIBOBJS)
+ rm -f $@
+ ar clqs $@ $^
+
+# Or we can build a shared library
+# (The shared library is nicer because it's linked with all the libs
+# that the rts depends on. But it has the problem that the bfd code
+# can't see the symbols defined in the library - though that may be easy
+# to fix.)
+$(LIBRARY:.a=.so): $(LIBOBJS)
+ rm -f $@
+ $(CC) -shared $^ -L$(HOME)/lib -lm -lbfd -liberty -o $@
+
+clean::
+ $(RM) *.o *.a *.so
+veryclean :: clean
+tags:
+ etags ../*/*.{c,h,hc,S}
+
+################################################################
+# Floppy disk for me to take home at night
+################################################################
+
+# We avoid using zip because we're fed up being bitten by the
+# default=non-recursive bug
+
+GHC_DIR = fptools/ghc
+TEST_DIR = $(GHC_DIR)/tests/rts
+RTS_DIR = $(GHC_DIR)/rts
+LIB_DIR = $(GHC_DIR)/lib
+GMP_DIR = $(GHC_DIR)/rts/gmp
+INC_DIR = $(GHC_DIR)/includes
+HUGS_DIR = $(GHC_DIR)/interpreter
+
+TARFILES += $(GHC_DIR)/CVS
+
+TARFILES += $(INC_DIR)/*.h
+TARFILES += $(INC_DIR)/CVS
+
+TARFILES += $(RTS_DIR)/*.{c,h,hc,S}
+TARFILES += $(RTS_DIR)/comments
+TARFILES += $(RTS_DIR)/adr
+TARFILES += $(RTS_DIR)/CVS
+
+TARFILES += $(TEST_DIR)/Makefile
+TARFILES += $(TEST_DIR)/.gdbinit
+TARFILES += $(TEST_DIR)/*.{c,h}
+TARFILES += $(TEST_DIR)/CVS
+
+TARFILES += $(GMP_DIR)
+
+TARFILES += $(LIB_DIR)/*/CVS
+TARFILES += $(LIB_DIR)/*/*.{lhs,hi-boot}
+TARFILES += $(LIB_DIR)/*/cbits/*.{c,h}
+
+TARFILES += $(HUGS_DIR)
+
+tarfile:
+ cd ../../../$(GMP_DIR) && make clean
+ cd ../../../$(HUGS_DIR) && make clean
+ cd ../../..; tar zcvf rts.tgz $(TARFILES)
+ ls -l ../../../rts.tgz
+ echo todo: add unlit to tarfile
+
+floppy: tarfile
+ mount /mnt/floppy
+ - cp ../../../rts.tgz /mnt/floppy
+ umount /mnt/floppy
+
+################################################################
+# Dependencies
+################################################################
+
+DEP_FILES += $(C_FILES:.c=.d)
+DEP_FILES += $(S_FILES:.S=.d)
+DEP_FILES += $(HC_FILES:.hc=.d)
+
+include $(DEP_FILES)
+
+#Copied from the gmake manual - builds a dependency file for every C file
+%.d : %.c
+ @echo "Making dependency file $@"
+ @$(SHELL) -ec '$(CC) -MM $(CPPFLAGS) $< \
+ | sed '\''s/\($*\)\.o[ :]*/\1.o $@ : /g'\'' > $@ \
+ ; [ -s $@ ] || rm -f $@'
+%.d : %.S
+ @echo "Making dependency file $@"
+ @$(SHELL) -ec '$(CC) -MM $(CPPFLAGS) $< \
+ | sed '\''s/\($*\)\.o[ :]*/\1.o $@ : /g'\'' > $@ \
+ ; [ -s $@ ] || rm -f $@'
+%.d : %.hc
+ @echo "Making dependency file $@"
+ @$(SHELL) -ec '$(CC) -MM $(CPPFLAGS) -xc $< \
+ | sed '\''s/\($*\)\.hc\.o[ :]*/\1.o $@ : /g'\'' > $@ \
+ ; [ -s $@ ] || rm -f $@'
+
+veryclean::
+ $(RM) $(DEP_FILES)
+
+################################################################
+# End of Makefile
+################################################################
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: FetchMe.c,v 1.2 1998/12/02 13:29:03 simonm Exp $
+ *
+ * Entry code for a FETCH_ME closure
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifdef PAR /* all of it */
+
+#include "Rts.h"
+#include "FetchMe.h"
+#include "HLC.h"
+
+/* -----------------------------------------------------------------------------
+ FETCH_ME closures.
+
+ A FETCH_ME closure represents data that currently resides on
+ another PE. We issue a fetch message, and wait for the data to be
+ retrieved.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(FETCH_ME_info, FETCH_ME_entry, 0,2, FETCH_ME, const, EF_,0,0);
+
+STGFUN(FETCH_ME_entry)
+{
+ globalAddr *rGA;
+ globalAddr *lGA;
+ globalAddr fmbqGA;
+
+# if defined(GRAN)
+ STGCALL0(void,(),GranSimBlock); /* Do this before losing its TSO_LINK */
+# endif
+
+ rGA = FETCHME_GA(R1);
+ ASSERT(rGA->loc.gc.gtid != mytid);
+
+ /* Turn the FETCH_ME into a FETCH_ME_BQ, and place the current thread
+ * on the blocking queue.
+ */
+ R1.cl->header.info = FETCH_ME_BQ_info;
+ CurrentTSO->link = END_TSO_QUEUE;
+ ((StgBlackHole *)R1.cl)->blocking_queue = CurrentTSO;
+
+#ifdef 0 /* unknown junk... needed? --SDM */
+ if (DO_QP_PROF) {
+ QP_Event1("GR", CurrentTSO);
+ }
+
+ if (RTSflags.ParFlags.granSimStats) {
+ /* Note that CURRENT_TIME may perform an unsafe call */
+ TIME now = CURRENT_TIME;
+ TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
+ TSO_FETCHCOUNT(CurrentTSO)++;
+ TSO_QUEUE(CurrentTSO) = Q_FETCHING;
+ TSO_BLOCKEDAT(CurrentTSO) = now;
+ /* DumpGranEventAndNode(GR_FETCH, CurrentTSO, (SAVE_R1).p,
+ taskIDtoPE(rGA->loc.gc.gtid)); */
+ DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(rGA->loc.gc.gtid),GR_FETCH,
+ CurrentTSO,(SAVE_R1).p,0);
+ }
+
+ /* Phil T. claims that this was a workaround for a hard-to-find
+ * bug, hence I'm leaving it out for now --SDM
+ */
+ /* Assign a brand-new global address to the newly created FMBQ */
+ lGA = MakeGlobal((SAVE_R1).p, rtsFalse);
+ splitWeight(&fmbqGA, lGA);
+ ASSERT(fmbqGA.weight == 1L << (BITS_IN(unsigned) - 1));
+#endif
+
+ /* I *hope* it's ok to call this from STG land. --SDM */
+ STGCALL3(sendFetch, rGA, &fmbqGA, 0/*load*/);
+
+ BLOCK_NP(1); /* back to the scheduler */
+
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ FETCH_ME_BQ
+
+ On the first entry of a FETCH_ME closure, we turn the closure into
+ a FETCH_ME_BQ, which behaves just like a black hole. Any thread
+ entering the FETCH_ME_BQ will be placed in the blocking queue.
+ When the data arrives from the remote PE, all waiting threads are
+ woken up and the FETCH_ME_BQ is overwritten with the fetched data.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(FETCH_ME_BQ_info, BLACKHOLE_entry,0,2,BLACKHOLE,const,EF_,0,0);
+
+#endif /* PAR */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: FetchMe.h,v 1.2 1998/12/02 13:29:04 simonm Exp $
+ *
+ * Closure types for the parallel system.
+ *
+ * ---------------------------------------------------------------------------*/
+
+EI_(FETCH_ME_info);
+EF_(FETCH_ME_entry);
+
+EI_(FETCH_ME_BQ_info);
+
+EI_(BLOCKED_FETCH_info);
+EF_(BLOCKED_FETCH_entry);
+
--- /dev/null
+/********************************************************************
+* High Level Communications Header (HLC.h) *
+* *
+* Contains the high-level definitions (i.e. communication *
+* subsystem independent) used by GUM *
+* Phil Trinder, Glasgow University, 12 December 1994 *
+*********************************************************************/
+
+#ifndef __HLC_H
+#define __HLC_H
+#ifdef PAR
+
+#include "LLC.h"
+
+#define NEW_FISH_AGE 0
+#define NEW_FISH_HISTORY 0
+#define NEW_FISH_HUNGER 0
+#define FISH_LIFE_EXPECTANCY 10
+
+void sendFetch (globalAddr *ga, globalAddr *bqga, int load);
+void sendResume (globalAddr *bqga, int nelem, P_ data);
+void sendAck (GLOBAL_TASK_ID task, int ngas, globalAddr *gagamap);
+void sendFish (GLOBAL_TASK_ID destPE, GLOBAL_TASK_ID origPE, int age, int history, int hunger);
+void sendFree (GLOBAL_TASK_ID destPE, int nelem, P_ data);
+void sendSchedule (GLOBAL_TASK_ID origPE, int nelem, P_ data);
+void processMessages(void);
+void processFetches(void);
+
+void prepareFreeMsgBuffers(void);
+void freeRemoteGA (int pe, globalAddr *ga);
+void sendFreeMessages(void);
+
+GLOBAL_TASK_ID choosePE(void);
+
+void WaitForTermination(void);
+
+void DebugPrintGAGAMap (globalAddr *gagamap, int nGAs);
+
+void CommonUp (P_, P_);
+
+#endif /* PAR */
+#endif /* __HLC_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * $Id: HLComms.c,v 1.2 1998/12/02 13:29:05 simonm Exp $
+ *
+ * High Level Communications Routines (HLComms.lc)
+ *
+ * Contains the high-level routines (i.e. communication
+ * subsystem independent) used by GUM
+ *
+ * Phil Trinder, Glasgow University, 12 December 1994
+ * Adapted for new RTS
+ * Phil Trinder, Simon Marlow July 1998
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifdef PAR /* whole file */
+
+#ifndef _AIX
+#define NON_POSIX_SOURCE /* so says Solaris */
+#endif
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "RtsFlags.h"
+
+#include "HLC.h"
+#include "Parallel.h"
+
+/*
+ * GUM Message Sending and Unpacking Functions
+ * ********************************************
+ */
+
+/*
+ * Allocate space for message processing
+ */
+
+static W_ *gumPackBuffer;
+
+void
+InitMoreBuffers(void)
+{
+ gumPackBuffer
+ = (W_ *) stgMallocWords(RtsFlags.ParFlags.packBufferSize, "initMoreBuffers");
+}
+
+/*
+ *SendFetch packs the two global addresses and a load into a message +
+ *sends it.
+ */
+
+void
+sendFetch(globalAddr *rga, globalAddr *lga, int load)
+{
+
+ ASSERT(rga->weight > 0 && lga->weight > 0);
+#ifdef FETCH_DEBUG
+ fprintf(stderr, "Sending Fetch (%x, %d, 0), load = %d\n",
+ rga->loc.gc.gtid, rga->loc.gc.slot, load);
+#endif
+ SendOpV(PP_FETCH, rga->loc.gc.gtid, 6,
+ (W_) rga->loc.gc.gtid, (W_) rga->loc.gc.slot,
+ (W_) lga->weight, (W_) lga->loc.gc.gtid, (W_) lga->loc.gc.slot, (W_) load);
+}
+
+/*
+ *unpackFetch unpacks a FETCH message into two Global addresses and a load figure.
+ */
+
+static void
+unpackFetch(globalAddr *lga, globalAddr *rga, int *load)
+{
+ long buf[6];
+
+ GetArgs(buf, 6);
+ lga->weight = 1;
+ lga->loc.gc.gtid = (GLOBAL_TASK_ID) buf[0];
+ lga->loc.gc.slot = (int) buf[1];
+
+ rga->weight = (unsigned) buf[2];
+ rga->loc.gc.gtid = (GLOBAL_TASK_ID) buf[3];
+ rga->loc.gc.slot = (int) buf[4];
+
+ *load = (int) buf[5];
+
+ ASSERT(rga->weight > 0);
+}
+
+/*
+ * SendResume packs the remote blocking queue's GA and data into a message
+ * and sends it.
+ */
+
+void
+sendResume(globalAddr *rga, int nelem, StgPtr data)
+{
+
+#ifdef RESUME_DEBUG
+ PrintPacket(data);
+ fprintf(stderr, "Sending Resume for (%x, %d, %x)\n",
+ rga->loc.gc.gtid, rga->loc.gc.slot, rga->weight);
+#endif
+
+ SendOpNV(PP_RESUME, rga->loc.gc.gtid, nelem, data, 2,
+ (W_) rga->weight, (W_) rga->loc.gc.slot);
+
+}
+
+/*
+ * blockFetch blocks a BlockedFetch node on some kind of black hole.
+ */
+static void
+blockFetch(StgPtr bf, StgPtr bh)
+{}
+
+/*
+ * Empty until Blocked fetches etc defined
+ * switch (INFO_TYPE(INFO_PTR(bh))) {
+ * case INFO_BH_TYPE:
+ * BF_LINK(bf) = PrelBase_Z91Z93_closure;
+ * SET_INFO_PTR(bh, BQ_info);
+ * BQ_ENTRIES(bh) = (W_) bf;
+ *
+ *#ifdef GC_MUT_REQUIRED
+ * /*
+ * * If we modify a black hole in the old generation, we have to
+ * * make sure it goes on the mutables list
+ * *
+ *
+ * if (bh <= StorageMgrInfo.OldLim) {
+ * MUT_LINK(bh) = (W_) StorageMgrInfo.OldMutables;
+ * StorageMgrInfo.OldMutables = bh;
+ * } else
+ * MUT_LINK(bh) = MUT_NOT_LINKED;
+ *#endif
+ * break;
+ * case INFO_BQ_TYPE:
+ * BF_LINK(bf) = (P_) BQ_ENTRIES(bh);
+ * BQ_ENTRIES(bh) = (W_) bf;
+ * break;
+ * case INFO_FMBQ_TYPE:
+ * BF_LINK(bf) = (P_) FMBQ_ENTRIES(bh);
+ * FMBQ_ENTRIES(bh) = (W_) bf;
+ * break;
+ * case INFO_SPEC_RBH_TYPE:
+ * BF_LINK(bf) = (P_) SPEC_RBH_BQ(bh);
+ * SPEC_RBH_BQ(bh) = (W_) bf;
+ * break;
+ * case INFO_GEN_RBH_TYPE:
+ * BF_LINK(bf) = (P_) GEN_RBH_BQ(bh);
+ * GEN_RBH_BQ(bh) = (W_) bf;
+ * break;
+ * default:
+ * fprintf(stderr, "Panic: thought %#lx was a black hole (IP %#lx)\n",
+ * (W_) bh, INFO_PTR(bh));
+ * EXIT(EXIT_FAILURE);
+ * }
+ *}
+ */
+
+/*
+ * processFetches constructs and sends resume messages for every
+ * BlockedFetch which is ready to be awakened.
+ */
+extern P_ PendingFetches;
+
+void
+processFetches()
+{}
+/*
+ * Empty till closure defined
+ * P_ bf;
+ * P_ next;
+ * P_ closure;
+ * P_ ip;
+ * globalAddr rga;
+ *
+ * for (bf = PendingFetches; bf != PrelBase_Z91Z93_closure; bf = next) {
+ * next = BF_LINK(bf);
+ *
+ * /*
+ * * Find the target at the end of the indirection chain, and
+ * * process it in much the same fashion as the original target
+ * * of the fetch. Though we hope to find graph here, we could
+ * * find a black hole (of any flavor) or even a FetchMe.
+ * *
+ * closure = BF_NODE(bf);
+ * while (IS_INDIRECTION(INFO_PTR(closure)))
+ * closure = (P_) IND_CLOSURE_PTR(closure);
+ * ip = (P_) INFO_PTR(closure);
+ *
+ * if (INFO_TYPE(ip) == INFO_FETCHME_TYPE) {
+ * /* Forward the Fetch to someone else *
+ * rga.loc.gc.gtid = (GLOBAL_TASK_ID) BF_GTID(bf);
+ * rga.loc.gc.slot = (int) BF_SLOT(bf);
+ * rga.weight = (unsigned) BF_WEIGHT(bf);
+ *
+ * sendFetch(FETCHME_GA(closure), &rga, 0 /* load *);
+ * } else if (IS_BLACK_HOLE(ip)) {
+ * BF_NODE(bf) = closure;
+ * blockFetch(bf, closure);
+ * } else {
+ * /* We now have some local graph to send back *
+ * W_ size;
+ * P_ graph;
+ *
+ * if ((graph = PackNearbyGraph(closure, &size)) == NULL) {
+ * PendingFetches = bf;
+ * ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
+ * SAVE_Hp -= PACK_HEAP_REQUIRED;
+ * bf = PendingFetches;
+ * next = BF_LINK(bf);
+ * closure = BF_NODE(bf);
+ * graph = PackNearbyGraph(closure, &size);
+ * ASSERT(graph != NULL);
+ * }
+ * rga.loc.gc.gtid = (GLOBAL_TASK_ID) BF_GTID(bf);
+ * rga.loc.gc.slot = (int) BF_SLOT(bf);
+ * rga.weight = (unsigned) BF_WEIGHT(bf);
+ *
+ * sendResume(&rga, size, graph);
+ * }
+ * }
+ * PendingFetches = PrelBase_Z91Z93_closure;
+ *}
+ */
+
+/*
+ * unpackResume unpacks a Resume message into two Global addresses and
+ * a data array.
+ */
+
+static void
+unpackResume(globalAddr *lga, int *nelem, W_ *data)
+{
+ long buf[3];
+
+ GetArgs(buf, 3);
+ lga->weight = (unsigned) buf[0];
+ lga->loc.gc.gtid = mytid;
+ lga->loc.gc.slot = (int) buf[1];
+
+ *nelem = (int) buf[2];
+ GetArgs(data, *nelem);
+}
+
+/*
+ *SendAck packs the global address being acknowledged, together with
+ *an array of global addresses for any closures shipped and sends them.
+ */
+
+void
+sendAck(GLOBAL_TASK_ID task, int ngas, globalAddr *gagamap)
+{
+ static long *buffer;
+ long *p;
+ int i;
+
+ buffer = (long *) gumPackBuffer;
+
+ for(i = 0, p = buffer; i < ngas; i++, p += 6) {
+ ASSERT(gagamap[1].weight > 0);
+ p[0] = (long) gagamap->weight;
+ p[1] = (long) gagamap->loc.gc.gtid;
+ p[2] = (long) gagamap->loc.gc.slot;
+ gagamap++;
+ p[3] = (long) gagamap->weight;
+ p[4] = (long) gagamap->loc.gc.gtid;
+ p[5] = (long) gagamap->loc.gc.slot;
+ gagamap++;
+ }
+#ifdef ACK_DEBUG
+ fprintf(stderr,"Sending Ack (%d pairs) to %x\n", ngas, task);
+#endif
+ SendOpN(PP_ACK, task, p - buffer, buffer);
+
+}
+
+/*
+ *unpackAck unpacks an Acknowledgement message into a Global address,
+ *a count of the number of global addresses following and a map of
+ *Global addresses
+ */
+
+static void
+unpackAck(int *ngas, globalAddr *gagamap)
+{
+ long GAarraysize;
+ long buf[6];
+
+ GetArgs(&GAarraysize, 1);
+
+ *ngas = GAarraysize / 6;
+
+ while (GAarraysize > 0) {
+ GetArgs(buf, 6);
+ gagamap->weight = (unsigned) buf[0];
+ gagamap->loc.gc.gtid = (GLOBAL_TASK_ID) buf[1];
+ gagamap->loc.gc.slot = (int) buf[2];
+ gagamap++;
+ gagamap->weight = (unsigned) buf[3];
+ gagamap->loc.gc.gtid = (GLOBAL_TASK_ID) buf[4];
+ gagamap->loc.gc.slot = (int) buf[5];
+ ASSERT(gagamap->weight > 0);
+ gagamap++;
+ GAarraysize -= 6;
+ }
+}
+
+/*
+ *SendFish packs the global address being acknowledged, together with
+ *an array of global addresses for any closures shipped and sends them.
+ */
+
+void
+sendFish(GLOBAL_TASK_ID destPE, GLOBAL_TASK_ID origPE,
+ int age, int history, int hunger)
+{
+
+#ifdef FISH_DEBUG
+ fprintf(stderr,"Sending Fish to %lx\n", destPE);
+#endif
+ SendOpV(PP_FISH, destPE, 4, (W_) origPE, (W_) age, (W_) history, (W_) hunger);
+ if (origPE == mytid)
+ fishing = rtsTrue;
+
+}
+
+/*
+ *unpackFish unpacks a FISH message into the global task id of the
+ *originating PE and 3 data fields: the age, history and hunger of the
+ *fish. The history + hunger are not currently used.
+ */
+
+static void
+unpackFish(GLOBAL_TASK_ID *origPE, int *age, int *history, int *hunger)
+{
+ long buf[4];
+
+ GetArgs(buf, 4);
+
+ *origPE = (GLOBAL_TASK_ID) buf[0];
+ *age = (int) buf[1];
+ *history = (int) buf[2];
+ *hunger = (int) buf[3];
+}
+
+/*
+ *SendFree sends (weight, slot) pairs for GAs that we no longer need references
+ *to.
+ */
+void
+sendFree(GLOBAL_TASK_ID pe, int nelem, StgPtr data)
+{
+#ifdef FREE_DEBUG
+ fprintf(stderr, "Sending Free (%d GAs) to %x\n", nelem / 2, pe);
+#endif
+ SendOpN(PP_FREE, pe, nelem, data);
+
+}
+
+
+/*
+ *unpackFree unpacks a FREE message into the amount of data shipped and
+ *a data block.
+ */
+
+static void
+unpackFree(int *nelem, W_ *data)
+{
+ long buf[1];
+
+ GetArgs(buf, 1);
+ *nelem = (int) buf[0];
+ GetArgs(data, *nelem);
+}
+
+/*
+ *SendSchedule sends a closure to be evaluated in response to a Fish
+ *message. The message is directed to the PE that originated the Fish
+ *(origPE), and includes the packed closure (data) along with its size
+ *(nelem).
+ */
+
+void
+sendSchedule(GLOBAL_TASK_ID origPE, int nelem, StgPtr data)
+{
+#ifdef SCHEDULE_DEBUG
+ PrintPacket(data);
+ fprintf(stderr, "Sending Schedule to %x\n", origPE);
+#endif
+
+ SendOpN(PP_SCHEDULE, origPE, nelem, data);
+}
+
+/*
+ *unpackSchedule unpacks a SCHEDULE message into the Global address of
+ *the closure shipped, the amount of data shipped (nelem) and the data
+ *block (data).
+ */
+
+static void
+unpackSchedule(int *nelem, W_ *data)
+{
+ long buf[1];
+
+ GetArgs(buf, 1);
+ *nelem = (int) buf[0];
+ GetArgs(data, *nelem);
+}
+
+/*
+ *Message-Processing Functions
+ *
+ *The following routines process incoming GUM messages. Often reissuing
+ *messages in response.
+ *
+ *processFish unpacks a fish message, reissuing it if it's our own,
+ *sending work if we have it or sending it onwards otherwise.
+ *
+ * Only stubs now. Real stuff in HLCommsRest PWT
+ */
+static void
+processFish(void)
+{} /* processFish */
+
+/*
+ * processFetch either returns the requested data (if available)
+ * or blocks the remote blocking queue on a black hole (if not).
+ */
+static void
+processFetch(void)
+{}
+
+/*
+ * processFree unpacks a FREE message and adds the weights to our GAs.
+ */
+static void
+processFree(void)
+{}
+
+/*
+ * processResume unpacks a RESUME message into the graph, filling in
+ * the LA -> GA, and GA -> LA tables. Threads blocked on the original
+ * FetchMe (now a blocking queue) are awakened, and the blocking queue
+ * is converted into an indirection. Finally it sends an ACK in response
+ * which contains any newly allocated GAs.
+ */
+
+static void
+processResume(GLOBAL_TASK_ID sender)
+{}
+
+/*
+ * processSchedule unpacks a SCHEDULE message into the graph, filling
+ * in the LA -> GA, and GA -> LA tables. The root of the graph is added to
+ * the local spark queue. Finally it sends an ACK in response
+ * which contains any newly allocated GAs.
+ */
+static void
+processSchedule(GLOBAL_TASK_ID sender)
+{
+}
+
+/*
+ * processAck unpacks an ACK, and uses the GAGA map to convert RBH's
+ * (which represent shared thunks that have been shipped) into fetch-mes
+ * to remote GAs.
+ */
+static void
+processAck(void)
+{}
+
+/*
+ * GUM Message Processor
+
+ * processMessages processes any messages that have arrived, calling
+ * appropriate routines depending on the message tag
+ * (opcode). N.B. Unless profiling it assumes that there {\em ARE} messages
+ * present and performs a blocking receive! During profiling it
+ * busy-waits in order to record idle time.
+ */
+
+void
+processMessages(void)
+{
+ PACKET packet;
+ OPCODE opcode;
+ GLOBAL_TASK_ID task;
+
+ do {
+
+ packet = GetPacket(); /* Get next message; block until one available */
+
+ get_opcode_and_sender(packet, &opcode, &task);
+
+ switch (opcode) {
+
+ case PP_FINISH:
+ stg_exit(EXIT_SUCCESS); /* The computation has been completed by someone
+ * else */
+ break;
+
+ case PP_FETCH:
+ processFetch();
+ break;
+
+ case PP_RESUME:
+ processResume(task);
+ break;
+
+ case PP_ACK:
+ processAck();
+ break;
+
+ case PP_FISH:
+ processFish();
+ break;
+
+ case PP_FREE:
+ processFree();
+ break;
+
+ case PP_SCHEDULE:
+ processSchedule(task);
+ break;
+
+ default:
+ /* Anything we're not prepared to deal with. */
+ fprintf(stderr, "Task %x: Unexpected opcode %x from %x\n",
+ mytid, opcode, task);
+
+ stg_exit(EXIT_FAILURE);
+ } /* switch */
+
+ } while (PacketsWaiting()); /* While there are messages: process them */
+} /* processMessages */
+
+/*
+ * Miscellaneous Functions
+ *
+ *
+ * ChoosePE selects a GlobalTaskId from the array of PEs 'at random'.
+ * Important properties:
+ * - it varies during execution, even if the PE is idle
+ * - it's different for each PE
+ * - we never send a fish to ourselves
+ */
+extern long lrand48 (void);
+
+GLOBAL_TASK_ID
+choosePE(void)
+{
+ long temp;
+
+ temp = lrand48() % nPEs;
+ if (PEs[temp] == mytid) { /* Never send a FISH to yourself */
+ temp = (temp + 1) % nPEs;
+ }
+ return PEs[temp];
+}
+
+/*
+ *WaitForTermination enters a loop ignoring spurious messages while waiting for the
+ *termination sequence to be completed.
+ */
+void
+WaitForTermination(void)
+{
+ do {
+ PACKET p = GetPacket();
+ ProcessUnexpected(p);
+ } while (rtsTrue);
+}
+
+#ifdef DEBUG
+void
+DebugPrintGAGAMap(globalAddr *gagamap, int nGAs)
+{
+ int i;
+
+ for (i = 0; i < nGAs; ++i, gagamap += 2)
+ fprintf(stderr, "gagamap[%d] = (%x, %d, %x) -> (%x, %d, %x)\n", i,
+ gagamap[0].loc.gc.gtid, gagamap[0].loc.gc.slot, gagamap[0].weight,
+ gagamap[1].loc.gc.gtid, gagamap[1].loc.gc.slot, gagamap[1].weight);
+}
+#endif
+
+static PP_ freeMsgBuffer = NULL;
+static int *freeMsgIndex = NULL;
+
+void
+prepareFreeMsgBuffers(void)
+{
+ int i;
+
+ /* Allocate the freeMsg buffers just once and then hang onto them. */
+
+ if (freeMsgIndex == NULL) {
+
+ freeMsgIndex = (int *) stgMallocBytes(nPEs * sizeof(int), "prepareFreeMsgBuffers (Index)");
+ freeMsgBuffer = (PP_) stgMallocBytes(nPEs * sizeof(long *), "prepareFreeMsgBuffers (Buffer)");
+
+ for(i = 0; i < nPEs; i++) {
+ if (i != thisPE) {
+ freeMsgBuffer[i] = (P_) stgMallocWords(RtsFlags.ParFlags.packBufferSize,
+ "prepareFreeMsgBuffers (Buffer #i)");
+ }
+ }
+ }
+
+ /* Initialize the freeMsg buffer pointers to point to the start of their buffers */
+ for (i = 0; i < nPEs; i++)
+ freeMsgIndex[i] = 0;
+}
+
+void
+freeRemoteGA(int pe, globalAddr *ga)
+{
+ int i;
+
+ ASSERT(GALAlookup(ga) == NULL);
+
+ if ((i = freeMsgIndex[pe]) + 2 >= RtsFlags.ParFlags.packBufferSize) {
+#ifdef FREE_DEBUG
+ fprintf(stderr, "Filled a free message buffer\n");
+#endif
+ sendFree(ga->loc.gc.gtid, i, freeMsgBuffer[pe]);
+ i = 0;
+ }
+ freeMsgBuffer[pe][i++] = (W_) ga->weight;
+ freeMsgBuffer[pe][i++] = (W_) ga->loc.gc.slot;
+ freeMsgIndex[pe] = i;
+#ifdef DEBUG
+ ga->weight = 0x0f0f0f0f;
+ ga->loc.gc.gtid = 0x666;
+ ga->loc.gc.slot = 0xdeaddead;
+#endif
+}
+
+void
+sendFreeMessages(void)
+{
+ int i;
+
+ for (i = 0; i < nPEs; i++) {
+ if (freeMsgIndex[i] > 0)
+ sendFree(PEs[i], freeMsgIndex[i], freeMsgBuffer[i]);
+ }
+}
+
+/* Process messaging code ripped out for the time being -- SDM & PWT */
+
+#ifdef 0
+/* These are the remaining message-processing functions from HLComms*/
+
+
+/*
+ *Message-Processing Functions
+ *
+ *The following routines process incoming GUM messages. Often reissuing
+ *messages in response.
+ *
+ *processFish unpacks a fish message, reissuing it if it's our own,
+ *sending work if we have it or sending it onwards otherwise.
+ */
+static void
+processFish(void)
+{
+ GLOBAL_TASK_ID origPE;
+ int age, history, hunger;
+
+ unpackFish(&origPE, &age, &history, &hunger);
+
+ if (origPE == mytid) {
+ fishing = rtsFalse;
+ } else {
+ P_ spark;
+
+ while ((spark = FindLocalSpark(rtsTrue)) != NULL) {
+ W_ size;
+ P_ graph;
+
+ if ((graph = PackNearbyGraph(spark, &size)) == NULL) {
+ ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
+ SAVE_Hp -= PACK_HEAP_REQUIRED;
+ /* Now go back and try again */
+ } else {
+ sendSchedule(origPE, size, graph);
+ DisposeSpark(spark);
+ break;
+ }
+ }
+ if (spark == NULL) {
+ /* We have no sparks to give */
+ if (age < FISH_LIFE_EXPECTANCY)
+ sendFish(choosePE(), origPE,
+ (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
+
+ /* Send it home to die */
+ else
+ sendFish(origPE, origPE, (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
+ }
+ }
+} /* processFish */
+
+/*
+ *processFetch either returns the requested data (if available)
+ *or blocks the remote blocking queue on a black hole (if not).
+ */
+static void
+processFetch(void)
+{
+ globalAddr ga, rga;
+ int load;
+
+ P_ closure;
+ P_ ip;
+
+ unpackFetch(&ga, &rga, &load);
+#ifdef FETCH_DEBUG
+ fprintf(stderr, "Rcvd Fetch for (%x, %d, 0), Resume (%x, %d, %x) (load %d) \n",
+ ga.loc.gc.gtid, ga.loc.gc.slot,
+ rga.loc.gc.gtid, rga.loc.gc.slot, rga.weight, load);
+#endif
+
+ closure = GALAlookup(&ga);
+ ip = (P_) INFO_PTR(closure);
+
+ if (INFO_TYPE(ip) == INFO_FETCHME_TYPE) {
+ /* Forward the Fetch to someone else */
+ sendFetch(FETCHME_GA(closure), &rga, load);
+ } else if (rga.loc.gc.gtid == mytid) {
+ /* Our own FETCH forwarded back around to us */
+ P_ fmbq = GALAlookup(&rga);
+
+ /* We may have already discovered that the fetch target is our own. */
+ if (fmbq != closure)
+ CommonUp(fmbq, closure);
+ (void) addWeight(&rga);
+ } else if (IS_BLACK_HOLE(ip)) {
+ /* This includes RBH's and FMBQ's */
+ P_ bf;
+
+ if ((bf = AllocateHeap(FIXED_HS + BF_CLOSURE_SIZE(dummy))) == NULL) {
+ ReallyPerformThreadGC(FIXED_HS + BF_CLOSURE_SIZE(dummy), rtsFalse);
+ closure = GALAlookup(&ga);
+ bf = SAVE_Hp - (FIXED_HS + BF_CLOSURE_SIZE(dummy)) + 1;
+ }
+ ASSERT(GALAlookup(&rga) == NULL);
+
+ SET_BF_HDR(bf, BF_info, bogosity);
+ BF_NODE(bf) = closure;
+ BF_GTID(bf) = (W_) rga.loc.gc.gtid;
+ BF_SLOT(bf) = (W_) rga.loc.gc.slot;
+ BF_WEIGHT(bf) = (W_) rga.weight;
+ blockFetch(bf, closure);
+
+#ifdef FETCH_DEBUG
+ fprintf(stderr, "Blocking Fetch (%x, %d, %x) on %#lx\n",
+ rga.loc.gc.gtid, rga.loc.gc.slot, rga.weight, closure);
+#endif
+
+ } else {
+ /* The target of the FetchMe is some local graph */
+ W_ size;
+ P_ graph;
+
+ if ((graph = PackNearbyGraph(closure, &size)) == NULL) {
+ ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
+ SAVE_Hp -= PACK_HEAP_REQUIRED;
+ closure = GALAlookup(&ga);
+ graph = PackNearbyGraph(closure, &size);
+ ASSERT(graph != NULL);
+ }
+ sendResume(&rga, size, graph);
+ }
+}
+
+/*
+ *processFree unpacks a FREE message and adds the weights to our GAs.
+ */
+static void
+processFree(void)
+{
+ int nelem;
+ static W_ *freeBuffer;
+ int i;
+ globalAddr ga;
+
+ freeBuffer = gumPackBuffer;
+ unpackFree(&nelem, freeBuffer);
+#ifdef FREE_DEBUG
+ fprintf(stderr, "Rcvd Free (%d GAs)\n", nelem / 2);
+#endif
+ ga.loc.gc.gtid = mytid;
+ for (i = 0; i < nelem;) {
+ ga.weight = (unsigned) freeBuffer[i++];
+ ga.loc.gc.slot = (int) freeBuffer[i++];
+#ifdef FREE_DEBUG
+ fprintf(stderr,"Processing free (%x, %d, %x)\n", ga.loc.gc.gtid,
+ ga.loc.gc.slot, ga.weight);
+#endif
+ (void) addWeight(&ga);
+ }
+}
+
+/*
+ *processResume unpacks a RESUME message into the graph, filling in
+ *the LA -> GA, and GA -> LA tables. Threads blocked on the original
+ *FetchMe (now a blocking queue) are awakened, and the blocking queue
+ *is converted into an indirection. Finally it sends an ACK in response
+ *which contains any newly allocated GAs.
+ */
+
+static void
+processResume(GLOBAL_TASK_ID sender)
+{
+ int nelem;
+ W_ nGAs;
+ static W_ *packBuffer;
+ P_ newGraph;
+ P_ old;
+ globalAddr lga;
+ globalAddr *gagamap;
+
+ packBuffer = gumPackBuffer;
+ unpackResume(&lga, &nelem, packBuffer);
+
+#ifdef RESUME_DEBUG
+ fprintf(stderr, "Rcvd Resume for (%x, %d, %x)\n",
+ lga.loc.gc.gtid, lga.loc.gc.slot, lga.weight);
+ PrintPacket(packBuffer);
+#endif
+
+ /*
+ * We always unpack the incoming graph, even if we've received the
+ * requested node in some other data packet (and already awakened
+ * the blocking queue).
+ */
+ if (SAVE_Hp + packBuffer[0] >= SAVE_HpLim) {
+ ReallyPerformThreadGC(packBuffer[0], rtsFalse);
+ SAVE_Hp -= packBuffer[0];
+ }
+
+ /* Do this *after* GC; we don't want to release the object early! */
+
+ if (lga.weight > 0)
+ (void) addWeight(&lga);
+
+ old = GALAlookup(&lga);
+
+ if (RtsFlags.ParFlags.granSimStats) {
+ P_ tso = NULL;
+
+ if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE) {
+ for(tso = (P_) FMBQ_ENTRIES(old);
+ TSO_LINK(tso) != PrelBase_Z91Z93_closure;
+ tso = TSO_LINK(tso))
+ ;
+ }
+ /* DumpGranEventAndNode(GR_REPLY, tso, old, taskIDtoPE(sender)); */
+ DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(sender),GR_REPLY,
+ tso,old,0);
+ }
+
+ newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
+ ASSERT(newGraph != NULL);
+
+ /*
+ * Sometimes, unpacking will common up the resumee with the
+ * incoming graph, but if it hasn't, we'd better do so now.
+ */
+
+ if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE)
+ CommonUp(old, newGraph);
+
+#ifdef RESUME_DEBUG
+ DebugPrintGAGAMap(gagamap, nGAs);
+#endif
+
+ sendAck(sender, nGAs, gagamap);
+}
+
+/*
+ *processSchedule unpacks a SCHEDULE message into the graph, filling
+ *in the LA -> GA, and GA -> LA tables. The root of the graph is added to
+ *the local spark queue. Finally it sends an ACK in response
+ *which contains any newly allocated GAs.
+ */
+static void
+processSchedule(GLOBAL_TASK_ID sender)
+{
+ int nelem;
+ int space_required;
+ rtsBool success;
+ static W_ *packBuffer;
+ W_ nGAs;
+ P_ newGraph;
+ globalAddr *gagamap;
+
+ packBuffer = gumPackBuffer; /* HWL */
+ unpackSchedule(&nelem, packBuffer);
+
+#ifdef SCHEDULE_DEBUG
+ fprintf(stderr, "Rcvd Schedule\n");
+ PrintPacket(packBuffer);
+#endif
+
+ /*
+ * For now, the graph is a closure to be sparked as an advisory
+ * spark, but in future it may be a complete spark with
+ * required/advisory status, priority etc.
+ */
+
+ space_required = packBuffer[0];
+ if (SAVE_Hp + space_required >= SAVE_HpLim) {
+ ReallyPerformThreadGC(space_required, rtsFalse);
+ SAVE_Hp -= space_required;
+ }
+ newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
+ ASSERT(newGraph != NULL);
+ success = Spark(newGraph, rtsFalse);
+ ASSERT(success);
+
+#ifdef SCHEDULE_DEBUG
+ DebugPrintGAGAMap(gagamap, nGAs);
+#endif
+
+ if (nGAs > 0)
+ sendAck(sender, nGAs, gagamap);
+
+ fishing = rtsFalse;
+}
+
+/*
+ *processAck unpacks an ACK, and uses the GAGA map to convert RBH's
+ *(which represent shared thunks that have been shipped) into fetch-mes
+ *to remote GAs.
+ */
+static void
+processAck(void)
+{
+ int nGAs;
+ globalAddr *gaga;
+
+ globalAddr gagamap[MAX_GAS * 2];
+
+ unpackAck(&nGAs, gagamap);
+
+#ifdef ACK_DEBUG
+ fprintf(stderr, "Rcvd Ack (%d pairs)\n", nGAs);
+ DebugPrintGAGAMap(gagamap, nGAs);
+#endif
+
+ /*
+ * For each (oldGA, newGA) pair, set the GA of the corresponding
+ * thunk to the newGA, convert the thunk to a FetchMe, and return
+ * the weight from the oldGA.
+ */
+ for (gaga = gagamap; gaga < gagamap + nGAs * 2; gaga += 2) {
+ P_ old = GALAlookup(gaga);
+ P_ new = GALAlookup(gaga + 1);
+
+ if (new == NULL) {
+ /* We don't have this closure, so we make a fetchme for it */
+ globalAddr *ga = setRemoteGA(old, gaga + 1, rtsTrue);
+
+ convertToFetchMe(old, ga);
+ } else {
+ /*
+ * Oops...we've got this one already; update the RBH to
+ * point to the object we already know about, whatever it
+ * happens to be.
+ */
+ CommonUp(old, new);
+
+ /*
+ * Increase the weight of the object by the amount just
+ * received in the second part of the ACK pair.
+ */
+ (void) addWeight(gaga + 1);
+ }
+ (void) addWeight(gaga);
+ }
+}
+
+#endif
+
+#endif /* PAR -- whole file */
+
--- /dev/null
+/***********************************************************************
+* Low Level Communications Header (LLC.h) *
+* Contains the definitions used by the Low-level Communications *
+* module of the GUM Haskell runtime environment. *
+* Based on the Graph for PVM implementation. *
+* Phil Trinder, Glasgow University, 13th Dec 1994 *
+************************************************************************/
+
+#ifndef __LLC_H
+#define __LLC_H
+#ifdef PAR
+
+#include "Rts.h"
+#include "Parallel.h"
+
+#include "PEOpCodes.h"
+#include "pvm3.h"
+
+#define ANY_TASK (-1) /* receive messages from any task */
+#define ANY_GLOBAL_TASK ANY_TASK
+#define ANY_OPCODE (-1) /* receive any opcode */
+#define ALL_GROUP (-1) /* wait for barrier from every group member */
+
+#define PEGROUP "PE"
+
+#define MGRGROUP "MGR"
+#define PECTLGROUP "PECTL"
+
+
+#define PETASK "PE"
+
+#define sync(gp,op) do { broadcast(gp,op); pvm_barrier(gp,ALL_GROUP); } while(0)
+#define broadcast(gp,op) do { pvm_initsend(PvmDataDefault); pvm_bcast(gp,op); } while(0)
+#define checkComms(c,s) do {if((c)<0) { pvm_perror(s); stg_exit(EXIT_FAILURE); }} while(0)
+
+#define _my_gtid pvm_mytid()
+#define GetPacket() pvm_recv(ANY_TASK,ANY_OPCODE)
+#define PacketsWaiting() (pvm_probe(ANY_TASK,ANY_OPCODE) != 0)
+
+#define SPARK_THREAD_DESCRIPTOR 1
+#define GLOBAL_THREAD_DESCRIPTOR 2
+
+#define _extract_jump_field(v) (v)
+
+#define MAX_DATA_WORDS_IN_PACKET 1024
+
+#define PutArg1(a) pvm_pklong(&(a),1,1)
+#define PutArg2(a) pvm_pklong(&(a),1,1)
+#define PutArgN(n,a) pvm_pklong(&(a),1,1)
+#define PutArgs(b,n) pvm_pklong(b,n,1)
+
+#define PutLit(l) { int a = l; PutArgN(?,a); }
+
+#define GetArg1(a) pvm_upklong(&(a),1,1)
+#define GetArg2(a) pvm_upklong(&(a),1,1)
+#define GetArgN(n,a) pvm_upklong(&(a),1,1)
+#define GetArgs(b,n) pvm_upklong(b,n,1)
+
+extern void SendOp (OPCODE,GLOBAL_TASK_ID),
+ SendOp1 (OPCODE,GLOBAL_TASK_ID,StgWord),
+ SendOp2 (OPCODE,GLOBAL_TASK_ID,StgWord,StgWord),
+ SendOpV (OPCODE,GLOBAL_TASK_ID,int,...),
+ SendOpN (OPCODE,GLOBAL_TASK_ID,int,StgPtr),
+ SendOpNV (OPCODE,GLOBAL_TASK_ID,int,StgPtr,int,...);
+
+char *GetOpName (unsigned op);
+void NullException(void);
+
+PACKET WaitForPEOp (OPCODE op, GLOBAL_TASK_ID who);
+OPCODE Opcode (PACKET p);
+GLOBAL_TASK_ID Sender_Task (PACKET p);
+void get_opcode_and_sender (PACKET p, OPCODE *popcode, GLOBAL_TASK_ID *psender_id);
+GLOBAL_TASK_ID *PEStartUp (unsigned nPEs);
+void PEShutDown(void);
+void ProcessUnexpected (PACKET);
+
+#endif /*PAR */
+#endif /*defined __LLC_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * $Id: LLComms.c,v 1.2 1998/12/02 13:29:06 simonm Exp $
+ *
+ * GUM Low-Level Inter-Task Communication
+ *
+ * This module defines PVM Routines for PE-PE communication.
+ *
+ * P. Trinder, December 5th. 1994.
+ * Adapted for the new RTS, P. Trinder July 1998
+ *
+ ---------------------------------------------------------------------------- */
+
+#ifdef PAR /* whole file */
+
+/*
+ *This module defines the routines which communicate between PEs. The
+ *code is based on Kevin Hammond's GRIP RTS. (Opcodes.h defines
+ *PEOp1 etc. in terms of SendOp1 etc.).
+ *
+ *Routine & Arguments
+ * &
+ *SendOp & 0 \\
+ *SendOp1 & 1 \\
+ *SendOp2 & 2 \\
+ *SendOpN & vector \\
+ *SendOpV & variable \\
+ *SendOpNV & variable+ vector \\
+ *
+ *First the standard include files.
+ */
+
+#define NON_POSIX_SOURCE /* so says Solaris */
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "Parallel.h"
+
+#include "LLC.h"
+#ifdef __STDC__
+#include <stdarg.h>
+#else
+#include <varargs.h>
+#endif
+
+/*
+ *Then some miscellaneous functions.
+ *GetOpName returns the character-string name of any opcode.
+ */
+
+char *UserPEOpNames[] = { PEOP_NAMES };
+
+char *
+GetOpName(nat op)
+{
+ if (op >= MIN_PEOPS && op <= MAX_PEOPS)
+ return (UserPEOpNames[op - MIN_PEOPS]);
+
+ else
+ return ("Unknown PE Opcode");
+}
+
+/*
+ * trace_SendOp handles the tracing of messages.
+ */
+
+static void
+trace_SendOp(OPCODE op, GLOBAL_TASK_ID dest UNUSED,
+ unsigned int data1 UNUSED, unsigned int data2 UNUSED)
+{
+ char *OpName;
+
+ OpName = GetOpName(op);
+/* fprintf(stderr, " %s [%x,%x] sent from %x to %x\n", OpName, data1, data2, mytid, dest);*/
+}
+
+/*
+ *SendOp sends a 0-argument message with opcode {\em op} to
+ *the global task {\em task}.
+ */
+
+void
+SendOp(OPCODE op, GLOBAL_TASK_ID task)
+{
+ trace_SendOp(op, task,0,0);
+
+ pvm_initsend(PvmDataRaw);
+ pvm_send( task, op );
+}
+
+/*
+ *SendOp1 sends a 1-argument message with opcode {\em op}
+ *to the global task {\em task}.
+ */
+
+void
+SendOp1(OPCODE op, GLOBAL_TASK_ID task, StgWord arg1)
+{
+ trace_SendOp(op, task, arg1,0);
+
+ pvm_initsend(PvmDataRaw);
+ PutArg1(arg1);
+ pvm_send( task, op );
+}
+
+
+/*
+ *SendOp2 is used by the FP code only.
+ */
+
+void
+SendOp2(OPCODE op, GLOBAL_TASK_ID task, StgWord arg1, StgWord arg2)
+{
+ trace_SendOp(op, task, arg1, arg2);
+
+ pvm_initsend(PvmDataRaw);
+ PutArg1(arg1);
+ PutArg2(arg2);
+ pvm_send( task, op );
+}
+
+/*
+ *
+ *SendOpV takes a variable number of arguments, as specified by {\em n}.
+ *For example,
+ *
+ * SendOpV( PP_STATS, StatsTask, 3, start_time, stop_time, sparkcount);
+ */
+
+void
+SendOpV(OPCODE op, GLOBAL_TASK_ID task, int n, ...)
+{
+ va_list ap;
+ int i;
+ StgWord arg;
+
+ va_start(ap, n);
+
+ trace_SendOp(op, task, 0, 0);
+
+ pvm_initsend(PvmDataRaw);
+
+ for (i = 0; i < n; ++i) {
+ arg = va_arg(ap, StgWord);
+ PutArgN(i, arg);
+ }
+ va_end(ap);
+
+ pvm_send(task, op);
+}
+
+/*
+ *
+ *SendOpNV takes a variable-size datablock, as specified by {\em
+ *nelem} and a variable number of arguments, as specified by {\em
+ *narg}. N.B. The datablock and the additional arguments are contiguous
+ *and are copied over together. For example,
+ *
+ * SendOpNV(PP_RESUME, tsoga.pe, 6, nelem, data,
+ * (W_) ga.weight, (W_) ga.loc.gc.gtid, (W_) ga.loc.gc.slot,
+ * (W_) tsoga.weight, (W_) tsoga.loc.gc.gtid, (W_) tsoga.loc.gc.slot);
+ *
+ *Important: The variable arguments must all be StgWords.
+ */
+
+void
+SendOpNV(OPCODE op, GLOBAL_TASK_ID task, int nelem,
+ StgWord *datablock, int narg, ...)
+{
+ va_list ap;
+ int i;
+ StgWord arg;
+
+ va_start(ap, narg);
+
+ trace_SendOp(op, task, 0, 0);
+/* fprintf(stderr,"SendOpNV: op = %x, task = %x, narg = %d, nelem = %d\n",op,task,narg,nelem); */
+
+ pvm_initsend(PvmDataRaw);
+
+ for (i = 0; i < narg; ++i) {
+ arg = va_arg(ap, StgWord);
+/* fprintf(stderr,"SendOpNV: arg = %d\n",arg); */
+ PutArgN(i, arg);
+ }
+ arg = (StgWord) nelem;
+ PutArgN(narg, arg);
+
+/* for (i=0; i < nelem; ++i) fprintf(stderr, "%d ",datablock[i]); */
+/* fprintf(stderr," in SendOpNV\n");*/
+
+ PutArgs(datablock, nelem);
+ va_end(ap);
+
+ pvm_send(task, op);
+}
+
+/*
+ *SendOpN take a variable size array argument, whose size is given by
+ *{\em n}. For example,
+ *
+ * SendOpN( PP_STATS, StatsTask, 3, stats_array);
+ */
+
+void
+SendOpN(OPCODE op, GLOBAL_TASK_ID task, int n, StgPtr args)
+{
+ long arg;
+
+ trace_SendOp(op, task, 0, 0);
+
+ pvm_initsend(PvmDataRaw);
+ arg = (long) n;
+ PutArgN(0, arg);
+ PutArgs(args, n);
+ pvm_send(task, op);
+}
+
+/*
+ *WaitForPEOp waits for a packet from global task {\em who} with the
+ *opcode {\em op}. Other opcodes are handled by processUnexpected.
+ */
+PACKET
+WaitForPEOp(OPCODE op, GLOBAL_TASK_ID who)
+{
+ PACKET p;
+ int nbytes;
+ OPCODE opcode;
+ GLOBAL_TASK_ID sender_id;
+ rtsBool match;
+
+ do {
+#if 0
+ fprintf(stderr,"WaitForPEOp: op = %x, who = %x\n",op,who);
+#endif
+ while((p = pvm_recv(ANY_TASK,ANY_OPCODE)) < 0)
+ pvm_perror("WaitForPEOp: Waiting for PEOp");
+
+ pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
+#if 0
+ fprintf(stderr,"WaitForPEOp: received: opcode = %x, sender_id = %x\n",opcode,sender_id);
+#endif
+ match = (op == ANY_OPCODE || op == opcode) && (who == ANY_TASK || who == sender_id);
+
+ if(match)
+ return(p);
+
+ /* Handle the unexpected opcodes */
+ ProcessUnexpected(p);
+
+ } while(rtsTrue);
+}
+
+/*
+ *ProcessUnexpected processes unexpected messages. If the message is a
+ *FINISH it exits the prgram, and PVM gracefully
+ */
+void
+ProcessUnexpected(PACKET packet)
+{
+ OPCODE opcode = Opcode(packet);
+
+#ifdef 0
+ {
+ GLOBAL_TASK_ID sender = Sender_Task(packet);
+ fprintf(stderr,"ProcessUnexpected: Received %s (%x), sender %x\n",GetOpName(opcode),opcode,sender);
+ }
+#endif
+
+ switch (opcode) {
+
+ case PP_FINISH:
+ stg_exit(EXIT_SUCCESS);
+ break;
+
+ /* Anything we're not prepared to deal with. Note that ALL opcodes are discarded
+ during termination -- this helps prevent bizarre race conditions.
+ */
+ default:
+ if (!GlobalStopPending)
+ {
+ GLOBAL_TASK_ID ErrorTask;
+ int opcode;
+
+ get_opcode_and_sender(packet,&opcode,&ErrorTask);
+ fprintf(stderr,"Task %x: Unexpected opcode %x from %x in ProcessUnexpected\n",
+ mytid, opcode, ErrorTask );
+
+ stg_exit(EXIT_FAILURE);
+ }
+ }
+}
+
+OPCODE
+Opcode(PACKET p)
+{
+ int nbytes;
+ OPCODE opcode;
+ GLOBAL_TASK_ID sender_id;
+ pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
+ return(opcode);
+}
+
+GLOBAL_TASK_ID
+Sender_Task(PACKET p)
+{
+ int nbytes;
+ OPCODE opcode;
+ GLOBAL_TASK_ID sender_id;
+ pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
+ return(sender_id);
+}
+
+void
+get_opcode_and_sender(PACKET p, OPCODE *popcode, GLOBAL_TASK_ID *psender_id)
+{
+ int nbytes;
+ pvm_bufinfo( p, &nbytes, popcode, psender_id );
+}
+
+
+/*
+ *PEStartUp does the low-level comms specific startup stuff for a
+ *PE. It initialises the comms system, joins the appropriate groups,
+ *synchronises with the other PEs. Receives and records in a global
+ *variable the task-id of SysMan. If this is the main thread (discovered
+ *in main.lc), identifies itself to SysMan. Finally it receives
+ *from SysMan an array of the Global Task Ids of each PE, which is
+ *returned as the value of the function.
+ */
+GLOBAL_TASK_ID *
+PEStartUp(nat nPEs)
+{
+ int i;
+ PACKET addr;
+ long *buffer = (long *) stgMallocBytes(sizeof(long) * nPEs, "PEStartUp (buffer)");
+ GLOBAL_TASK_ID *PEs
+ = (GLOBAL_TASK_ID *) stgMallocBytes(sizeof(GLOBAL_TASK_ID) * nPEs, "PEStartUp (PEs)");
+
+ mytid = _my_gtid; /* Initialise PVM and get task id into global var.*/
+
+/* fprintf(stderr,"PEStartup, Task id = [%x], No. PEs = %d \n", mytid, nPEs); */
+ checkComms(pvm_joingroup(PEGROUP), "PEStartup");
+/* fprintf(stderr,"PEStartup, Joined PEGROUP\n"); */
+ checkComms(pvm_joingroup(PECTLGROUP), "PEStartup");
+/* fprintf(stderr,"PEStartup, Joined PECTLGROUP\n"); */
+ checkComms(pvm_barrier(PECTLGROUP, nPEs+1), "PEStartup");
+/* fprintf(stderr,"PEStartup, Passed PECTLGROUP barrier\n"); */
+
+ addr = WaitForPEOp(PP_SYSMAN_TID, ANY_GLOBAL_TASK);
+ SysManTask = Sender_Task(addr);
+ if (IAmMainThread) { /* Main Thread Identifies itself to SysMan */
+ pvm_initsend(PvmDataDefault);
+ pvm_send(SysManTask, PP_MAIN_TASK);
+ }
+ addr = WaitForPEOp(PP_PETIDS, ANY_GLOBAL_TASK);
+ GetArgs(buffer, nPEs);
+ for (i = 0; i < nPEs; ++i) {
+ PEs[i] = (GLOBAL_TASK_ID) buffer[i];
+#if 0
+ fprintf(stderr,"PEs[%d] = %x \n", i, PEs[i]);
+#endif
+ }
+ free(buffer);
+ return PEs;
+}
+
+/*
+ *PEShutdown does the low-level comms-specific shutdown stuff for a
+ *single PE. It leaves the groups and then exits from pvm.
+ */
+void
+PEShutDown(void)
+{
+ checkComms(pvm_lvgroup(PEGROUP),"PEShutDown");
+ checkComms(pvm_lvgroup(PECTLGROUP),"PEShutDown");
+ checkComms(pvm_exit(),"PEShutDown");
+}
+
+/*
+heapChkCounter tracks the number of heap checks since the last probe.
+Not currently used! We check for messages when a thread is resheduled.
+*/
+int heapChkCounter = 0;
+
+#endif /* PAR -- whole file */
+
--- /dev/null
+/****************************************************************************
+
+[ParInit.c] Initialising the parallel RTS
+
+ P. Trinder, January 17th 1995.
+ An extension based on Kevin Hammond's GRAPH for PVM version
+ P. Trinder, July 1997.
+ Adapted for the new RTS
+
+****************************************************************************/
+
+#ifdef PAR /* whole file */
+
+#define NON_POSIX_SOURCE /* so says Solaris */
+
+#include "Rts.h"
+#include <setjmp.h>
+#include "LLC.h"
+#include "HLC.h"
+
+/* Global conditions defined here. */
+
+rtsBool
+ IAmMainThread = rtsFalse, /* Set for the main thread */
+ GlobalStopPending = rtsFalse; /* Terminating */
+
+/* Task identifiers for various interesting global tasks. */
+
+GLOBAL_TASK_ID IOTask = 0, /* The IO Task Id */
+ SysManTask = 0, /* The System Manager Task Id */
+ mytid = 0; /* This PE's Task Id */
+
+REAL_TIME main_start_time; /* When the program started */
+REAL_TIME main_stop_time; /* When the program finished */
+jmp_buf exit_parallel_system; /* How to abort from the RTS */
+
+
+/* Flag handling. */
+
+/*rtsBool TraceSparks = rtsFalse; /* Enable the spark trace mode */
+/*rtsBool SparkLocally = rtsFalse; /* Use local threads if possible */
+/*rtsBool DelaySparks = rtsFalse; /* Use delayed sparking */
+/*rtsBool LocalSparkStrategy = rtsFalse; /* Either delayed threads or local threads*/
+/*rtsBool GlobalSparkStrategy = rtsFalse; /* Export all threads */
+/*
+/*rtsBool DeferGlobalUpdates = rtsFalse; /* Defer updating of global nodes */
+
+rtsBool fishing = rtsFalse; /* We have no fish out in the stream */
+
+/* Initialisation Routines */
+
+/*
+par_exit defines how to terminate the program. If the exit code is
+non-zero (i.e. an error has occurred), the PE should not halt until
+outstanding error messages have been processed. Otherwise, messages
+might be sent to non-existent Task Ids. The infinite loop will actually
+terminate, since STG_Exception will call myexit\tr{(0)} when
+it received a PP_FINISH from the system manager task.
+*/
+
+void
+par_exit(I_ n) /* NB: "EXIT" is set to "myexit" for parallel world */
+{
+ GlobalStopPending = rtsTrue;
+ SendOp(PP_FINISH, SysManTask);
+ if (n != 0)
+ WaitForTermination();
+ else
+ WaitForPEOp(PP_FINISH, SysManTask);
+ PEShutDown();
+/* fprintf(stderr,"PE %lx shutting down, %ld Threads run, %ld Sparks Ignored\n", (W_) mytid, threadId, sparksIgnored); */
+ fprintf(stderr,"PE %lx shutting down, %ld Threads run\n", (W_) mytid, threadId);
+
+ exit(n);
+}
+
+void srand48 (long);
+time_t time (time_t *);
+
+void
+initParallelSystem(void)
+{
+ /* Don't buffer standard channels... */
+ setbuf(stdout,NULL);
+ setbuf(stderr,NULL);
+
+ srand48(time(NULL) * getpid()); /*Initialise Random-number generator seed*/
+ /* Used to select target of FISH message*/
+ InitPackBuffer();
+ InitMoreBuffers();
+}
+
+/*
+ *SynchroniseSystem synchronises the reduction task with the system
+ *manager, and initialises the Global address tables (LAGA & GALA)
+ */
+
+GLOBAL_TASK_ID *PEs;
+
+void
+SynchroniseSystem(void)
+{
+ int i;
+
+ PEs = PEStartUp(nPEs);
+
+ /* Initialize global address tables */
+ initGAtables();
+
+ /* Record the shortened the PE identifiers for LAGA etc. tables */
+ for (i = 0; i < nPEs; ++i)
+ registerTask(PEs[i]);
+
+}
+
+#endif /* PAR -- whole file */
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * ParInit.h,1
+ *
+ * Phil Trinder
+ * July 1998
+ *
+ * External Parallel Initialisation Interface
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef PARINIT_H
+#define PARINIT_H
+
+extern void RunParallelSystem (P_);
+extern void initParallelSystem(void);
+extern void SynchroniseSystem(void);
+extern void par_exit(I_);
+
+#endif PARINIT_H
--- /dev/null
+/************************************************************************
+ * *
+ * Runtime system types for GUM *
+ * *
+ ************************************************************************/
+
+#ifndef PARTYPES_H
+#define PARTYPES_H
+
+#ifdef PAR /* all of it */
+
+typedef struct hashtable HashTable;
+typedef struct hashlist HashList;
+
+typedef double REAL_TIME;
+typedef int GLOBAL_TASK_ID;
+typedef int PACKET;
+typedef int OPCODE;
+typedef W_ TIME;
+typedef GLOBAL_TASK_ID PROC;
+
+/* Global addresses, in all their glory */
+
+typedef struct {
+ union {
+ P_ plc;
+ struct {
+ GLOBAL_TASK_ID gtid;
+ int slot;
+ } gc;
+ } loc;
+ unsigned weight;
+} globalAddr;
+
+/* (GA, LA) pairs */
+typedef struct gala {
+ globalAddr ga;
+ P_ la;
+ struct gala *next;
+ rtsBool preferred;
+} GALA;
+
+#if defined(GRAN)
+typedef unsigned long TIME;
+typedef unsigned char PROC;
+typedef unsigned char EVTTYPE;
+#endif
+
+#endif /* PAR */
+
+#endif /* ! PARTYPES_H */
+
+
--- /dev/null
+
+/************************************************************************
+ * *
+ * [Parallel.h]{Definitions for parallel machines}
+ * *
+ ************************************************************************/
+
+#ifndef Parallel_H
+#define Parallel_H
+
+/*
+ * This section contains definitions applicable only to programs compiled
+ * to run on a parallel machine.
+ *
+ * These basic definitions need to be around, one way or the other:
+ */
+
+#include "ParTypes.h"
+
+# ifdef PAR
+# define MAX_PES 256 /* Maximum number of processors */
+ /* MAX_PES is enforced by SysMan, which does not
+ allow more than this many "processors".
+ This is important because PackGA [GlobAddr.lc]
+ **assumes** that a PE# can fit in 8+ bits.
+ */
+
+extern I_ do_sp_profile;
+
+extern P_ PendingFetches;
+extern GLOBAL_TASK_ID *PEs;
+
+extern rtsBool IAmMainThread, GlobalStopPending;
+extern rtsBool fishing;
+extern GLOBAL_TASK_ID SysManTask;
+extern int seed; /*pseudo-random-number generator seed:*/
+ /*Initialised in ParInit*/
+extern I_ threadId; /*Number of Threads that have existed on a PE*/
+extern GLOBAL_TASK_ID mytid;
+
+extern int nPEs;
+
+extern rtsBool InGlobalGC; /* Are we in the midst of performing global GC */
+
+extern HashTable *pGAtoGALAtable;
+extern HashTable *LAtoGALAtable;
+extern GALA *freeIndirections;
+extern GALA *liveIndirections;
+extern GALA *freeGALAList;
+extern GALA *liveRemoteGAs;
+extern int thisPE;
+
+void RunParallelSystem (StgPtr program_closure);
+void initParallelSystem(void);
+void SynchroniseSystem(void);
+
+void registerTask (GLOBAL_TASK_ID gtid);
+globalAddr *LAGAlookup (P_ addr);
+P_ GALAlookup (globalAddr *ga);
+globalAddr *MakeGlobal (P_ addr, rtsBool preferred);
+globalAddr *setRemoteGA (P_ addr, globalAddr *ga, rtsBool preferred);
+void splitWeight (globalAddr *to, globalAddr *from);
+globalAddr *addWeight (globalAddr *ga);
+void initGAtables(void);
+W_ taskIDtoPE (GLOBAL_TASK_ID gtid);
+void RebuildLAGAtable(void);
+
+void *lookupHashTable (HashTable *table, StgWord key);
+void insertHashTable (HashTable *table, StgWord key, void *data);
+void freeHashTable (HashTable *table, void (*freeDataFun) (void *data));
+HashTable *allocHashTable(void);
+void *removeHashTable (HashTable *table, StgWord key, void *data);
+
+extern void par_exit (I_);
+#endif
+
+/************************************************************************
+ * *
+[anti-parallel-SM]{But if we're {\em not} compiling for a parallel system...}
+ * *
+ ************************************************************************
+ *
+ *Get this out of the way. These are all null definitions.
+ */
+
+#if defined(GRAN)
+
+# define GA_HDR_SIZE 1
+
+# define PROCS_HDR_POSN PAR_HDR_POSN
+# define PROCS_HDR_SIZE 1
+
+/* Accessing components of the field */
+# define PROCS(closure) (*((P_)(closure)+PROCS_HDR_POSN))
+
+# define SET_PROCS(closure, procs) \
+ PROCS(closure) = (W_)(procs) /* Set closure's location */
+# define SET_GRAN_HDR(closure,pe) SET_PROCS(closure,pe)
+
+# define SET_STATIC_PROCS(closure) , (W_) (Everywhere)
+
+# define SET_TASK_ACTIVITY(act) /* nothing */
+#endif
+
+/************************************************************************
+ * *
+ *[parallel-GAs]{Parallel-only part of fixed headers (global addresses)}
+ * *
+ ************************************************************************
+ *
+ *Definitions relating to the entire parallel-only fixed-header field.
+ *
+ *On GUM, the global addresses for each local closure are stored in a separate
+ *hash table, rather then with the closure in the heap. We call @getGA@ to
+ *look up the global address associated with a local closure (0 is returned
+ *for local closures that have no global address), and @setGA@ to store a new
+ *global address for a local closure which did not previously have one.
+ */
+
+#if defined(PAR)
+
+# define GA(closure) getGA(closure)
+# define SET_GA(closure, ga) setGA(closure,ga)
+
+# define SET_STATIC_GA(closure)
+# define SET_STATIC_PROCS(closure)
+
+# define MAX_GA_WEIGHT 0 /* Treat as 2^n */
+
+W_ PackGA (W_, int);
+/* There was a PACK_GA macro here; but we turned it into the PackGA
+ * routine [GlobAddr.lc] (because it needs to do quite a bit of
+ * paranoia checking. Phil & Will (95/08)
+ */
+
+/**
+ *At the moment, there is no activity profiling for GUM:
+ */
+
+# define SET_TASK_ACTIVITY(act)
+
+
+
+/************************************************************************
+ * *
+ *[parallel-heap-objs]{Special parallel-only heap objects (`closures')}
+ * *
+ ************************************************************************
+ *
+ * %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ * NB: The following definitons are BOTH for GUM and GrAnSim -- HWL
+ * %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ *
+ *The rest of this file contains definitions for {\it GUM and GrAnSim}.
+ *Although we don't create FetchMe nodes in GrAnSim (we simulate it by
+ *bitmask twiddling) we use FetchMe_info when converting nodes into RBHs
+ *(mainly to keep the code as close to GUM as possible). So, we define all
+ *the FetchMe related stuff in GrAnSim, too. % -- HWL
+ *
+ ************************************************************************
+ * *
+ * [FETCHME-closures]{@FETCHME@ heap objects (`closures')}
+ * *
+ ************************************************************************
+
+ ... Zapped for now PWT ...
+*/
+
+
+/************************************************************************
+ * *
+ [parallel-pack-defs]{Parallel-only Packing definitions}
+ * *
+ ************************************************************************
+ *
+ *
+ *Symbolic constants for the packing code.
+ *
+ *This constant defines how many words of data we can pack into a single
+ *packet in the parallel (GUM) system.
+ */
+
+void InitPackBuffer(void);
+P_ PackTSO (P_ tso, W_ *size);
+P_ PackStkO (P_ stko, W_ *size);
+P_ AllocateHeap (W_ size); /* Doesn't belong */
+
+void InitClosureQueue (void);
+P_ DeQueueClosure(void);
+void QueueClosure (P_ closure);
+rtsBool QueueEmpty(void);
+void PrintPacket (P_ buffer);
+
+P_ get_closure_info (P_ closure, W_ *size, W_ *ptrs, W_ *nonptrs, W_ *vhs, char *type);
+
+rtsBool isOffset (globalAddr *ga),
+ isFixed (globalAddr *ga);
+
+void doGlobalGC(void);
+
+P_ PackNearbyGraph (P_ closure,W_ *size);
+P_ UnpackGraph (W_ *buffer, globalAddr **gamap, W_ *nGAs);
+
+# 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_ */
+extern W_ *freeBuffer; /* HWL_ */
+extern W_ *packBuffer; /* HWL_ */
+
+extern void InitPackBuffer(void);
+extern void InitMoreBuffers(void);
+extern void InitPendingGABuffer(W_ size);
+extern void AllocClosureQueue(W_ size);
+
+# define MAX_GAS (RTSflags.ParFlags.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 1 /* Words of header in a packet */
+
+# define PACK_PLC_SIZE 2 /* Size of a packed PLC in words */
+
+#if defined(GRAN)
+/* ToDo: Check which of the PAR routines are needed in GranSim -- HWL */
+void InitPackBuffer(void);
+P_ AllocateHeap (W_ size); /* Doesn't belong */
+P_ PackNearbyGraph (P_ closure, P_ tso, W_ *packbuffersize);
+P_ PackOneNode (P_ closure, P_ tso, W_ *packbuffersize);
+P_ UnpackGraph (P_ buffer);
+
+void InitClosureQueue (void);
+P_ DeQueueClosure(void);
+void QueueClosure (P_ closure);
+rtsBool QueueEmpty(void);
+void PrintPacket (P_ buffer);
+
+P_ get_closure_info (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 /* GRAN */
+
+#endif /* PAR */
+#endif /* Parallel_H */
+
+
+
--- /dev/null
+/****************************************************************************
+
+ GUM System Manager Program
+
+ The Parade/AQUA Projects, Glasgow University, 1994-1995.
+ P. Trinder, November 30th. 1994.
+ Adapted for new RTS
+ P. Trinder, July 1997.
+
+
+****************************************************************************
+
+The Sysman task currently controls initiation, termination, of a
+parallel Haskell program running under GUM. In the future it may
+control global GC synchronisation and statistics gathering. Based on
+K. Hammond's SysMan.lc in Graph for PVM. SysMan is unusual in that it
+is not part of the executable produced by ghc: it is a free-standing
+program that spawns PVM tasks (logical PEs) to evaluate the
+program. After initialisation it runs in parallel with the PE tasks,
+awaiting messages.
+
+OK children, buckle down for some serious weirdness, it works like this ...
+
+
+o The argument vector (argv) for SysMan has one the following 2 shapes:
+
+-------------------------------------------------------------------------------
+| SysMan path | debug flag | pvm-executable path | Num. PEs | Program Args ...|
+-------------------------------------------------------------------------------
+
+-------------------------------------------------------------------
+| SysMan path | pvm-executable path | Num. PEs | Program Args ... |
+-------------------------------------------------------------------
+
+The "pvm-executable path" is an absolute path of where PVM stashes the
+code for each PE. The arguments passed on to each PE-executable
+spawned by PVM are:
+
+-------------------------------
+| Num. PEs | Program Args ... |
+-------------------------------
+
+The arguments passed to the Main-thread PE-executable are
+
+-------------------------------------------------------------------
+| main flag | pvm-executable path | Num. PEs | Program Args ... |
+-------------------------------------------------------------------
+
+o SysMan's algorithm is as follows.
+
+o use PVM to spawn (nPE-1) PVM tasks
+o fork SysMan to create the main-thread PE. This permits the main-thread to
+read and write to stdin and stdout.
+o Barrier-synchronise waiting for all of the PE-tasks to start.
+o Broadcast the SysMan task-id, so that the main thread knows it.
+o Wait for the Main-thread PE to send it's task-id.
+o Broadcast an array of the PE task-ids to all of the PE-tasks.
+o Enter a loop awaiting incoming messages, e.g. failure, Garbage-collection,
+termination.
+
+The forked Main-thread algorithm, in SysMan, is as follows.
+
+o disconnects from PVM.
+o sets a flag in argv to indicate that it is the main thread.
+o `exec's a copy of the pvm-executable (i.e. the program being run)
+
+
+The pvm-executable run by each PE-task, is initialised as follows.
+
+o Registers with PVM, obtaining a task-id.
+o Joins the barrier synchronisation awaiting the other PEs.
+o Receives and records the task-id of SysMan, for future use.
+o If the PE is the main thread it sends its task-id to SysMan.
+o Receives and records the array of task-ids of the other PEs.
+o Begins execution.
+
+***************************************************************************/
+
+#define NON_POSIX_SOURCE /* so says Solaris */
+
+#include "Rts.h"
+#include "ParTypes.h"
+#include "LLC.h"
+#include "Parallel.h"
+
+/*
+ *The following definitions included so that SysMan can be linked with
+ *Low Level Communications module (LLComms). They are not used in
+ *SysMan.
+ */
+
+GLOBAL_TASK_ID mytid, SysManTask;
+rtsBool IAmMainThread;
+rtsBool GlobalStopPending = rtsFalse; /* Handle Unexpexted messages correctly */
+
+static GLOBAL_TASK_ID gtids[MAX_PES];
+static long PEbuffer[MAX_PES];
+int nPEs = 0;
+static GLOBAL_TASK_ID sysman_id, sender_id, mainThread_id;
+static unsigned PEsTerminated = 0;
+static rtsBool Finishing = rtsFalse;
+
+/*
+ * This reproduced from RtsUtlis to save linking with a whole ball of wax
+ */
+stgMallocBytes (int n, char *msg)
+{
+ char *space;
+
+ if ((space = (char *) malloc((size_t) n)) == NULL) {
+ fflush(stdout);
+ fprintf(stderr,"stgMallocBytes failed: ", msg);
+ stg_exit(EXIT_FAILURE);
+ }
+ return space;
+}
+
+#define checkerr(c) do {if((c)<0) { pvm_perror("Sysman"); exit(EXIT_FAILURE); }} while(0)
+
+main(int argc, char **argv)
+{
+ int rbufid;
+ int opcode, nbytes;
+ char **pargv;
+ int i, cc;
+ int spawn_flag = PvmTaskDefault;
+ PACKET addr;
+
+ char *petask, *pvmExecutable;
+
+ setbuf(stdout, NULL);
+ setbuf(stderr, NULL);
+
+ if (argc > 1) {
+ if (*argv[1] == '-') {
+ spawn_flag = PvmTaskDebug;
+ argv[1] = argv[0];
+ argv++; argc--;
+ }
+ sysman_id = pvm_mytid();/* This must be the first PVM call */
+
+ checkerr(sysman_id);
+
+ /*
+ Get the full path and filename of the pvm executable (stashed in some
+ PVM directory.
+ */
+ pvmExecutable = argv[1];
+
+ nPEs = atoi(argv[2]);
+
+ if ((petask = getenv(PETASK)) == NULL)
+ petask = PETASK;
+
+#if 1
+ fprintf(stderr, "nPEs (%s) = %d\n", petask, nPEs);
+#endif
+
+ /* Check that we can create the number of PE and IMU tasks requested */
+ if (nPEs > MAX_PES) {
+ fprintf(stderr, "No more than %d PEs allowed (%d requested)\n", MAX_PES, nPEs);
+ exit(EXIT_FAILURE);
+ }
+
+ /*
+ Now create the PE Tasks. We spawn (nPEs-1) pvm threads: the Main Thread
+ (which starts execution and performs IO) is created by forking SysMan
+ */
+ nPEs--;
+ if (nPEs > 0) {
+ /* Initialise the PE task arguments from Sysman's arguments */
+ pargv = argv + 2;
+#if 1
+ fprintf(stderr, "Spawning %d PEs(%s) ...\n", nPEs, petask);
+ fprintf(stderr, " args: ");
+ for (i = 0; pargv[i]; ++i)
+ fprintf(stderr, "%s, ", pargv[i]);
+ fprintf(stderr, "\n");
+#endif
+ checkerr(pvm_spawn(petask, pargv, spawn_flag, "", nPEs, gtids));
+ /*
+ * Stash the task-ids of the PEs away in a buffer, once we know
+ * the Main Thread's task-id, we'll broadcast them all.
+ */
+ for (i = 0; i < nPEs; i++)
+ PEbuffer[i+1] = (long) gtids[i];
+#if 1
+ fprintf(stderr, "Spawned /* PWT */\n");
+#endif
+ }
+
+ /*
+ Create the MainThread PE by forking SysMan. This arcane coding
+ is required to allow MainThread to read stdin and write to stdout.
+ PWT 18/1/96
+ */
+ nPEs++; /* Record that the number of PEs is increasing */
+ if ((cc = fork())) {
+ checkerr(cc); /* Parent continues as SysMan */
+#if 1
+ fprintf(stderr, "SysMan Task is [t%x]\n", sysman_id);
+#endif
+ /*
+ SysMan joins PECTLGROUP, so that it can wait (at the
+ barrier sysnchronisation a few instructions later) for the
+ other PE-tasks to start.
+
+ The manager group (MGRGROUP) is vestigial at the moment. It
+ may eventually include a statistics manager, and a (global)
+ garbage collector manager.
+ */
+ checkerr(pvm_joingroup(PECTLGROUP));
+#if 1
+ fprintf(stderr, "Joined PECTLGROUP /* PWT */\n");
+#endif
+ /* Wait for all the PEs to arrive */
+ checkerr(pvm_barrier(PECTLGROUP, nPEs + 1));
+#if 1
+ fprintf(stderr, "PECTLGROUP barrier passed /* HWL */\n");
+#endif
+ /* Broadcast SysMan's ID, so Main Thread PE knows it */
+ pvm_initsend(PvmDataDefault);
+ pvm_bcast(PEGROUP, PP_SYSMAN_TID);
+
+ /* Wait for Main Thread to identify itself*/
+ addr = WaitForPEOp(PP_MAIN_TASK, ANY_GLOBAL_TASK);
+ pvm_bufinfo(addr, &nbytes, &opcode, &mainThread_id );
+ PEbuffer[0] = mainThread_id;
+#if 1
+ fprintf(stderr,"SysMan received Main Task = %x\n",mainThread_id);
+#endif
+ /* Now that we have them all, broadcast Global Task Ids of all PEs */
+ pvm_initsend(PvmDataDefault);
+ PutArgs(PEbuffer, nPEs);
+ pvm_bcast(PEGROUP, PP_PETIDS);
+#if 1
+ fprintf(stderr, "Sysman successfully initialized!\n");
+#endif
+ /* Process incoming messages */
+ while (1) {
+ if ((rbufid = pvm_recv(ANY_TASK, ANY_OPCODE)) < 0)
+ pvm_perror("Sysman: Receiving Message");
+ else {
+ pvm_bufinfo(rbufid, &nbytes, &opcode, &sender_id);
+#if 1
+ fprintf(stderr, "HWL-DBG(SysMan; main loop): rbufid=%x, nbytes = %d, opcode = %x, sender_id = %x\n",
+ rbufid, nbytes, opcode, sender_id);
+#endif
+ switch (opcode) {
+ case PP_GC_INIT:
+ /* This Function not yet implemented for GUM */
+ fprintf(stderr, "Global GC from %x Not yet implemented for GUM!\n", sender_id);
+ sync(PECTLGROUP, PP_FULL_SYSTEM);
+ broadcast(PEGROUP, PP_GC_INIT);
+/* DoGlobalGC(); */
+/* broadcast(PEGROUP, PP_INIT); */
+ break;
+
+ case PP_STATS_ON:
+ case PP_STATS_OFF:
+ /* This Function not yet implemented for GUM */
+ break;
+
+ case PP_FINISH:
+ if (!Finishing) {
+ fprintf(stderr, "\nFinish from %x\n", sender_id);
+ Finishing = rtsTrue;
+ pvm_initsend(PvmDataDefault);
+ pvm_bcast(PEGROUP, PP_FINISH);
+ } else {
+ ++PEsTerminated;
+ }
+ if (PEsTerminated >= nPEs) {
+ broadcast(PEGROUP, PP_FINISH);
+ broadcast(MGRGROUP, PP_FINISH);
+ pvm_lvgroup(PECTLGROUP);
+ pvm_lvgroup(MGRGROUP);
+ pvm_exit();
+ exit(EXIT_SUCCESS);
+ }
+ break;
+
+ case PP_FAIL:
+ fprintf(stderr, "Fail from %x\n", sender_id);
+ if (!Finishing) {
+ Finishing = rtsTrue;
+ broadcast(PEGROUP, PP_FAIL);
+ }
+ break;
+
+ default:
+ {
+/* char *opname = GetOpName(opcode);
+ fprintf(stderr,"Sysman: Unrecognised opcode %s (%x)\n",
+ opname,opcode); */
+ fprintf(stderr, "Sysman: Unrecognised opcode (%x)\n",
+ opcode);
+ }
+ break;
+ } /* switch */
+ } /* else */
+ } /* while 1 */
+ } /* forked Sysman Process */
+ else {
+ pvmendtask(); /* Disconnect from PVM to avoid confusion: */
+ /* executable reconnects */
+ *argv[0] = '-'; /* Flag that this is the Main Thread PE */
+ execv(pvmExecutable,argv); /* Parent task becomes Main Thread PE */
+ }
+ } /* argc > 1 */
+} /* main */
+
+/* Needed here because its used in loads of places like LLComms etc */
+
+void stg_exit(n)
+I_ n;
+{
+ exit(n);
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: ErrorHdr.c,v 1.2 1998/12/02 13:29:11 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+void
+ErrorHdrHook (long fd)
+{
+ const char msg[] = "\nFail: ";
+ write(fd, msg, sizeof(msg)-1);
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: FlagDefaults.c,v 1.2 1998/12/02 13:29:11 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+void
+defaultsHook (void)
+{ /* this is called *after* RTSflags has had
+ its defaults set, but *before* we start
+ processing the RTS command-line options.
+
+ This default version does *nothing*.
+ The user may provide a more interesting
+ one.
+ */
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: InitEachPE.c,v 1.2 1998/12/02 13:29:12 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef PAR
+void
+initEachPEHook (void)
+{ /* in a GUM setup this is called on each
+ PE immediately before SynchroniseSystem
+ it can be used to read in static data
+ to each PE which has to be available to
+ each PE
+
+ This version is the one specialised
+ for Lolita, calling the LoadAllData stuff.
+ The default version probably should do
+ nothing -- HWL
+ */
+}
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: MallocFail.c,v 1.2 1998/12/02 13:29:12 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+void
+MallocFailHook (lnat request_size /* in bytes */, char *msg)
+{
+ fprintf(stderr, "malloc: failed on request for %lu bytes; message: %s\n", request_size, msg);
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: NoRunnableThreads.c,v 1.2 1998/12/02 13:29:13 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+/*
+ Hook to invoke when there's nothing left on the runnable threads
+ queue {\em and} we've got nothing to wait for. The value
+ returned is the exit code to report back.
+
+ NOTE: This hook is really CONCURRENT specific, but we include
+ it in the way-independent libHSclib.a.
+*/
+
+int
+NoRunnableThreadsHook (void)
+{
+ fflush(stdout);
+ fprintf(stderr, "No runnable threads!\n");
+ return(EXIT_FAILURE);
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: OnExit.c,v 1.2 1998/12/02 13:29:14 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+/* Note: by the time this hook has been called, Haskell land
+ * will have been shut down completely.
+ *
+ * ToDo: feed the hook info on whether we're shutting down as a result
+ * of termination or run-time error ?
+ */
+
+void
+OnExitHook ()
+{
+}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: OutOfHeap.c,v 1.2 1998/12/02 13:29:14 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+void
+OutOfHeapHook (lnat request_size, lnat heap_size) /* both sizes in bytes */
+{
+ /* fprintf(stderr, "Heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse `+RTS -H<size>' to increase the total heap size.\n", */
+
+ fprintf(stderr, "Heap exhausted;\nCurrent maximum heap size is %lu bytes;\nuse `+RTS -M<size>' to increase it.\n",
+ heap_size);
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: PatErrorHdr.c,v 1.2 1998/12/02 13:29:15 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+void
+PatErrorHdrHook (long fd)
+{
+ const char msg[] = "\nFail: ";
+ write(fd,msg,sizeof(msg)-1);
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: StackOverflow.c,v 1.2 1998/12/02 13:29:15 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+void
+StackOverflowHook (lnat stack_size) /* in bytes */
+{
+ fprintf(stderr, "Stack space overflow: current size %ld bytes.\nUse `+RTS -Ksize' to increase it.\n", stack_size);
+}
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Trace.c,v 1.2 1998/12/02 13:29:16 simonm Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+void
+PreTraceHook (long fd)
+{
+ /* Default is not to print anything, however this might be useful:
+ *
+ * const char msg[]="\nTrace On:\n";
+ * write(fd,msg,sizeof(msg)-1);
+ */
+}
+
+void
+PostTraceHook (long fd)
+{
+ /* Default is not to print anything, however this might be useful:
+ *
+ * const char msg[]="\nTrace Off.\n";
+ * write(fd,msg,sizeof(msg)-1);
+ */
+}
+
+++ /dev/null
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.12 1998/08/15 14:06:48 sof Exp $
-
-# This is the Makefile for the runtime-system stuff.
-# This stuff is written in C (and cannot be written in Haskell).
-#
-# Things are organised into exactly one level of subdirs.
-#
-# At the moment, there are a few such subdirs:
-# c-as-asm -- mini-interpreter & register hackery
-# gum -- GUM-specific stuff
-# main -- "main", associated startup stuff, & MISC things
-# prims -- code for primitives that must be written in C
-# profiling -- cost-centre profiling
-# storage -- the storage manager(s)
-#
-# We create two libraries. One, libHSrts<tag>.a, is built separately
-# for each "way". The other, libHSclib.a is built once: it is just
-# .lc files that end up the same no matter what, i.e. completely
-# ordinary C.
-
-# Other sorta independent, compile-once subdirs are:
-
-# gmp -- GNU multi-precision library (for Integer)
-
-#-----------------------------------------------------------------------------
-
-TOP=..
-DoingRTS=YES
-include $(TOP)/mk/boilerplate.mk
-
-WAYS=$(GhcLibWays)
-
-#
-# A general rule for the grand mk setup is that in a build tree, only
-# directories that don't have any subdirs containing Makefiles are built
-# all the different `ways' when doing `make all'.
-#
-# The directory structure for the RTS is a bit at odds to the general
-# scheme of things, with the GNU gmp library in gmp/ and a way-independent
-# archive libHSclib.a beside all the way-archives for the RTS proper.
-#
-# So to avoid having to redo building the way-proof pieces each time
-# the Makefile is invoked with a different setting of $(way), SUBDIRS
-# is only set if $(way) isn't set.
-#
-
-SUBDIRS = gmp
-
-#-----------------------------------------------------------------------------
-# knock the "clib" (completely ordinary C, compiled once)
-# stuff over the head first...
-#
-# Write out the rule for libHSclib explicitly, as it is special
-# (not to be built n different ways)
-#
-SRCS_CLIB_LC = $(wildcard hooks/*.lc) main/Mallocs.lc
-LIBOBJS_clib = $(SRCS_CLIB_LC:.lc=.o)
-
-all :: libHSclib.a
-
-libHSclib.a :: $(LIBOBJS_clib)
- @$(RM) $@
- $(AR) $(AR_OPTS) $@ $(LIBOBJS_clib)
- $(RANLIB) $@
-
-#
-# Stuff to clean out, only on way `normal'
-#
-ifeq "$(way)" ""
-MOSTLY_CLEAN_FILES += libHSclib.a $(LIBOBJS_clib)
-CLEAN_FILES += $(SRCS_CLIB_LC:.lc=.c)
-endif
-
-#
-# Add libHSclib to the install library variable *only*
-# if we're doing `make install' the `normal' way - don't want
-# to install the same library for each different way.
-#
-ifeq "$(way)" ""
-INSTALL_LIBS += libHSclib.a
-endif
-
-#------------------------------------------------------------------
-#
-# Run-time system parts that are `way' sensitive, you have to build
-# a copy of libHSrts for each different ways.
-#
-
-SRCS_RTS_LH = $(wildcard storage/*.lh)
-
-SRCS_RTS_LC = $(wildcard c-as-asm/*.lc) \
- gum/GlobAddr.lc \
- gum/HLComms.lc \
- gum/Hash.lc \
- gum/LLComms.lc \
- gum/Pack.lc \
- gum/ParInit.lc \
- gum/RBH.lc \
- gum/Sparks.lc \
- gum/Unpack.lc \
- main/GranSim.lc \
- main/Itimer.lc \
- main/Ticky.lc \
- main/SMRep.lc \
- main/Select.lc \
- main/Signals.lc \
- main/StgOverflow.lc \
- main/Threads.lc \
- main/RtsFlags.lc \
- main/main.lc \
- prims/PrimArith.lc \
- prims/LongLong.lc \
- prims/PrimMisc.lc \
- profiling/CostCentre.lc \
- profiling/Hashing.lc \
- profiling/HeapProfile.lc \
- profiling/Indexing.lc \
- profiling/Timer.lc \
- storage/SM1s.lc \
- storage/SM2s.lc \
- storage/SMap.lc \
- storage/SMcheck.lc \
- storage/SMcompacting.lc \
- storage/SMcopying.lc \
- storage/SMdu.lc \
- storage/SMevac.lc \
- storage/SMextn.lc \
- storage/SMinit.lc \
- storage/SMmarking.lc \
- storage/SMscan.lc \
- storage/SMscav.lc \
- storage/SMstacks.lc \
- storage/SMstatic.lc \
- storage/SMstats.lc \
- storage/mprotect.lc
-
-#
-# LATER: Include Patrick's generational collector
-# that's almost-but-not-quite there: storage/SMgen.lc
-#
-
-SRCS_RTS_LHC = $(wildcard main/*.lhc c-as-asm/*.lhc storage/*.lhc gum/*.lhc)
-
-HEADER_FILES = $(SRCS_RTS_LH:.lh=.h)
-
-C_SRCS = $(SRCS_RTS_LC:.lc=.c) $(SRCS_RTS_LHC:.lhc=.hc) $(SRCS_CLIB_LC:.lc=.c) $(HEADER_FILES)
-
-# To avoid having to redo these each time.
-.PRECIOUS : %.$(way_)hc
-
-#
-# Clean out header files when doing way `normal'
-#
-ifeq "$(way)" ""
-CLEAN_FILES += $(H_FILES) $(C_SRCS)
-endif
-
-#-----------------------------------------------------------------------------
-# creating and installing libHSrts.a (in its many flavors)
-#
-LIBRARY = libHSrts$(_way).a
-LIBOBJS = $(patsubst %.lc,%.$(way_)o,$(SRCS_RTS_LC)) \
- $(patsubst %.lhc,%.$(way_)o,$(SRCS_RTS_LHC))
-
-SRC_HC_OPTS += -I$(GHC_INCLUDE_DIR) $(GCap) $(GC2s) $(GC1s) -O -optc-DIN_GHC_RTS=1 -I$(GHC_RUNTIME_DIR)/storage
-
-#
-# Note: _have_ to drop the -optc prefix for the GC-type opts (e.g. -optc-DGCap), since
-# -o<foo> is interpreted by mkdependC as meaning use <foo> as suffix.
-#
-# Hack: Include -D for all the different collectors to be sure we gather all the deps.
-#
-SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) -DGCap -DGC1s -DGC2s
-
-#-----------------------------------------------------------------------------
-# file-specific options
-c-as-asm/PerformIO_HC_OPTS = -optc-DIN_GHC_RTS=1
-gum/FetchMe_HC_OPTS = -optc-DIN_GHC_RTS=1
-main/StgStartup_HC_OPTS = -optc-DIN_GHC_RTS=1
-main/StgThreads_HC_OPTS = -optc-DIN_GHC_RTS=1
-main/StgUpdate_HC_OPTS = -optc-DIN_GHC_RTS=1
-storage/SMmark_HC_OPTS = -optc-DIN_GHC_RTS=1 -optc-DMARK_REG_MAP
-
-#-----------------------------------------------------------------------------
-#
-# Compiling the individual files
-#
-# Rules for building various types of objects from C files,
-# override the default suffix rule here, as we want to use
-# ../driver/ghc (a better C compiler :-) to compile the
-# different RTS pieces
-#
-CC=$(HC) $(HC_OPTS) $($*_HC_OPTS)
-
-#-----------------------------------------------------------------------------
-# the TopClosure
-#
-# Hook it into the list of files to generate dependencies for
-#
-C_SRCS += main/TopClosure.c
-
-#
-# The TopClosure is not part of libHSrts, so we add an extra all::
-# target to make sure it is built (TopClosure is way-proof):
-#
-ifeq "$(way)" ""
-all :: main/TopClosure.o
-
-CLEAN_FILES += main/TopClosure.o
-#
-# The driver expects to find it in lib/
-#
-INSTALL_LIBS += main/TopClosure.o
-endif
-
-#-----------------------------------------------------------------------------
-#
-# Files to install
-#
-# Just libHSrts is installed uniformly across ways
-#
-INSTALL_LIBS += $(LIBRARY)
-
-
-#-----------------------------------------------------------------------------
-#
-# Building the GUM SysMan
-#
-
-ifeq "$(way)" "mp"
-all :: gum/SysMan
-
-ifdef solaris2_TARGET_OS
-__socket_libs = -lsocket -lnsl
-else
-__socket_libs =
-endif
-
-gum/SysMan : gum/SysMan.mp_o gum/LLComms.mp_o main/Mallocs.o hooks/OutOfVM.o
- $(RM) $@
- gcc -o $@ gum/SysMan.mp_o gum/LLComms.mp_o main/Mallocs.o hooks/OutOfVM.o -L$$PVM_ROOT/lib/$$PVM_ARCH -lpvm3 -lgpvm3 $(__socket_libs)
-
-CLEAN_FILES += gum/SysMan.mp_o gum/SysMan
-INSTALL_LIBEXECS += gum/SysMan
-endif
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-%
-%
-%
-\section[adjustor]{Adjustor `thunks'}
-
-An adjustor is a dynamically allocated code snippet that allows
-Haskell closures to be viewed as C function pointers.
-
-Stable pointers provide a way for the outside world to get access to,
-and evaluate, Haskell heap objects (see @StablePtrOps.lc@ for the (small)
-set of operations supported). So, assuming we've got a stable pointer in
-our hand in C, we can jump into the Haskell world and evaluate a callback
-procedure, say. This works OK in some cases where callbacks are used, but
-does require the external code to know about stable pointers and how to deal
-with them. We'd like to hide the Haskell-nature of a callback and have it
-be invoked just like any other C function pointer.
-
-An adjustor `thunk' takes care of this, generating a little bit of code
-on the fly that, when entered (from C), will rearrange the C stack, pushing
-an implicit stable pointer (to the Haskell callback) before calling a
-C function stub that enters the Haskell code.
-
-An adjustor thunk is allocated on the C heap, and is called from within
-Haskell just before handing out the function pointer to the Haskell (IO)
-action. User code should never have to invoke it explicitly.
-
-An adjustor thunk differs from a C function pointer in one respect, when
-the code is through with it, it has to be freed in order to release Haskell
-and C resources. Failure to do so result in memory leaks on both the C and
-Haskell side.
-
-\begin{code}
-#if !defined(PAR)
-
-#include "rtsdefs.h"
-
-#if defined(i386_TARGET_ARCH)
-char*
-createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
-{
- void *adjustor,*adj;
- unsigned char* adj_code;
- int i;
- size_t sizeof_adjustor;
-
- if (cconv) { /* the adjustor will be _stdcall'ed */
-
- /* Magic constant computed by inspecting the code length of
- the following assembly language snippet
- (offset and machine code prefixed):
-
- <0>: 58 popl %eax # temp. remove ret addr..
- <1>: 68 63 fd fc fe fa pushl 0xfafefcfd # constant is large enough to
- # hold a StgStablePtr
- <6>: 50 pushl %eax # put back ret. addr
- <7>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr
- <c>: ff e0 jmp %eax # and jump to it.
- # the callee cleans up the it will then clean up the stack
- */
- sizeof_adjustor = 15*sizeof(char);
-
- if ((adjustor = malloc(sizeof_adjustor)) == NULL) {
- return NULL;
- }
-
- adj_code = (unsigned char*)adjustor;
- adj_code[0] = (unsigned char)0x58; /* popl %eax */
- adj_code[1] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */
-
- adj = (StgStablePtr*)(adj_code+2);
- *((StgStablePtr*)adj) = (StgStablePtr)hptr;
-
- i = 2 + sizeof(StgStablePtr);
- adj_code[i] = (unsigned char)0x50; /* pushl %eax */
- adj_code[i+1] = (unsigned char)0xb8; /* movl $wptr, %eax */
- adj = (char*)(adj_code+i+2);
- *((StgFunPtr*)adj) = (StgFunPtr)wptr;
-
- i = i+2+sizeof(StgFunPtr);
- adj_code[i] = (unsigned char)0xff; /* jmp %eax */
- adj_code[i+1] = (unsigned char)0xe0;
-
- } else { /* the adjustor will be _ccall'ed */
-
- /* Magic constant computed by inspecting the code length of
- the following assembly language snippet
- (offset and machine code prefixed):
-
- <0>: 58 popl %eax # temp. remove ret addr..
- <1>: 68 63 fd fc fe fa pushl 0xfafefcfd # constant is large enough to
- # hold a StgStablePtr
- <6>: 50 pushl %eax # put back ret. addr
- <7>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr
- <c>: ff d0 call %eax # and call it.
- <e>: 58 popl %eax # store away return address.
- <f>: 83 c4 04 addl $0x4,%esp # remove stable pointer
- <12>: 50 pushl %eax # put back return address.
- <13>: c3 ret # return to where you came from.
-
- */
- sizeof_adjustor = 20*sizeof(char);
-
- if ((adjustor = malloc(sizeof_adjustor)) == NULL) {
- return NULL;
- }
-
- adj_code = (unsigned char*)adjustor;
- adj_code[0] = (unsigned char)0x58; /* popl %eax */
- adj_code[1] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */
-
- adj = (StgStablePtr*)(adj_code+2);
- *((StgStablePtr*)adj) = (StgStablePtr)hptr;
-
- i = 2 + sizeof(StgStablePtr);
- adj_code[i] = (unsigned char)0x50; /* pushl %eax */
- adj_code[i+1] = (unsigned char)0xb8; /* movl $wptr, %eax */
- adj = (char*)(adj_code+i+2);
- *((StgFunPtr*)adj) = (StgFunPtr)wptr;
-
- i = i+2+sizeof(StgFunPtr);
- adj_code[i] = (unsigned char)0xff; /* call %eax */
- adj_code[i+1] = (unsigned char)0xd0;
- adj_code[i+2] = (unsigned char)0x58; /* popl %eax */
- adj_code[i+3] = (unsigned char)0x83; /* addl $0x4, %esp */
- adj_code[i+4] = (unsigned char)0xc4;
- adj_code[i+5] = (unsigned char)0x04;
- adj_code[i+6] = (unsigned char)0x50; /* pushl %eax */
- adj_code[i+7] = (unsigned char)0xc3; /* ret */
- }
-
- /* Have fun! */
- return (adjustor);
-}
-
-void
-freeAdjustor(void* ptr)
-{
- char* tmp;
-
- /* Free the stable pointer first..*/
- tmp=(char*)ptr+2;
- freeStablePointer(*((StgStablePtr*)tmp));
-
- free(ptr);
-}
-
-#endif /* i386_TARGET_ARCH */
-
-#endif /* !PAR */
-\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\section[CallWrap_C.lc]{``callWrapper'' stuff that can be written in C}
-%* *
-%************************************************************************
-
-\begin{code}
-#define MAIN_REG_MAP /* These routines are all a bit special */
-#define CALLWRAPPER_C /* Don't give standard declarations for wrappers */
-#include "rtsdefs.h"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[call-wrapping]{Routines to ``wrap'' special calls to C}
-%* *
-%************************************************************************
-
-In most cases, this requires some assembly-language hacking (see the
-discussion in @COptWraps.lh@.)
-
-\begin{code}
-#if defined(__STG_GCC_REGS__)
-
-# if defined(CALLER_SAVES_SYSTEM) || defined(CALLER_SAVES_USER)
-void
-callWrapper(STG_NO_ARGS)
-{
- MAGIC_CALL_SETUP
-
- CALLER_SAVE_Base
- CALLER_SAVE_StkO
- CALLER_SAVE_R1
- CALLER_SAVE_R2
- CALLER_SAVE_R3
- CALLER_SAVE_R4
- CALLER_SAVE_R5
- CALLER_SAVE_R6
- CALLER_SAVE_R7
- CALLER_SAVE_R8
- CALLER_SAVE_FltReg1
- CALLER_SAVE_FltReg2
- CALLER_SAVE_FltReg3
- CALLER_SAVE_FltReg4
- CALLER_SAVE_DblReg1
- CALLER_SAVE_DblReg2
- CALLER_SAVE_LngReg1
- CALLER_SAVE_LngReg2
- CALLER_SAVE_Tag
- CALLER_SAVE_SpA
- CALLER_SAVE_SuA
- CALLER_SAVE_SpB
- CALLER_SAVE_SuB
- CALLER_SAVE_Hp
- CALLER_SAVE_HpLim
- CALLER_SAVE_Liveness
- CALLER_SAVE_Ret
-
- MAGIC_CALL
-
- CALLER_RESTORE_Base /* has to be first! */
-
- CALLER_RESTORE_StkO
- CALLER_RESTORE_R1
- CALLER_RESTORE_R2
- CALLER_RESTORE_R3
- CALLER_RESTORE_R4
- CALLER_RESTORE_R5
- CALLER_RESTORE_R6
- CALLER_RESTORE_R7
- CALLER_RESTORE_R8
- CALLER_RESTORE_FltReg1
- CALLER_RESTORE_FltReg2
- CALLER_RESTORE_FltReg3
- CALLER_RESTORE_FltReg4
- CALLER_RESTORE_DblReg1
- CALLER_RESTORE_DblReg2
- CALLER_RESTORE_LngReg1
- CALLER_RESTORE_LngReg2
- CALLER_RESTORE_Tag
- CALLER_RESTORE_SpA
- CALLER_RESTORE_SuA
- CALLER_RESTORE_SpB
- CALLER_RESTORE_SuB
- CALLER_RESTORE_Hp
- CALLER_RESTORE_HpLim
- CALLER_RESTORE_Liveness
- CALLER_RESTORE_Ret
-
- /* These next two are restore-only */
- CALLER_RESTORE_StdUpdRetVec
- CALLER_RESTORE_StkStub
-
- MAGIC_RETURN
-}
-# endif /* defined(CALLER_SAVES_SYSTEM) || defined(CALLER_SAVES_USER) */
-
-# if defined(CALLER_SAVES_SYSTEM)
-void
-callWrapper_safe(STG_NO_ARGS)
-{
- MAGIC_CALL_SETUP
-
- CALLER_SAVE_Base
- CALLER_SAVE_StkO
- CALLER_SAVE_SpA
- CALLER_SAVE_SuA
- CALLER_SAVE_SpB
- CALLER_SAVE_SuB
- CALLER_SAVE_Hp
- CALLER_SAVE_HpLim
- CALLER_SAVE_Liveness
- CALLER_SAVE_Ret
-
- MAGIC_CALL
-
- CALLER_RESTORE_Base /* has to be first! */
-
- CALLER_RESTORE_StkO
- CALLER_RESTORE_SpA
- CALLER_RESTORE_SuA
- CALLER_RESTORE_SpB
- CALLER_RESTORE_SuB
- CALLER_RESTORE_Hp
- CALLER_RESTORE_HpLim
- CALLER_RESTORE_Liveness
- CALLER_RESTORE_Ret
-
- /* These next two are restore-only */
- CALLER_RESTORE_StdUpdRetVec
- CALLER_RESTORE_StkStub
-
- MAGIC_RETURN
-}
-# endif /* defined(CALLER_SAVES_SYSTEM) */
-
-/*
-Nota Bene:
-
-Anyone changing the definition of @callWrapper_GC@ should make
-appropriate changes in the compiler (absCSyn/PprAbsC.lhs :: pprCCall).
-
-The reason is that \tr{_ccall_GC_} and \tr{_casm_GC_} generate code like this:
-\begin{verbatim}
- { R _ccall_result;
- SaveAllStgRegs();
- inCCallGC+=1;
- _ccall_result = << do the call/asm>>;
- inCCallGC-=1;
- RestoreAllStgRegs();
- }
-\end{verbatim}
-
-This avoids limiting _ccall_GC_ to 6 arguments and makes it possible
-to implement _ccall_GC_. (The local variable avoids the need for some
-of the deeper magic hidden inside @GC_SETUP@, @GC_CCALL@ and
-@GC_RETURN@.)
-
-ADR */
-
-EXTFUN(EnterNodeCode);
-
-void *__temp_esp, *__temp_eax;
-
-void PerformGC_wrapper PROTO((W_)) WRAPPER_NAME(PerformGC);
-void PerformGC_wrapper(args)
-W_ args;
-{
-#if i386_TARGET_ARCH
- void *ret_addr;
-
- WRAPPER_SETUP(PerformGC,ret_addr,args)
-#else
- WRAPPER_SETUP(PerformGC, ignore_me, ignore_me)
-#endif
- PerformGC(args);
- WRAPPER_RETURN(0)
-}
-
-# ifdef CONCURRENT
-
-void __DISCARD__ (STG_NO_ARGS) { /*nothing*/ }
-
-void StackOverflow_wrapper PROTO((W_,W_)) WRAPPER_NAME(StackOverflow);
-void StackOverflow_wrapper(args1,args2)
-W_ args1, args2;
-{
-#if i386_TARGET_ARCH
- void *ret_addr, *ignore_me;
- WRAPPER_SETUP(StackOverflow,ret_addr,ignore_me)
-#else
- WRAPPER_SETUP(StackOverflow, ignore_me, ignore_me)
-#endif
- if(StackOverflow(args1,args2)) {
- WRAPPER_RETURN(1)
- }
- WRAPPER_RETURN(0)
-}
-
-void Yield_wrapper PROTO((W_)) WRAPPER_NAME(Yield);
-void Yield_wrapper(args)
-W_ args;
-{
-#if i386_TARGET_ARCH
- void *ret_addr, *ignore_me;
- WRAPPER_SETUP(Yield, ret_addr, ignore_me)
-#else
- WRAPPER_SETUP(Yield, ignore_me, ignore_me)
-#endif
- Yield(args);
- WRAPPER_RETURN(0)
-}
-
-#if defined(GRAN)
-void PerformReschedule_wrapper PROTO((W_, W_)) WRAPPER_NAME(PerformReschedule);
-void PerformReschedule_wrapper(liveness, always_reenter_node)
- W_ liveness;
- W_ always_reenter_node;
-{
-#if i386_TARGET_ARCH
- void *ret_addr, *ignore_me;
- WRAPPER_SETUP(PerformReschedule, ret_addr, ignore_me)
-#else
- WRAPPER_SETUP(PerformReschedule, ignore_me, ignore_me)
-#endif
- PerformReschedule(liveness, always_reenter_node);
- WRAPPER_RETURN(0)
-}
-
-/* Similar wrappers for all GrAnSim functions. */
-/* NB: These are normal functions, which don't call ReSchedule. So we just */
-/* have to safe/restore the registers. */
-
-void GranSimAllocate_wrapper PROTO((I_, P_, W_)) WRAPPER_NAME(GranSimAllocate);
-void GranSimAllocate_wrapper(n, node, liveness)
-I_ n;
-P_ node;
-W_ liveness;
-{
-#if i386_TARGET_ARCH
- void *ret_addr, *ignore_me;
- WRAPPER_SETUP(GranSimAllocate, ret_addr, ignore_me)
-#else
- WRAPPER_SETUP(GranSimAllocate, ignore_me, ignore_me)
-#endif
- GranSimAllocate(n, node, liveness);
- WRAPPER_RETURN(0);
-}
-
-void GranSimUnallocate_wrapper PROTO((I_, P_, W_)) WRAPPER_NAME(GranSimUnallocate);
-void GranSimUnallocate_wrapper(n, node, liveness)
-I_ n;
-P_ node;
-W_ liveness;
-{
-#if i386_TARGET_ARCH
- void *ret_addr, *ignore_me;
- WRAPPER_SETUP(GranSimUnallocate, ret_addr, ignore_me)
-#else
- WRAPPER_SETUP(GranSimUnallocate, ignore_me, ignore_me)
-#endif
- GranSimUnallocate(n, node, liveness);
- WRAPPER_RETURN(0);
-}
-
-void GranSimFetch_wrapper PROTO((P_)) WRAPPER_NAME(GranSimFetch);
-void GranSimFetch_wrapper(node)
-P_ node;
-{
-#if i386_TARGET_ARCH
- void *ret_addr, *ignore_me;
- WRAPPER_SETUP(GranSimFetch, ret_addr, ignore_me)
-#else
- WRAPPER_SETUP(GranSimFetch, ignore_me, ignore_me)
-#endif
- GranSimFetch(node);
- WRAPPER_RETURN(0);
-}
-
-void GranSimExec_wrapper PROTO((W_, W_, W_, W_, W_)) WRAPPER_NAME(GranSimExec);
-void GranSimExec_wrapper(arith,branch,load,store,floats)
-W_ arith,branch,load,store,floats;
-{
-#if i386_TARGET_ARCH
- void *ret_addr, *ignore_me;
- WRAPPER_SETUP(GranSimExec, ret_addr, ignore_me)
-#else
- WRAPPER_SETUP(GranSimExec, ignore_me, ignore_me)
-#endif
- GranSimExec(arith,branch,load,store,floats);
- WRAPPER_RETURN(0);
-}
-
-# endif /* GRAN */
-
-# endif /* CONCURRENT */
-
-/*
- * In the threaded world, context switches may occur during one of these
- * wrapped calls, and when we come back, our stack will have been trashed.
- * If gcc, in all of its cleverness, tries to store any temporary values on
- * the stack, we need to separate the restoration function. See the sparc
- * code for an example.
- */
-
-SEPARATE_WRAPPER_RESTORE
-
-#endif /* defined(__STG_GCC_REGS__) */
-
-/* We can perform a runtime check that we have used @_ccall_GC_@ when
- appropriate using this flag. */
-StgInt inCCallGC = 0;
-
-void
-checkInCCallGC()
-{
- if (inCCallGC == 0) {
- fprintf(stderr, "Error: entering a closure from C without using _ccall_GC_\n");
- EXIT(EXIT_FAILURE);
- }
-}
-\end{code}
-
+++ /dev/null
-\section[PerformGC]{Wrapper for heap overflow}
-
-\begin{code}
-#include "rtsdefs.h"
-\end{code}
-
-@PerformGC@ is the wrapper for calls to @collectHeap@ in the
-storage manager. It performs the following actions:
-\begin{enumerate}
-\item Save live registers.
-\item If black holing is required before garbage collection we must
-black hole the update frames on the B stack and any live registers
-pointing at updatable closures --- possibly R1, if live and in update? --JSM
-\item Call the garbage collector.
-\item Restore registers.
-\end{enumerate}
-They either succeed or crash-and-burn; hence, they don't return
-anything.
-
-@PerformGC@ saves the fixed STG registers. and calls the garbage
-collector. It also black holes the B Stack if this is required at
-garbage collection time.
-
-There's also a function @PerformGCIO@ which does all the above and is
-used to force a full collection.
-
-\begin{code}
-#if defined(CONCURRENT)
-EXTFUN(EnterNodeCode); /* For reentering node after GC */
-EXTFUN(CheckHeapCode); /* For returning to thread after a context switch */
-extern P_ AvailableStack;
-# if defined(PAR)
-EXTDATA_RO(FetchMe_info);
-# endif
-#else
-static void BlackHoleUpdateStack(STG_NO_ARGS);
-#endif /* CONCURRENT */
-
-extern smInfo StorageMgrInfo;
-extern void PrintTickyInfo(STG_NO_ARGS);
-
-/* the real work is done by this function --- see wrappers at end */
-
-void
-RealPerformGC(liveness, reqsize, always_reenter_node, do_full_collection)
- W_ liveness;
- W_ reqsize;
- W_ always_reenter_node;
- rtsBool do_full_collection;
-{
- I_ num_ptr_roots = 0; /* we bump this counter as we
- store roots; de-bump it
- as we re-store them. */
-#if defined(PROFILING)
- CostCentre Save_CCC;
-#endif
-
- /* stop the profiling timer --------------------- */
-#if defined(PROFILING)
-/* STOP_TIME_PROFILER; */
-#endif
-
-#ifdef CONCURRENT
-
- SAVE_Liveness = liveness;
-
- /*
- fprintf(stderr,"RealGC:liveness=0x%lx,reqsize=0x%lx,reenter=%lx,do_full=%d,context_switch=%ld\n",
- liveness, reqsize,always_reenter_node,do_full_collection,context_switch);
- */
-
- /*
- Even on a uniprocessor, we may have to reenter node after a
- context switch. Though it can't turn into a FetchMe, its shape
- may have changed (e.g. from a thunk to a data object).
- */
- if (always_reenter_node) {
- /* Avoid infinite loops at the same heap check */
- if (SAVE_Hp <= SAVE_HpLim && TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) {
- TSO_SWITCH(CurrentTSO) = NULL;
- return;
- }
- /* Set up to re-enter Node, so as to be sure it's really there. */
- ASSERT(liveness & LIVENESS_R1);
- TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO);
- TSO_PC2(CurrentTSO) = EnterNodeCode;
- }
-
- SAVE_Hp -= reqsize;
-
- if (context_switch && !do_full_collection
-# if defined(PROFILING)
- && !interval_expired
-# endif
- ) {
- /* We're in a GC callWrapper, so the thread state is safe */
- TSO_ARG1(CurrentTSO) = reqsize;
- TSO_PC1(CurrentTSO) = CheckHeapCode;
-# ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- TSO_EXECTIME(CurrentTSO) += CURRENT_TIME - TSO_BLOCKEDAT(CurrentTSO);
- }
-# endif
-# if defined(GRAN)
- ReSchedule(SAME_THREAD);
-# else
- ReSchedule(1);
-# endif
- }
-
-# if defined(PROFILING)
- Save_CCC = CCC;
-# endif
-# if defined(PAR)
- SET_CCC_RTS(CC_GC,0,1); /* without the sub_scc_count++ */
-# endif
-
- ReallyPerformThreadGC(reqsize, do_full_collection);
-
-#else /* !CONCURRENT */
-
-# if defined(PROFILING)
- Save_CCC = CCC;
- SET_CCC_RTS(CC_GC,0,1); /* without the sub_scc_count++ */
-# endif
-
- /* root saving ---------------------------------- */
-
-# define __ENROOT_PTR_REG(cond,n) /* n == 1 <=> R1 */ \
- do { if ( cond ) { \
- StorageMgrInfo.roots[num_ptr_roots] = CAT2(MAIN_R,n).p; \
- num_ptr_roots++; \
- }} while (0)
-
- __ENROOT_PTR_REG(IS_LIVE_R1(liveness),1);
- __ENROOT_PTR_REG(IS_LIVE_R2(liveness),2);
- __ENROOT_PTR_REG(IS_LIVE_R3(liveness),3);
- __ENROOT_PTR_REG(IS_LIVE_R4(liveness),4);
- __ENROOT_PTR_REG(IS_LIVE_R5(liveness),5);
- __ENROOT_PTR_REG(IS_LIVE_R6(liveness),6);
- __ENROOT_PTR_REG(IS_LIVE_R7(liveness),7);
- __ENROOT_PTR_REG(IS_LIVE_R8(liveness),8);
-
- /*
- * Before we garbage collect we may have to squeeze update frames and/or
- * black hole the update stack
- */
- if (! RTSflags.GcFlags.squeezeUpdFrames) {
- BlackHoleUpdateStack();
-
- } else { /* Squeeze and/or black hole update frames */
- I_ displacement;
-
- displacement = SqueezeUpdateFrames(stackInfo.botB + BREL(1), MAIN_SpB, MAIN_SuB);
-
- MAIN_SuB += BREL(displacement);
- MAIN_SpB += BREL(displacement);
- /* fprintf(stderr, "B size %d, squeezed out %d\n", MAIN_SpB - stackInfo.botB,
- displacement); */
- }
-
- /* Add the stable pointer table to the roots list */
-#ifndef PAR
- StorageMgrInfo.roots[num_ptr_roots++] = StorageMgrInfo.StablePointerTable;
-#endif
-
- ASSERT(num_ptr_roots <= SM_MAXROOTS);
- StorageMgrInfo.rootno = num_ptr_roots;
-
- SAVE_Hp -= reqsize;
- /* Move (SAVE_)Hp back to where it was */
- /* (heap is known to grow upwards) */
- /* we *do* have to do this, so reported stats will be right! */
-
- /* the main business ---------------------------- */
-
- blockUserSignals();
-
- {
- int GC_result;
-
- /* Restore hpLim to its "correct" setting */
- StorageMgrInfo.hplim += StorageMgrInfo.hardHpOverflowSize;
-
- GC_result = collectHeap(reqsize, &StorageMgrInfo, do_full_collection);
-
- if ( GC_result == GC_HARD_LIMIT_EXCEEDED ) {
- OutOfHeapHook(reqsize * sizeof(W_), RTSflags.GcFlags.heapSize * sizeof(W_)); /*msg*/
- shutdownHaskell();
- EXIT(EXIT_FAILURE);
-
- } else if ( GC_result == GC_SOFT_LIMIT_EXCEEDED ) {
- /* Allow ourselves to use emergency space */
- /* Set hplim so that we'll GC when we hit the soft limit */
- StorageMgrInfo.hplim -= StorageMgrInfo.hardHpOverflowSize;
- raiseError( softHeapOverflowHandler );
-
- } else if ( GC_result == GC_SUCCESS ) {
- /* Set hplim so that we'll GC when we hit the soft limit */
- StorageMgrInfo.hplim -= StorageMgrInfo.hardHpOverflowSize;
-
- } else { /* This should not happen */
- fprintf(stderr, "Panic: garbage collector returned %d please report it as a bug to glasgow-haskell-bugs@dcs.gla.ac.uk\n", GC_result );
-
-# if defined(TICKY_TICKY)
- if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
-# endif
- abort();
- }
- }
-
- StorageMgrInfo.rootno = 0; /* reset */
-
- SAVE_Hp += reqsize;
- /* Semantics of GC ensures that a block of
- `reqsize' is now available (and allocated) [NB: sequential only] */
-
- /* root restoring ------------------------------- */
- /* must do all the restoring exactly backwards to the storing! */
-
- /* remove the stable pointer table first */
-#ifndef PAR
- StorageMgrInfo.StablePointerTable = StorageMgrInfo.roots[--num_ptr_roots];
-#endif
-
- /* now the general regs, in *backwards* order */
-
-# define __DEROOT_PTR_REG(cond,n) /* n == 1 <=> R1 */ \
- do { if ( cond ) { \
- num_ptr_roots--; \
- CAT2(MAIN_R,n).p = StorageMgrInfo.roots[num_ptr_roots]; \
- }} while (0)
-
- __DEROOT_PTR_REG(IS_LIVE_R8(liveness),8);
- __DEROOT_PTR_REG(IS_LIVE_R7(liveness),7);
- __DEROOT_PTR_REG(IS_LIVE_R6(liveness),6);
- __DEROOT_PTR_REG(IS_LIVE_R5(liveness),5);
- __DEROOT_PTR_REG(IS_LIVE_R4(liveness),4);
- __DEROOT_PTR_REG(IS_LIVE_R3(liveness),3);
- __DEROOT_PTR_REG(IS_LIVE_R2(liveness),2);
- __DEROOT_PTR_REG(IS_LIVE_R1(liveness),1);
-
- ASSERT(num_ptr_roots == 0); /* we have put it all back */
-
- unblockUserSignals();
-
-#endif /* !CONCURRENT */
-
-#if defined(PROFILING)
- CCC = Save_CCC;
-
- RESTART_TIME_PROFILER;
-#endif
-}
-\end{code}
-
-This is a wrapper used for all standard, non-threaded, non-parallel GC
-purposes.
-\begin{code}
-#ifdef HEAP_CHK_HYGIENE
-I_ doHygieneCheck = 0;
-#endif
-
-void
-PerformGC(args)
- W_ args;
-{
- W_ liveness = HEAP_OVERFLOW_LIVENESS(args);
- W_ reqsize = HEAP_OVERFLOW_REQSIZE(args);
- W_ always_reenter_node = HEAP_OVERFLOW_REENTER(args);
-
-#ifdef HEAP_CHK_HYGIENE
- if (doHygieneCheck) {
- checkHygiene();
- return;
- }
-#endif
- RealPerformGC(liveness, reqsize, always_reenter_node, rtsFalse);
-}
-
-#if defined(CONCURRENT) && defined(GRAN)
-/* This is directly called from the macro GRAN_RESCHEDULE out of the */
-/* threaded world. -- HWL */
-
-void
-PerformReschedule(liveness, always_reenter_node)
- W_ liveness;
- rtsBool always_reenter_node;
-
-{
- rtsBool need_to_reschedule;
-
-#if 0 && defined(DEBUG)
- fprintf(stderr,"PerfReS:liveness=0x%lx,reenter=%lx,,context_switch=%ld\n",
- liveness, always_reenter_node, context_switch);
-#endif
-
- /* Reset the global NeedToReSchedule --
- this is used only to communicate the fact that we should schedule
- a new thread rather than the existing one following a fetch.
- if (RTSflags.GranFlags.Light) {
- Yield(liveness);
- }
-
- ASSERT(!RTSflags.GranFlags.Light);
- */
-
- need_to_reschedule = NeedToReSchedule;
- NeedToReSchedule = rtsFalse;
-
- SAVE_Liveness = liveness;
-
- if (always_reenter_node) {
- /* Avoid infinite loops at the same context switch */
- if (/* (TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) || */
- (!need_to_reschedule &&
- CurrentTime[CurrentProc]<EndOfTimeSlice &&
- (TimeOfNextEvent==0 || TimeOfNextEvent>=CurrentTime[CurrentProc])
- || IgnoreEvents
- )) {
- /* TSO_SWITCH(CurrentTSO) = NULL; */
- return;
- }
-
- /* Set up to re-enter Node, so as to be sure it's really there. */
- ASSERT(liveness & LIVENESS_R1);
- /* TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO); */
- TSO_PC2(CurrentTSO) = (void *) EnterNodeCode;
- }
-
- /* We're in a GC callWrapper, so the thread state is safe */
- TSO_ARG1(CurrentTSO) = 0;
- TSO_PC1(CurrentTSO) = EnterNodeCode;
- ReSchedule( (need_to_reschedule &&
- !RTSflags.GranFlags.DoReScheduleOnFetch &&
- !RTSflags.GranFlags.Light) ?
- CHANGE_THREAD : SAME_THREAD );
- /* In a block-on-fetch setup we must not use SAME_THREAD since that */
- /* would continue the fetching TSO, which is still at the head of the */
- /* of the threadq */
- /* GrAnSim-Light always uses SAME_THREAD */
-}
-#endif
-
-#ifndef PAR
-/* this is a wrapper used when we want to do a full GC.
-
- One reason might be that we're about to enter a time-critical piece
- of code and want to reduce the risk of a GC during the run. The
- motivating reason is that we want to force the GC to report any
- dead Malloc Pointers to us.
-
- Note: this should only be called using _ccall_GC_ which saves all
- registers in the usual place (ie the global save area) before the
- call and restores them afterwards.
-
- ToDo: put in a runtime check that _ccall_GC_ is in action. */
-
-void
-StgPerformGarbageCollection()
-{
-# if ! defined(__STG_GCC_REGS__)
- SaveAllStgRegs(); /* unregisterised case */
-# endif
-
- RealPerformGC(0,0,0,rtsTrue);
-
-# if ! defined(__STG_GCC_REGS__)
- RestoreAllStgRegs(); /* unregisterised case */
-# endif
-}
-#endif /* !PAR */
-
-#if defined(CONCURRENT)
-
-# if defined(GRAN)
-
-# if defined(DEPTH_FIRST_PRUNING)
-
-/* Jim's spark pools are very similar to our processors, except that
- he uses a hard-wired constant. This would be a mistake for us,
- since we won't always need this many pools.
-*/
-void
-PruneSparks(STG_NO_ARGS)
-{
- sparkq spark, prev, next;
- I_ proc, pool, prunedSparks;
- I_ tot_sparks[MAX_PROC], total_sparks = 0, tot = 0;;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x40 )
- fprintf(stderr,"Pruning (depth-first) spark roots for GC ...\n");
-# endif
-
- for(proc=0; proc<RTSflags.GranFlags.proc; ++proc) {
- tot_sparks[proc] = 0;
- prev = NULL;
-
- for (pool = 0; pool < SPARK_POOLS; pool++) {
- prunedSparks=0;
-
- for(spark = PendingSparksHd[proc][pool];
- spark != NULL;
- spark = next) {
- next = SPARK_NEXT(spark);
-
- if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0)
- {
- if ( RTSflags.GcFlags.giveStats )
- if (i==ADVISORY_POOL) {
- tot_sparks[proc]++;
- tot++;
- }
-
- /* HACK! This clause should actually never happen HWL */
- if ( (SPARK_NODE(spark) == NULL) ||
- (SPARK_NODE(spark) == PrelBase_Z91Z93_closure) ) {
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats &&
- (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or PrelBase_Z91Z93_closure\n", spark);
-# endif
- /* prune it below */
- }
- else if (SHOULD_SPARK(SPARK_NODE(spark))) {
- /* Keep it */
- if (prev == NULL)
- PendingSparksHd[proc][pool] = spark;
- else
- SPARK_NEXT(prev) = spark;
- SPARK_PREV(spark) = prev;
- prev = spark;
- continue;
- }
- }
-
- /* By now we know that the spark has to be pruned */
- if(RTSflags.GranFlags.granSimStats_Sparks)
- /* DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark); */
- DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
- PrelBase_Z91Z93_closure,SPARK_NODE(spark),0);
-
- DisposeSpark(spark);
- prunedSparks++;
- } /* forall spark ... */
- if (prev == NULL)
- PendingSparksHd[proc][pool] = NULL;
- else
- SPARK_NEXT(prev) = NULL;
- PendingSparksTl[proc][pool] = prev;
- if ( (RTSflags.GcFlags.giveStats) &&
- (RTSflags.GranFlags.debug & 0x1000) &&
- (prunedSparks>0) )
- fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu sparks (_NS flag!) on proc %d (pool %d) in PruneSparks\n",
- prunedSparks,proc,pool);
- } /* forall pool ... */
- } /* forall proc ... */
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats ) {
- fprintf(RTSflags.GcFlags.statsFile,
- "Spark statistics (after pruning) (total sparks: %d; before pruning: %d):",
- tot,total_sparks);
- for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
- if (proc % 4 == 0) fprintf(RTSflags.GcFlags.statsFile,"\n> ");
- fprintf(RTSflags.GcFlags.statsFile,"\tPE %d: %d ",proc,tot_sparks[proc]);
- }
- fprintf(RTSflags.GcFlags.statsFile,".\n");
- }
-# endif
-}
-
-# else /* !DEPTH_FIRST_PRUNING */
-
-/* Auxiliary functions that are used in the GranSim version of PruneSparks */
-
-static W_
-arr_and(W_ arr[], I_ max)
-{
- I_ i;
- W_ res;
-
- /* Doesn't work with max==0; but then, many things don't work in this */
- /* special case. */
- for (i=1, res = arr[0]; i<max; i++)
- res &= arr[i];
-
- return (res);
-}
-
-static W_
-arr_max(W_ arr[], I_ max)
-{
- I_ i;
- W_ res;
-
- /* Doesn't work with max==0; but then, many things don't work in this */
- /* special case. */
- for (i=1, res = arr[0]; i<max; i++)
- res = (arr[i]>res) ? arr[i] : res;
-
- return (res);
-}
-
-/* In case of an excessive number of sparks, depth first pruning is a Bad */
-/* Idea as we might end up with all remaining sparks on processor 0 and */
-/* none on the other processors. So, this version uses breadth first */
-/* pruning. -- HWL */
-
-void
-PruneSparks(STG_NO_ARGS)
-{
- sparkq spark, prev,
- prev_spark[MAX_PROC][SPARK_POOLS],
- curr_spark[MAX_PROC][SPARK_POOLS];
- PROC proc;
- W_ allProcs = 0,
- endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
- I_ pool, total_sparks=0,
- prunedSparks[MAX_PROC][SPARK_POOLS];
- I_ tot_sparks[MAX_PROC], tot = 0;;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x40 )
- fprintf(stderr,"Pruning (breadth-first) sparks for GC ...\n");
-# endif
-
- /* Init */
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- allProcs |= PE_NUMBER(proc);
- tot_sparks[proc] = 0;
- for(pool = 0; pool < SPARK_POOLS; ++pool) {
- prev_spark[proc][pool] = NULL;
- curr_spark[proc][pool] = PendingSparksHd[proc][pool];
- prunedSparks[proc][pool] = 0;
- endQueues[pool] = 0;
- finishedQueues[pool] = 0;
- }
- }
-
- /* Breadth first pruning */
- do {
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(pool = 0; pool < SPARK_POOLS; ++pool) {
- spark = curr_spark[proc][pool];
- prev = prev_spark[proc][pool];
-
- if (spark == NULL) { /* at the end of the queue already? */
- if (! (endQueues[pool] & PE_NUMBER(proc)) ) {
- endQueues[pool] |= PE_NUMBER(proc);
- if (prev==NULL)
- PendingSparksHd[proc][pool] = NULL;
- else
- SPARK_NEXT(prev) = NULL;
- PendingSparksTl[proc][pool] = prev;
- }
- continue;
- }
-
- /* HACK! This clause should actually never happen HWL */
- if ( (SPARK_NODE(spark) == NULL) ||
- (SPARK_NODE(spark) == PrelBase_Z91Z93_closure) ) {
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats &&
- (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or PrelBase_Z91Z93_closure\n", spark);
-# endif
- /* prune it below */
- } else if (SHOULD_SPARK(SPARK_NODE(spark))) {
- if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0) {
- if ( RTSflags.GcFlags.giveStats )
- if (pool==ADVISORY_POOL) {
- tot_sparks[proc]++;
- tot++;
- }
-
- /* Keep it */
- if (prev_spark[proc][pool] == NULL)
- PendingSparksHd[proc][pool] = spark;
- else
- SPARK_NEXT(prev_spark[proc][pool]) = spark;
- SPARK_PREV(spark) = prev_spark[proc][pool];
- prev_spark[proc][pool] = spark;
- curr_spark[proc][pool] = SPARK_NEXT(spark);
- continue;
- } else { /* total_sparks > MAX_SPARKS */
- /* Sparkq will end before the current spark */
- if (prev == NULL)
- PendingSparksHd[proc][pool] = NULL;
- else
- SPARK_NEXT(prev) = NULL;
- PendingSparksTl[proc][pool] = prev;
- endQueues[pool] |= PE_NUMBER(proc);
- continue;
- }
- }
-
- /* By now we know that the spark has to be pruned */
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
- PrelBase_Z91Z93_closure,SPARK_NODE(spark),0);
-
- SPARK_NODE(spark) = PrelBase_Z91Z93_closure;
- curr_spark[proc][pool] = SPARK_NEXT(spark);
- prunedSparks[proc][pool]++;
- DisposeSpark(spark);
- } /* forall pool ... */
- } /* forall proc ... */
- } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
-
- /* Prune all sparks on all processor starting with */
- /* curr_spark[proc][pool]. */
-
- do {
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(pool = 0; pool < SPARK_POOLS; ++pool) {
- spark = curr_spark[proc][pool];
-
- if ( spark != NULL ) {
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
- PrelBase_Z91Z93_closure,SPARK_NODE(spark),0);
-
- SPARK_NODE(spark) = PrelBase_Z91Z93_closure;
- curr_spark[proc][pool] = SPARK_NEXT(spark);
-
- prunedSparks[proc][pool]++;
- DisposeSpark(spark);
- } else {
- finishedQueues[pool] |= PE_NUMBER(proc);
- }
- } /* forall pool ... */
- } /* forall proc ... */
- } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
-
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x1000) {
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(pool = 0; pool < SPARK_POOLS; ++pool) {
- if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][pool]>0)) {
- fprintf(RTSflags.GcFlags.statsFile,
- "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
- prunedSparks[proc][pool],proc,pool);
- }
- }
- }
-
- if ( RTSflags.GcFlags.giveStats ) {
- fprintf(RTSflags.GcFlags.statsFile,
- "Spark statistics (after discarding) (total sparks = %d):",tot);
- for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
- if (proc % 4 == 0)
- fprintf(RTSflags.GcFlags.statsFile,"\n> ");
- fprintf(RTSflags.GcFlags.statsFile,
- "\tPE %d: %d ",proc,tot_sparks[proc]);
- }
- fprintf(RTSflags.GcFlags.statsFile,".\n");
- }
- }
-# endif
-}
-
-# endif /* !DEPTH_FIRST_PRUNING */
-
-# else /* !GRAN */
-
-void
-PruneSparks(STG_NO_ARGS)
-{
- I_ pool;
-
- PP_ old;
- PP_ new;
-
- for (pool = 0; pool < SPARK_POOLS; pool++) {
- new = PendingSparksBase[pool];
- for (old = PendingSparksHd[pool]; old < PendingSparksTl[pool]; old++) {
- if (SHOULD_SPARK(*old)) {
- /* Keep it */
- *new++ = *old;
- } else {
- if (DO_QP_PROF)
- QP_Event0(threadId++, *old);
-# if 0
- /* ToDo: Fix log entries for pruned sparks in GUM */
- if(RTSflags.GranFlags.granSimStats_Sparks)
- /* DumpSparkGranEvent(SP_PRUNED, threadId++);*/
- DumpGranEvent(SP_PRUNED,PrelBase_Z91Z93_closure);
- ^^^^^^^^^^^ should be a TSO
-# endif
- }
- }
- PendingSparksHd[pool] = PendingSparksBase[pool];
- PendingSparksTl[pool] = new;
- }
-}
-
-# endif /* !GRAN */
-
-\end{code}
-
-This is the real GC wrapper for the threaded world. No context
-switching or other nonsense... just set up StorageMgrInfo and perform
-a garbage collection.
-
-\begin{code}
-void handleTimerExpiry PROTO((rtsBool));
-
-void
-ReallyPerformThreadGC(reqsize, do_full_collection)
-W_ reqsize;
-rtsBool do_full_collection;
-{
-# if defined(GRAN)
- I_ proc;
-#endif
-
- I_ num_ptr_roots = 0; /* we bump this counter as we store roots; de-bump it
- as we re-store them. */
- P_ stack, tso, next;
-
- /* Discard the saved stack and TSO space.
- What's going on here: TSOs and StkOs are on the mutables
- list (mutable things in the old generation). Here, we change
- them to immutable, so that the scavenger (which chks all
- mutable objects) can detect their immutability and remove
- them from the list. Setting to MUTUPLE_VHS as the size is
- essentially saying "No pointers in here" (i.e., empty).
-
- Without this change of status, these
- objects might not really die, probably with some horrible
- disastrous consequence that we don't want to think about.
- Will & Phil 95/10
- */
-
- for(stack = AvailableStack; stack != PrelBase_Z91Z93_closure; stack = next) {
- next = STKO_LINK(stack);
- FREEZE_MUT_HDR(stack, ImMutArrayOfPtrs_info);
- MUTUPLE_CLOSURE_SIZE(stack) = MUTUPLE_VHS;
- }
-
- for(tso = AvailableTSO; tso != PrelBase_Z91Z93_closure; tso = next) {
- next = TSO_LINK(tso);
- FREEZE_MUT_HDR(tso, ImMutArrayOfPtrs_info);
- MUTUPLE_CLOSURE_SIZE(tso) = MUTUPLE_VHS;
- }
-
- AvailableStack = AvailableTSO = PrelBase_Z91Z93_closure;
-
- PruneSparks();
-
-# if defined(GRAN)
- traverse_eventq_for_gc(); /* tidy up eventq for GC */
-
- /* Store head and tail of runnable lists as roots for GC */
- if (RTSflags.GranFlags.Light) {
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[0];
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[0];
- } else {
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
- num_ptr_roots,proc,RunnableThreadsHd[proc]);
-# endif
-
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[proc];
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
- num_ptr_roots,proc,RunnableThreadsTl[proc]);
-# endif
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[proc];
-
- } /* forall proc ... */
- } /* RTSflags.GranFlags.Light */
-
- /* This is now done as part of collectHeap (see ../storage dir) */
- /* num_ptr_roots = SaveSparkRoots(num_ptr_roots); */
- /* num_ptr_roots = SaveEventRoots(num_ptr_roots); */
-
-# else /* !GRAN */
-
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd;
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl;
- StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsHd;
- StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsTl;
-
-# endif /* GRAN */
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"Saving CurrentTSO %d -- 0x%lx\n",
- num_ptr_roots,CurrentTSO);
-# endif
-
- StorageMgrInfo.roots[num_ptr_roots++] = CurrentTSO;
-
-# ifdef PAR
- StorageMgrInfo.roots[num_ptr_roots++] = PendingFetches;
-# endif
-
-# ifndef PAR
- StorageMgrInfo.roots[num_ptr_roots++] = StorageMgrInfo.StablePointerTable;
-# endif
-
- StorageMgrInfo.rootno = num_ptr_roots;
-
- blockUserSignals();
-
- /* For VTALRM timer ticks to be handled correctly, we need to record that
- we are now about to enter GC, delaying the handling of timer expiry
- for delayed threads till after the GC.
- */
- handleTimerExpiry(rtsFalse);
-
- /* ====> The REAL THING happens here */
- if (collectHeap(reqsize, &StorageMgrInfo, do_full_collection) != GC_SUCCESS) {
-
- OutOfHeapHook(reqsize * sizeof(W_), RTSflags.GcFlags.heapSize * sizeof(W_)); /*msg*/
-
-# if defined(TICKY_TICKY)
- if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
-# endif
- EXIT(EXIT_FAILURE);
- }
-
- StorageMgrInfo.rootno = 0; /* reset */
-
- /* root restoring ------------------------------- */
- /* must do all the restoring exactly backwards to the storing! */
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,
- "Restoring CurrentTSO %d -- new: 0x%lx\n",
- num_ptr_roots-1,StorageMgrInfo.roots[num_ptr_roots-1]);
-# endif
-
-# ifndef PAR
- StorageMgrInfo.StablePointerTable = StorageMgrInfo.roots[--num_ptr_roots];
-# endif
-
-# ifdef PAR
- PendingFetches = StorageMgrInfo.roots[--num_ptr_roots];
-# endif
- CurrentTSO = StorageMgrInfo.roots[--num_ptr_roots];
- CurrentRegTable = TSO_INTERNAL_PTR(CurrentTSO);
-
-# if !defined(GRAN)
-
- WaitingThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
- WaitingThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];
-
- RunnableThreadsTl = StorageMgrInfo.roots[--num_ptr_roots];
- RunnableThreadsHd = StorageMgrInfo.roots[--num_ptr_roots];
-
-# else /* GRAN */
-
- /* num_ptr_roots = RestoreEventRoots(num_ptr_roots); */
- /* num_ptr_roots = RestoreSparkRoots(num_ptr_roots); */
-
- /* NB: PROC is unsigned datatype i.e. (PROC)-1 > 0 ! */
-
- if (RTSflags.GranFlags.Light) {
- RunnableThreadsTl[0] = StorageMgrInfo.roots[--num_ptr_roots] ;
- RunnableThreadsHd[0] = StorageMgrInfo.roots[--num_ptr_roots] ;
- } else {
- for(proc = RTSflags.GranFlags.proc - 1;
- (proc >= 0) && (proc < RTSflags.GranFlags.proc) ;
- --proc) {
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,
- "Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
- num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
-# endif
- RunnableThreadsTl[proc] = StorageMgrInfo.roots[--num_ptr_roots];
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,
- "Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
- num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
-# endif
- RunnableThreadsHd[proc] = StorageMgrInfo.roots[--num_ptr_roots];
- } /* forall proc ... */
- } /* RTSflags.GranFlags.Light */
-
-# endif /* GRAN */
-
- /* Semantics of GC ensures that a block of `reqsize' is now available */
- SAVE_Hp += reqsize;
-
- /* Activate the handling of entries on the WaitingThreads queue again */
- handleTimerExpiry(rtsTrue);
-
- unblockUserSignals();
-}
-
-#endif /* CONCURRENT */
-
-\end{code}
-
-This routine rattles down the B stack, black-holing any
-pending updates to avoid space leaks from them.
-
-\begin{code}
-#if !defined(CONCURRENT)
-
-static
-void
-BlackHoleUpdateStack(STG_NO_ARGS)
-{
- P_ PtrToUpdateFrame;
-
- if (! RTSflags.GcFlags.lazyBlackHoling)
- return;
-
- PtrToUpdateFrame = MAIN_SuB;
-
- /* ToDo: There may be an optimisation here which stops at the first
- BHed closure on the stack as all below must have been BHed */
-
- while (SUBTRACT_B_STK(PtrToUpdateFrame, stackInfo.botB) > 0) {
-
- UPD_BH(GRAB_UPDATEE(PtrToUpdateFrame), BH_UPD_info);
-
- /* Move PtrToUpdateFrame down B Stack */
- PtrToUpdateFrame = GRAB_SuB(PtrToUpdateFrame);
- }
-}
-#endif /* !CONCURRENT */
-\end{code}
+++ /dev/null
-%/****************************************************************
-%* *
-\section[adr-performIO]{PerformIO --- part of the Foreign Language Extension}
-%* *
-%****************************************************************/
-
-The following is heavily based on code in
-@runtime/main/StgStartup.lhc@.
-
-\begin{code}
-#ifndef PAR
-
-#define MAIN_REG_MAP /* STG world */
-#include "rtsdefs.h"
-\end{code}
-
-\begin{code}
-#if 0
-I_ CStackDelta;
-#endif
-W_ SAVE_esp;
-
-STGFUN(stopPerformIODirectReturn)
-{
- FUNBEGIN;
-
- /* The final exit.
-
- The top-top-level closures (e.g., "main") are of type "PrimIO ()".
- When entered, they perform an IO action and return a () --
- essentially, TagReg is set to 1. Here, we don't need to do
- anything with that.
-
- We just tidy up the register stuff (real regs in *_SAVE, then
- *_SAVE -> smInfo locs).
-
- */
-
- /* Pop off saved C stack pointer */
-#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
- SAVE_esp = (W_)*SpB;
- SpB = SpB - 1;
-#endif
-
-#if defined(__STG_GCC_REGS__)
- SaveAllStgRegs(); /* inline! */
-#else
- SAVE_Hp = Hp;
- SAVE_HpLim = HpLim;
-#endif
-
- /* Grimily restore C stack pointer */
-#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
- __asm__ volatile ("mov %0,%%esp" : "m=" (SAVE_esp));
-#endif
-
- RESUME_(miniInterpretEnd);
- FUNEND;
-}
-
-/*
- NB: For direct returns to work properly, the name of the routine must be
- the same as the name of the vector table with vtbl_ removed and DirectReturn
- appended. This is all the mangler understands.
-*/
-
-const W_ vtbl_stopPerformIO[] = {
- /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
- (W_) stopPerformIODirectReturn,
- (W_) stopPerformIODirectReturn,
- (W_) stopPerformIODirectReturn,
- (W_) stopPerformIODirectReturn,
- (W_) stopPerformIODirectReturn,
- (W_) stopPerformIODirectReturn,
- (W_) stopPerformIODirectReturn,
- (W_) stopPerformIODirectReturn
-};
-
-/* ptr to a closure (should be of type @IO_Int#@) which the C-world
- has gotten hold of (hopefully via @MakeStablePtr#@).
-*/
-P_ unstable_Closure;
-ED_RO_(realWorldZh_closure);
-
-STGFUN(startPerformIO)
-{
- FUNBEGIN;
-
- /* At this point we are in the threaded-code world.
-
- unstable_Closure points to a closure of type PrimIO (),
- which should be performed (by applying it to the
- state of the world).
-
- The main stg register dump is assumed to be up to date,
- and is used to load the STG registers.
- */
-
-#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
- __asm__ volatile ("mov %%esp,%0" : "=m" (SAVE_esp));
-#endif
-
- /* Load up the real registers from the *_SAVE locns. */
- RestoreAllStgRegs(); /* inline! */
-
- /* ------- STG registers are now valid! -------------------------*/
-
- /* first off, check for stk space.. */
-#if defined(CONCURRENT) || !defined(STACK_CHECK_BY_PAGE_FAULT)
- STK_CHK(LivenessReg,0/*A*/,2/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/);
-#else
- STK_CHK(LivenessReg,0/*A*/,1, 0, 0, 0/*prim*/, 0/*re-enter*/);
-#endif
-
- /* Put a suitable return address on the B stack */
- RetReg = (StgRetAddr) UNVEC(stopPerformIODirectReturn,vtbl_stopPerformIO);
-
- /* Save away C stack pointer so that we can restore it when we leave
- the Haskell world.
- */
-#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
- SpB -= BREL(1);
- *SpB = (W_)SAVE_esp;
-#endif
-
- /* Put a World State Token on the B stack */
- /* This is necessary because we've not unboxed it (to reveal a void) yet */
- SpB -= BREL(1);
- *SpB = (W_) realWorldZh_closure;
-
- Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FUNEND;
-}
-\end{code}
-
-\begin{code}
-StgInt enterInt_Result;
-
-STGFUN(stopEnterIntDirectReturn)
-{
- FUNBEGIN;
- enterInt_Result = R1.i;
-
-#if defined(__STG_GCC_REGS__)
- SaveAllStgRegs(); /* inline! */
-#else
- SAVE_Hp = Hp;
- SAVE_HpLim = HpLim;
-#endif
-
- JMP_(miniInterpretEnd);
- FUNEND;
-}
-
-/*
- NB: For direct returns to work properly, the name of the routine must be
- the same as the name of the vector table with vtbl_ removed and DirectReturn
- appended. This is all the mangler understands.
-*/
-
-const W_ vtbl_stopEnterInt[] = {
- (W_) stopEnterIntDirectReturn,
- (W_) stopEnterIntDirectReturn,
- (W_) stopEnterIntDirectReturn,
- (W_) stopEnterIntDirectReturn,
- (W_) stopEnterIntDirectReturn,
- (W_) stopEnterIntDirectReturn,
- (W_) stopEnterIntDirectReturn,
- (W_) stopEnterIntDirectReturn
-};
-
-STGFUN(startEnterInt)
-{
- FUNBEGIN;
-
- /* Load up the real registers from the *_SAVE locns. */
-#if defined(__STG_GCC_REGS__)
- RestoreAllStgRegs(); /* inline! */
-#else
- Hp = SAVE_Hp;
- HpLim = SAVE_HpLim;
-#endif
-
- /* ------- STG registers are now valid! -------------------------*/
-
- /* Put a suitable return address on the B stack */
- SpB -= BREL(1); /* Allocate a word for the return address */
- *SpB = (W_) UNVEC(stopEnterIntDirectReturn,vtbl_stopEnterInt); /* Push return vector */
-
- Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FUNEND;
-}
-\end{code}
-
-
-\begin{code}
-StgInt enterFloat_Result;
-
-STGFUN(stopEnterFloatDirectReturn)
-{
- FUNBEGIN;
- enterFloat_Result = R1.f;
-
-#if defined(__STG_GCC_REGS__)
- SaveAllStgRegs(); /* inline! */
-#else
- SAVE_Hp = Hp;
- SAVE_HpLim = HpLim;
-#endif
-
- JMP_(miniInterpretEnd);
- FUNEND;
-}
-
-/* usual comment about the mangler (hack...) */
-
-const W_ vtbl_stopEnterFloat[] = {
- (W_) stopEnterFloatDirectReturn,
- (W_) stopEnterFloatDirectReturn,
- (W_) stopEnterFloatDirectReturn,
- (W_) stopEnterFloatDirectReturn,
- (W_) stopEnterFloatDirectReturn,
- (W_) stopEnterFloatDirectReturn,
- (W_) stopEnterFloatDirectReturn,
- (W_) stopEnterFloatDirectReturn
-};
-
-STGFUN(startEnterFloat)
-{
- FUNBEGIN;
-
- /* Load up the real registers from the *_SAVE locns. */
-#if defined(__STG_GCC_REGS__)
- RestoreAllStgRegs(); /* inline! */
-#else
- Hp = SAVE_Hp;
- HpLim = SAVE_HpLim;
-#endif
-
- /* ------- STG registers are now valid! -------------------------*/
-
- /* Put a suitable return address on the B stack */
- SpB -= BREL(1); /* Allocate a word for the return address */
- *SpB = (W_) UNVEC(stopEnterFloatDirectReturn,vtbl_stopEnterFloat); /* Push return vector */
-
- Node = unstable_Closure; /* Point to the closure for main/errorIO-arg */
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FUNEND;
-}
-\end{code}
-
-
-\begin{code}
-#endif /* ! PAR */
-\end{code}
-
+++ /dev/null
-\section[Stable-Pointers]{Creation and use of Stable Pointers}
-
-\begin{code}
-#if !defined(PAR)
-
-#include "rtsdefs.h"
-\end{code}
-
-This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
-small change in @HpOverflow.lc@) consists of the changes in the
-runtime system required to implement "Stable Pointers". But we're
-getting a bit ahead of ourselves --- what is a stable pointer and what
-is it used for?
-
-When Haskell calls C, it normally just passes over primitive integers,
-floats, bools, strings, etc. This doesn't cause any problems at all
-for garbage collection because the act of passing them makes a copy
-from the heap, stack or wherever they are onto the C-world stack.
-However, if we were to pass a heap object such as a (Haskell) @String@
-and a garbage collection occured before we finished using it, we'd run
-into problems since the heap object might have been moved or even
-deleted.
-
-So, if a C call is able to cause a garbage collection or we want to
-store a pointer to a heap object between C calls, we must be careful
-when passing heap objects. Our solution is to keep a table of all
-objects we've given to the C-world and to make sure that the garbage
-collector collects these objects --- updating the table as required to
-make sure we can still find the object.
-
-
-Of course, all this rather begs the question: why would we want to
-pass a boxed value?
-
-One very good reason is to preserve laziness across the language
-interface. Rather than evaluating an integer or a string because it
-{\em might\/} be required by the C function, we can wait until the C
-function actually wants the value and then force an evaluation.
-
-Another very good reason (the motivating reason!) is that the C code
-might want to execute an object of sort $IO ()$ for the side-effects
-it will produce. For example, this is used when interfacing to an X
-widgets library to allow a direct implementation of callbacks.
-
-
-The @makeStablePointer# :: a -> PrimIO (StablePtr a)@ function
-converts a value into a stable pointer. It is part of the @PrimIO@
-monad, because we want to be sure we don't allocate one twice by
-accident, and then only free one of the copies.
-
-\begin{verbatim}
-makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
-freeStablePointer# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
-deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
-\end{verbatim}
-There is also a C procedure @FreeStablePtr@ which frees a stable pointer.
-
-There may be additional functions on the C side to allow evaluation,
-application, etc of a stable pointer.
-
-\begin{code}
-EXTDATA(UnusedSP_closure);
-EXTDATA(EmptySPTable_closure);
-
-void
-enlargeSPTable( newTable, oldTable )
- StgPtr newTable;
- StgPtr oldTable;
-{
- StgInt OldNoPtrs = SPT_NoPTRS(oldTable);
- StgInt NewNoPtrs = SPT_NoPTRS(newTable);
- StgInt i, NewTop;
-
- ASSERT( NewNoPtrs > OldNoPtrs );
- ASSERT( SPT_TOP(oldTable) == 0 );
-
- CHECK_SPT_CLOSURE(oldTable);
-
- /* Copy old stable pointers over */
- for( i = 0; i < OldNoPtrs; ++i ) {
- SPT_SPTR(newTable, i) = SPT_SPTR(oldTable,i);
- }
- /* Top up with unused stable pointers */
- for( i = OldNoPtrs; i < NewNoPtrs; ++i ) {
- SPT_SPTR(newTable, i) = UnusedSP_closure;
- }
-
- /* Setup free stack with indices of new stable pointers*/
- NewTop = 0;
- for( i = OldNoPtrs; i < NewNoPtrs; ++i ) {
- SPT_FREE(newTable, NewTop++) = i;
- }
- SPT_TOP(newTable) = NewTop;
-
- StorageMgrInfo.StablePointerTable = newTable;
-
-#if defined(DEBUG)
- /* Now trash the old table to encourage bugs to show themselves */
- if ( oldTable != EmptySPTable_closure ) {
- I_ size = SPT_SIZE(oldTable) + _FHS;
-
- for( i = 0; i != size; ++i ) {
- oldTable[ i ] = DEALLOCATED_TRASH;
- }
- }
-#endif
-
- CHECK_SPT_CLOSURE(newTable);
-}
-\end{code}
-
-
-There are a lot of checks in here. However, they are not to catch
-bugs in the compiler - they are to catch bugs in the users program.
-
-ToDo: maybe have a compiler switch to be less paranoid? [ADR]
-
-\begin{code}
-EXTDATA(UnusedSP_closure);
-
-void
-freeStablePointer(stablePtr)
- I_ stablePtr;
-{
- P_ SPTable = StorageMgrInfo.StablePointerTable;
-
- /* Check what we can of tables integrity - can't check infotable
- since we may be in a GC and (compacting) GC may have mangled it. */
- CHECK_SPT_Size(SPTable);
- CHECK_SPT_Contents(SPTable);
-
- if (! (0 <= stablePtr && stablePtr < SPT_NoPTRS(SPTable)) ) { /* bogus index */
- /* This can only happen if the Haskell/C programmer has really messed up. */
-
- fprintf(stderr, "Panic (freeStablePointer): stable pointer %ld not in range 0..%ld.\n",
- stablePtr, SPT_NoPTRS(SPTable)-1);
- abort();
- }
-
- if (SPT_SPTR(SPTable,stablePtr) == UnusedSP_closure) { /* freeing an unused stable pointer */
- /* This can only happen if the Haskell/C programmer has already
- returned the same stable pointer or never allocated it. */
-
- fprintf(stderr, "Panic: stable pointer %ld freed multiple times (or never allocated)\nby the Haskell/C programmer.\n", stablePtr);
- EXIT(EXIT_FAILURE); /* ToDo: abort()? */
- }
-
- if (SPT_FULL(SPTable)) { /* free stack full! */
- /* This can only happen if the Haskell/C programmer has returned
- the same stable pointer several times.
- */
-
- fprintf(stderr, "Panic: stable pointer free stack overflowed.\nThis is probably due to the same stable pointer being freed multiple times\nby the Haskell/C programmer.\n");
- EXIT(EXIT_FAILURE); /* ToDo: abort()? */
- }
-
- SPT_SPTR(SPTable,stablePtr) = UnusedSP_closure; /* erase old entry */
- SPT_PUSH(SPTable,stablePtr); /* Add it to free stack */
-
- CHECK_SPT_Size(SPTable);
- CHECK_SPT_Contents(SPTable);
-}
-\end{code}
-
-\begin{code}
-StgPtr
-_deRefStablePointer(stablePtr,SPTable)
- StgInt stablePtr;
- StgPtr SPTable;
-{
- CHECK_SPT_CLOSURE(SPTable);
-
- if (! (0 <= stablePtr && stablePtr < SPT_NoPTRS(SPTable)) ) { /* bogus index */
- /* This can only happen if the Haskell/C programmer has really messed up. */
-
- fprintf(stderr, "Panic (deRefStablePointer): stable pointer %ld not in range 0..%ld.\n",
- stablePtr, SPT_NoPTRS(SPTable)-1);
- EXIT(EXIT_FAILURE); /* ToDo: abort()? */
- }
-
- if (SPT_SPTR(SPTable,stablePtr) == UnusedSP_closure) { /* dereferencing an unused stable pointer */
- /* This can only happen if the Haskell/C programmer has already
- returned this stable pointer. */
-
- fprintf(stderr, "Panic: stable pointer %ld not allocated by the Haskell/C programmer.\n", stablePtr);
- EXIT(EXIT_FAILURE); /* ToDo: abort()? */
- }
-
- return SPT_SPTR(SPTable,stablePtr);
-}
-\end{code}
-
-For error detecting in the debug version, we have a check that all
-free pointers are really free and all non-free pointers are really not
-free.
-
-\begin{code}
-#ifdef DEBUG
-int ValidateSPTable( P_ SPTable )
-{
- I_ i, j;
- I_ NoPtrs = SPT_NoPTRS( SPTable );
- I_ Top = SPT_TOP( SPTable );
-
- for( i = 0; i != Top; ++i ) {
- /* Check the free indexes are in range */
- if (!( (0 <= SPT_FREE( SPTable, i )) && (SPT_FREE( SPTable, i ) < NoPtrs) ) ) return 1;
- /* Check the free indexes are unused */
- if ( SPT_SPTR( SPTable, SPT_FREE( SPTable, i ) ) != UnusedSP_closure ) return 2;
- }
-
- /* Check each unused stable pointer is in free list (and vice-versa) */
- for( i = 0; i != NoPtrs; i++ ) {
- if ( SPT_SPTR( SPTable, i ) == UnusedSP_closure ) {
- j = 0;
- while (j != Top && SPT_FREE( SPTable, j ) != i) {
- j++;
- }
- if (j == Top) return 3; /* Space leak - losing free SPs */
- } else {
- j = Top;
- while (j != NoPtrs && SPT_FREE( SPTable, j ) != i) {
- j++;
- }
- }
- }
-
- /* If all that worked, we've got a good structure here */
- return 0;
-}
-#endif /* DEBUG */
-
-#endif /* ! PAR */
-\end{code}
+++ /dev/null
-\section[stable-ptr-ops]{Stable Pointer Operations}
-
-The code that implements @performIO@ is mostly in
-@ghc/runtime/c-as-asm/PerformIO.lhc@. However, this code can be
-called from the C world so it goes in a @.lc@ file.
-
-This code is based heavily on the code in @ghc/runtime/main/main.lc@.
-
-It is used to call a (stable pointer to a) function of type
-@IoWorld -> PrimIntAndIoWorld@ (ie @PrimIO_Int#@).
-
-(I doubt very much that this works at the moment - and we're going to
-change it to take/return a byte array anyway. Code in PerformIO.lhc
-is even more dated.)
-
-\begin{code}
-#if !defined(PAR)
-
-#include "rtsdefs.h"
-
-extern StgPtr unstable_Closure;
-#if 0
-extern int CStackDelta;
-#endif
-
-StgInt entersFromC=0;
-
-void
-enterStablePtr(stableIndex, startCode)
- StgStablePtr stableIndex;
- StgFunPtr startCode;
-{
- unstable_Closure
- = _deRefStablePointer(stableIndex, StorageMgrInfo.StablePointerTable);
-
- /* ToDo: Set arity to right value - if necessary */
-
- /* Inactive code for computing the chunk of C stack we have allocated
- since initially leaving Haskell land.
- */
-#if 0 && defined(CONCURRENT) && defined(i386_TARGET_ARCH)
- __asm__ volatile ("mov %%esp,%0" : "=m" (CurrentRegTable->rWrapReturn));
- CStackDelta=(int)(((unsigned int)CurrentRegTable->rCstkptr - (unsigned int)CurrentRegTable->rWrapReturn) / sizeof(W_));
- CurrentTSOinC=CurrentTSO;
-# if defined(DEBUG)
- fprintf(stderr,"enterStablePtr: current: %#x c-entry: %#x (delta %d)\n", CurrentRegTable->rWrapReturn, CurrentRegTable->rCstkptr, CStackDelta);
- __asm__ volatile ("mov %%esp,%0" : "=m" (CurrentRegTable->rWrapReturn));
- CStackDelta=(int)(((unsigned int)CurrentRegTable->rCstkptr - (unsigned int)CurrentRegTable->rWrapReturn) / sizeof(W_));
-# endif
-#endif
- /*
- * Combining Concurrent Haskell and stable pointers poses a headache or
- * two. If the thread that jumps into Haskell causes a context switch,
- * we're in deep trouble, as miniInterpret() is used to enter the threaded world,
- * which stash away return address and callee-saves registers on the C
- * stack and enter.
- *
- * If the thread should happen to context switch, the scheduler is
- * currently coded to use longjmp() to jump from the rescheduling
- * code to the main scheduler loop. i.e., we unwind chunks of the
- * C stack, including the return address++ the thread left there
- * before entering the stable pointer.
- *
- * Ideally, we would like to impose no restrictions on the use of
- * stable pointers with Concurrent Haskell, but currently we
- * do turn off heap check context switching when a thread jumps into
- * Haskell from C. This reduces the `risk' of a context switch, but
- * doesn't solve the problem - a thread that blocks will still
- * force a re-schedule. To cope with this situation, we use a counter
- * to keep track of whether any threads have entered Haskell from C.
- * If any have, we avoid longjmp()ing in the RTS to preserve the region
- * of the C stack that the thread expects to be there when it exits.
- *
- * This scheme is a hack (no, really!) to get Haskell callbacks to work
- * with Concurrent Haskell. It is currently only supported for x86 platforms
- * (due to use of asm to get at stack pointer in PerformIO.lhc)
- *
- * ToDo: do Right in the new RTS.
- */
-#if defined(CONCURRENT) && defined(i386_TARGET_ARCH)
- entersFromC++;
- miniInterpret(startCode);
- entersFromC--;
-#else
- miniInterpret(startCode);
-#endif
-
-#if 0 && defined(DEBUG)
- if (CurrentTSO == CurrentTSOinC) {
- CurrentTSOinC=NULL;
- }
- /* C stack should have been reconstructed by now (we'll soon find out..) */
- do {
- char *p;
- __asm__ volatile ("mov %%esp,%0" : "=m" (p));
- fprintf(stderr,"enterStablePtr-end: current: %#x c-entry: %#x\n", p, CurrentRegTable->rCstkptr);
- } while(0);
-#endif
-}
-\end{code}
-
-\begin{code}
-EXTFUN(startPerformIO);
-
-extern void checkInCCallGC(STG_NO_ARGS);
-
-void
-performIO(stableIndex)
- StgStablePtr stableIndex;
-{
- checkInCCallGC();
- enterStablePtr( stableIndex, (StgFunPtr) startPerformIO );
-}
-
-extern StgInt enterInt_Result;
-EXTFUN(startEnterInt);
-
-StgInt
-enterInt(stableIndex)
- StgStablePtr stableIndex;
-{
- checkInCCallGC();
- enterStablePtr( stableIndex, (StgFunPtr) startEnterInt );
- return enterInt_Result;
-}
-
-extern StgFloat enterFloat_Result;
-EXTFUN(startEnterFloat);
-
-StgInt
-enterFloat(stableIndex)
- StgStablePtr stableIndex;
-{
- checkInCCallGC();
- enterStablePtr( stableIndex, (StgFunPtr) startEnterFloat );
- return enterFloat_Result;
-}
-\end{code}
-
-\begin{code}
-StgPtr
-deRefStablePointer(stableIndex)
- StgStablePtr stableIndex;
-{
- return _deRefStablePointer(stableIndex, StorageMgrInfo.StablePointerTable);
-}
-\end{code}
-
-Despite the file name, we have a little ForeignObj operation here - not
-worth putting in a file by itself.
-
-\begin{code}
-StgInt
-eqForeignObj(p1, p2)
- StgForeignObj p1;
- StgForeignObj p2;
-{
- return (p1 == p2);
-}
-
-StgInt
-eqStablePtr(p1, p2)
- StgStablePtr p1;
- StgStablePtr p2;
-{
- return (p1 == p2);
-}
-\end{code}
-
-And some code that HAS NO RIGHT being here.
-
-\begin{code}
-StgStablePtr softHeapOverflowHandler = -1;
-
-StgInt
-catchSoftHeapOverflow( newHandler, deltaLimit )
- StgStablePtr newHandler;
- StgInt deltaLimit;
-{
- StgStablePtr oldHandler = softHeapOverflowHandler;
-
- /* If we're in a _ccall_GC_ then HpLim will be stored in SAVE_HpLim
- which provides an easy way of changing it. */
- checkInCCallGC();
-
- StorageMgrInfo.hardHpOverflowSize += deltaLimit;
- SAVE_HpLim -= deltaLimit;
-
- if (StorageMgrInfo.hardHpOverflowSize < 0) {
- fprintf(stderr, "Error: Setting Hard Heap Overflow Size to negative value!\n");
- EXIT(EXIT_FAILURE);
- }
-
- softHeapOverflowHandler = newHandler;
- return oldHandler;
-}
-
-StgInt
-getSoftHeapOverflowHandler(STG_NO_ARGS)
-{
- return (StgInt) softHeapOverflowHandler;
-}
-
-#endif /* !PAR */
-\end{code}
+++ /dev/null
-\section[StgDebug]{Useful debugging routines for the STG machine}
-
-Call these functions directly from a debugger to print Nodes,
-registers, stacks, etc.
-
-(An invocation such as
-
- make EXTRA_HC_OPTS='-optl-u -optl_DEBUG_LoadSymbols' ghci
-
- is usually required to get this code included in the object code.)
-
-Nota Bene: in a registerised build, you have to save all the registers
-in their appropriate SAVE locations before calling any code that needs
-register contents. (This has to be repeated every time you emerge
-from the STG world.)
-
-On a sparc, this can be done by the following gdb script
-
-define saveRegs
-
- set *(&MainRegTable+8) = $l1
- set *(&MainRegTable+9) = $l2
- set *(&MainRegTable+10) = $l3
- set *(&MainRegTable+11) = $l4
- set *(&MainRegTable+12) = $l5
- set *(&MainRegTable+13) = $l6
- set *(&MainRegTable+14) = $l7
- set *(&MainRegTable+4) = $f2
- set *(&MainRegTable+5) = $f3
- set *(&MainRegTable+6) = $f4
- set *(&MainRegTable+7) = $f5
-
- set *((double *) &MainRegTable+0) = (double) $f6
- set *((double *) &MainRegTable+2) = (double) $f8
- set *(&MainRegTable+23) = $l0
- set *(&MainRegTable+16) = $i0
- set *(&MainRegTable+17) = $i1
- set *(&MainRegTable+18) = $i2
- set *(&MainRegTable+19) = $i3
- set *(&StorageMgrInfo+0) = $i4
- set *(&StorageMgrInfo+1) = $i5
-
-end
-
-
-New code (attempts to interpret heap/stack contents)
- DEBUG_LoadSymbols( filename ) Load symbol table from object file
- (not essential but useful initialisation)
- DEBUG_PrintA( depth, size ) Print "depth" entries from A stack
- DEBUG_PrintB( depth, size ) ditto
- DEBUG_Where( depth, size ) Ambitious attempt to print stacks
- symbolically. Result is a little inaccurate
- but often good enough to do the job.
- DEBUG_NODE( closure, size ) Print a closure on the heap
- DEBUG_INFO_TABLE(closure) Print info-table of a closure
- DEBUG_SPT( size ) Print the Stable Pointer Table
-
-(Use variable DEBUG_details to set level of detail shown.)
-
-Older code (less fancy ==> more reliable)
- DEBUG_ASTACK(lines) Print "lines" lines of the A Stack
- DEBUG_BSTACK(lines) Print "lines" lines of the B Stack
- DEBUG_UPDATES(frames) Print "frames" update frames
- DEBUG_REGS() Print register values
- DEBUG_FO() Print the ForeignObj Lists
- DEBUG_TSO(tso) (CONCURRENT) Print a Thread State Object
-
-Not yet implemented:
- DEBUG_STKO(stko) (CONCURRENT) Print a STacK Object
-
-\begin{code}
-#include "rtsdefs.h"
-\end{code}
-
-\subsection[StgDebug_Symbol_Tables]{Loading Symbol Tables}
-
-NB: this assumes a.out files - won't work on Alphas.
-ToDo: At least add some #ifdefs
-
-\begin{code}
-/* #include <a.out.h> */
-/* #include <stab.h> */
-/* #include <nlist.h> */
-
-#include <stdio.h>
-
-#define FROM_START 0 /* for fseek */
-
-/* Simple lookup table */
-
-/* Current implementation is pretty dumb! */
-
-struct entry {
- unsigned value;
- int index;
- char *name;
-};
-
-static int table_uninitialised = 1;
-static int max_table_size;
-static int table_size;
-static struct entry* table;
-
-static void
-reset_table( int size )
-{
- max_table_size = size;
- table_size = 0;
- table = (struct entry *) stgMallocBytes(size * sizeof(struct entry), "reset_table");
-}
-
-static void
-prepare_table()
-{
- /* Could sort it... */
-}
-
-static void
-insert( unsigned value, int index, char *name )
-{
- if ( table_size >= max_table_size ) {
- fprintf( stderr, "Symbol table overflow\n" );
- EXIT( 1 );
- }
- table[table_size].value = value;
- table[table_size].index = index;
- table[table_size].name = name;
- table_size = table_size + 1;
-}
-
-static int
-lookup( unsigned value, int *result )
-{
- int i;
- for( i = 0; i < table_size && table[i].value != value; ++i ) {
- }
- if (i < table_size) {
- *result = table[i].index;
- return 1;
- } else {
- return 0;
- }
-}
-
-static int
-lookup_name( char *name, unsigned *result )
-{
- int i;
- for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
- }
- if (i < table_size) {
- *result = table[i].value;
- return 1;
- } else {
- return 0;
- }
-}
-\end{code}
-
-* Z-escapes:
- "std"++xs -> "Zstd"++xs
- char_to_c 'Z' = "ZZ"
- char_to_c '&' = "Za"
- char_to_c '|' = "Zb"
- char_to_c ':' = "Zc"
- char_to_c '/' = "Zd"
- char_to_c '=' = "Ze"
- char_to_c '>' = "Zg"
- char_to_c '#' = "Zh"
- char_to_c '<' = "Zl"
- char_to_c '-' = "Zm"
- char_to_c '!' = "Zn"
- char_to_c '.' = "Zo"
- char_to_c '+' = "Zp"
- char_to_c '\'' = "Zq"
- char_to_c '*' = "Zt"
- char_to_c '_' = "Zu"
- char_to_c c = "Z" ++ show (ord c)
-
-\begin{code}
-static char unZcode( char ch )
-{
- switch (ch) {
- case 'Z' :
- case '\0' :
- return ('Z');
- case 'a' :
- return ('&');
- case 'b' :
- return ('|');
- case 'c' :
- return (':');
- case 'd' :
- return ('/');
- case 'e' :
- return ('=');
- case 'g' :
- return ('>');
- case 'h' :
- return ('#');
- case 'l' :
- return ('<');
- case 'm' :
- return ('-');
- case 'n' :
- return ('!');
- case 'o' :
- return ('.');
- case 'p' :
- return ('+');
- case 'q' :
- return ('\'');
- case 't' :
- return ('*');
- case 'u' :
- return ('_');
- default :
- return (ch);
- }
-}
-
-/* Precondition: out big enough to handle output (about twice length of in) */
-static void enZcode( char *in, char *out )
-{
- int i, j;
-
- j = 0;
- out[ j++ ] = '_';
- for( i = 0; in[i] != '\0'; ++i ) {
- switch (in[i]) {
- case 'Z' :
- out[j++] = 'Z';
- out[j++] = 'Z';
- break;
- case '&' :
- out[j++] = 'Z';
- out[j++] = 'a';
- break;
- case '|' :
- out[j++] = 'Z';
- out[j++] = 'b';
- break;
- case ':' :
- out[j++] = 'Z';
- out[j++] = 'c';
- break;
- case '/' :
- out[j++] = 'Z';
- out[j++] = 'd';
- break;
- case '=' :
- out[j++] = 'Z';
- out[j++] = 'e';
- break;
- case '>' :
- out[j++] = 'Z';
- out[j++] = 'g';
- break;
- case '#' :
- out[j++] = 'Z';
- out[j++] = 'h';
- break;
- case '<' :
- out[j++] = 'Z';
- out[j++] = 'l';
- break;
- case '-' :
- out[j++] = 'Z';
- out[j++] = 'm';
- break;
- case '!' :
- out[j++] = 'Z';
- out[j++] = 'n';
- break;
- case '.' :
- out[j++] = 'Z';
- out[j++] = 'o';
- break;
- case '+' :
- out[j++] = 'Z';
- out[j++] = 'p';
- break;
- case '\'' :
- out[j++] = 'Z';
- out[j++] = 'q';
- break;
- case '*' :
- out[j++] = 'Z';
- out[j++] = 't';
- break;
- case '_' :
- out[j++] = 'Z';
- out[j++] = 'u';
- break;
- default :
- out[j++] = in[i];
- break;
- }
- }
- out[j] = '\0';
-}
-\end{code}
-
-\begin{code}
-static int lookupForName( P_ addr, char **result )
-{
- int i;
- for( i = 0; i < table_size && table[i].value != (unsigned) addr; ++i ) {
- }
- if (i < table_size) {
- *result = table[i].name;
- return 1;
- } else {
- return 0;
- }
-}
-
-static void printZcoded( char *raw )
-{
- int j;
-
- /* start at 1 to skip the leading "_" */
- for( j = 1; raw[j] != '\0'; /* explicit */) {
- if (raw[j] == 'Z') {
- putchar(unZcode(raw[j+1]));
- j = j + 2;
- } else {
- putchar(raw[j]);
- j = j + 1;
- }
- }
-}
-
-static void printName( P_ addr )
-{
- char *raw;
-
- if (lookupForName( addr, &raw )) {
- printZcoded(raw);
- } else {
- printf("0x%x", addr);
- }
-}
-
-#if 0 /* OMIT load-symbol stuff cos it doesn't work on Alphas */
-
-/* Fairly ad-hoc piece of code that seems to filter out a lot of
- rubbish like the obj-splitting symbols */
-
-static int
-isReal( unsigned char type, char *name )
-{
- int external = type & N_EXT;
- int tp = type & N_TYPE;
-
- if (tp == N_TEXT || tp == N_DATA) {
- return( name[0] == '_' && name[1] != '_' );
- } else {
- return( 0 );
- }
-}
-
-void
-DEBUG_LoadSymbols( char *name )
-{
- FILE *binary;
-
- struct exec header;
-
- long sym_offset;
- long sym_size;
- long num_syms;
- long num_real_syms;
- struct nlist *symbol_table;
-
- long str_offset;
- long str_size; /* assumed 4 bytes.... */
- char *string_table;
-
- long i;
-
- binary = fopen( name, "r" );
- if (binary == NULL) {
- fprintf( stderr, "Can't open symbol table file \"%s\".\n", name );
- }
-
-
- if (fread( &header, sizeof( struct exec ), 1, binary ) != 1) {
- fprintf( stderr, "Can't read symbol table header.\n" );
- EXIT( 1 );
- }
- if ( N_BADMAG( header ) ) {
- fprintf( stderr, "Bad magic number in symbol table header.\n" );
- EXIT( 1 );
- }
-
-
-
- sym_offset = N_SYMOFF( header );
- sym_size = header.a_syms;
- num_syms = sym_size / sizeof( struct nlist );
- fseek( binary, sym_offset, FROM_START );
-
- symbol_table = (struct nlist *) stgMallocBytes(sym_size, "symbol table (DEBUG_LoadSymbols)");
- printf("Reading %d symbols\n", num_syms);
-
- if (fread( symbol_table, sym_size, 1, binary ) != 1) {
- fprintf( stderr, "Can't read symbol table\n");
- EXIT( 1 );
- }
-
- str_offset = N_STROFF( header );
- fseek( binary, str_offset, FROM_START );
-
- if (fread( &str_size, 4, 1, binary ) != 1) {
- fprintf( stderr, "Can't read string table size\n");
- EXIT( 1 );
- }
-
- /* apparently the size of the string table includes the 4 bytes that
- * store the size...
- */
- string_table = (char *) stgMallocBytes(str_size, "string table (DEBUG_LoadSymbols)");
-
- if (fread( string_table+4, str_size-4, 1, binary ) != 1) {
- fprintf( stderr, "Can't read string table\n");
- EXIT( 1 );
- }
-
- num_real_syms = 0;
- for( i = 0; i != num_syms; ++i ) {
- unsigned char type = symbol_table[i].n_type;
- unsigned value = symbol_table[i].n_value;
- char *str = &string_table[symbol_table[i].n_un.n_strx];
-
- if ( isReal( type, str ) ) {
- num_real_syms = num_real_syms + 1;
- }
- }
-
- printf("Of which %d are real symbols\n", num_real_syms);
-
-/*
- for( i = 0; i != num_syms; ++i ) {
- unsigned char type = symbol_table[i].n_type;
- unsigned value = symbol_table[i].n_value;
- char *str = &string_table[symbol_table[i].n_un.n_strx];
-
- if ( isReal(type, str) ) {
- printf("Symbol %d. Extern? %c. Type: %c. Value: 0x%x. Name: %s\n",
- i,
- (external ? 'y' : 'n'),
- type,
- value,
- str
- );
- }
- }
-*/
-
- reset_table( num_real_syms );
-
- for( i = 0; i != num_syms; ++i ) {
- unsigned char type = symbol_table[i].n_type;
- unsigned value = symbol_table[i].n_value;
- char *str = &string_table[symbol_table[i].n_un.n_strx];
-
- if ( isReal( type, str ) ) {
- insert( value, i, str );
- }
-
- }
-
- prepare_table();
-}
-#endif /* 0 */
-\end{code}
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%
-\subsection[StgDebug_PrettyPrinting]{Pretty printing internal structures}
-%
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-\begin{code}
-#include "../storage/SMinternal.h"
-
-#ifdef GCap
-#define HP_BOT appelInfo.oldbase
-#elif GCdu
-#define HP_BOT dualmodeInfo.modeinfo[dualmodeInfo.mode].base
-#elif GC2s
-#define HP_BOT semispaceInfo[semispace].base
-#elif GC1s
-#define HP_BOT compactingInfo.base
-#else
- unknown garbage collector - help, help!
-#endif
-\end{code}
-
-\begin{code}
-/* range: 0..NUM_LEVELS_OF_DETAIL-1. Level of machine-related detail shown */
-#define NUM_LEVELS_OF_DETAIL 3
-static int DEBUG_details = 2;
-\end{code}
-
-\begin{code}
-/* Determine the size and number of pointers for this kind of closure */
-static void
-getClosureShape( P_ node, int *vhs, int *size, int *ptrs, char **type )
-{
- /* The result is used for printing out closure contents. If the
- info-table is mince, we'd better conservatively guess there's
- nothing in the closure to avoid chasing non-ptrs. */
- *vhs = 0;
- *size = 0;
- *ptrs = 0;
- *type = "*unknown info type*";
-
- /* ToDo: if in garbage collector, consider subtracting some weird offset which some GCs add to infoptr */
-
- /* The order here precisely reflects that in SMInfoTables.lh to make
- it easier to check that this list is complete. */
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE:
- *vhs = 0; /* by decree */
- *size = SPEC_CLOSURE_SIZE(node);
- *ptrs = SPEC_CLOSURE_NoPTRS(node);
- *type = "SPECU";
- break;
- case INFO_SPEC_N_TYPE:
- *vhs = 0; /* by decree */
- *size = SPEC_CLOSURE_SIZE(node);
- *ptrs = SPEC_CLOSURE_NoPTRS(node);
- *type = "SPECN";
- break;
-
- case INFO_GEN_U_TYPE:
- *vhs = GEN_VHS;
- *size = GEN_CLOSURE_SIZE(node);
- *ptrs = GEN_CLOSURE_NoPTRS(node);
- *type = "GENU";
- break;
- case INFO_GEN_N_TYPE:
- *vhs = GEN_VHS;
- *size = GEN_CLOSURE_SIZE(node);
- *ptrs = GEN_CLOSURE_NoPTRS(node);
- *type = "GENN";
- break;
-
- case INFO_DYN_TYPE:
- *vhs = DYN_VHS;
- *size = DYN_CLOSURE_SIZE(node);
- *ptrs = DYN_CLOSURE_NoPTRS(node);
- *type = "DYN";
- break;
-
- case INFO_TUPLE_TYPE:
- *vhs = TUPLE_VHS;
- *size = TUPLE_CLOSURE_SIZE(node);
- *ptrs = TUPLE_CLOSURE_NoPTRS(node);
- *type = "TUPLE";
- break;
-
- case INFO_DATA_TYPE:
- *vhs = DATA_VHS;
- *size = DATA_CLOSURE_SIZE(node);
- *ptrs = DATA_CLOSURE_NoPTRS(node);
- *type = "DATA";
- break;
-
- case INFO_MUTUPLE_TYPE:
- *vhs = MUTUPLE_VHS;
- *size = MUTUPLE_CLOSURE_SIZE(node);
- *ptrs = MUTUPLE_CLOSURE_NoPTRS(node);
- *type = "MUTUPLE";
- break;
-
- case INFO_IMMUTUPLE_TYPE:
- *vhs = MUTUPLE_VHS;
- *size = MUTUPLE_CLOSURE_SIZE(node);
- *ptrs = MUTUPLE_CLOSURE_NoPTRS(node);
- *type = "IMMUTUPLE";
- break;
-
- case INFO_STATIC_TYPE:
- *vhs = STATIC_VHS;
- *size = INFO_SIZE(INFO_PTR(node));
- *ptrs = INFO_NoPTRS(INFO_PTR(node));
- *type = "STATIC";
- break;
-
- case INFO_CONST_TYPE:
- *vhs = 0;
- *size = 0;
- *ptrs = 0;
- *type = "CONST";
- break;
-
- case INFO_CHARLIKE_TYPE:
- *vhs = 0;
- *size = 1;
- *ptrs = 0;
- *type = "CHAR";
- break;
-
- case INFO_INTLIKE_TYPE:
- *vhs = 0;
- *size = 1;
- *ptrs = 0;
- *type = "INT";
- break;
-
- case INFO_BH_TYPE:
- *vhs = 0;
- *size = INFO_SIZE(INFO_PTR(node));
- *ptrs = 0;
- *type = "BHOLE";
- break;
-
-/* most of the following are plausible guesses (particularily VHSs) ADR */
- case INFO_BQ_TYPE:
-#ifdef CONCURRENT
- *vhs = 0;
- *size = BQ_CLOSURE_SIZE(node);
- *ptrs = BQ_CLOSURE_NoPTRS(node);
- *type = "BQ";
-#else
- printf("Panic: found BQ Infotable in non-threaded system.\n");
-#endif
- break;
-
- case INFO_IND_TYPE:
- *vhs = 0;
- *size = IND_CLOSURE_SIZE(node);
- *ptrs = IND_CLOSURE_NoPTRS(node);
- *type = "IND";
- break;
-
- case INFO_CAF_TYPE:
- *vhs = 0; /* ?? ADR */
- *size = INFO_SIZE(INFO_PTR(node));
- *ptrs = 0;
- *type = "CAF";
- break;
-
- case INFO_FETCHME_TYPE:
-#ifdef PAR
- *vhs = FETCHME_VHS;
- *size = FETCHME_CLOSURE_SIZE(node);
- *ptrs = FETCHME_CLOSURE_NoPTRS(node);
- *type = "FETCHME";
-#else
- printf("Panic: found FETCHME Infotable in sequential system.\n");
-#endif
- break;
-
- case INFO_FMBQ_TYPE:
-#ifdef PAR
- *vhs = FMBQ_VHS;
- *size = FMBQ_CLOSURE_SIZE(node);
- *ptrs = FMBQ_CLOSURE_NoPTRS(node);
- *type = "FMBQ";
-#else
- printf("Panic: found FMBQ Infotable in sequential system.\n");
-#endif
- break;
-
- case INFO_BF_TYPE:
-#ifdef PAR
- *vhs = 0;
- *size = 0;
- *ptrs = 0;
- *type = "BlockedFetch";
-#else
- printf("Panic: found BlockedFetch Infotable in sequential system.\n");
-#endif
- break;
-
- case INFO_TSO_TYPE:
- /* Conservative underestimate: this will contain a regtable
- which comes nowhere near fitting the standard "p ptrs; s-p
- non-ptrs" format. ADR */
-#ifdef CONCURRENT
- *vhs = TSO_VHS;
- *size = 0;
- *ptrs = 0;
- *type = "TSO";
-#else
- printf("Panic: found TSO Infotable in non-threaded system.\n");
-#endif
- break;
-
- case INFO_STKO_TYPE:
- /* Conservative underestimate: this will contain stuff
- which comes nowhere near fitting the standard "p ptrs; s-p
- non-ptrs" format. JSM */
-#ifdef CONCURRENT
- *vhs = STKO_VHS;
- *size = 0;
- *ptrs = 0;
- *type = "STKO";
-#else
- printf("Panic: found STKO Infotable in non-threaded system.\n");
-#endif
- break;
-
- /* There are no others in SMInfoTables.lh 11/5/94 ADR*/
- default:
- printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(node)));
- break;
- }
-}
-
-static void
-printWord( W_ word )
-{
- printf("0x%08lx", word);
-}
-
-static void
-printAddress( P_ address )
-{
-# ifdef CONCURRENT
- PP_ SpA = STKO_SpA(SAVE_StkO);
- PP_ SuA = STKO_SuA(SAVE_StkO);
- P_ SpB = STKO_SpB(SAVE_StkO);
- P_ SuB = STKO_SuB(SAVE_StkO);
- PP_ botA = 0; /* junk */
- P_ botB = 0;
-# define CAN_SEE_STK_BOTTOMS 0
-# else
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
- PP_ botA = stackInfo.botA;
- P_ botB = stackInfo.botB;
-# define CAN_SEE_STK_BOTTOMS 1
-# endif
- P_ Hp = SAVE_Hp;
-
- P_ HpBot = HP_BOT;
-
- char *name;
-
- /* ToDo: check if it's in text or data segment. */
-
- /* The @-1@s in stack comparisons are because we sometimes use the
- address of just below the stack... */
-
-#if 0
- if (lookupForName( address, &name )) {
- printZcoded( name );
- }
- else
-#endif
- {
- if (DEBUG_details > 1) {
- printWord( (W_) address );
- printf(" : ");
- }
- if (HpBot <= address && address < Hp) {
- printf("Hp[%d]", address - HpBot);
- } else if ( CAN_SEE_STK_BOTTOMS
- && SUBTRACT_A_STK((PP_)address, botA) >= -1
- && SUBTRACT_A_STK(SpA, (PP_)address) >= 0) {
- printf("SpA[%d]", SUBTRACT_A_STK((PP_)address, botA));
-
- } else if ( CAN_SEE_STK_BOTTOMS
- && SUBTRACT_B_STK(address, botB) >= -1
- && SUBTRACT_B_STK(SpB, address) >= 0) {
- /* ToDo: check if it's an update frame */
- printf("SpB[%d]", SUBTRACT_B_STK(address, botB));
-
- } else {
- printWord( (W_) address );
- }
- }
-}
-
-static void
-printIndentation( int indentation )
-{
- int i;
- for (i = 0; i < indentation; ++i) { printf(" "); }
-}
-
-/* The weight parameter is used to (eventually) break cycles */
-static void
-printStandardShapeClosure(
- int indentation,
- int weight,
- P_ closure, int vhs, int size, int noPtrs
-)
-{
-#ifdef CONCURRENT
- PP_ SpA = STKO_SpA(SAVE_StkO);
- PP_ SuA = STKO_SuA(SAVE_StkO);
- P_ SpB = STKO_SpB(SAVE_StkO);
- P_ SuB = STKO_SuB(SAVE_StkO);
-#else
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
-#endif
- P_ Hp = SAVE_Hp;
-
- void printClosure PROTO( (P_, int, int) );
- int numValues = size - vhs;
- P_ HpBot = HP_BOT;
-
- if (DEBUG_details > 1) {
- printAddress( closure );
- printf(": ");
- }
- printName((P_)INFO_PTR(closure));
-
- if ( numValues > 0 ) {
- int newWeight = weight-1 ;
- /* I've tried dividing the weight by size to share it out amongst
- sub-closures - but that didn't work too well. */
-
- if (newWeight > 0) {
- int i=0;
- printf("(\n");
- while (i < numValues) {
- P_ data = (P_) closure[_FHS + vhs + i];
-
- printIndentation(indentation+1);
- if (i < noPtrs) {
- printClosure( data, indentation+1, newWeight);
- } else {
- printAddress( data );
- }
- i = i + 1;
- if (i < numValues) printf(",\n");
- }
- printf(")");
- } else {
- int i;
- printf("(_");
- for( i = 1; i < size; ++i ) {
- printf(",_");
- }
- printf(")");
- }
- }
-}
-
-/* Should be static but has to be extern to allow mutual recursion */
-void
-printClosure( P_ closure, int indentation, int weight )
-{
- int vhs, size, ptrs;
- char *type;
-
- /* I'd love to put a test here that this actually _is_ a closure -
- but testing that it is in the heap is overly strong. */
-
- getClosureShape(closure, &vhs, &size, &ptrs, &type);
-
- /* The order here precisely reflects that in SMInfoTables.lh to make
- it easier to check that this list is complete. */
- switch(INFO_TYPE(INFO_PTR(closure))) {
- case INFO_SPEC_U_TYPE:
- case INFO_SPEC_N_TYPE:
- case INFO_GEN_U_TYPE:
- case INFO_GEN_N_TYPE:
- case INFO_DYN_TYPE:
- case INFO_TUPLE_TYPE:
- case INFO_DATA_TYPE:
- case INFO_MUTUPLE_TYPE:
- case INFO_IMMUTUPLE_TYPE:
- printStandardShapeClosure(indentation, weight, closure,
- vhs, size, ptrs);
- break;
-
- case INFO_STATIC_TYPE:
- /* If the STATIC contains Floats or Doubles, we can't print it. */
- /* And we can't always rely on the size/ptrs info either */
- printAddress( closure );
- printf(" STATIC");
- break;
-
- case INFO_CONST_TYPE:
- if (DEBUG_details > 1) {
- printAddress( closure );
- printf(": ");
- }
- printName((P_)INFO_PTR(closure));
- break;
-
- case INFO_CHARLIKE_TYPE:
- /* ToDo: check for non-printable characters */
- if (DEBUG_details > 1) printf("CHARLIKE ");
- printf("\'%c\'", (unsigned char) CHARLIKE_VALUE(closure));
- break;
-
- case INFO_INTLIKE_TYPE:
- if (DEBUG_details > 1) printf("INTLIKE ");
- printf("%ld",INTLIKE_VALUE(closure));
- break;
-
- case INFO_BH_TYPE:
- /* Is there anything to say here> */
- if (DEBUG_details > 1) {
- printAddress( closure );
- printf(": ");
- }
- printName((P_)INFO_PTR(closure));
- break;
-
-/* most of the following are just plausible guesses (particularily VHSs) ADR */
-
- case INFO_BQ_TYPE:
-#ifdef CONCURRENT
- printStandardShapeClosure(indentation, weight, closure,
- vhs, size, ptrs);
-#else
- printf("Panic: found BQ Infotable in non-threaded system.\n");
-#endif
- break;
-
- case INFO_IND_TYPE:
- if (DEBUG_details > 0) {
- printAddress( closure );
- printf(" IND: ");
- }
- printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
- break;
-
- case INFO_CAF_TYPE:
- if (DEBUG_details > 0) {
- printAddress( closure );
- printf(" CAF: ");
- }
- printClosure( (P_) IND_CLOSURE_PTR(closure), indentation, weight );
- break;
-
- case INFO_FETCHME_TYPE:
-#ifdef PAR
- printStandardShapeClosure(indentation, weight, closure,
- vhs, size, ptrs);
-#else
- printf("Panic: found FETCHME Infotable in sequential system.\n");
-#endif
- break;
-
- case INFO_FMBQ_TYPE:
-#ifdef PAR
- printStandardShapeClosure(indentation, weight, closure,
- vhs, size, ptrs);
-#else
- printf("Panic: found FMBQ Infotable in sequential system.\n");
-#endif
- break;
-
- case INFO_BF_TYPE:
-#ifdef PAR
- printStandardShapeClosure(indentation, weight, closure,
- vhs, size, ptrs);
-#else
- printf("Panic: found BlockedFetch Infotable in sequential system.\n");
-#endif
- break;
-
- case INFO_TSO_TYPE:
-#ifdef CONCURRENT
- /* A TSO contains a regtable... */
- printAddress( closure );
- printf(" TSO: ...");
-#else
- printf("Panic: found TSO Infotable in non-threaded system.\n");
-#endif
- break;
-
- case INFO_STKO_TYPE:
-#ifdef CONCURRENT
- /* A STKO contains parts of the A and B stacks... */
- printAddress( closure );
- printf(" STKO: ...");
-#else
- printf("Panic: found STKO Infotable in non-threaded system.\n");
-#endif
- break;
-
- /* There are no others in SMInfoTables.lh 11/5/94 ADR*/
- default:
- printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(closure)));
- break;
- }
-}
-
-void
-DEBUG_NODE( P_ closure, int size )
-{
- printClosure( closure, 0, size );
- printf("\n");
-}
-\end{code}
-
-Now some stuff for printing stacks - almost certainly doesn't work
-under threads which keep the stack on the heap.
-
-\begin{code}
-#ifndef CONCURRENT
-
-static int
-minimum(int a, int b)
-{
- if (a < b) {
- return a;
- } else {
- return b;
- }
-}
-
-void
-DEBUG_PrintA( int depth, int weight )
-{
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
-
- int i;
- I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1);
-
- printf("Dump of the Address Stack (SpA = 0x%lx, SuA = 0x%lx)\n", SpA, SuA);
-
- for( i = 0; i < size; ++i ) {
- printIndentation(1);
- printf("SpA[%d] (0x%08lx):", i, SpA + AREL(i));
- printClosure((P_)*(SpA + AREL(i)), 2, weight);
- printf("\n");
- }
-}
-
-void
-DEBUG_PrintB( int depth, int weight )
-{
- PP_ SpA = SAVE_SpA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
-
- I_ i;
- I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1);
-
- P_ updateFramePtr;
- I_ update_count;
-
- printf("Dump of the Value Stack (SpB = 0x%lx, SuB = 0x%lx)\n", SpB, SuB);
-
- updateFramePtr = SuB;
- update_count = 0;
- i = 0;
- while (i < size) {
- if (updateFramePtr == SpB + BREL(i)) {
-
- printIndentation(1);
- printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
- i,
- updateFramePtr,
- update_count
- );
- printName( (P_) *(SpB + BREL(i)) );
- printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
- update_count+1,
- SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
- SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
- );
- printAddress( GRAB_UPDATEE(updateFramePtr) );
- printf(")\n");
-
- printIndentation(2);
- printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
- printf("\n");
-
- updateFramePtr = GRAB_SuB(updateFramePtr);
- update_count = update_count + 1;
-
- /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
- i = i + STD_UF_SIZE;
- } else {
- printIndentation(1);
- printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
- printName((P_) *(SpB + BREL(i)) );
- printf("\n");
- i = i + 1;
- }
- }
-}
-
-#else /* CONCURRENT */
-
-static int
-minimum(int a, int b)
-{
- if (a < b) {
- return a;
- } else {
- return b;
- }
-}
-
-void
-DEBUG_PrintA( int depth, int weight )
-{
- P_ stko = SAVE_StkO;
- PP_ SpA = STKO_SpA(stko);
- PP_ SuA = STKO_SuA(stko);
- P_ SpB = STKO_SpB(stko);
- P_ SuB = STKO_SuB(stko);
- P_ Hp = SAVE_Hp;
-
- int i;
- I_ size = minimum(depth, SUBTRACT_A_STK(SpA, STKO_ASTK_BOT(stko))+1);
-
- printf("Dump of the Address Stack (SpA = 0x%x, SuA = 0x%x)\n", SpA, SuA);
-
- for( i = 0; i < size; ++i ) {
- printIndentation(1);
- printf("SpA[%ld] (0x%08lx):", i, SpA + AREL(i));
- printClosure((P_)*(SpA + AREL(i)), 2, weight);
- printf("\n");
- }
-}
-
-void
-DEBUG_PrintB( int depth, int weight )
-{
- P_ stko = SAVE_StkO;
- PP_ SpA = STKO_SpA(stko);
- PP_ SuA = STKO_SuA(stko);
- P_ SpB = STKO_SpB(stko);
- P_ SuB = STKO_SuB(stko);
- P_ Hp = SAVE_Hp;
-
- I_ i;
- I_ size = minimum(depth, SUBTRACT_B_STK(SpB, STKO_BSTK_BOT(stko))+1);
-
- P_ updateFramePtr;
- I_ update_count;
-
- printf("Dump of the Value Stack (SpB = 0x%x, SuB = 0x%x)\n", SpB, SuB);
-
- updateFramePtr = SuB;
- update_count = 0;
- i = 0;
- while (i < size) {
- if (updateFramePtr == SpB + BREL(i)) {
-
- printIndentation(1);
- printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
- i,
- updateFramePtr,
- update_count
- );
- printName( (P_) *(SpB + BREL(i)) );
- printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
- update_count+1,
- SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
- SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
- );
- printAddress( GRAB_UPDATEE(updateFramePtr) );
- printf(")\n");
-
- printIndentation(2);
- printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
- printf("\n");
-
- updateFramePtr = GRAB_SuB(updateFramePtr);
- update_count = update_count + 1;
-
- /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
- i = i + STD_UF_SIZE;
- } else {
- printIndentation(1);
- printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
- printName((P_) *(SpB + BREL(i)) );
- printf("\n");
- i = i + 1;
- }
- }
-}
-
-#endif /* not CONCURRENT */
-\end{code}
-
-ToDo:
-
- All the following code incorrectly assumes that the only return
- addresses are those associated with update frames.
-
- To do a proper job of printing the environment we need to:
-
- 1) Recognise vectored and non-vectored returns on the B stack.
-
- 2) Know where the local variables are in the A and B stacks for
- each return situation.
-
- Until then, we'll just need to look suspiciously at the
- "environment" being printed out.
-
- ADR
-
-\begin{code}
-/* How many real stacks are there on SpA and SpB? */
-/* Say what?? (Will and Phil, 96/01) */
-#ifndef CONCURRENT
-static int
-numStacks( )
-{
-#ifdef CONCURRENT
- PP_ SpA = STKO_SpA(SAVE_StkO);
- PP_ SuA = STKO_SuA(SAVE_StkO);
- P_ SpB = STKO_SpB(SAVE_StkO);
- P_ SuB = STKO_SuB(SAVE_StkO);
-#else
- P_ SuB = SAVE_SuB;
-#endif
-
- int depth = 1; /* There's always at least one stack */
-
- while (SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
- SuB = GRAB_SuB( SuB );
- depth = depth + 1;
- }
- return depth;
-}
-#endif /* !CONCURRENT */
-
-static void
-printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size )
-{
- int i;
-
- ASSERT( size >= 0 );
-
- for( i = size-1; i >= 0; --i ) {
- printIndentation( indentation );
- printf("A[%ld][%d]", depth, i);
- if (DEBUG_details > 1) printf(" (0x%08lx) ", SpA + AREL(i) );
- printf("=");
- printClosure( *(SpA + AREL(i)), indentation+2, weight );
- printf("\n");
- }
-}
-
-static void
-printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size )
-{
- int i;
-
- ASSERT( size >= 0 );
-
- for( i = size-1; i >= 0; --i) {
- printIndentation( indentation );
- printf("B[%d][%d]", depth, i);
- if (DEBUG_details > 1) printf(" (0x%08lx) ", SpB + BREL(i) );
- printf("=");
- printAddress( (P_) *(SpB + BREL(i)) );
- printf("\n");
- }
-}
-
-static void
-printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
-{
- int sizeA = SUBTRACT_A_STK(SpA, SuA);
- int sizeB = SUBTRACT_B_STK(SpB, SuB);
-
- if (sizeA + sizeB > 0) {
- printIndentation( indentation );
- printf("let\n");
-
- printLocalAStack( depth, indentation+1, weight, SpA, sizeA );
- printLocalBStack( depth, indentation+1, weight, SpB, sizeB );
-
- printIndentation( indentation );
- printf("in\n");
- }
-}
-\end{code}
-
-Printing the current context is a little tricky.
-
-Ideally, we would work from the bottom of the stack up to the top
-recursively printing the stuff nearer the top.
-
-In practice, we have to work from the top down because the top
-contains info about how much data is below the current return address.
-
-The result is that we have two recursive passes over the stacks: the
-first one prints the "cases" and the second one prints the
-continuations (vector tables, etc.)
-
-Note that because we compress chains of update frames, the depth and
-indentation do not always change in step.
-
-ToDo:
-
-* detecting non-updating cases too
-* printing continuations (from vector tables) properly
-* printing sensible names in environment.
-* fix bogus nature of lets
-
-
-\begin{code}
-static int maxDepth = 5;
-
-static int
-printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
-{
-#ifdef CONCURRENT
- printf("no printCases for CONCURRENT\n");
-#else
- int indentation;
-
- if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
- PP_ nextSpA, nextSuA;
- P_ nextSpB, nextSuB;
-
- /* ToDo: GhcConstants.lh reveals that there are two other sizes of
- update frame possible */
- /* ToDo: botB is probably wrong in THREAD system */
-
- nextSpB = SuB + BREL(STD_UF_SIZE);
- nextSuB = GRAB_SuB( SuB );
- nextSpA = SuA;
- nextSuA = GRAB_SuA( nextSuB );
-
- indentation = printCases( depth+1, weight, nextSpA, nextSuA, nextSpB, nextSuB );
-
- if (DEBUG_details > 1 || nextSpB != nextSuB) { /* show frame (even if adjacent to another) */
- printIndentation( indentation );
- printf("case\n");
- indentation = indentation + 1;
- }
- if (SpB != SuB) {
- /* next thing on stack is a return vector - no need to show it here. */
- SpB = SpB + BREL(1);
- }
- printEnvironment( depth, indentation, weight, SpA, SuA, SpB, SuB );
- } else {
- printf("...\n");
- indentation = 1;
- }
-
- return indentation;
-
-#endif /* CONCURRENT */
-}
-
-/* ToDo: pay more attention to format of vector tables in SMupdate.lh */
-
-static int
-isVTBLEntry( P_ entry )
-{
- char *raw;
-
- if (lookupForName( entry, &raw )) {
- if ( strncmp( "_ret", raw, 4 ) == 0 ) {
- return 1;
- } else if ( strncmp( "_djn", raw, 4 ) == 0) {
- return 1;
- } else {
- return 0;
- }
- } else {
- return 0;
- }
-}
-
-static void
-printVectorTable( int indentation, PP_ vtbl )
-{
- if (isVTBLEntry( (P_) vtbl )) { /* Direct return */
- printName( (P_) vtbl );
- } else {
- int i = 0;
- while( isVTBLEntry( vtbl[RVREL(i)] )) {
- printIndentation( indentation );
- printf( "%d -> ", i );
- printName( vtbl[RVREL(i)] );
- printf( "\n" );
- i = i + 1;
- }
- }
-}
-
-static void
-printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
-{
-#ifdef CONCURRENT
- printf("no printContinuations for CONCURRENT\n");
-#else
- if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
- PP_ nextSpA, nextSuA;
- P_ nextSpB, nextSuB;
- int nextIndent = indentation; /* Indentation to print next frame at */
-
- /* ToDo: GhcConstants.lh reveals that there are two other sizes of
- update frame possible */
- /* ToDo: botB is probably wrong in THREAD system */
-
- /* ToDo: ASSERT that SuA == nextSuA */
-
- nextSpB = SuB + BREL(STD_UF_SIZE);
- nextSuB = GRAB_SuB( SuB );
- nextSpA = SuA;
- nextSuA = GRAB_SuA( nextSuB );
-
- if (DEBUG_details > 0) { /* print update information */
-
- if (SpB != SuB) { /* start of chain of update frames */
- printIndentation( indentation );
- printf("of updatePtr ->\n");
- printIndentation( indentation+1 );
- printf("update\n");
- }
- printIndentation( indentation+2 );
- printClosure( (P_)*(SuB + BREL(UF_UPDATEE)), indentation+2, weight );
- printf(" := ");
- printName( (P_) *(SuB + BREL(UF_RET)) );
- printf("(updatePtr)\n");
-
- if (nextSpB != nextSuB) { /* end of chain of update frames */
- nextIndent = nextIndent-1;
- printVectorTable( indentation+1, (PP_) *(nextSpB) );
- }
- } else {
- if (nextSpB != nextSuB) { /* end of chain of update frames */
- nextIndent = nextIndent-1;
- printVectorTable( indentation, (PP_) *(nextSpB) );
- }
- }
- printContinuations( depth+1, nextIndent, weight, nextSpA, nextSuA, nextSpB, nextSuB );
-
- } else {
- printf("...\n");
- }
-#endif /* CONCURRENT */
-}
-
-void
-DEBUG_Where( int depth, int weight )
-{
-#ifdef CONCURRENT
- PP_ SpA = STKO_SpA(SAVE_StkO);
- PP_ SuA = STKO_SuA(SAVE_StkO);
- P_ SpB = STKO_SpB(SAVE_StkO);
- P_ SuB = STKO_SuB(SAVE_StkO);
-#else
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
-#endif
- P_ Hp = SAVE_Hp;
- StgRetAddr RetReg = SAVE_Ret;
- P_ Node = SAVE_R1.p;
-
- int indentation;
-
- maxDepth = depth;
-
- printf("WARNING: Non-updating cases may be incorrectly displayed\n");
-
- indentation = printCases( 1, weight, SpA, SuA, SpB, SuB );
-
- printIndentation( indentation );
- printf("CASE\n");
-
- printIndentation( indentation+1 );
- printName( Node );
- printf("\n");
- printVectorTable( indentation+1, (PP_) RetReg );
-
- printContinuations( depth, indentation, weight, SpA, SuA, SpB, SuB );
-}
-\end{code}
-
-
-\begin{code}
-void
-DEBUG_INFO_TABLE(node)
- P_ node;
-{
- int vhs, size, ptrs; /* not used */
- char *ip_type;
- StgPtr info_ptr = (StgPtr) INFO_PTR(node);
-
- getClosureShape(node, &vhs, &size, &ptrs, &ip_type);
-
- fprintf(stderr,
- "%s Info Ptr 0x%lx; Entry: 0x%lx; Update: 0x%lx\n",
- ip_type, info_ptr,
- (W_) ENTRY_CODE(info_ptr), (W_) UPDATE_CODE(info_ptr));
- fprintf(stderr,
- "Tag: %ld; Type: %ld; Size: %lu; Ptrs: %lu\n\n",
- INFO_TAG(info_ptr), INFO_TYPE(info_ptr),
- INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
-#if defined(GRIP)
- /* flushing is GRIP only */
- fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
-#endif /* GRIP */
-
-#if defined(PROFILING)
- fprintf(stderr,"Cost Centre: 0x%lx\n",INFO_CAT(info_ptr));
-#endif /* PROFILING */
-
-#if defined(_INFO_COPYING)
- fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
- INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
-#endif /* INFO_COPYING */
-
-#if defined(_INFO_COMPACTING)
- fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
- (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
- fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\n",
- (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
- if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
- fprintf(stderr,"plus specialised code\n");
- else
- fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
-#endif /* INFO_COMPACTING */
-}
-
-void
-DEBUG_REGS()
-{
-#ifdef CONCURRENT
- PP_ SpA = STKO_SpA(SAVE_StkO);
- PP_ SuA = STKO_SuA(SAVE_StkO);
- P_ SpB = STKO_SpB(SAVE_StkO);
- P_ SuB = STKO_SuB(SAVE_StkO);
-#else
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
-#endif
- P_ Hp = SAVE_Hp;
- P_ HpLim= SAVE_HpLim;
- I_ TagReg= SAVE_Tag;
- StgRetAddr RetReg = SAVE_Ret;
- P_ Node = SAVE_R1.p;
- StgUnion R1 = SAVE_R1;
- StgUnion R2 = SAVE_R2;
- StgUnion R3 = SAVE_R3;
- StgUnion R4 = SAVE_R4;
- StgUnion R5 = SAVE_R5;
- StgUnion R6 = SAVE_R6;
- StgUnion R7 = SAVE_R7;
- StgUnion R8 = SAVE_R8;
- StgFloat FltReg1 = SAVE_Flt1;
- StgFloat FltReg2 = SAVE_Flt2;
- StgFloat FltReg3 = SAVE_Flt3;
- StgFloat FltReg4 = SAVE_Flt4;
- StgDouble DblReg1 = SAVE_Dbl1;
- StgDouble DblReg2 = SAVE_Dbl2;
-#if HAVE_LONG_LONG
- StgDouble LngReg1 = SAVE_Lng1;
- StgDouble LngReg2 = SAVE_Lng2;
-#endif
-
- fprintf(stderr,"STG-Machine Register Values:\n\n");
- fprintf(stderr,"Node: %08lx; Hp: %08lx; HpLim: %08lx; Tag: %8lu\n",Node,(W_)Hp,(W_)HpLim,TagReg);
- fprintf(stderr,"SpA: %08lx; SpB: %08lx; SuA: %08lx; SuB: %08lx\n",(W_)SpA,(W_)SpB,(W_)SuA,(W_)SuB);
- fprintf(stderr,"RetReg: %08lx\n",RetReg);
-
-#if 0
-/* These bits need to have the FLUSH_REG_MAP, whereas the surrounding bits
- use the MAIN_REG_MAP */
-
- fprintf(stderr, "\n");
- fprintf(stderr,"LiveR: %08lx\n", LivenessReg);
- fprintf(stderr,"Flush: %08lx; FStk: %08lx; FStkB: %08lx; FTmp: %08lx\n",(W_)FlushP,(W_)FStack,(W_)FStackBase,(W_)Temp);
-#endif /* 0 */
-
- fprintf(stderr, "\n");
-
- fprintf(stderr,"Gen: %8lu, %8lu, %8lu, %8lu\n",R1.i,R2.i,R3.i,R4.i);
- fprintf(stderr," %8lu, %8lu, %8lu, %8lu\n",R5.i,R6.i,R7.i,R8.i);
- fprintf(stderr,"Float: %8g, %8g, %8g, %8g\n",FltReg1,FltReg2,FltReg3,FltReg4);
- fprintf(stderr,"Dble: %8g, %8g\n",DblReg1,DblReg2);
-#if HAVE_LONG_LONG
- fprintf(stderr,"Long: %8lu, %8lu\n",LngReg1,LngReg2);
-#endif
-}
-
-#ifndef CONCURRENT
-
-void
-DEBUG_FO()
-{
- StgPtr mp;
- StgInt i;
-
- fprintf(stderr,"ForeignObjList\n\n");
-
- for(mp = StorageMgrInfo.ForeignObjList;
- mp != NULL;
- mp = ForeignObj_CLOSURE_LINK(mp)) {
-
- fprintf(stderr,
- "ForeignObjPtr(0x%lx) = 0x%lx, finaliser: 0x%lx\n",
- mp,
- ForeignObj_CLOSURE_DATA(mp),
- ForeignObj_CLOSURE_FINALISER(mp));
-
-/*
- DEBUG_PRINT_NODE(mp);
-*/
- }
-
-# if defined(GCap) || defined(GCgn)
- fprintf(stderr,"\nOldForeignObj List\n\n");
-
- for(mp = StorageMgrInfo.OldForeignObjList;
- mp != NULL;
- mp = ForeignObj_CLOSURE_LINK(mp)) {
-
- fprintf(stderr,
- "ForeignObj(0x%lx) = 0x%lx, finaliser: 0x%lx\n",
- mp,
- ForeignObj_CLOSURE_DATA(mp),
- ForeignObj_CLOSURE_FINALISER(mp));
-/*
- DEBUG_PRINT_NODE(mp);
-*/
- }
-# endif /* GCap || GCgn */
-
- fprintf(stderr, "\n");
-}
-
-void
-DEBUG_SPT(int weight)
-{
- StgPtr SPTable = StorageMgrInfo.StablePointerTable;
- StgInt size = SPT_SIZE(SPTable);
- StgInt ptrs = SPT_NoPTRS(SPTable);
- StgInt top = SPT_TOP(SPTable);
-
- StgInt i;
-
-/*
- DEBUG_PRINT_NODE(SPTable);
-*/
-
- fprintf(stderr,"SPTable@0x%lx:\n", SPTable);
- fprintf(stderr," InfoPtr = 0x%lx\n", INFO_PTR(SPTable));
- fprintf(stderr," size = %d, ptrs = %d, top = %d\n",
- size, ptrs, top
- );
- for( i=0; i < ptrs; i++ ) {
- if (i % 10 == 0) {
- fprintf(stderr,"\n ");
- }
- printClosure(SPT_SPTR(SPTable, i),1,weight);
- fprintf(stderr, "\n");
- }
- fprintf(stderr, "\n");
- for( i=0; i < top; i++) {
- if (i % 10 == 0) {
- fprintf(stderr,"\n ");
- }
- fprintf(stderr, " %3d", SPT_FREE(SPTable, i));
- }
-
- fprintf(stderr, "\n\n");
-
-}
-#endif /* !CONCURRENT */
-
-/*
- These routines crawl over the A and B stacks, printing
- a maximum "lines" lines at the top of the stack.
-*/
-
-#define STACK_VALUES_PER_LINE 5
-
-#ifndef CONCURRENT
-/* (stack stuff is really different on parallel machines) */
-
-void
-DEBUG_ASTACK(lines)
- I_ lines;
-{
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
-
- PP_ stackptr;
- I_ count = 0;
-
- fprintf(stderr,"Dump of the Address Stack, SpA: 0x%08lx, BOS: 0x%08lx\n",
- (W_) SpA, (W_) stackInfo.botA);
-
- for (stackptr = SpA;
- SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
- stackptr = stackptr + AREL(1))
- {
- if( count++ % STACK_VALUES_PER_LINE == 0)
- {
- if(count >= lines * STACK_VALUES_PER_LINE)
- break;
- fprintf(stderr,"\nSpA[%ld] (0x%08lx): ",count-1,stackptr);
- }
- fprintf(stderr,"0x%08lx ",(W_) *stackptr);
- }
- fprintf(stderr, "\n");
-}
-
-void
-DEBUG_BSTACK(lines)
- I_ lines;
-{
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
-
- P_ stackptr;
- I_ count = 0;
-
- fprintf(stderr,"Dump of the Value Stack, SpB: 0x%08lx, BOS: 0x%08lx\n",
- (W_) SpB, (W_) stackInfo.botB);
-
- for (stackptr = SpB;
- SUBTRACT_B_STK(stackptr, stackInfo.botB) > 0;
- stackptr = stackptr + BREL(1))
- {
- if( count++ % STACK_VALUES_PER_LINE == 0)
- {
- if(count >= lines * STACK_VALUES_PER_LINE)
- break;
- fprintf(stderr,"\nSpB[%ld] (0x%08lx): ",count-1,stackptr);
- }
- fprintf(stderr,"0x%08lx ",(W_) *stackptr);
- }
- fprintf(stderr, "\n");
-}
-
-
-#endif /* not concurrent */
-
-/*
- This should disentangle update frames from both stacks.
-*/
-
-#ifndef CONCURRENT
-void
-DEBUG_UPDATES(limit)
- I_ limit;
-{
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
-
- P_ updatee, retreg;
- PP_ sua, spa;
- P_ sub, spb;
- I_ count = 0;
-
- fprintf(stderr,"Update Frame Stack Dump:\n\n");
-
- for(spa = SuA, spb = SuB;
- SUBTRACT_B_STK(spb, stackInfo.botB) > 0 && count++ < limit;
- spa = GRAB_SuA(spb), spb = GRAB_SuB(spb) ) {
-
- updatee = GRAB_UPDATEE(spb); /* Thing to be updated */
- retreg = (P_) GRAB_RET(spb); /* Return vector below */
-
- fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx (Info 0x%08lx), RetReg 0x%x\n",
- (W_) spa, (W_) spb,
- (W_) updatee, (W_) INFO_PTR(updatee), (W_) retreg);
- }
-}
-
-#endif /* not concurrent */
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-void
-DEBUG_TSO(P_ tso)
-{
- STGRegisterTable *r = TSO_INTERNAL_PTR(tso);
- W_ liveness = r->rLiveness;
- I_ i;
-
- fprintf(stderr,"TSO:\ntso=%lx, regs=%lx, liveness=%lx\nlink=%lx,name=%lx,id=%lx,type=%lx,pc1=%lx,arg1=%lx,switch=%lx\n"
- , tso
- , r
- , liveness
- , TSO_LINK(tso)
- , TSO_NAME(tso)
- , TSO_ID(tso)
- , TSO_TYPE(tso)
- , TSO_PC1(tso)
- , TSO_ARG1(tso)
- , TSO_SWITCH(tso)
- );
-
- for (i = 0; liveness != 0; liveness >>= 1, i++) {
- if (liveness & 1) {
- fprintf(stderr, "live reg %d (%lx)\n",i, r->rR[i].p);
- } else {
- fprintf(stderr, "reg %d (%lx) not live\n", i, r->rR[i].p);
- }
- }
-}
-
-#endif /* concurrent */
-\end{code}
-
-%****************************************************************************
-%
-\subsection[GrAnSim-debug]{Debugging routines for GrAnSim}
-%
-%****************************************************************************
-
-Debugging routines, mainly for GrAnSim.
-They should really be in a separate file.
-There is some code duplication of above routines in here, I'm afraid.
-
-As a naming convention all GrAnSim debugging functions start with @G_@.
-The shorthand forms defined at the end start only with @G@.
-
-\begin{code}
-#if defined(GRAN) && defined(GRAN_CHECK)
-
-#define NULL_REG_MAP /* Not threaded */
-/* #include "stgdefs.h" */
-
-char *
-info_hdr_type(info_ptr)
-P_ info_ptr;
-{
-#if ! defined(PAR) && !defined(GRAN)
- switch (INFO_TAG(info_ptr))
- {
- case INFO_OTHER_TAG:
- return("OTHER_TAG");
-/* case INFO_IND_TAG:
- return("IND_TAG");
-*/ default:
- return("TAG<n>");
- }
-#else /* PAR */
- switch(BASE_INFO_TYPE(info_ptr))
- {
- case INFO_SPEC_TYPE:
- return("SPEC");
-
- case INFO_GEN_TYPE:
- return("GEN");
-
- case INFO_DYN_TYPE:
- return("DYN");
-
- case INFO_TUPLE_TYPE:
- return("TUPLE");
-
- case INFO_DATA_TYPE:
- return("DATA");
-
- case INFO_MUTUPLE_TYPE:
- return("MUTUPLE");
-
- case INFO_IMMUTUPLE_TYPE:
- return("IMMUTUPLE");
-
- case INFO_STATIC_TYPE:
- return("STATIC");
-
- case INFO_CONST_TYPE:
- return("CONST");
-
- case INFO_CHARLIKE_TYPE:
- return("CHAR");
-
- case INFO_INTLIKE_TYPE:
- return("INT");
-
- case INFO_BH_TYPE:
- return("BHOLE");
-
- case INFO_BQ_TYPE:
- return("BQ");
-
- case INFO_IND_TYPE:
- return("IND");
-
- case INFO_CAF_TYPE:
- return("CAF");
-
- case INFO_FM_TYPE:
- return("FETCHME");
-
- case INFO_TSO_TYPE:
- return("TSO");
-
- case INFO_STKO_TYPE:
- return("STKO");
-
- case INFO_SPEC_RBH_TYPE:
- return("SPEC_RBH");
-
- case INFO_GEN_RBH_TYPE:
- return("GEN_RBH");
-
- case INFO_BF_TYPE:
- return("BF");
-
- case INFO_INTERNAL_TYPE:
- return("INTERNAL");
-
- default:
- fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
- return("??");
- }
-#endif /* PAR */
-}
-
-char *
-info_type(infoptr, str)
-P_ infoptr;
-char *str;
-{
- strcpy(str,"");
- if ( IS_NF(infoptr) )
- strcat(str,"|_NF ");
- else if ( IS_MUTABLE(infoptr) )
- strcat(str,"|_MU");
- else if ( IS_STATIC(infoptr) )
- strcat(str,"|_ST");
- else if ( IS_UPDATABLE(infoptr) )
- strcat(str,"|_UP");
- else if ( IS_BIG_MOTHER(infoptr) )
- strcat(str,"|_BM");
- else if ( IS_BLACK_HOLE(infoptr) )
- strcat(str,"|_BH");
- else if ( IS_INDIRECTION(infoptr) )
- strcat(str,"|_IN");
- else if ( IS_THUNK(infoptr) )
- strcat(str,"|_TH");
-
- return(str);
-}
-
-/*
-@var_hdr_size@ computes the size of the variable header for a closure.
-*/
-
-I_
-var_hdr_size(node)
-P_ node;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE: return(0); /* by decree */
- case INFO_SPEC_N_TYPE: return(0);
- case INFO_GEN_U_TYPE: return(GEN_VHS);
- case INFO_GEN_N_TYPE: return(GEN_VHS);
- case INFO_DYN_TYPE: return(DYN_VHS);
- /*
- case INFO_DYN_TYPE_N: return(DYN_VHS);
- case INFO_DYN_TYPE_U: return(DYN_VHS);
- */
- case INFO_TUPLE_TYPE: return(TUPLE_VHS);
- case INFO_DATA_TYPE: return(DATA_VHS);
- case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS);
- case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
- case INFO_STATIC_TYPE: return(STATIC_VHS);
- case INFO_CONST_TYPE: return(0);
- case INFO_CHARLIKE_TYPE: return(0);
- case INFO_INTLIKE_TYPE: return(0);
- case INFO_BH_TYPE: return(0);
- case INFO_IND_TYPE: return(0);
- case INFO_CAF_TYPE: return(0);
- case INFO_FETCHME_TYPE: return(0);
- case INFO_BQ_TYPE: return(0);
- /*
- case INFO_BQENT_TYPE: return(0);
- */
- case INFO_TSO_TYPE: return(TSO_VHS);
- case INFO_STKO_TYPE: return(STKO_VHS);
- default:
- fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
- INFO_TYPE(INFO_PTR(node)));
- return(0);
- }
-}
-
-
-/* Determine the size and number of pointers for this kind of closure */
-void
-size_and_ptrs(node,size,ptrs)
-P_ node;
-W_ *size, *ptrs;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE:
- case INFO_SPEC_N_TYPE:
- *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */
- *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */
- /*
- *size = SPEC_CLOSURE_SIZE(node);
- *ptrs = SPEC_CLOSURE_NoPTRS(node);
- */
- break;
-
- case INFO_GEN_U_TYPE:
- case INFO_GEN_N_TYPE:
- *size = GEN_CLOSURE_SIZE(node);
- *ptrs = GEN_CLOSURE_NoPTRS(node);
- break;
-
- /*
- case INFO_DYN_TYPE_U:
- case INFO_DYN_TYPE_N:
- */
- case INFO_DYN_TYPE:
- *size = DYN_CLOSURE_SIZE(node);
- *ptrs = DYN_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_TUPLE_TYPE:
- *size = TUPLE_CLOSURE_SIZE(node);
- *ptrs = TUPLE_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_DATA_TYPE:
- *size = DATA_CLOSURE_SIZE(node);
- *ptrs = DATA_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_IND_TYPE:
- *size = IND_CLOSURE_SIZE(node);
- *ptrs = IND_CLOSURE_NoPTRS(node);
- break;
-
-/* ToDo: more (WDP) */
-
- /* Don't know about the others */
- default:
- *size = *ptrs = 0;
- break;
- }
-}
-
-void
-G_PRINT_NODE(node)
-P_ node;
-{
- P_ info_ptr, bqe; /* = INFO_PTR(node); */
- I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0;
- char info_hdr_ty[80], info_ty[80];
-
- if (node==NULL) {
- fprintf(stderr,"NULL\n");
- return;
- } else if (node==PrelBase_Z91Z93_closure) {
- fprintf(stderr,"PrelBase_Z91Z93_closure\n");
- return;
- } else if (node==MUT_NOT_LINKED) {
- fprintf(stderr,"MUT_NOT_LINKED\n");
- return;
- }
- /* size_and_ptrs(node,&size,&ptrs); */
- info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_hdr_ty);
-
- /* vhs = var_hdr_size(node); */
- info_type(info_ptr,info_ty);
-
- fprintf(stderr,"Node: 0x%lx", (W_) node);
-
-#if defined(PAR)
- fprintf(stderr," [GA: 0x%lx]",GA(node));
-#endif
-
-#if defined(USE_COST_CENTRES)
- fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
-#endif
-
-#if defined(GRAN)
- fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
-#endif
-
- if (info_ptr==INFO_TSO_TYPE)
- fprintf(stderr," TSO: 0x%lx (%x) IP: 0x%lx (%s), type %s \n ",
- node, TSO_ID(node), info_ptr, info_hdr_ty, info_ty);
- else
- fprintf(stderr," IP: 0x%lx (%s), type %s \n VHS: %d, size: %ld, ptrs:%ld, nonptrs: %ld\n ",
- info_ptr,info_hdr_ty,info_ty,vhs,size,ptrs,nonptrs);
-
- /* For now, we ignore the variable header */
-
- fprintf(stderr," Ptrs: ");
- for(i=0; i < ptrs; ++i)
- {
- if ( (i+1) % 6 == 0)
- fprintf(stderr,"\n ");
- fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
- };
-
- fprintf(stderr," Data: ");
- for(i=0; i < nonptrs; ++i)
- {
- if( (i+1) % 6 == 0)
- fprintf(stderr,"\n ");
- fprintf(stderr," %lu[D]",*(node+_FHS+vhs+ptrs+i));
- }
- fprintf(stderr, "\n");
-
-
- switch (INFO_TYPE(info_ptr))
- {
- case INFO_TSO_TYPE:
- fprintf(stderr,"\n TSO_LINK: %#lx",
- TSO_LINK(node));
- break;
-
- case INFO_BH_TYPE:
- case INFO_BQ_TYPE:
- bqe = (P_)BQ_ENTRIES(node);
- fprintf(stderr," BQ of %#lx: ", node);
- PRINT_BQ(bqe);
- break;
- case INFO_FMBQ_TYPE:
- printf("Panic: found FMBQ Infotable in GrAnSim system.\n");
- break;
- case INFO_SPEC_RBH_TYPE:
- bqe = (P_)SPEC_RBH_BQ(node);
- fprintf(stderr," BQ of %#lx: ", node);
- PRINT_BQ(bqe);
- break;
- case INFO_GEN_RBH_TYPE:
- bqe = (P_)GEN_RBH_BQ(node);
- fprintf(stderr," BQ of %#lx: ", node);
- PRINT_BQ(bqe);
- break;
- }
-}
-
-void
-G_PPN(node) /* Extracted from PrintPacket in Pack.lc */
-P_ node;
-{
- P_ info ;
- I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0, locn = 0;
- char info_type[80];
-
- /* size_and_ptrs(node,&size,&ptrs); */
- info = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type);
-
- if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
- size = ptrs = nonptrs = vhs = 0;
-
- if (IS_THUNK(info)) {
- if (IS_UPDATABLE(info))
- fputs("SHARED ", stderr);
- else
- fputs("UNSHARED ", stderr);
- }
- if (IS_BLACK_HOLE(info)) {
- fputs("BLACK HOLE\n", stderr);
- } else {
- /* Fixed header */
- fprintf(stderr, "(%s) FH [%#lx", info_type, node[locn++]);
- for (i = 1; i < FIXED_HS; i++)
- fprintf(stderr, " %#lx", node[locn++]);
-
- /* Variable header */
- if (vhs > 0) {
- fprintf(stderr, "] VH [%#lx", node[locn++]);
-
- for (i = 1; i < vhs; i++)
- fprintf(stderr, " %#lx", node[locn++]);
- }
-
- fprintf(stderr, "] PTRS %u", ptrs);
-
- /* Non-pointers */
- if (nonptrs > 0) {
- fprintf(stderr, " NPTRS [%#lx", node[locn++]);
-
- for (i = 1; i < nonptrs; i++)
- fprintf(stderr, " %#lx", node[locn++]);
-
- putc(']', stderr);
- }
- putc('\n', stderr);
- }
-
- }
-
-#define INFO_MASK 0x80000000
-
-void
-G_MUT(node,verbose) /* Print mutables list starting with node */
-P_ node;
-{
- if (verbose & 0x1) { G_PRINT_NODE(node); fprintf(stderr, "\n"); }
- else fprintf(stderr, "0x%#lx, ", node);
-
- if (node==NULL || node==PrelBase_Z91Z93_closure || node==MUT_NOT_LINKED) {
- return;
- }
- G_MUT(MUT_LINK(node), verbose);
-}
-
-
-void
-G_TREE(node)
-P_ node;
-{
- W_ size = 0, ptrs = 0, i, vhs = 0;
-
- /* Don't print cycles */
- if((INFO_PTR(node) & INFO_MASK) != 0)
- return;
-
- size_and_ptrs(node,&size,&ptrs);
- vhs = var_hdr_size(node);
-
- G_PRINT_NODE(node);
- fprintf(stderr, "\n");
-
- /* Mark the node -- may be dangerous */
- INFO_PTR(node) |= INFO_MASK;
-
- for(i = 0; i < ptrs; ++i)
- G_TREE((P_)node[i+vhs+_FHS]);
-
- /* Unmark the node */
- INFO_PTR(node) &= ~INFO_MASK;
-}
-
-
-void
-G_INFO_TABLE(node)
-P_ node;
-{
- P_ info_ptr = (P_)INFO_PTR(node);
- char *ip_type = info_hdr_type(info_ptr);
-
- fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
- ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
-
- if (IS_THUNK(info_ptr) && IS_UPDATABLE(info_ptr) ) {
- fprintf(stderr," RBH InfoPtr: %#lx\n",
- RBH_INFOPTR(info_ptr));
- }
-
-#if defined(PAR)
- fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
-#endif
-
-#if defined(USE_COST_CENTRES)
- fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr));
-#endif
-
-#if defined(_INFO_COPYING)
- fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
- INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
-#endif
-
-#if defined(_INFO_COMPACTING)
- fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
- (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
- fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t",
- (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
-#if 0 /* avoid INFO_TYPE */
- if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
- fprintf(stderr,"plus specialised code\n");
- else
- fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
-#endif /* 0 */
-#endif /* _INFO_COMPACTING */
-}
-#endif /* GRAN */
-
-\end{code}
-
-The remaining debugging routines are more or less specific for GrAnSim.
-
-\begin{code}
-#if defined(GRAN) && defined(GRAN_CHECK)
-void
-G_CURR_THREADQ(verbose)
-I_ verbose;
-{
- fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
- G_THREADQ(ThreadQueueHd, verbose);
-}
-
-void
-G_THREADQ(closure, verbose)
-P_ closure;
-I_ verbose;
-{
- P_ x;
-
- fprintf(stderr,"Thread Queue: ");
- for (x=closure; x!=PrelBase_Z91Z93_closure; x=TSO_LINK(x))
- if (verbose)
- G_TSO(x,0);
- else
- fprintf(stderr," %#lx",x);
-
- if (closure==PrelBase_Z91Z93_closure)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-/* Check with Threads.lh */
-static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
-
-void
-G_TSO(closure,verbose)
-P_ closure;
-I_ verbose;
-{
-
- if (closure==PrelBase_Z91Z93_closure) {
- fprintf(stderr,"TSO at %#lx is PrelBase_Z91Z93_closure!\n");
- return;
- }
-
- if ( verbose & 0x08 ) { /* short info */
- fprintf(stderr,"[TSO @ %#lx, PE %d]: Name: %#lx, Id: %#lx, Link: %#lx\n",
- closure,where_is(closure),
- TSO_NAME(closure),TSO_ID(closure),TSO_LINK(closure));
- return;
- }
-
- fprintf(stderr,"TSO at %#lx has the following contents:\n",
- closure);
-
- fprintf(stderr,"> Name: \t%#lx",TSO_NAME(closure));
- fprintf(stderr,"\tLink: \t%#lx\n",TSO_LINK(closure));
- fprintf(stderr,"> Id: \t%#lx",TSO_ID(closure));
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GranFlags.debug & 0x10)
- fprintf(stderr,"\tType: \t%s %s\n",
- type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
- (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
- else
- fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
-#else
- fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
-#endif
- fprintf(stderr,"> PC1: \t%#lx",TSO_PC1(closure));
- fprintf(stderr,"\tPC2: \t%#lx\n",TSO_PC2(closure));
- fprintf(stderr,"> ARG1: \t%#lx",TSO_ARG1(closure));
- /* fprintf(stderr,"\tARG2: \t%#lx\n",TSO_ARG2(closure)); */
- fprintf(stderr,"> SWITCH: \t%#lx", TSO_SWITCH(closure));
-#if defined(GRAN_PRI_SCHED)
- fprintf(stderr,"\tPRI: \t%#lx\n", TSO_PRI(closure));
-#else
- fprintf(stderr,"\n");
-#endif
- if (verbose) {
- fprintf(stderr,"} LOCKED: \t%#lx",TSO_LOCKED(closure));
- fprintf(stderr,"\tSPARKNAME: \t%#lx\n", TSO_SPARKNAME(closure));
- fprintf(stderr,"} STARTEDAT: \t%#lx", TSO_STARTEDAT(closure));
- fprintf(stderr,"\tEXPORTED: \t%#lx\n", TSO_EXPORTED(closure));
- fprintf(stderr,"} BASICBLOCKS: \t%#lx", TSO_BASICBLOCKS(closure));
- fprintf(stderr,"\tALLOCS: \t%#lx\n", TSO_ALLOCS(closure));
- fprintf(stderr,"} EXECTIME: \t%#lx", TSO_EXECTIME(closure));
- fprintf(stderr,"\tFETCHTIME: \t%#lx\n", TSO_FETCHTIME(closure));
- fprintf(stderr,"} FETCHCOUNT: \t%#lx", TSO_FETCHCOUNT(closure));
- fprintf(stderr,"\tBLOCKTIME: \t%#lx\n", TSO_BLOCKTIME(closure));
- fprintf(stderr,"} BLOCKCOUNT: \t%#lx", TSO_BLOCKCOUNT(closure));
- fprintf(stderr,"\tBLOCKEDAT: \t%#lx\n", TSO_BLOCKEDAT(closure));
- fprintf(stderr,"} GLOBALSPARKS:\t%#lx", TSO_GLOBALSPARKS(closure));
- fprintf(stderr,"\tLOCALSPARKS:\t%#lx\n", TSO_LOCALSPARKS(closure));
- }
-#if defined(GRAN_CHECK)
- if ( verbose & 0x02 ) {
- fprintf(stderr,"BQ that starts with this TSO: ");
- PRINT_BQ(closure);
- }
-#endif
-}
-
-void
-G_EVENT(event, verbose)
-eventq event;
-I_ verbose;
-{
- if (verbose) {
- print_event(event);
- }else{
- fprintf(stderr," %#lx",event);
- }
-}
-
-void
-G_EVENTQ(verbose)
-I_ verbose;
-{
- eventq x;
-
- fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd);
- for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
- G_EVENT(x,verbose);
- }
- if (EventHd==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-G_PE_EQ(pe,verbose)
-PROC pe;
-I_ verbose;
-{
- eventq x;
-
- fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd);
- for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
- if (EVENT_PROC(x)==pe)
- G_EVENT(x,verbose);
- }
- if (EventHd==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-G_SPARK(spark, verbose)
-sparkq spark;
-I_ verbose;
-{
- if (verbose)
- print_spark(spark);
- else
- fprintf(stderr," %#lx",spark);
-}
-
-void
-G_SPARKQ(spark,verbose)
-sparkq spark;
-I_ verbose;
-{
- sparkq x;
-
- fprintf(stderr,"Sparkq (hd @%#lx):\n",spark);
- for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
- G_SPARK(x,verbose);
- }
- if (spark==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-G_CURR_SPARKQ(verbose)
-I_ verbose;
-{
- G_SPARKQ(SparkQueueHd,verbose);
-}
-
-void
-G_PROC(proc,verbose)
-I_ proc;
-I_ verbose;
-{
- extern char *proc_status_names[];
-
- fprintf(stderr,"Status of proc %d at time %d (%#lx): %s (%s)\n",
- proc,CurrentTime[proc],CurrentTime[proc],
- (CurrentProc==proc)?"ACTIVE":"INACTIVE",
- proc_status_names[procStatus[proc]]);
- G_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
- if ( (CurrentProc==proc) )
- G_TSO(CurrentTSO,1);
-
- if (EventHd!=NULL)
- fprintf(stderr,"Next event (%s) is on proc %d\n",
- event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
-
- if (verbose & 0x1) {
- fprintf(stderr,"\nREQUIRED sparks: ");
- G_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
- fprintf(stderr,"\nADVISORY_sparks: ");
- G_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
- }
-}
-
-/* Debug Processor */
-void
-GP(proc)
-I_ proc;
-{ G_PROC(proc,1);
-}
-
-/* Debug Current Processor */
-void
-GCP(){ G_PROC(CurrentProc,2); }
-
-/* Debug TSO */
-void
-GT(P_ tso){
- G_TSO(tso,1);
-}
-
-/* Debug CurrentTSO */
-void
-GCT(){
- fprintf(stderr,"Current Proc: %d\n",CurrentProc);
- G_TSO(CurrentTSO,1);
-}
-
-/* Shorthand for debugging event queue */
-void
-GEQ() { G_EVENTQ(1); }
-
-/* Shorthand for debugging thread queue of a processor */
-void
-GTQ(PROC p) { G_THREADQ(RunnableThreadsHd[p],1); }
-
-/* Shorthand for debugging thread queue of current processor */
-void
-GCTQ() { G_THREADQ(RunnableThreadsHd[CurrentProc],1); }
-
-/* Shorthand for debugging spark queue of a processor */
-void
-GSQ(PROC p) { G_SPARKQ(PendingSparksHd[p][1],1); }
-
-/* Shorthand for debugging spark queue of current processor */
-void
-GCSQ() { G_CURR_SPARKQ(1); }
-
-/* Shorthand for printing a node */
-void
-GN(P_ node) { G_PRINT_NODE(node); }
-
-/* Shorthand for printing info table */
-void
-GIT(P_ node) { G_INFO_TABLE(node); }
-
-/* Shorthand for some of ADRs debugging functions */
-
-void
-pC(P_ closure) { printClosure(closure, 0/*indentation*/, 10/*weight*/); }
-
-/* Print a closure on the heap */
-void
-DN(P_ closure) { DEBUG_NODE( closure, 1/*size*/ );}
-
-/* Print info-table of a closure */
-void
-DIT(P_ closure) { DEBUG_INFO_TABLE(closure); }
-
-/* (CONCURRENT) Print a Thread State Object */
-void
-DT(P_ tso) { DEBUG_TSO(tso); }
-
-/* Not yet implemented: */
-/* (CONCURRENT) Print a STacK Object
-void
-DS(P_ stko) { DEBUG_STKO(stko) ; }
-*/
-
-#endif /* GRAN */
-
-/* --------------------------- vvvv old vvvvv ------------------------*/
-
-#if 0 /* ngo' ngoq! veQ yIboS! */
-
-#define NULL_REG_MAP /* Not threaded */
-#include "stgdefs.h"
-
-char *
-info_hdr_type(info_ptr)
-W_ info_ptr;
-{
-#if ! defined(PAR) && !defined(GRAN)
- switch (INFO_TAG(info_ptr))
- {
- case INFO_OTHER_TAG:
- return("OTHER_TAG");
-/* case INFO_IND_TAG:
- return("IND_TAG");
-*/ default:
- return("TAG<n>");
- }
-#else /* PAR */
- switch(INFO_TYPE(info_ptr))
- {
- case INFO_SPEC_U_TYPE:
- return("SPECU");
-
- case INFO_SPEC_N_TYPE:
- return("SPECN");
-
- case INFO_GEN_U_TYPE:
- return("GENU");
-
- case INFO_GEN_N_TYPE:
- return("GENN");
-
- case INFO_DYN_TYPE:
- return("DYN");
-
- /*
- case INFO_DYN_TYPE_N:
- return("DYNN");
-
- case INFO_DYN_TYPE_U:
- return("DYNU");
- */
-
- case INFO_TUPLE_TYPE:
- return("TUPLE");
-
- case INFO_DATA_TYPE:
- return("DATA");
-
- case INFO_MUTUPLE_TYPE:
- return("MUTUPLE");
-
- case INFO_IMMUTUPLE_TYPE:
- return("IMMUTUPLE");
-
- case INFO_STATIC_TYPE:
- return("STATIC");
-
- case INFO_CONST_TYPE:
- return("CONST");
-
- case INFO_CHARLIKE_TYPE:
- return("CHAR");
-
- case INFO_INTLIKE_TYPE:
- return("INT");
-
- case INFO_BH_TYPE:
- return("BHOLE");
-
- case INFO_IND_TYPE:
- return("IND");
-
- case INFO_CAF_TYPE:
- return("CAF");
-
- case INFO_FETCHME_TYPE:
- return("FETCHME");
-
- case INFO_BQ_TYPE:
- return("BQ");
-
- /*
- case INFO_BQENT_TYPE:
- return("BQENT");
- */
-
- case INFO_TSO_TYPE:
- return("TSO");
-
- case INFO_STKO_TYPE:
- return("STKO");
-
- default:
- fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
- return("??");
- }
-#endif /* PAR */
-}
-
-/*
-@var_hdr_size@ computes the size of the variable header for a closure.
-*/
-
-I_
-var_hdr_size(node)
-P_ node;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE: return(0); /* by decree */
- case INFO_SPEC_N_TYPE: return(0);
- case INFO_GEN_U_TYPE: return(GEN_VHS);
- case INFO_GEN_N_TYPE: return(GEN_VHS);
- case INFO_DYN_TYPE: return(DYN_VHS);
- /*
- case INFO_DYN_TYPE_N: return(DYN_VHS);
- case INFO_DYN_TYPE_U: return(DYN_VHS);
- */
- case INFO_TUPLE_TYPE: return(TUPLE_VHS);
- case INFO_DATA_TYPE: return(DATA_VHS);
- case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS);
- case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
- case INFO_STATIC_TYPE: return(STATIC_VHS);
- case INFO_CONST_TYPE: return(0);
- case INFO_CHARLIKE_TYPE: return(0);
- case INFO_INTLIKE_TYPE: return(0);
- case INFO_BH_TYPE: return(0);
- case INFO_IND_TYPE: return(0);
- case INFO_CAF_TYPE: return(0);
- case INFO_FETCHME_TYPE: return(0);
- case INFO_BQ_TYPE: return(0);
- /*
- case INFO_BQENT_TYPE: return(0);
- */
- case INFO_TSO_TYPE: return(TSO_VHS);
- case INFO_STKO_TYPE: return(STKO_VHS);
- default:
- fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
- INFO_TYPE(INFO_PTR(node)));
- return(0);
- }
-}
-
-
-/* Determine the size and number of pointers for this kind of closure */
-void
-size_and_ptrs(node,size,ptrs)
-P_ node;
-W_ *size, *ptrs;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE:
- case INFO_SPEC_N_TYPE:
- *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */
- *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */
- /*
- *size = SPEC_CLOSURE_SIZE(node);
- *ptrs = SPEC_CLOSURE_NoPTRS(node);
- */
- break;
-
- case INFO_GEN_U_TYPE:
- case INFO_GEN_N_TYPE:
- *size = GEN_CLOSURE_SIZE(node);
- *ptrs = GEN_CLOSURE_NoPTRS(node);
- break;
-
- /*
- case INFO_DYN_TYPE_U:
- case INFO_DYN_TYPE_N:
- */
- case INFO_DYN_TYPE:
- *size = DYN_CLOSURE_SIZE(node);
- *ptrs = DYN_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_TUPLE_TYPE:
- *size = TUPLE_CLOSURE_SIZE(node);
- *ptrs = TUPLE_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_DATA_TYPE:
- *size = DATA_CLOSURE_SIZE(node);
- *ptrs = DATA_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_IND_TYPE:
- *size = IND_CLOSURE_SIZE(node);
- *ptrs = IND_CLOSURE_NoPTRS(node);
- break;
-
-/* ToDo: more (WDP) */
-
- /* Don't know about the others */
- default:
- *size = *ptrs = 0;
- break;
- }
-}
-
-void
-DEBUG_PRINT_NODE(node)
-P_ node;
-{
- W_ info_ptr = INFO_PTR(node);
- I_ size = 0, ptrs = 0, i, vhs = 0;
- char *info_type = info_hdr_type(info_ptr);
-
- size_and_ptrs(node,&size,&ptrs);
- vhs = var_hdr_size(node);
-
- fprintf(stderr,"Node: 0x%lx", (W_) node);
-
-#if defined(PAR)
- fprintf(stderr," [GA: 0x%lx]",GA(node));
-#endif
-
-#if defined(PROFILING)
- fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
-#endif
-
-#if defined(GRAN)
- fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
-#endif
-
- fprintf(stderr," IP: 0x%lx (%s), size %ld, %ld ptrs\n",
- info_ptr,info_type,size,ptrs);
-
- /* For now, we ignore the variable header */
-
- for(i=0; i < size; ++i)
- {
- if(i == 0)
- fprintf(stderr,"Data: ");
-
- else if(i % 6 == 0)
- fprintf(stderr,"\n ");
-
- if(i < ptrs)
- fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
- else
- fprintf(stderr," %lu[D]",*(node+_FHS+vhs+i));
- }
- fprintf(stderr, "\n");
-}
-
-
-#define INFO_MASK 0x80000000
-
-void
-DEBUG_TREE(node)
-P_ node;
-{
- W_ size = 0, ptrs = 0, i, vhs = 0;
-
- /* Don't print cycles */
- if((INFO_PTR(node) & INFO_MASK) != 0)
- return;
-
- size_and_ptrs(node,&size,&ptrs);
- vhs = var_hdr_size(node);
-
- DEBUG_PRINT_NODE(node);
- fprintf(stderr, "\n");
-
- /* Mark the node -- may be dangerous */
- INFO_PTR(node) |= INFO_MASK;
-
- for(i = 0; i < ptrs; ++i)
- DEBUG_TREE((P_)node[i+vhs+_FHS]);
-
- /* Unmark the node */
- INFO_PTR(node) &= ~INFO_MASK;
-}
-
-
-void
-DEBUG_INFO_TABLE(node)
-P_ node;
-{
- W_ info_ptr = INFO_PTR(node);
- char *ip_type = info_hdr_type(info_ptr);
-
- fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
- ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
-#if defined(PAR)
- fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
-#endif
-
-#if defined(PROFILING)
- fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr));
-#endif
-
-#if defined(_INFO_COPYING)
- fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
- INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
-#endif
-
-#if defined(_INFO_COMPACTING)
- fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
- (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
- fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t",
- (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
-#if 0 /* avoid INFO_TYPE */
- if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
- fprintf(stderr,"plus specialised code\n");
- else
- fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
-#endif /* 0 */
-#endif /* _INFO_COMPACTING */
-}
-
-\end{code}
-
-The remaining debugging routines are more or less specific for GrAnSim.
-
-\begin{code}
-#if defined(GRAN) && defined(GRAN_CHECK)
-void
-DEBUG_CURR_THREADQ(verbose)
-I_ verbose;
-{
- fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
- DEBUG_THREADQ(ThreadQueueHd, verbose);
-}
-
-void
-DEBUG_THREADQ(closure, verbose)
-P_ closure;
-I_ verbose;
-{
- P_ x;
-
- fprintf(stderr,"Thread Queue: ");
- for (x=closure; x!=PrelBase_Z91Z93_closure; x=TSO_LINK(x))
- if (verbose)
- DEBUG_TSO(x,0);
- else
- fprintf(stderr," 0x%x",x);
-
- if (closure==PrelBase_Z91Z93_closure)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-/* Check with Threads.lh */
-static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
-
-void
-DEBUG_TSO(closure,verbose)
-P_ closure;
-I_ verbose;
-{
-
- if (closure==PrelBase_Z91Z93_closure) {
- fprintf(stderr,"TSO at 0x%x is PrelBase_Z91Z93_closure!\n");
- return;
- }
-
- fprintf(stderr,"TSO at 0x%x has the following contents:\n",closure);
-
- fprintf(stderr,"> Name: 0x%x",TSO_NAME(closure));
- fprintf(stderr,"\tLink: 0x%x\n",TSO_LINK(closure));
- fprintf(stderr,"> Id: 0x%x",TSO_ID(closure));
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GranFlags.debug & 0x10)
- fprintf(stderr,"\tType: %s %s\n",
- type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
- (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
- else
- fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
-#else
- fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
-#endif
- fprintf(stderr,"> PC1: 0x%x",TSO_PC1(closure));
- fprintf(stderr,"\tPC2: 0x%x\n",TSO_PC2(closure));
- fprintf(stderr,"> ARG1: 0x%x",TSO_ARG1(closure));
- /* fprintf(stderr,"\tARG2: 0x%x\n",TSO_ARG2(closure)); */
- fprintf(stderr,"> SWITCH: 0x%x\n", TSO_SWITCH(closure));
-
- if (verbose) {
- fprintf(stderr,"} LOCKED: 0x%x",TSO_LOCKED(closure));
- fprintf(stderr,"\tSPARKNAME: 0x%x\n", TSO_SPARKNAME(closure));
- fprintf(stderr,"} STARTEDAT: 0x%x", TSO_STARTEDAT(closure));
- fprintf(stderr,"\tEXPORTED: 0x%x\n", TSO_EXPORTED(closure));
- fprintf(stderr,"} BASICBLOCKS: 0x%x", TSO_BASICBLOCKS(closure));
- fprintf(stderr,"\tALLOCS: 0x%x\n", TSO_ALLOCS(closure));
- fprintf(stderr,"} EXECTIME: 0x%x", TSO_EXECTIME(closure));
- fprintf(stderr,"\tFETCHTIME: 0x%x\n", TSO_FETCHTIME(closure));
- fprintf(stderr,"} FETCHCOUNT: 0x%x", TSO_FETCHCOUNT(closure));
- fprintf(stderr,"\tBLOCKTIME: 0x%x\n", TSO_BLOCKTIME(closure));
- fprintf(stderr,"} BLOCKCOUNT: 0x%x", TSO_BLOCKCOUNT(closure));
- fprintf(stderr,"\tBLOCKEDAT: 0x%x\n", TSO_BLOCKEDAT(closure));
- fprintf(stderr,"} GLOBALSPARKS: 0x%x", TSO_GLOBALSPARKS(closure));
- fprintf(stderr,"\tLOCALSPARKS: 0x%x\n", TSO_LOCALSPARKS(closure));
- }
-}
-
-void
-DEBUG_EVENT(event, verbose)
-eventq event;
-I_ verbose;
-{
- if (verbose) {
- print_event(event);
- }else{
- fprintf(stderr," 0x%x",event);
- }
-}
-
-void
-DEBUG_EVENTQ(verbose)
-I_ verbose;
-{
- eventq x;
-
- fprintf(stderr,"Eventq (hd @0x%x):\n",EventHd);
- for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
- DEBUG_EVENT(x,verbose);
- }
- if (EventHd==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-DEBUG_SPARK(spark, verbose)
-sparkq spark;
-I_ verbose;
-{
- if (verbose)
- print_spark(spark);
- else
- fprintf(stderr," 0x%x",spark);
-}
-
-void
-DEBUG_SPARKQ(spark,verbose)
-sparkq spark;
-I_ verbose;
-{
- sparkq x;
-
- fprintf(stderr,"Sparkq (hd @0x%x):\n",spark);
- for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
- DEBUG_SPARK(x,verbose);
- }
- if (spark==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-DEBUG_CURR_SPARKQ(verbose)
-I_ verbose;
-{
- DEBUG_SPARKQ(SparkQueueHd,verbose);
-}
-
-void
-DEBUG_PROC(proc,verbose)
-I_ proc;
-I_ verbose;
-{
- fprintf(stderr,"Status of proc %d at time %d (0x%x): %s\n",
- proc,CurrentTime[proc],CurrentTime[proc],
- (CurrentProc==proc)?"ACTIVE":"INACTIVE");
- DEBUG_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
- if ( (CurrentProc==proc) )
- DEBUG_TSO(CurrentTSO,1);
-
- if (EventHd!=NULL)
- fprintf(stderr,"Next event (%s) is on proc %d\n",
- event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
-
- if (verbose & 0x1) {
- fprintf(stderr,"\nREQUIRED sparks: ");
- DEBUG_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
- fprintf(stderr,"\nADVISORY_sparks: ");
- DEBUG_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
- }
-}
-
-/* Debug CurrentTSO */
-void
-DCT(){
- fprintf(stderr,"Current Proc: %d\n",CurrentProc);
- DEBUG_TSO(CurrentTSO,1);
-}
-
-/* Debug Current Processor */
-void
-DCP(){ DEBUG_PROC(CurrentProc,2); }
-
-/* Shorthand for debugging event queue */
-void
-DEQ() { DEBUG_EVENTQ(1); }
-
-/* Shorthand for debugging spark queue */
-void
-DSQ() { DEBUG_CURR_SPARKQ(1); }
-
-/* Shorthand for printing a node */
-void
-DN(P_ node) { DEBUG_PRINT_NODE(node); }
-
-#endif /* GRAN */
-
-#endif /* 0 */
-\end{code}
-
+++ /dev/null
-\section[StgMiniInt]{The ``mini-interpreter'' that drives the STG machine}
-
-% this file is part of the C-as-assembler document
-
-\begin{code}
-#include "rtsdefs.h"
-\end{code}
-
-For portable~C, there really is a mini-interpreter that repeatedly
-grabs the continuation from each code fragment and jumps to it.
-
-In portable~C, we also have a ``debugging'' version of the
-mini-interpreter which does ``hygiene-checking'' of the stacks/heap(?)
-each time it regains control. This is deeply wonderful when the
-compiler's generating duff code and things are badly broken!
-
-For optimised~C, the mini-interpreter really {\em doesn't} do anything
-remotely interpretive. It just jumps off into a Haskell Threaded
-World, dropping a label for \tr{_miniInterpretEnd} so we'll have a
-place to eventually come back to.
-
-A complication in optimised~C: Because we completely nuke C-stack
-activity (pushing/popping frames, moving register-windows) within the
-Haskell-threaded world, we need to ensure there is enough C-stack
-space actually present to satisfy the code that GCC generated.
-
-IMPORTANT POINT: the mini-interpreter is supposed to be {\em generic}.
-It is not only for the Haskell Threaded World---the storage manager
-may use it as well. So: whatever threaded world is in operation has
-to handle its own register saving/restoring, and such grimy details.
-For an example, see the @startStgWorld@, @stopStgWorld@ pair of
-routines.
-
-%************************************************************************
-%* *
-\subsection[StgMiniInt-optimised]{Mini-interpreter for ``optimised~C''}
-%* *
-%************************************************************************
-
-Unusually, for mini-interpreters, the ``optimised~C'' case involves
-less code.
-
-\begin{code}
-#if defined(__STG_TAILJUMPS__) && defined(__GNUC__)
-
-void
-miniInterpret(start_cont)
- StgFunPtr start_cont;
-{
- /*
- * MINI_INTERPRETER_SETUP _must_ save _all_ callee-saves registers, because
- * the caller expects them to be saved if they are used, but the threaded
- * code never saaves anything (all function prologues have been removed).
- */
-
- MINI_INTERPRETER_SETUP
-
- /*
- * starts Haskell world by _calling_ "start_cont"
- *
- * Make this a JMP_ and dead code elimination will make you unhappy.
- *
- * You will be even more unhappy with a registerized HP build, because
- * the continuation passed in here is actually the address of a function
- * ADT, and not the address where the function really begins.
- */
- (start_cont)();
-
- /*
- * and drops a label for "miniInterpretEnd" right here, along
- * with any cleanup that has to be done before we return.
- *
- * _Always_ RESUME_(miniInterpretEnd). Never JMP_(miniInterpretEnd).
- */
-
- MINI_INTERPRETER_END
-
- return;
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[StgMiniInt-portable]{Mini-interpreter for ``portable~C''}
-%* *
-%************************************************************************
-
-\begin{code}
-#else /* ! (__STG_TAILJUMPS__ && __GNUC__) */
-
-#include <setjmp.h>
-/* by which we mean the Standard C Library stuff */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMiniInt-portable-normal]{Normal mini-interpreter for ``portable~C''}
-%* *
-%************************************************************************
-
-The static @jmp_environment@ variable allows @miniInterpret@ to
-communicate with @miniInterpretEnd@.
-
-Because @miniInterpret@ may be used recursively, we carefully
-save and restore the whole of @jmp_environment@.
-
-\begin{code}
-static jmp_buf jmp_environment;
-
-void bcopy PROTO((char *, char *, int)); /*ToDo: properly?*/
-
-void
-miniInterpret(start_cont)
- StgFunPtr start_cont;
-{
- StgFunPtr continuation = (StgFunPtr) start_cont;
- jmp_buf save_buf;
- bcopy((char *) jmp_environment, (char *) save_buf, sizeof(jmp_buf));
- /* Save jmp_environment for previous call to miniInterpret */
-
- if (setjmp(jmp_environment) == 0) {
-
- while ( 1 ) {
- /* unrolled for a little speed */
- continuation = (StgFunPtr) (continuation)();
- continuation = (StgFunPtr) (continuation)();
- continuation = (StgFunPtr) (continuation)();
- continuation = (StgFunPtr) (continuation)();
- continuation = (StgFunPtr) (continuation)();
- }
- }
-
-
- /* Restore jmp_environment for previous call */
- bcopy((char *) save_buf, (char *) jmp_environment, sizeof(jmp_buf));
-
- /* ToDo: restore real registers ... (see longjmp) */
- return;
- /*
- Note that on returning (after miniInterpretEnd is called)
- the values variables declared as real machine registers
- will be undefined.
- */
-}
-
-void miniInterpretEnd(STG_NO_ARGS)
-{
- /* ToDo: save real register in something somewhere */
- longjmp(jmp_environment, 1);
-}
-
-#endif /* ! __STG_TAILJUMPS__ */
-\end{code}
+++ /dev/null
- GNU GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1989, 1991 Free Software Foundation, Inc.
- 675 Mass Ave, Cambridge, MA 02139, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users. This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it. (Some other Free Software Foundation software is covered by
-the GNU Library General Public License instead.) You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have. You must make sure that they, too, receive or can get the
-source code. And you must show them these terms so they know their
-rights.
-
- We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
- Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software. If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary. To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-\f
- GNU GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License. The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language. (Hereinafter, translation is included without limitation in
-the term "modification".) Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
- 1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
- 2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) You must cause the modified files to carry prominent notices
- stating that you changed the files and the date of any change.
-
- b) You must cause any work that you distribute or publish, that in
- whole or in part contains or is derived from the Program or any
- part thereof, to be licensed as a whole at no charge to all third
- parties under the terms of this License.
-
- c) If the modified program normally reads commands interactively
- when run, you must cause it, when started running for such
- interactive use in the most ordinary way, to print or display an
- announcement including an appropriate copyright notice and a
- notice that there is no warranty (or else, saying that you provide
- a warranty) and that users may redistribute the program under
- these conditions, and telling the user how to view a copy of this
- License. (Exception: if the Program itself is interactive but
- does not normally print such an announcement, your work based on
- the Program is not required to print an announcement.)
-\f
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
- a) Accompany it with the complete corresponding machine-readable
- source code, which must be distributed under the terms of Sections
- 1 and 2 above on a medium customarily used for software interchange; or,
-
- b) Accompany it with a written offer, valid for at least three
- years, to give any third party, for a charge no more than your
- cost of physically performing source distribution, a complete
- machine-readable copy of the corresponding source code, to be
- distributed under the terms of Sections 1 and 2 above on a medium
- customarily used for software interchange; or,
-
- c) Accompany it with the information you received as to the offer
- to distribute corresponding source code. (This alternative is
- allowed only for noncommercial distribution and only if you
- received the program in object code or executable form with such
- an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it. For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable. However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-\f
- 4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License. Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
- 5. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Program or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
- 6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all. For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-\f
- 8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded. In such case, this License incorporates
-the limitation as if written in the body of this License.
-
- 9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation. If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
- 10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission. For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this. Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
- NO WARRANTY
-
- 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
- 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
- END OF TERMS AND CONDITIONS
-\f
- Appendix: How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) 19yy <name of author>
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- 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.
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
- Gnomovision version 69, Copyright (C) 19yy name of author
- Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the program
- `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
- <signature of Ty Coon>, 1 April 1989
- Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs. If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library. If this is what you want to do, use the GNU Library General
-Public License instead of this License.
+++ /dev/null
-Wed May 19 12:14:19 1993 Torbjorn Granlund (tege@nada.kth.se)
-
- * Many files: Call alloca(0) before function return.
- * alloca.c: New file.
- * Makefile (IMPL_SRCS): Add alloca.c.
- (IMPL_OBJS): Add alloca.o.
-
-Fri May 14 00:52:01 1993 Torbjorn Granlund (tege@nada.kth.se)
-
- * mpz_iset_str.c: Fix header comment.
-
- * gmp.h: Don't test just FILE, tests some variants of _STDIO_H for
- machines were FILE is a typedef.
-
-Tue May 11 21:20:07 1993 Torbjorn Granlund (tege@nada.kth.se)
-
- * Makefile (realclean): Make it just be like clean.
- (In particular, don't delete Makefile...)
-
-Thu May 6 14:31:02 1993 Torbjorn Granlund (tege@nada.kth.se)
-
- * mpn_mul.c (vsize < KARATSUBA_THRESHOLD): Eliminate unused
- variable `c'.
-
- * longlong.h (#if mc88110): Use local union to avoid explicit mov
- insns.
- * longlong.h (All union defs): Prepend __ before tags to avoid
- conflicts. Cleanup union definitions to look the same.
-
- * mpz_inp_str.c: Pass BASE to char_ok_for_base.
-
-Wed May 5 01:25:23 1993 Torbjorn Granlund (tege@nada.kth.se)
-
- * tests/tst-convert.c: Try base == 0.
-
- * mpz_inp_str.c: Fix typo in assignment.
-
- * longlong.h: Adjust UMUL_TIME and UDIV_TIME for several archs.
- (#if hppa): Remove udiv_qrnnd.
- (#if vax): Define sdiv_qrnnd. Use "g" constraint for umul_ppmm's
- operand 0.
-
-Tue May 4 17:11:55 1993 Torbjorn Granlund (tege@du.nada.kth.se)
-
- * longlong.h (#if ns32000): Fix typo, udiv_qrnnd was div_qrnnd.
-
-Mon May 3 00:20:52 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se)
-
- * Makefile: Add rule for mp_bases.o.
-
- * _mpz_set_str.c: Make inp_digit an mp_limb. Remove casts of
- inp_digit to unsigned.
-
- * mpn_dm_1.c: Use BITS_PER_MP_LIMB instead of 32.
- * mpn_mod_1.c: Likewise.
- * mpn_dm_1.c (udiv_qrnnd_preinv): Delete testing of overflow that
- Peter Montgomery proved can't happen.
-
- * tests/*.c: Include gmp-impl.h to make `inline' and `const' be
- #define'd.
-
- * Makefile: Update automatically generated dependencies.
-
- * mpz_pow_ui: Don't include mp.h.
- Use MP_INT instead of MINT even for rpow.
-
-Sun May 2 16:35:53 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se)
-
- * tests/tst-convert.c, tests/tst-dm_ui.c, tests/tst-mdm.c,
- tests/tst-mdm_ui.c: New files.
- * tests/tst-dm.c: New name for tests/tst-divmod.c.
- * tests/*.c: Include urandom.h. Use urandom(), never random().
- Restructure test code to be more consistent, define and use
- dump_abort(), only dump input operands, generate negative operands
- when allowed by the tested function, etc.
- * tests/urandom.h: New file.
- * tests/Makefile: Add new tests. Update dependencies.
- (CFLAGS): Pass `-I.'.
- (tests) Don't print "The tests passed" since we don't correctly
- detect failures.
-
- * mpz_fac_ui: Fix some comments.
-
- * mpz_random.c, mpz_random2.c: Declare random();
- Define random to call mrand48 for __alpha__.
-
- * All files: Use #ifdef instead if #if for testing __STDC__.
-
- * longlong.h (#if sparc_v8): Define UMUL_TIME and UDIV_TIME.
-
- * mpz_inp_str.c: If BASE is 0, try to determine the base from the
- leading characters. Restructure code.
-
- * mpz_pprime_p.c: Include gmp-impl.h.
-
-Fri Apr 30 09:35:03 1993 Torbjorn Granlund (tege@du.nada.kth.se)
-
- * tests/Makefile: Set CC and OPT as in main Makefile.
- Add copyright notice.
-
- * gmp.h: Remove declaration of mpz_not.
-
-Thu Apr 29 19:51:34 1993 Torbjorn Granlund (tege@du.nada.kth.se)
-
- * mpq_cmp.c: Fix header comment.
-
- From Anders Thulin:
- * mpz_inp_str.c: Get condition for char_ok_for_base right.
-
-Tue Apr 27 12:30:48 1993 Torbjorn Granlund (tege@du.nada.kth.se)
-
- * Makefile (check): Pass OPT to recursive make.
- * tests/Makefile (OPT): Set to default value.
- (CFLAGS): Don't include -g.
- (tst-mul): Pass $(CFLAGS) to $(CC).
- (tst-divmod): Likewise.
- (tst-gcd): Likewise.
- (tst-sqrtrem): Likewise.
-
- * mpz_gcd.c: Fix typo in comments.
-
- * mpz_sqrtrem.c: Really divide by zero for negative operands.
-
- * mpz_mul_ui.c: Fix header comment.
-
- * mpz_get_si.c: Fix type typo in cast.
-
-Sun Apr 25 18:40:26 1993 Torbjorn Granlund (tege@pde.nada.kth.se)
-
- * memory.c: Use #if instead of #ifdef for __STDC__ for consistency.
- * bsd/xtom.c: Likewise.
-
- * cre-conv-tab.c: #include gmp.h and gmp-impl.h to get bit size
- right for longlong.h.
- * Makefile: Add new deps for `cre-conv-tab'.
-
- * Makefile, tests/Makefile: Don't define or use srcdir.
-
- * longlong.h (#if alpha): Define umul_ppmm.
- Define UMUL_TIME and UDIV_TIME.
- (#if i960): Define umul_ppmm and __umulsidi3.
- (#if hppa): Define count_leading_zeros.
- (#if IBMR2): Remove umul_ppmm. Define smul_ppmm.
- (#if 68020): Define smul_ppmm.
- (#if mc88110): Define umul_ppmm and udiv_qrnnd.
- (#if ns32000): Define umul_ppmm.
- (#if pyr): Rewrite umul_ppmm.
-
- * mpz_powm: `carry_digit' => `carry_limb'.
- * sdiv.c: Clearify comment.
-
-Sat Apr 24 16:23:33 1993 Torbjorn Granlund (tege@pde.nada.kth.se)
-
- * tests: Update header comments. Make default sizes 8, use SIZE
- symbol to allow user override. Increase default repetitions.
-
- * longlong.h (__udiv_qrnnd_c): Define this always.
- Make all variables `unsigned long int'.
- (__LLDEBUG__): Remove this conditional.
-
- * gmp-impl.h: #define ABS.
- * (Many files): Use ABS instead of abs.
-
- * _mpz_get_str, mpn_sqrt, mpz_clrbit, mpz_get_si, mpz_mod_2exp,
- mpz_pow_ui, mpz_random2: Cast 1 to mp_limb before shifting.
-
- * gmp.h: mpn_add returns mp_limb.
-
- * mpz_perfsqr: Use #if, not plain if for exclusion of code for
- non-32-bit machines.
-
-Tue Apr 20 13:13:58 1993 Torbjorn Granlund (tege@du.nada.kth.se)
-
- * mpn_sqrt: Handle overflow for intermediate quotients by rounding
- them down to fit.
-
- * mpz_random2: Back to random(); rand() is so bad we get into cycles.
-
- * mpz_perfsqr.c (PP): Define in hexadecimal to avoid GCC warnings.
-
- * mpz_inp_str.c (char_ok_for_base): New function.
- (mpz_inp_str): Use it.
-
- * gmp.h: Add `const' to decl of mpz_probab_pripe_p.
-
- * _mpz_set_str.c (char_type): Remove final `,'.
- (ascii_to_num): Likewise.
-
-Sun Mar 28 21:54:06 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se)
-
- * mpz_inp_raw: Allocate x_index, not xsize limbs.
-
-Mon Mar 15 11:44:06 1993 Torbjorn Granlund (tege@pde.nada.kth.se)
-
- * mpz_pprime_p.c: Declare param `const'.
- * gmp.h: Add declarations for mpz_com.
-
-Thu Feb 18 14:10:34 1993 Torbjorn Granlund (tege@pde.nada.kth.se)
-
- * mpq_add, mpq_sub: Call mpz_clear for t.
-
-Fri Feb 12 20:27:34 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se)
-
- * mpz_inp_str: Recog minus sign as first character.
-
-Wed Feb 3 01:36:02 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se)
-
- * mpz_random.c (urandom): New conditionally defined local function.
- Use it instead of random().
- * mpz_random2: Use rand() instead of random() here, since we don't
- care how many bits we get.
-
- * mpz_iset: Handle 0 size.
-
-Tue Feb 2 13:03:33 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se)
-
- * _mpz_get_str: Adjust for negative msize when returning str.
-
- * mpz_mod_ui: Initialize dividend_size before it's used.
-
-Mon Jan 4 09:11:15 1993 Torbjorn Granlund (tege@sics.se)
-
- * itom: Declare param explicitly 'signed'.
- * sdiv: Likewise.
-
- * mpq_cmp: Remove unused variable tmp_size.
- * mpz_powm_ui: Fix typo in esize==0 if stmt.
- * mpz_powm: Likewise.
-
-Sun Nov 29 01:16:11 1992 Torbjorn Granlund (tege@sics.se)
-
- * mpn_dm_1.c (mpn_divmod_1): Handle
- divisor_limb == 1 << (BITS_PER_MP_LIMB - 1)
- specifically.
-
-Sat Nov 28 17:19:40 1992 Torbjorn Granlund (tege@sics.se)
-
- * mpz_div: Remove free_me and free_me_size and their usage.
-
-Wed Oct 28 17:40:04 1992 Torbjorn Granlund (tege@jupiter.sics.se)
-
- * longlong.h (__hppa umul_ppmm): Fix typos.
- (__hppa sub_ddmmss): Swap input arguments.
-
- * mpz_perfsqr.c (mpz_perfect_square_p): Avoid , before } in
- initializator.
-
-Sun Oct 25 20:30:06 1992 Torbjorn Granlund (tege@jupiter.sics.se)
-
- * mpz_pprime_p.c (mpz_probab_prime_p): Handle numbers <= 3
- specifically (used to consider all negative numbers prime).
-
- * mpz_powm_ui: `carry_digit' => `carry_limb'.
-
- * sdiv: Handle zero dividend specifically. Replace most code in
- this function with a call to mpn_divmod_1.
-
- * mpn_add: Return type is mp_limb.
-
- * _mpz_get_str: Assign and use MSIZE smarter, to avoid using
- m->size.
- * _mpz_get_str: Allocate extra STR space if (MSIZE < 0) for minus
- sign.
- * _mpz_get_str: Move string backwards smarter, avoid copying when
- not needed.
-
- * gmp.h (mpn_lshift, mpn_rshift, mpn_rshiftci): Remove `long' from
- 4:th arg.
- * Makefile.in (MP_OBJS) : Include mpz_sizeinb.o.
-
-Fri Sep 11 22:15:55 1992 Torbjorn Granlund (tege@tarrega.sics.se)
-
- * mpq_clear: Don't free the MP_RAT!
-
- * mpn_lshift, mpn_rshift, mpn_rshiftci: Remove `long' from 4:th arg.
-
-Thu Sep 3 01:47:07 1992 Torbjorn Granlund (tege@jupiter.sics.se)
-
- * mpn_mul: Rewrite code jumping between `carry case' and `noncarry
- case' to avoid jumping. Special case for V_LIMB being 0 ot 1.
- * All files: Remove leading _ from mpn function names.
-
-Wed Sep 2 22:21:16 1992 Torbjorn Granlund (tege@jupiter.sics.se)
-
- Fix from Jan-Hein Buhrman:
- * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c: Make them work as documented.
-
- * mpz_mmod.c, mpz_mdm.c: Move decl of TEMP_DIVISOR to reflect its
- life.
-
-Sun Aug 30 18:37:15 1992 Torbjorn Granlund (tege@jupiter.sics.se)
-
- * _mpz_get_str: Use mpz_sizeinbase for computing out_len.
- * _mpz_get_str: Don't remove leading zeros. Abort if there are some.
-
-Tue Feb 18 14:38:39 1992 Torbjorn Granlund (tege@zevs.sics.se)
-
- longlong.h (hppa umul_ppmm): Add missing semicolon. Declare type
- of __w1 and __w0.
-
-Fri Feb 14 21:33:21 1992 Torbjorn Granlund (tege@zevs.sics.se)
-
- * longlong.h: Make default count_leading_zeros work for machines >
- 32 bits. Prepend `__' before local variables to avoid conflicts
- with users' variables.
-
-Thu Feb 6 15:10:42 1992 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpn_dm_1.c (_mpn_divmod_1): Add code for avoiding division by
- pre-inverting divisor.
-
-Sun Feb 2 11:10:25 1992 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h: Make __LLDEBUG__ work differently.
- (_IBMR2): Reinsert old code.
-
-Sat Feb 1 16:43:00 1992 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h (#ifdef _IBMR2): Replace udiv_qrnnd with new code
- using floating point operations. Don't define
- UDIV_NEEDS_NORMALIZATION any longer.
-
-Fri Jan 31 15:09:13 1992 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h: Define UMUL_TIME and UDIV_TIME for most machines.
- * longlong.h (#ifdef __hppa): Define umul_ppmm.
-
-Wed Jan 29 16:41:36 1992 Torbjorn Granlund (tege@sics.se)
-
- * mpn_cmp: Only one length parameter, assume operand lengths are
- the same. Don't require normalization.
- * mpq_cmp, mpz_add, mpz_sub, mpz_gcd, mpn_mul, mpn_sqrt: Change for
- new mpn_cmp definition.
-
-Tue Jan 28 11:18:55 1992 Torbjorn Granlund (tege@sics.se)
-
- * _mpz_get_str: Fix typo in comment.
-
-Mon Jan 27 09:44:16 1992 Torbjorn Granlund (tege@sics.se)
-
- * Makefile.in: Add new files.
-
- * mpn_dm_1.c: New file with function _mpn_divmod_1.
- * mpz_dm_ui.c (mpz_divmod_ui): Use _mpn_divmod_1.
- * mpz_div_ui: Likewise.
-
- * mpn_mod_1.c: New file with function _mpn_mod_1.
- * mpz_mod_ui: Use _mpn_mod_1.
-
-Thu Jan 23 18:54:09 1992 Torbjorn Granlund (tege@sics.se)
-
- Bug found by Paul Zimmermann (zimmermann@inria.inria.fr):
- * mpz_div_ui.c (mpz_div_ui), mpz_dm_ui.c (mpz_divmod_ui):
- Handle dividend == 0.
-
-Wed Jan 22 12:02:26 1992 Torbjorn Granlund (tege@sics.se)
-
- * mpz_pprime_p.c: Use "" for #include.
-
-Sun Jan 19 13:36:55 1992 Torbjorn Granlund (tege@sics.se)
-
- * mpn_rshiftci.c (header): Correct comment.
-
-Wed Jan 15 18:56:04 1992 Torbjorn Granlund (tege@sics.se)
-
- * mpz_powm, mpz_powm_ui (if (bsize > msize)): Do alloca (bsize + 1)
- to make space for ignored quotient at the end. (The quotient might
- always be an extra limb.)
-
-Tue Jan 14 21:28:48 1992 Torbjorn Granlund (tege@sics.se)
-
- * mpz_powm_ui: Fix comment.
- * mpz_powm: Likewise.
-
-Mon Jan 13 18:16:25 1992 Torbjorn Granlund (tege@sics.se)
-
- * tests/Makefile.in: Prepend $(TEST_PREFIX) to Makefile target.
-
-Sun Jan 12 13:54:28 1992 Torbjorn Granlund (tege@sics.se)
-
- Fixes from Kazumaro Aoki:
- * mpz_out_raw: Take abs of size to handle negative values.
- * mpz_inp_raw: Reallocate before reading ptr from X.
- * mpz_inp_raw: Store, don't read, size to x->size.
-
-Tue Jan 7 17:50:25 1992 Torbjorn Granlund (tege@sics.se)
-
- * gmp.h, mp.h: Remove parameter names from prototypes.
-
-Sun Dec 15 00:09:36 1991 Torbjorn Granlund (tege@sics.se)
-
- * tests/Makefile.in: Prepend "./" to file names when executing
- tests.
-
- * Makefile.in: Fix many problems.
-
-Sat Dec 14 01:00:02 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpn_sqrt.c: New file with _mpn_sqrt.
- * mpz_sqrt, mpz_sqrtrem, mpz_perfect_square_p: Use _mpn_sqrt.
- * msqrt.c: Delete. Create from mpz_sqrtrem.c in Makefile.in.
- * mpz_do_sqrt.c: Delete.
- * Makefile.in: Update to reflect these changes.
-
- * Makefile.in, configure, configure.subr: New files
- (from bothner@cygnus.com).
- * dist-Makefile: Delete.
-
- * mpz_fac_ui: Fix comment.
-
- * mpz_random2: Rewrite to make it possible for the most significant
- limb to be == 1.
-
- * mpz_pprime_p.c (mpz_probab_prime_p): Remove \t\n.
-
-Fri Dec 13 23:10:02 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_do_sqrt: Simplify special case for U == 0.
- * m*sqrt*.c, mpz_perfsqr.c (mpz_perfect_square_p):
- Rename _mpz_impl_sqrt to _mpz_do_sqrt.
-
-Fri Dec 13 12:52:28 1991 Torbjorn Granlund (tege@sics.se)
-
- * gmp-impl.h (MPZ_TMP_INIT): Cast to the right type.
-
-Thu Dec 12 22:17:29 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpn_add, mpn_sub, mpn_mul, mpn_div: Change type of several
- variables to mp_size.
-
-Wed Dec 11 22:00:34 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpn_rshift.c: Fix header comments.
-
-Mon Dec 9 17:46:10 1991 Torbjorn Granlund (tege@sics.se)
-
- Released 1.2.
-
- * gmp-impl.h (MPZ_TMP_INIT): Cast alloca return value.
-
- * dist-Makefile: Add missing dependency for cre-mparam.
-
- * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c, mpz_mdiv_ui.c,
- mpz_mmod_ui.c, mpz_mdm_ui.c: Remove obsolete comment.
-
- * dist-Makefile (clean): clean in tests subdir too.
- * tests/Makefile: Define default values for ROOT and SUB.
-
- * longlong.h (__a29k__ udiv_qrnnd): Change "q" to "1" for operand
- 2 constraint.
-
-Mon Nov 11 00:06:05 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_sizeinb.c (mpz_sizeinbase): Special code for size == 0.
-
-Sat Nov 9 23:47:38 1991 Torbjorn Granlund (tege@sics.se)
-
- Released 1.1.94.
-
- * dist-Makefile, Makefile, tests/Makefile: Merge tests into
- distribution.
-
-Fri Nov 8 22:57:19 1991 Torbjorn Granlund (tege@sics.se)
-
- * gmp.h: Don't use keyword `signed' for non-ANSI compilers.
-
-Thu Nov 7 22:06:46 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h: Cosmetic changes to keep it identical to gcc2 version
- of longlong.h.
- * longlong.h (__ibm032__): Fix operand order for add_ssaaaa and
- sub_ddmmss.
-
-Mon Nov 4 00:36:46 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpn_mul: Fix indentation.
-
- * mpz_do_sqrt: Don't assume 32 bit limbs (had constant
- 4294967296.0).
- * mpz_do_sqrt: Handle overflow in conversion from double returned
- by SQRT to mp_limb.
-
- * gmp.h: Add missing function definitions.
-
-Sun Nov 3 18:25:25 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_pow_ui: Change type of `i' to int.
-
- * ChangeLog: Add change log entry.
- * ChangeLog: Add change log entry.
- * ChangeLog: Add change log entry.
- * ChangeLog: Add change log entry.
- * ChangeLog: Add change log entry.
- * ChangeLog: Add change log entry.
- * ChangeLog: Add change log entry.
- * ChangeLog: Add change log entry.
-Stack overflow.
-
- * mpz_pow_ui.c: Fix typo in comment.
-
- * dist-Makefile: Create rpow.c from mpz_powm_ui.c.
- * mpz_powm_ui.c: Add code for rpow.
- * rpow.c: Delete this file. The rpow function is now implemented
- in mpz_powm_ui.c.
-
- * mpz_fac_ui.c: New file.
- * gmp.h, dist-Makefile: Add stuff for mpz_fac_ui.
-
- Bug found by John Amanatides (amana@sasquatch.cs.yorku.ca):
- * mpz_powm_ui, mpz_powm: Call _mpn_mul in the right way, with
- the first argument not smaller than the second.
-
-Tue Oct 29 13:56:55 1991 Torbjorn Granlund (tege@sics.se)
-
- * cre-conv-tab.c (main), cre-mparam.c (main): Fix typo in output
- header text.
-
-Mon Oct 28 00:35:29 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_random2: Handle size == 0.
-
- * gmp-impl.h (struct __mp_bases): Rename chars_per_limb_exactly to
- chars_per_bit_exactly, and change its definition.
- * cre-conv-tab.c (main): Output field according to its new
- definition.
- * mpz_out_str, _mpz_get_str, mpz_sizeinb, mout:
- Use chars_per_bit_exactly.
-
- * mpz_random2: Change the loop termination condition in order to
- get a large most significant limb with higher probability.
-
- * gmp.h: Add declaration of new mpz_random2 and mpz_get_si.
- * mpz_get_si.c: New file.
- * dist-Makefile: Add mpz_random2 and mpz_get_si.
-
- * mpz_sizeinb.c (mpz_sizeinbase): Special code for base being a
- power of 2, giving exact result.
-
- * mpn_mul: Fix MPN_MUL_VERIFY in various ways.
- * mpn_mul: New macro KARATSUBA_THRESHOLD.
- * mpn_mul (karatsuba's algorithm): Don't write intermediate results
- to prodp, use temporary pp instead. (Intermediate results can be
- larger than the final result, possibly writing into hyperspace.)
- * mpn_mul: Make smarter choice between Karatsuba's algorithm and the
- shortcut algorithm.
- * mpn_mul: Fix typo, cy instead of xcy. Unify carry handling code.
-
-Sun Oct 27 19:57:32 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpn_mul: In non-classical case, choose Karatsuba's algorithm only
- when usize > 1.5 vsize.
-
- * mpn_mul: Break between classical and Karatsuba's algorithm at
- KARATSUBA_THRESHOLD, if defined. Default to 8.
-
- * mpn_div: Kludge to fix stray memory read.
-
-Sat Oct 26 20:06:14 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_gcdext: Handle a = b = 0. Remove memory leakage by calling
- mpz_clear for all temporary variables.
-
- * mpz_gcd: Reduce w_bcnt in _mpn_lshift call to hold that
- function's argument constraints. Compute wsize correctly.
-
- * mpz_gcd: Fix typo in comment.
-
- * memory.c (_mp_default_allocate, _mp_default_reallocate): Call
- abort if allocation fails, don't just exit.
-
-Fri Oct 25 22:17:20 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_random2.c: New file.
-
-Thu Oct 17 18:06:42 1991 Torbjorn Granlund (tege@sics.se)
-
- Bugs found by Pierre-Joseph Gailly (pjg@sunbim.be):
- * mpq_cmp: Take sign into account, don't just compare the
- magnitudes.
- * mpq_cmp: Call _mpn_mul in the right way, with the first argument
- not smaller than the second.
-
-Wed Oct 16 19:27:32 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_random: Ensure the result is normalized.
-
-Tue Oct 15 14:55:13 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_clrbit: Support non-ANSI compilers.
-
-Wed Oct 9 18:03:28 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h (68k add_ssaaaa, sub_ddmmss): Generalize constraints.
-
-Tue Oct 8 17:42:59 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_mdm_ui: Add comments.
-
- * mpz_mdiv: Use MPZ_TMP_INIT instead of mpz_init.
- * mpz_init_ui: Change spacing and header comment.
-
-Thu Oct 3 18:36:13 1991 Torbjorn Granlund (tege@sics.se)
-
- * dist-Makefile: Prepend `./' before some filenames.
-
-Sun Sep 29 14:02:11 1991 Torbjorn Granlund (tege@sics.se)
-
- Released 1.1 (public).
-
- * mpz_com: New name of mpz_not.
- * dist-Makefile: Change mpz_not to mpz_com.
-
-Tue Sep 24 12:44:11 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h: Fix header comment.
-
-Mon Sep 9 15:16:24 1991 Torbjorn Granlund (tege@sics.se)
-
- Released 1.0.92.
-
- * mpn_mul.c (_mpn_mul): Handle leading zero limbs in non-Karatsuba
- case.
-
- * longlong.h (m68000 umul_ppmm): Clobber one register less by
- slightly rearranging the code.
-
-Sun Sep 1 18:53:25 1991 Torbjorn Granlund (tege@sics.se)
-
- * dist-Makefile (stamp-stddefh): Fix typo.
-
-Sat Aug 31 20:41:31 1991 Torbjorn Granlund (tege@sics.se)
-
- Released 1.0.91.
-
- * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c, mpz_mdiv_ui.c,
- mpz_mmod_ui.c, mpz_mdm_ui.c: New files and functions.
- * gmp.h, gmp.texi: Define the new functions.
-
-Fri Aug 30 08:32:56 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_gcdext: Compute t argument from the other quantities at the
- end, of the function, not in the loop. New feature: Allow t to be
- NULL.
-
- * mpz_add.c, mpz_sub.c, mpz_mul.c, mpz_powm.c, mpz_gcd.c: Don't
- include "mp.h". Use type name `MP_INT' always.
-
- * dist-Makefile, mpz_cmp.c: Merge mcmp.c from mpz_cmp.c.
-
-Wed Aug 28 00:45:11 1991 Torbjorn Granlund (tege@sics.se)
-
- * dist-Makefile (documentation): Go via tmp.texi to avoid the
- creation of gmp.dvi if any errors occur. Make tex read input
- from /dev/null.
-
-Fri Aug 23 15:58:52 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h (68020, i386): Don't define machine-dependent
- __umulsidi3 (so the default definition is used).
- * longlong.h (all machines): Cast all operands, sources and
- destinations, to `unsigned long int'.
- * longlong.h: Add gmicro support.
-
-Thu Aug 22 00:28:29 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h: Rename BITS_PER_LONG to LONG_TYPE_SIZE.
- * longlong.h (__ibm032__): Define count_leading_zeros and umul_ppmm.
- * longlong.h: Define UMUL_TIME and UDIV_TIME for some CPUs.
- * _mpz_get_str.c: Add code to do division by big_base using only
- umul_qrnnd, if that is faster. Use UMUL_TIME and UDIV_TIME to
- decide which variant to use.
-
-Wed Aug 21 15:45:23 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h (__sparc__ umul_ppmm): Move two insn from end to the
- nops. (Saves two insn.)
-
- * longlong.h (__sparc__ umul_ppmm): Rewrite in order to avoid
- branch, and to permit input/output register overlap.
-
- * longlong.h (__29k__): Remove duplicated udiv_qrnnd definition.
- * longlong.h (__29k__ umul_ppmm): Split asm instructions into two
- asm statements (gives better code if either the upper or lower
- part of the product is unused.
-
-Tue Aug 20 17:57:59 1991 Torbjorn Granlund (tege@sics.se)
-
- * _mpz_get_str.c (outside of functions): Remove
- num_to_ascii_lower_case and num_to_ascii_upper_case. Use string
- constants in the function instead.
-
-Mon Aug 19 00:37:42 1991 Torbjorn Granlund (tege@sics.se)
-
- * cre-conv-tab.c (main): Output table in hex. Output 4 fields, not
- 3, for components 0 and 1.
-
- * gmp.h: Add declaration of mpq_neg.
-
- Released 1.0beta.13.
-
- * _mpz_set_str.c (mpz_set_str): Cast EOF and SPC to char before
- comparing to enum literals SPC and EOF. This makes the code work
- for compilers where `char' is unsigned. (Bug found by Brian
- Beuning).
-
- Released 1.0beta.12.
-
- * mpz_mod_ui: Remove references to quot. Remove quot_ptr, quot_size
- declarations and assignment code.
-
-Sun Aug 18 14:44:26 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_mod_ui: Handle dividend < 0.
-
- Released 1.0beta.11.
-
- * mpz_dm_ui, mpz_div_ui, mpz_mod_ui, sdiv: Make them share the same
- general structure, variable names, etc.
-
- * sdiv: Un-normalize the remainder in n1 before it is negated.
-
- * longlong.h: Mention UDIV_NEEDS_NORMALIZATION in description of
- udiv_qrnnd.
-
- * mpz_dm_ui.c (mpz_divmod_ui), mpz_div_ui.c (mpz_div_ui): Increment
- the quotient size if the dividend size is incremented. (Bug found
- by Brian Beuning.)
-
- * mpz_mod_ui: Shift back the remainder, if UDIV_NEEDS_NORMALIZATION.
- (Bug found by Brian Beuning.)
-
- * mpz_mod_ui: Replace "digit" by "limb".
-
- * mpz_perfsqr.c (mpz_perfect_square_p): Disable second test case
- for non-32-bit machines (PP is hardwired for such machines).
- * mpz_perfsqr.c (outside of functions): Define PP value with an L.
-
- * mpn_mul.c (_mpn_mul): Add verification code that is activated if
- DEBUG is defined. Replace "digit" by "limb".
- * mpn_mul.c (_mpn_mul: Karatsuba's algorithm: 4.): Normalize temp
- after the addition.
- * mpn_mul.c (_mpn_mul: Karatsuba's algorithm: 1.): Compare u0_size
- and v0_size, and according to the result, swap arguments in
- recursive call. (Don't violate mpn_mul's own argument
- constraints.)
-
-Fri Aug 16 13:47:12 1991 Torbjorn Granlund (tege@sics.se)
-
- Released 1.0beta.10.
-
- * longlong.h (IBMR2): Add udiv_qrnnd.
-
- * mpz_perfsqr: Remove unused variables.
-
- * mpz_and (case for different signs): Initialize loop variable i!
-
- * dist-Makefile: Update automatically generated dependencies.
- * dist-Makefile (madd.c, msub.c, pow.c, mult.c, gcd.c): Add mp.h,
- etc to dependency file lists.
-
- * longlong.h (add_ssaaaa, sub_ddmmss [C default versions]): Make __x
- `unsigned long int'.
- * longlong.h: Add `int' after `unsigned' and `long' everywhere.
-
-Wed Aug 14 18:06:48 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h: Add ARM, i860 support.
-
- * mpn_lshift, mpn_rshift, mpn_rshiftci: Rename *_word with *_limb.
-
-Tue Aug 13 21:57:43 1991 Torbjorn Granlund (tege@sics.se)
-
- * _mpz_get_str.c, _mpz_set_str.c, mpz_sizeinb.c (mpz_sizeinbase),
- mpz_out_str.c, mout.c: Remove declaration of __mp_bases.
- * gmp-impl.h: Put it here, and make it `const'.
- * cre-conv-tab.c (main): Make struct __mp_bases `const'.
-
-Mon Aug 12 17:11:46 1991 Torbjorn Granlund (tege@sics.se)
-
- * cre-conv-tab.c (main): Use %lu in printf for long ints.
-
- * dist-Makefile: Fix cre-* dependencies.
-
- * cre-conv-tab.c (main): Output field big_base_inverted.
-
- * gmp-impl.h (struct bases): New field big_base_inverted.
- * gmp-impl.h (struct bases): Change type of chars_per_limb_exactly
- to float (in order to keep the structure smaller).
-
- * mp.h, gmp.h: Change names of macros for avoiding multiple
- includes.
-
-Fri Aug 9 18:01:36 1991 Torbjorn Granlund (tege@sics.se)
-
- * _mpz_get_str: Only shift limb array if normalization_steps != 0
- (optimization).
-
- * longlong.h (sparc umul_ppmm): Use __asm__, not asm.
- * longlong.h (IBMR2 umul_ppmm): Refer to __m0 and __m1, not to m0
- and m1 (overlap between output and input operands did not work).
- * longlong.h: Add VAX, ROMP and HP-PA support.
- * longlong.h: Sort the machine dependent code in alphabetical order
- on the CPU name.
- * longlong.h: Hack comments.
-
-Thu Aug 8 14:13:36 1991 Torbjorn Granlund (tege@sics.se)
-
- Released 1.0beta.9.
-
- * longlong.h: Define BITS_PER_LONG to 32 if it's not already
- defined.
- * Define __BITS4 to BITS_PER_LONG / 4.
- * Don't assume 32 bit word size in "count_leading_zeros" C macro.
- Use __BITS4 and BITS_PER_LONG instead.
-
- * longlong.h: Don't #undef internal macros (reverse change of Aug 3).
-
- * longlong.h (68k): Define add_ssaaaa sub_ddmmss, and umul_ppmm
- even for plain mc68000.
-
- * mpq_div: Flip the sign of the numerator *and* denominator of the
- result if the intermediate denominator is negative.
-
- * mpz_and.c, mpz_ior.c: Use MPN_COPY for all copying operations.
-
- * mpz_and.c: Compute the result size more conservatively.
- * mpz_ior.c: Likewise.
-
- * mpz_realloc: Never allocate zero space even if NEW_SIZE == 0.
-
- * dist-Makefile: Remove madd.c, msub.c, pow.c, mult.c, gcd.c from
- BSDMP_SRCS.
-
- * dist-Makefile: Create mult.c from mpz_mul.c.
- * mult.c: Delete this file.
-
- * _mpz_set_str: Normalize the result (for bases 2, 4, 8... it was
- not done properly if the input string had many leading zeros).
-
-Sun Aug 4 16:54:14 1991 Torbjorn Granlund (tege@sics.se)
-
- * dist-Makefile (gcd.c, pow.c, madd.c, msub.c): Make these targets
- work with VPATH and GNU MP.
-
- * mpz_gcd: Don't call mpz_set; inline its functionality.
-
- * mpq_mul, mpq_div: Fix several serious typos.
-
- * mpz_dmincl, mpz_div: Don't normalize the quotient if it's already
- zero.
-
- * mpq_neg.c: New file.
-
- * dist-Makefile: Remove obsolete dependencies.
-
- * mpz_sub: Fix typo.
-
- Bugs found by Pierre-Joseph Gailly (pjg@sunbim.be):
- * mpq_mul, mpq_div: Initialize tmp[12] variables even when the gcd
- is just 1.
- * mpz_gcd: Handle gcd(0,v) and gcd(u,0) in special cases.
-
-Sat Aug 3 23:45:28 1991 Torbjorn Granlund (tege@sics.se)
-
- * longlong.h: Clean up comments.
- * longlong.h: #undef internal macros.
-
-Fri Aug 2 18:29:11 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpq_set_si, mpq_set_ui: Canonicalize 0/x to 0/1.
- * mpq_set_si, mpq_set_ui: Cosmetic formatting changes.
-
- * mpz_dmincl.c: Normalize the remainder before shifting it back.
-
- * mpz_dm_ui.c (mpz_divmod_ui): Handle rem == dividend.
-
- * mpn_div.c: Fix comment.
-
- * mpz_add.c, mpz_sub.c: Use __MP_INT (not MP_INT) for intermediate
- type, in order to work for both GNU and Berkeley functions.
-
- * dist-Makefile: Create gcd.c from mpz_gcd.c, pow.c from mpz_powm,
- madd.c from mpz_add.c, msub.c from mpz_sub.c.
- respectively.
- * pow.c, gcd.c, mpz_powmincl.c, madd.c, msub.c: Remove these.
- * mpz_powm.c, mpz_gcd.c, mpz_add.c, mpz_sub.c: #ifdef for GNU and
- Berkeley function name variants.
- * dist-Makefile: Add created files to "clean" target.
-
-Tue Jul 16 15:19:46 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpq_get_den: No need for absolute value of the size, the
- denominator is always positive.
-
- * mpz_get_ui: If the operand is zero, return zero. Don't read the
- limb array!
-
- * mpz_dmincl.c: Don't ignore the return value from _mpn_rshift, it
- is the size of the remainder.
-
-Mon Jul 15 11:08:05 1991 Torbjorn Granlund (tege@sics.se)
-
- * Several files: Remove unused variables and functions.
-
- * gmp-impl.h: Declare _mpz_impl_sqrt.
-
- * mpz_dm_ui (mpz_divmod_ui), sdiv: Shift back the remainder if
- UDIV_NEEDS_NORMALIZATION. (Fix from Brian Beuning.)
-
- * mpz_dm_ui.c, sdiv: Replace *digit with *limb.
-
- * mpz_ior: Add missing else statement in -OP1 | -OP2 case.
- * mpz_ior: Add missing else statement in OP1 | -OP2 case.
- * mpz_ior: Swap also OP1 and OP2 pointers in -OP1 & OP2 case.
- * mpz_ior: Duplicate _mpz_realloc code.
-
- * mpz_and: Add missing else statement in -OP1 & -OP2 case.
- * mpz_and: Rewrite OP1 & -OP2 case.
- * mpz_and: Swap also OP1 and OP2 pointers in -OP1 & OP2 case.
-
- * mpz_gcdext: Loop in d1.size (not b->size). (Fix from Brian
- Beuning.)
-
- * mpz_perfsqr: Fix argument order in _mpz_impl_sqrt call. (Fix from
- Brian Beuning.)
-
-Fri Jul 12 17:10:33 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpq_set.c, mpq_set_ui.c, mpq_set_si.c, mpq_inv.c,
- mpq_get_num.c, mpq_get_den.c, mpq_set_num.c, mpq_set_den.c:
- New files.
-
- * mpz_dmincl.c: Remove second re-allocation of rem->d. It
- was never executed.
-
- * dist-Makefile: Use `-r' instead of `-x' for test for ranlib (as
- some unixes' test doesn't have the -r option).
-
- * *.*: Cast allocated pointers to the appropriate type (makes old C
- compilers happier).
-
- * cre-conv-tab.c (main): Divide max_uli by 2 and multiply again
- after conversion to double. (Kludge for broken C compilers.)
-
- * dist-Makefile (stamp-stddefh): New target. Test if "stddef.h"
- exists in the system and creates a minimal one if it does not
- exist.
- * cre-stddefh.c: New file.
- * dist-Makefile: Make libgmp.a and libmp.a depend on stamp-stddefh.
- * dist-Makefile (clean): Add some more.
- * gmp.h, mp.h: Unconditionally include "stddef.h".
-
-Thu Jul 11 10:08:21 1991 Torbjorn Granlund (tege@sics.se)
-
- * min: Do ungetc of last read character.
- * min.c: include stdio.h.
-
- * dist-Makefile: Go via tmp- files for cre* redirection.
- * dist-Makefile: Add tmp* to "clean" target.
-
- * dist-Makefile: Use LOCAL_CC for cre*, to simplyfy cross
- compilation.
-
- * gmp.h, mp.h: Don't define NULL here.
- * gmp-impl.h: Define it here.
-
-Wed Jul 10 14:13:33 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_mod_2exp: Don't copy too much, overwriting most significant
- limb.
-
- * mpz_and, mpz_ior: Don't read op[12]_ptr from op[12] when
- reallocating res, if op[12]_ptr got their value from alloca.
-
- * mpz_and, mpz_ior: Clear up comments.
-
- * cre-mparam.c: Output parameters for `short int' and `int'.
-
- * mpz_and, mpz_ior: Negate negative op[12]_size in several places.
-
-Tue Jul 9 18:40:30 1991 Torbjorn Granlund (tege@sics.se)
-
- * gmp.h, mp.h: Test for _SIZE_T defined before typedef'ing size_t.
- (Fix for Sun lossage.)
-
- * gmp.h: Add declaration of mpq_clear.
-
- * dist-Makefile: Chack if "ranlib" exists, before using it.
- * dist-Makefile: Add mpz_sqrtrem.c and mpz_size.c.
- * mpz_powm: Fix typo, "pow" instead of "mpz_powm".
-
-Fri Jul 5 19:08:09 1991 Torbjorn Granlund (tege@sics.se)
-
- * move: Remove incorrect comment.
-
- * mpz_free, mpq_free: Rename to *_clear.
- * dist-Makefile: Likewise.
- * mpq_add, mpq_sub, mpq_mul, mpq_div: Likewise.
-
- * mpz_dmincl.c: Don't call "move", inline its functionality.
-
-Thu Jul 4 00:06:39 1991 Torbjorn Granlund (tege@sics.se)
-
- * Makefile: Include dist-Makefile. Fix dist target to include
- dist-Makefile (with the name "Makefile" in the archive).
-
- * dist-Makefile: New file made from Makefile. Add new mpz_...
- functions.
-
- * mpz_powincl.c New file for mpz_powm (Berkeley MP pow)
- functionality. Avoids code duplication.
- * pow.c, mpz_powm.c: Include mpz_powincl.c
-
- * mpz_dmincl.c: New file containing general division code. Avoids
- code duplication.
- * mpz_dm.c (mpz_divmod), mpz_mod.c (mpz_mod), mdiv.c (mdiv): Include
- mpz_dmincl.c.
-
- * _mpz_get_str: Don't call memmove, unless HAS_MEMMOVE is defined.
- Instead, write the overlapping memory copying inline.
-
- * mpz_dm_ui.c: New name for mpz_divmod_ui.c (SysV file name limit).
-
- * longlong.h: Don't use #elif.
- * mpz_do_sqrt.c: Likewise.
-
- * longlong.h: Use __asm__ instead of asm.
- * longlong.h (sparc udiv_qrnnd): Make it to one string over several
- lines.
-
- * longlong.h: Preend __ll_ to B, highpart, and lowpart.
-
- * longlong.h: Move array t in count_leading_zeros to the new file
- mp_clz_tab.c. Rename the array __clz_tab.
- * All files: #ifdef for traditional C compatibillity.
-
-Wed Jul 3 11:42:14 1991 Torbjorn Granlund (tege@sics.se)
-
- * mpz_and: Initialize res_ptr always (used to be initialized only
- when reallocating).
-
- * longlong.h (umul_ppmm [C variant]): Make __ul...__vh
- `unsigned int', and cast the multiplications. This way
- compilers more easily can choose cheaper multiplication
- instructions.
-
- * mpz_mod_2exp: Handle input argument < modulo argument.
- * mpz_many: Make sure mp_size is the type for sizes, not int.
-
- * mpz_init, mpz_init_set*, mpq_init, mpq_add, mpq_sub, mpq_mul,
- mpq_div: Change mpz_init* interface. Structure pointer as first
- arg to initialization function, no longer *return* struct.
-
-Sun Jun 30 19:21:44 1991 Torbjorn Granlund (tege@sics.se)
-
- * Rename mpz_impl_sqrt.c to mpz_do_sqrt.c to satisfy SysV 14
- character file name length limit.
-
- * Most files: Rename MINT to MP_INT. Rename MRAT to MP_RAT.
- * mpz_sizeinb.c: New file with function mpz_sizeinbase.
- * mp_bases.c: New file, with array __mp_bases.
- * _mpz_get_str, _mpz_set_str: Remove struct bases, use extern
- __mp_bases instead.
- * mout, mpz_out_str: Use array __mp_bases instead of function
- _mpz_get_cvtlen.
- * mpz_get_cvtlen.c: Remove.
- * Makefile: Update.
-
-Sat Jun 29 21:57:28 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * longlong.h (__sparc8__ umul_ppmm): Insert 3 nop:s for wr delay.
- * longlong.h (___IBMR2__): Define umul_ppmm, add_ssaaaa, sub_ddmmss.
- * longlong.h (__sparc__): Don't call .umul; expand asm instead.
- Don't define __umulsidi3 (i.e. use default definition).
-
-Mon Jun 24 17:37:23 1991 Torbjorn Granlund (tege@amon.sics.se)
-
- * _mpz_get_str.c (num_to_ascii_lower_case, num_to_ascii_upper_case):
- Swap 't' and 's'.
-
-Sat Jun 22 13:54:01 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpz_gcdext.c: New file.
-
- * mpn_mul: Handle carry and unexpected operand sizes in last
- additions/subtractions. (Bug trigged when v1_size == 1.)
-
- * mp*_alloc*: Rename functions to mp*_init* (files to mp*_iset*.c).
- * mpq_*: Call mpz_init*.
-
- * mpz_pow_ui, rpow: Use _mpn_mul instead of mult. Restructure.
-
-Wed May 29 20:32:33 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpz_get_cvtlen: multiply by size.
-
-Sun May 26 15:01:15 1991 Torbjorn Granlund (tege@bella.nada.kth.se)
-
- Alpha-release 0.95.
-
- Fixes from Doug Lea (dl@g.oswego.edu):
- * mpz_mul_ui: Loop to MULT_SIZE (not PROD_SIZE). Adjust PROD_SIZE
- correctly.
- * mpz_div: Prepend _ to mpz_realloc.
- * mpz_set_xs, mpz_set_ds: Fix typos in function name.
-
-Sat May 25 22:51:16 1991 Torbjorn Granlund (tege@bella.nada.kth.se)
-
- * mpz_divmod_ui: New function.
-
- * sdiv: Make the sign of the remainder correct.
-
-Thu May 23 15:28:24 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * Alpha-release 0.94.
-
- * mpz_mul_ui: Include longlong.h.
-
- * mpz_perfsqr.c (mpz_perfect_square_p): Call _mpz_impl_sqrt instead
- of msqrt.
-
- * mpz_impl_sqrt: Don't call "move", inline its functionality.
-
- * mdiv: Use MPN_COPY instead of memcpy.
- * rpow, mpz_mul, mpz_mod_2exp: Likewise.
- * pow.c: Likewise, and fix bug in the size arg.
-
- * xtom: Don't use mpz_alloc, inline needed code instead. Call
- _mpz_set_str instead of mpz_set_str.
-
- * Makefile: Make two libraries, libmp.a and libgmp.a.
-
-Thu May 22 20:25:29 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * Add manual to distribution.
- * Fold in many missing routines descibed in the manual.
- * Update Makefile.
-
-Wed May 22 13:48:46 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpz_set_str: Make it handle 0x prefix OK.
-
-Sat May 18 18:31:02 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * memory.c (_mp_default_reallocate): Swap OLD_SIZE and NEW_SIZE
- arguments.
- * mpz_realloc (_mpz_realloc): Swap in call to _mp_reallocate_func.
- * min: Likewise.
-
-Thu May 16 20:43:05 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * memory.c: Make the default allocations functions global.
- * mp_set_fns (mp_set_memory_functions): Make a NULL pointer mean the
- default memory function.
-
-Wed May 8 20:02:42 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpz_div: Handle DEN the same as QUOT correctly by copying DEN->D
- even if no normalization is needed.
- * mpz_div: Rework reallocation scheme, to avoid excess copying.
-
- * mpz_sub_ui.c, mpz_add_ui.c: New files.
-
- * mpz_cmp.c, mpz_cmp_ui.c: New files.
-
- * mpz_mul_2exp: Handle zero input MINT correctly.
-
- * mpn_rshiftci: Don't handle shift counts > BITS_PER_MP_DIGIT.
-
- * mpz_out_raw.c, mpz_inp_raw.c: New files for raw I/O.
-
-Tue May 7 15:44:58 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpn_rshift: Don't handle shift counts > BITS_PER_MP_DIGIT.
- * mpz_div_2exp: Don't call _mpn_rshift with cnt > BITS_PER_MP_DIGIT.
- * gcd, mpz_gcd: Likewise.
-
- * gcd, mpz_gcd: Handle common 2 factors correctly.
-
-Mon May 6 20:22:59 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * gmp-impl.h (MPN_COPY): Inline a loop instead of calling memcpy.
-
- * gmp-impl.h, mpz_get_str, rpow: Swap DST and SRC in TMPCOPY* macros.
-
-Sun May 5 15:16:23 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpz_div: Remove test for QUOT == 0.
-
-Sun Apr 28 20:21:04 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * pow: Don't make MOD normalization in place, as it's a bad idea to
- write on an input parameter.
- * pow: Reduce BASE if it's > MOD.
- * pow, mult, mpz_mul: Simplify realloc code.
-
-Sat Apr 27 21:03:11 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * Install multplication using Karatsuba's algorithm as default.
-
-Fri Apr 26 01:03:57 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * msqrt: Store in ROOT even for U==0, to make msqrt(0) defined.
-
- * mpz_div_2exp.c, mpz_mul_2exp.c: New files for shifting right and
- left, respectively.
- * gmp.h: Add definitions for mpz_div_2exp and mpz_mul_2exp.
-
- * mlshift.c, mrshift.c: Remove.
-
-Wed Apr 24 21:39:22 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * mpn_mul: Check only for m2_size == 0 in function header.
-
-Mon Apr 22 01:31:57 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * karatsuba.c: New file for Karatsuba's multplication algorithm.
-
- * mpz_random, mpz_init, mpz_mod_2exp: New files and functions.
-
- * mpn_cmp: Fix header comment.
-
-Sun Apr 21 00:10:44 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * pow: Switch off initial base reduction.
-
-Sat Apr 20 22:06:05 1991 Torbjorn Granlund (tege@echnaton.sics.se)
-
- * mpz_get_str: Don't generate initial zeros for initial word.
- Used to write outside of allocated storage.
-
-Mon Apr 15 15:48:08 1991 Torbjorn Granlund (tege@zevs.sics.se)
-
- * _mpz_realloc: Make it accept size in number of mp_digits.
- * Most functions: Use new _mpz_realloc definition.
-
- * mpz_set_str: Remove calls _mp_free_func.
-
- * Most functions: Rename mpn_* to _mpn_*. Rename mpz_realloc to
- _mpz_realloc.
- * mpn_lshift: Redefine _mpn_lshift to only handle small shifts.
- * mdiv, mpz_div, ...: Changes for new definition of _mpn_lshift.
- * msqrt, mp*_*shift*: Define cnt as unsigned (for speed).
-
-Sat Apr 6 14:05:16 1991 Torbjorn Granlund (tege@musta.nada.kth.se)
-
- * mpn_mul: Multiply by the first digit in M2 in a special
- loop instead of zeroing the product area.
-
- * mpz_abs.c: New file.
-
- * sdiv: Implement as mpz_div_si for speed.
-
- * mpn_add: Make it work for second source operand == 0.
-
- * msub: Negate the correct operand, i.e. V before swapping, not
- the smaller of U and V!
- * madd, msub: Update abs_* when swapping operands, and not after
- (optimization).
-
-Fri Apr 5 00:19:36 1991 Torbjorn Granlund (tege@black.nada.kth.se)
-
- * mpn_sub: Make it work for subtrahend == 0.
-
- * madd, msub: Rewrite to minimize mpn_cmp calls. Ensure
- mpn_cmp is called with positive sizes (used to be called
- incorrectly with negative sizes sometimes).
-
- * msqrt: Make it divide by zero if fed with a negative number.
- * Remove if statement at end of precision calculation that was
- never true.
-
- * itom, mp.h: The argument is of type short, not int.
-
- * mpz_realloc, gmp.h: Make mpz_realloc return the new digit pointer.
-
- * mpz_get_str.c, mpz_set_str.c, mpz_new_str.c: Don't include mp.h.
-
- * Add COPYING to distribution.
-
- * mpz_div_ui.c, mpz_div_si.c, mpz_new_ui.c, mpz_new_si.c: New files.
-
-Fri Mar 15 00:26:29 1991 Torbjorn Granlund (tege@musta.nada.kth.se)
-
- * Add Copyleft headers to all files.
-
- * mpn_mul.c, mpn_div.c: Add header comments.
- * mult.c, mdiv.c: Update header comments.
-
- * mpq_add.c, mpq_sub.c, mpq_div.c, mpq_new.c, mpq_new_ui.c,
- mpq_free.c: New files for rational arithmetics.
-
- * mpn_lshift.c: Avoid writing the most significant word if it is 0.
-
- * mdiv.c: Call mpn_lshift for the normalization.
- * mdiv.c: Remove #ifdefs.
-
- * Makefile: Add ChangeLog to DISTFILES.
-
- * mpn_div.c: Make the add_back code work (by removing abort()).
- * mpn_div.c: Make it return if the quotient is size as compared
- with the difference NSIZE - DSIZE. If the stored quotient is
- larger than that, return 1, otherwise 0.
- * gmp.h: Fix mpn_div declaration.
- * mdiv.c: Adopt call to mpn_div.
- * mpz_div.c: New file (developed from mdiv.c).
-
- * README: Update routine names.
-
-Thu Mar 14 18:45:28 1991 Torbjorn Granlund (tege@musta.nada.kth.se)
-
- * mpq_mul.c: New file for rational multplication.
-
- * gmp.h: Add definitions for rational arithmetics.
-
- * mpn_div: Kludge the case where the high numerator digit > the
- high denominator digit. (This code is going to be optimized later.)
-
- * New files: gmp.h for GNU specific functions, gmp-common.h for
- definitions common for mp.h and gmp.h.
-
- * Ensure mp.h just defines what BSD mp.h defines.
-
- * pow.c: Fix typo for bp allocation.
-
- * Rename natural number functions to mpn_*, integer functions to
- mpz_*.
-
-Tue Mar 5 18:47:04 1991 Torbjorn Granlund (tege@musta.nada.kth.se)
-
- * mdiv.c (_mp_divide, case 2): Change test for estimate of Q from
- "n0 >= r" to "n0 > r".
-
- * msqrt: Tune the increasing precision scheme, to do fewer steps.
-
-Tue Mar 3 18:50:10 1991 Torbjorn Granlund (tege@musta.nada.kth.se)
-
- * msqrt: Use the low level routines. Use low precision in the
- beginning, and increase the precision as the result converges.
- (This optimization gave a 6-fold speedup.)
-\f
-Local Variables:
-mode: indented-text
-left-margin: 8
-fill-column: 75
-version-control: never
-End:
+++ /dev/null
-Here is how to compile GNU MP.
-
-You probably want to use the GNU C compiler to build this library.
-With other compilers the speed of the library will be 3-10 times
-slower for many CPU:s. The reason for this is that the GNU C compiler
-will use inline assembler for some important operations, while other C
-compilers will have to stick to plain C code.
-
-This is how to build the library:
-
- Type "make" to build libgmp.a and libmp.a. The former is the main
- GNU MP library. The latter is the Berkeley MP compatible library.
-
- If you don't have GCC, type "make CC=cc". The compilation should, at
- least with GCC, proceed without any kind of warnings from the compiler
- programs. On the DEC Alpha, you have to use GCC because of bugs in DEC's
- own compiler. GCC 2.3.3 for x86, Alpha, and HP-PA has bugs that make
- several functions be mis-optimized. Later version of GCC does not have
- this problem.
-
- To build and run the tests, do "make check".
-
-The documentation is an a texinfo file, gmp.texi.
-
-To create the documentation from the texinfo source, type "make doc".
-This requires the "tex" and "makeinfo" commands to be available in
-your search path. If you have only one of them, you can create the
-dvi file (for the paper manual) with "make gmp.dvi", and the info file
-(for the GNU online manual facility) with "make gmp.info".
-
-You need version 2.06 or later of texinfo in order to build the
-documentation.
-
-Please report problems to tege@gnu.ai.mit.edu.
+++ /dev/null
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.4 1997/03/19 20:44:55 simonpj Exp $
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-# There's only one `way' for gmp, empty WAYS variable right away.
-WAYS=
-
-GMP_OBJS = $(MPZ_OBJS) $(MPQ_OBJS) $(MPN_OBJS) $(IMPL_OBJS) mp_bases.o
-
-IMPL_SRCS = memory.c mp_set_fns.c _mpz_set_str.c _mpz_get_str.c \
- mpz_realloc.c mp_clz_tab.c alloca.c
-IMPL_OBJS = memory.o mp_set_fns.o _mpz_set_str.o _mpz_get_str.o \
- mpz_realloc.o mp_clz_tab.o alloca.o
-
-MPZ_SRCS = mpz_init.c mpz_set.c mpz_set_ui.c mpz_set_si.c mpz_set_str.c \
- mpz_iset.c mpz_iset_ui.c mpz_iset_si.c mpz_iset_str.c mpz_clear.c \
- mpz_get_ui.c mpz_get_si.c mpz_get_str.c mpz_size.c mpz_sizeinb.c \
- mpz_add.c mpz_add_ui.c mpz_sub.c mpz_sub_ui.c mpz_mul.c mpz_mul_ui.c \
- mpz_div.c mpz_div_ui.c mpz_mod.c mpz_mod_ui.c mpz_dm.c mpz_dm_ui.c \
- mpz_mdiv.c mpz_mmod.c mpz_mdm.c mpz_mdiv_ui.c mpz_mmod_ui.c mpz_mdm_ui.c \
- mpz_gcd.c mpz_gcdext.c mpz_sqrt.c mpz_sqrtrem.c mpz_powm.c mpz_powm_ui.c \
- mpz_cmp.c mpz_cmp_ui.c mpz_cmp_si.c mpz_mul_2exp.c mpz_div_2exp.c \
- mpz_mod_2exp.c mpz_abs.c mpz_neg.c mpz_com.c mpz_and.c mpz_ior.c \
- mpz_inp_raw.c mpz_inp_str.c mpz_out_raw.c mpz_out_str.c \
- mpz_perfsqr.c mpz_random.c mpz_random2.c mpz_pow_ui.c \
- mpz_clrbit.c mpz_fac_ui.c mpz_pprime_p.c
-MPZ_OBJS = mpz_init.o mpz_set.o mpz_set_ui.o mpz_set_si.o mpz_set_str.o \
- mpz_iset.o mpz_iset_ui.o mpz_iset_si.o mpz_iset_str.o mpz_clear.o \
- mpz_get_ui.o mpz_get_si.o mpz_get_str.o mpz_size.o mpz_sizeinb.o \
- mpz_add.o mpz_add_ui.o mpz_sub.o mpz_sub_ui.o mpz_mul.o mpz_mul_ui.o \
- mpz_div.o mpz_div_ui.o mpz_mod.o mpz_mod_ui.o mpz_dm.o mpz_dm_ui.o \
- mpz_mdiv.o mpz_mmod.o mpz_mdm.o mpz_mdiv_ui.o mpz_mmod_ui.o mpz_mdm_ui.o \
- mpz_gcd.o mpz_gcdext.o mpz_sqrt.o mpz_sqrtrem.o mpz_powm.o mpz_powm_ui.o \
- mpz_cmp.o mpz_cmp_ui.o mpz_cmp_si.o mpz_mul_2exp.o mpz_div_2exp.o \
- mpz_mod_2exp.o mpz_abs.o mpz_neg.o mpz_com.o mpz_and.o mpz_ior.o \
- mpz_inp_raw.o mpz_inp_str.o mpz_out_raw.o mpz_out_str.o \
- mpz_perfsqr.o mpz_random.o mpz_random2.o mpz_pow_ui.o \
- mpz_clrbit.o mpz_fac_ui.o mpz_pprime_p.o
-
-MPQ_SRCS = mpq_init.c mpq_set.c mpq_set_ui.c mpq_set_si.c \
- mpq_set_num.c mpq_set_den.c mpq_get_num.c mpq_get_den.c \
- mpq_add.c mpq_sub.c mpq_mul.c mpq_div.c \
- mpq_clear.c mpq_cmp.c mpq_inv.c mpq_neg.c
-MPQ_OBJS = mpq_init.o mpq_set.o mpq_set_ui.o mpq_set_si.o \
- mpq_set_num.o mpq_set_den.o mpq_get_num.o mpq_get_den.o \
- mpq_add.o mpq_sub.o mpq_mul.o mpq_div.o \
- mpq_clear.o mpq_cmp.o mpq_inv.o mpq_neg.o
-
-MPN_SRCS = mpn_add.c mpn_sub.c mpn_cmp.c mpn_mul.c mpn_div.c mpn_dm_1.c \
- mpn_mod_1.c mpn_lshift.c mpn_rshift.c mpn_rshiftci.c mpn_sqrt.c
-MPN_OBJS = mpn_add.o mpn_sub.o mpn_cmp.o mpn_mul.o mpn_div.o mpn_dm_1.o \
- mpn_mod_1.o mpn_lshift.o mpn_rshift.o mpn_rshiftci.o mpn_sqrt.o
-
-#
-# Compiling gmp with gcc-2.7.2 *without* -O tripped up a bug in the
-# code that sets up and stores the regs around an __asm__ (mpn_mul.c : add_ssaaaa).
-# Enabling -O flushed out the problem, so dropping the -O is not advised.
-#
-SRC_CC_OPTS += -I. -O
-
-all depend :: gmp-mparam.h
-libgmp.a :: stamp-stddefh
-
-LIBRARY = libgmp.a
-LIBOBJS = $(GMP_OBJS)
-DESTDIR = $(INSTLIBDIR_GHC)
-C_SRCS = $(IMPL_SRCS) $(MPZ_SRCS) $(MPQ_SRCS) $(MPN_SRCS)
-
-#
-# Install gmp
-#
-INSTALL_LIBS += $(LIBRARY)
-
-CLEAN_FILES += test-with-stddefh.c stamp-stddefh cre-mparam gmp-mparam.h mp_bases.c cre-conv-tab
-
-SRC_H_FILES+=$(wildcard *.h) COPYING ChangeLog INSTALL Makefile.original README TODO VERSION gmp.texi mpn_mul_classic.c-EXTRA
-# ToDo: something to make the doc
-
-# from here on, it is magic from the original Makefile
-
-# If you cross compile on a machine with the same sizes of the integral
-# types ("int", "long int", "short int", and "char") define this as the
-# local compiler. Otherwise, you need look for the uses of LOCAL_CC below,
-# and handle those cases manually.
-
-LOCAL_CC = $(CC)
-
-stamp-stddefh:
- rm -f stddef.h
- rm -f test-stddefh.c
- ( echo '#include <stddef.h>' ;\
- echo 'main(){size_t foo=sizeof(size_t);exit(0);}' ;\
- ) > test-stddefh.c
- @if $(LOCAL_CC) $(CFLAGS) test-stddefh.c -c 2> /dev/null ;\
- then true ;\
- else \
- echo 'This machine has no "stddef.h". Creating a minimal in ./';\
- $(LOCAL_CC) $(CFLAGS) cre-stddefh.c -o cre-stddefh ;\
- ./cre-stddefh > stddef.h ;\
- fi
- rm -f test-stddefh.o
- touch stamp-stddefh
-
-mp_bases.c: cre-conv-tab
- ./cre-conv-tab > tmp-$@
- mv tmp-$@ $@
-cre-conv-tab: cre-conv-tab.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
- $(LOCAL_CC) $(CFLAGS) `if [ x$(firstword $^) = x ]; \
- then echo cre-conv-tab.c; \
- else echo $(firstword $^); fi` -o $@ -lm
-
-gmp-mparam.h: cre-mparam
- ./cre-mparam > tmp-$@
- mv tmp-$@ $@
-cre-mparam: cre-mparam.c stamp-stddefh gmp.h
- $(LOCAL_CC) $(CFLAGS) cre-mparam.c -o $@
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-# Makefile for GNU MP (a.k.a. biGNUm)
-# Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-# This file is part of the GNU MP Library.
-
-# The GNU MP Library is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-
-# The GNU MP Library is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-
-# You should have received a copy of the GNU General Public License
-# along with the GNU MP Library; see the file COPYING. If not, write to
-# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-CC = gcc
-
-# If you cross compile on a machine with the same sizes of the integral
-# types ("int", "long int", "short int", and "char") define this as the
-# local compiler. Otherwise, you need look for the uses of LOCAL_CC below,
-# and handle those cases manually.
-LOCAL_CC = $(CC)
-OPT = -O -g
-CFLAGS = -I. $(OPT)
-AR = ar
-RANLIB=`if [ -r /bin/ranlib -o -r /usr/bin/ranlib ]; \
- then echo ranlib; else echo true; fi`
-SHELL = /bin/sh
-
-SRCS = $(MPZ_SRCS) $(MPQ_SRCS) $(BSDMP_SRCS) $(MPN_SRCS) $(IMPL_SRCS)
-OBJS = $(MPZ_OBJS) $(MPQ_OBJS) $(BSDMP_OBJS) $(MPN_OBJS) $(IMPL_OBJS)
-
-MP_OBJS = $(BSDMP_OBJS) $(MPN_OBJS) $(IMPL_OBJS) mp_bases.o mpz_sizeinb.o
-GMP_OBJS = $(MPZ_OBJS) $(MPQ_OBJS) $(MPN_OBJS) $(IMPL_OBJS) mp_bases.o
-
-IMPL_SRCS = memory.c mp_set_fns.c _mpz_set_str.c _mpz_get_str.c \
- mpz_realloc.c mp_clz_tab.c alloca.c
-IMPL_OBJS = memory.o mp_set_fns.o _mpz_set_str.o _mpz_get_str.o \
- mpz_realloc.o mp_clz_tab.o alloca.o
-
-MPZ_SRCS = mpz_init.c mpz_set.c mpz_set_ui.c mpz_set_si.c mpz_set_str.c \
- mpz_iset.c mpz_iset_ui.c mpz_iset_si.c mpz_iset_str.c mpz_clear.c \
- mpz_get_ui.c mpz_get_si.c mpz_get_str.c mpz_size.c mpz_sizeinb.c \
- mpz_add.c mpz_add_ui.c mpz_sub.c mpz_sub_ui.c mpz_mul.c mpz_mul_ui.c \
- mpz_div.c mpz_div_ui.c mpz_mod.c mpz_mod_ui.c mpz_dm.c mpz_dm_ui.c \
- mpz_mdiv.c mpz_mmod.c mpz_mdm.c mpz_mdiv_ui.c mpz_mmod_ui.c mpz_mdm_ui.c \
- mpz_gcd.c mpz_gcdext.c mpz_sqrt.c mpz_sqrtrem.c mpz_powm.c mpz_powm_ui.c \
- mpz_cmp.c mpz_cmp_ui.c mpz_cmp_si.c mpz_mul_2exp.c mpz_div_2exp.c \
- mpz_mod_2exp.c mpz_abs.c mpz_neg.c mpz_com.c mpz_and.c mpz_ior.c \
- mpz_inp_raw.c mpz_inp_str.c mpz_out_raw.c mpz_out_str.c \
- mpz_perfsqr.c mpz_random.c mpz_random2.c mpz_pow_ui.c \
- mpz_clrbit.c mpz_fac_ui.c mpz_pprime_p.c
-MPZ_OBJS = mpz_init.o mpz_set.o mpz_set_ui.o mpz_set_si.o mpz_set_str.o \
- mpz_iset.o mpz_iset_ui.o mpz_iset_si.o mpz_iset_str.o mpz_clear.o \
- mpz_get_ui.o mpz_get_si.o mpz_get_str.o mpz_size.o mpz_sizeinb.o \
- mpz_add.o mpz_add_ui.o mpz_sub.o mpz_sub_ui.o mpz_mul.o mpz_mul_ui.o \
- mpz_div.o mpz_div_ui.o mpz_mod.o mpz_mod_ui.o mpz_dm.o mpz_dm_ui.o \
- mpz_mdiv.o mpz_mmod.o mpz_mdm.o mpz_mdiv_ui.o mpz_mmod_ui.o mpz_mdm_ui.o \
- mpz_gcd.o mpz_gcdext.o mpz_sqrt.o mpz_sqrtrem.o mpz_powm.o mpz_powm_ui.o \
- mpz_cmp.o mpz_cmp_ui.o mpz_cmp_si.o mpz_mul_2exp.o mpz_div_2exp.o \
- mpz_mod_2exp.o mpz_abs.o mpz_neg.o mpz_com.o mpz_and.o mpz_ior.o \
- mpz_inp_raw.o mpz_inp_str.o mpz_out_raw.o mpz_out_str.o \
- mpz_perfsqr.o mpz_random.o mpz_random2.o mpz_pow_ui.o \
- mpz_clrbit.o mpz_fac_ui.o mpz_pprime_p.o
-
-MPQ_SRCS = mpq_init.c mpq_set.c mpq_set_ui.c mpq_set_si.c \
- mpq_set_num.c mpq_set_den.c mpq_get_num.c mpq_get_den.c \
- mpq_add.c mpq_sub.c mpq_mul.c mpq_div.c \
- mpq_clear.c mpq_cmp.c mpq_inv.c mpq_neg.c
-MPQ_OBJS = mpq_init.o mpq_set.o mpq_set_ui.o mpq_set_si.o \
- mpq_set_num.o mpq_set_den.o mpq_get_num.o mpq_get_den.o \
- mpq_add.o mpq_sub.o mpq_mul.o mpq_div.o \
- mpq_clear.o mpq_cmp.o mpq_inv.o mpq_neg.o
-
-MPN_SRCS = mpn_add.c mpn_sub.c mpn_cmp.c mpn_mul.c mpn_div.c mpn_dm_1.c \
- mpn_mod_1.c mpn_lshift.c mpn_rshift.c mpn_rshiftci.c mpn_sqrt.c
-MPN_OBJS = mpn_add.o mpn_sub.o mpn_cmp.o mpn_mul.o mpn_div.o mpn_dm_1.o \
- mpn_mod_1.o mpn_lshift.o mpn_rshift.o mpn_rshiftci.o mpn_sqrt.o
-
-# There are fewer members in the BSDMP_SRCS list that in the BSDMP_OBJS
-# list because some of the .c files are created by this Makefile.
-BSDMP_SRCS = itom.c mdiv.c move.c mtox.c xtom.c sdiv.c mout.c min.c mfree.c
-BSDMP_OBJS = gcd.o itom.o madd.o mcmp.o mdiv.o move.o msub.o mtox.o mult.o \
- pow.o rpow.o xtom.o msqrt.o sdiv.o mout.o min.o mfree.o
-
-all: libgmp.a libmp.a
-
-check: libgmp.a
- cd tests; $(MAKE) CC="$(CC)" SHELL="$(SHELL)" OPT="$(OPT)"
-
-libgmp.a: stamp-stddefh $(GMP_OBJS)
- rm -f $@
- $(AR) cr $@ $(GMP_OBJS)
- $(RANLIB) $@
-
-# libmp.a depend on libgmp.a, to get around Unix(tm) ar/ranlib concurrency bug.
-libmp.a: stamp-stddefh $(MP_OBJS) libgmp.a
- rm -f $@
- $(AR) cr $@ $(MP_OBJS)
- $(RANLIB) $@
-
-stamp-stddefh:
- rm -f stddef.h
- rm -f test-stddefh.c
- ( echo '#include <stddef.h>' ;\
- echo 'main(){size_t foo=sizeof(size_t);exit(0);}' ;\
- ) > test-stddefh.c
- @if $(LOCAL_CC) $(CFLAGS) test-stddefh.c -c 2> /dev/null ;\
- then true ;\
- else \
- echo 'This machine has no "stddef.h". Creating a minimal in ./';\
- $(LOCAL_CC) $(CFLAGS) cre-stddefh.c -o cre-stddefh ;\
- ./cre-stddefh > stddef.h ;\
- fi
- rm -f test-stddefh.o
- touch stamp-stddefh
-
-mp_bases.c: cre-conv-tab
- ./cre-conv-tab > tmp-$@
- mv tmp-$@ $@
-cre-conv-tab: cre-conv-tab.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
- $(LOCAL_CC) $(CFLAGS) `if [ x$(firstword $^) = x ]; \
- then echo cre-conv-tab.c; \
- else echo $(firstword $^); fi` -o $@ -lm
-
-gmp-mparam.h: cre-mparam
- ./cre-mparam > tmp-$@
- mv tmp-$@ $@
-cre-mparam: cre-mparam.c stamp-stddefh gmp.h
- $(LOCAL_CC) $(CFLAGS) cre-mparam.c -o $@
-
-gcd.c : mpz_gcd.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h longlong.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_gcd.c \
- | grep -v '^#' > $@
-pow.c : mpz_powm.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h longlong.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_powm.c\
- | grep -v '^#' > $@
-rpow.c: mpz_pow_ui.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h longlong.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_pow_ui.c\
- | grep -v '^#' > $@
-madd.c : mpz_add.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_add.c\
- | grep -v '^#' > $@
-msub.c : mpz_sub.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_sub.c\
- | grep -v '^#' > $@
-mult.c : mpz_mul.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_mul.c\
- | grep -v '^#' > $@
-mcmp.c : mpz_cmp.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_cmp.c\
- | grep -v '^#' > $@
-msqrt.c : mpz_sqrtrem.c stamp-stddefh mp.h gmp.h gmp-impl.h gmp-mparam.h
- $(CC) $(CFLAGS) -E -DBERKELEY_MP mpz_sqrtrem.c\
- | grep -v '^#' > $@
-
-doc: gmp.dvi gmp.info
-LN = ln -s
-gmp.dvi: gmp.texi
- rm -f tmp.texi
- $(LN) gmp.texi tmp.texi
- tex tmp.texi < /dev/null
- texindex tmp.cp tmp.fn
- tex tmp.texi < /dev/null 2> /dev/null
- mv tmp.dvi gmp.dvi
-gmp.info: gmp.texi
- makeinfo gmp.texi
-
-clean:
- rm -f *.o libgmp.a libmp.a cre-conv-tab cre-mparam cre-stddefh \
- gmp.dvi gmp.info mp_bases.c gmp-mparam.h stamp-stddefh test-stddefh.c \
- stddef.h gcd.c pow.c rpow.c madd.c msub.c mult.c mcmp.c msqrt.c \
- tmp.* tmp-* gmp.ps core
- -cd tests; $(MAKE) clean
-realclean: clean
-
-# Automatically generated dependencies
-
-_mpz_get_str.o : _mpz_get_str.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-_mpz_set_str.o : _mpz_set_str.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-cre-conv-tab.o : cre-conv-tab.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-cre-mparam.o : cre-mparam.c gmp.h
-cre-stddefh.o : cre-stddefh.c
-itom.o : itom.c mp.h gmp.h gmp-impl.h gmp-mparam.h
-mdiv.o : mdiv.c mp.h gmp.h gmp-impl.h gmp-mparam.h longlong.h mpz_dmincl.c
-memory.o : memory.c gmp.h gmp-impl.h gmp-mparam.h
-mfree.o : mfree.c mp.h gmp.h gmp-impl.h gmp-mparam.h
-min.o : min.c mp.h gmp.h gmp-impl.h gmp-mparam.h
-mout.o : mout.c mp.h gmp.h gmp-impl.h gmp-mparam.h
-move.o : move.c mp.h gmp.h gmp-impl.h gmp-mparam.h
-mp_bases.o : mp_bases.c gmp.h gmp-impl.h gmp-mparam.h
-mp_clz_tab.o : mp_clz_tab.c gmp.h gmp-impl.h gmp-mparam.h
-mp_set_fns.o : mp_set_fns.c gmp.h gmp-impl.h gmp-mparam.h
-mpn_add.o : mpn_add.c gmp.h gmp-impl.h gmp-mparam.h
-mpn_cmp.o : mpn_cmp.c gmp.h gmp-impl.h gmp-mparam.h
-mpn_div.o : mpn_div.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpn_dm_1.o : mpn_dm_1.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpn_lshift.o : mpn_lshift.c gmp.h gmp-impl.h gmp-mparam.h
-mpn_mod_1.o : mpn_mod_1.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpn_mul.o : mpn_mul.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpn_rshift.o : mpn_rshift.c gmp.h gmp-impl.h gmp-mparam.h
-mpn_rshiftci.o : mpn_rshiftci.c gmp.h gmp-impl.h gmp-mparam.h
-mpn_sqrt.o : mpn_sqrt.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpn_sub.o : mpn_sub.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_add.o : mpq_add.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_clear.o : mpq_clear.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_cmp.o : mpq_cmp.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_div.o : mpq_div.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_get_den.o : mpq_get_den.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_get_num.o : mpq_get_num.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_init.o : mpq_init.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_inv.o : mpq_inv.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_mul.o : mpq_mul.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_neg.o : mpq_neg.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_set.o : mpq_set.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_set_den.o : mpq_set_den.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_set_num.o : mpq_set_num.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_set_si.o : mpq_set_si.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_set_ui.o : mpq_set_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpq_sub.o : mpq_sub.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_abs.o : mpz_abs.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_add.o : mpz_add.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_add_ui.o : mpz_add_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_and.o : mpz_and.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_clear.o : mpz_clear.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_clrbit.o : mpz_clrbit.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_cmp.o : mpz_cmp.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_cmp_si.o : mpz_cmp_si.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_cmp_ui.o : mpz_cmp_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_com.o : mpz_com.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_div.o : mpz_div.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_div_2exp.o : mpz_div_2exp.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_div_ui.o : mpz_div_ui.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_dm.o : mpz_dm.c gmp.h gmp-impl.h gmp-mparam.h longlong.h mpz_dmincl.c
-mpz_dm_ui.o : mpz_dm_ui.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_fac_ui.o : mpz_fac_ui.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_gcd.o : mpz_gcd.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_gcdext.o : mpz_gcdext.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_get_si.o : mpz_get_si.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_get_str.o : mpz_get_str.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_get_ui.o : mpz_get_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_init.o : mpz_init.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_inp_raw.o : mpz_inp_raw.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_inp_str.o : mpz_inp_str.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_ior.o : mpz_ior.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_iset.o : mpz_iset.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_iset_si.o : mpz_iset_si.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_iset_str.o : mpz_iset_str.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_iset_ui.o : mpz_iset_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mdiv.o : mpz_mdiv.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mdiv_ui.o : mpz_mdiv_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mdm.o : mpz_mdm.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mdm_ui.o : mpz_mdm_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mmod.o : mpz_mmod.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mmod_ui.o : mpz_mmod_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mod.o : mpz_mod.c gmp.h gmp-impl.h gmp-mparam.h longlong.h mpz_dmincl.c
-mpz_mod_2exp.o : mpz_mod_2exp.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mod_ui.o : mpz_mod_ui.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_mul.o : mpz_mul.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mul_2exp.o : mpz_mul_2exp.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_mul_ui.o : mpz_mul_ui.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_neg.o : mpz_neg.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_out_raw.o : mpz_out_raw.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_out_str.o : mpz_out_str.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_perfsqr.o : mpz_perfsqr.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_pow_ui.o : mpz_pow_ui.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_powm.o : mpz_powm.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_powm_ui.o : mpz_powm_ui.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_pprime_p.o : mpz_pprime_p.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_random.o : mpz_random.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_random2.o : mpz_random2.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_realloc.o : mpz_realloc.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_set.o : mpz_set.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_set_si.o : mpz_set_si.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_set_str.o : mpz_set_str.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_set_ui.o : mpz_set_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_size.o : mpz_size.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_sizeinb.o : mpz_sizeinb.c gmp.h gmp-impl.h gmp-mparam.h longlong.h
-mpz_sqrt.o : mpz_sqrt.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_sqrtrem.o : mpz_sqrtrem.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_sub.o : mpz_sub.c gmp.h gmp-impl.h gmp-mparam.h
-mpz_sub_ui.o : mpz_sub_ui.c gmp.h gmp-impl.h gmp-mparam.h
-mtox.o : mtox.c mp.h gmp.h gmp-impl.h gmp-mparam.h
-sdiv.o : sdiv.c mp.h gmp.h gmp-impl.h gmp-mparam.h longlong.h
-xtom.o : xtom.c mp.h gmp.h gmp-impl.h gmp-mparam.h
+++ /dev/null
- THE GNU MP LIBRARY
-
-
-GNU MP is a library for arbitrary precision arithmetic, operating on
-signed integers and rational numbers. It has a rich set of functions,
-and the functions have a regular interface.
-
-I have tried to make these functions as fast as possible, both for small
-operands and for huge operands. The speed is achieved by using fullwords
-as the basic arithmetic type, by using fast algorithms, by defining inline
-assembler for mixed sized multiplication and division (i.e 32*32->64 bit
-multiplication and 64/32->32,32 bit division), and by hacking the code
-with emphasis on speed (and not simplicity and elegance).
-
-The speed of GNU MP is about 5 to 100 times that of Berkeley MP for
-small operands. The speed-up increases with the operand sizes for
-certain operations, for which GNU MP has asymptotically faster algorithms.
-
-
-There are four classes of functions in GNU MP.
-
- 1. Signed integer arithmetic functions, mpz_*. The set of functions are
- intended to be easy to use, being rich and regular.
-
- To use these functions, include the file "gmp.h".
-
- 2. Rational arithmetic functions, mpq_*. For now, just a small set of
- functions necessary for basic rational arithmetics.
-
- To use these functions, include the file "gmp.h".
-
- 3. Positive-integer, low-level, harder-to-use, but for small operands
- about twice as fast than the mpz_* functions are the functions in the
- mpn_* class. No memory management is performed. The caller must
- ensure enough space is available for the results. The set of
- functions is not quite regular, nor is the calling interface. These
- functions accept input arguments in the form of pairs consisting of a
- pointer to the least significant word, and a integral size telling how
- many limbs (= words) the pointer points to.
-
- Almost all calculations, in the entire package, are made in these
- low-level functions.
-
- These functions are not fully documented in this release. They will
- probably be so in a future release.
-
- 4. Berkeley MP compatible functions.
-
- To use these functions, include the file "mp.h". You can test if you
- are using the GNU version by testing if the symbol __GNU_MP__ is
- defined.
-
-
- REPORTING BUGS
-
-If you find a bug in the library, please make sure to tell us about it!
-
-You can report bugs, and propose modifications and enhancements to
-tege@gnu.ai.mit.edu. How to report a bug is further described in
-the texinfo documentation, see the file gmp.texi.
-
+++ /dev/null
-THINGS TO WORK ON
-
-Note that many of these things mentioned here are already fixed in GMP 2.0.
-
-* Improve speed for non-gcc compilers by defining umul_ppmm, udiv_qrnnd,
- etc, to call __umul_ppmm, __udiv_qrnnd. A typical definition for
- umul_ppmm would be
- #define umul_ppmm(ph,pl,m0,m1) \
- {unsigned long __ph; (pl) = __umul_ppmm (&__ph, (m0), (m1)); (ph) = __ph;}
- In order to maintain just one version of longlong.h (gmp and gcc), this
- has to be done outside of longlong.h.
-
-* Change mpn-routines to not deal with normalisation?
- mpn_add: Unchanged.
- mpn_sub: Remove normalization loop. Does it assume normalised input?
- mpn_mul: Make it return most sign limb, to simplify normalisation.
- Karatsubas algorith will be greatly simplified if mpn_add and
- mpn_sub doesn't normalise their results.
- mpn_div: Still requires strict normalisation.
- Beware of problems with mpn_cmp (and similar), a larger size does not
- ensure that an operand is larger, since it may be "less normalised".
- Normalization has to be moved into mpz-functions.
-
-Bennet Yee at CMU proposes:
-* mpz_{put,get}_raw for memory oriented I/O like other *_raw functions.
-* A function mpfatal that is called for exceptions. The user may override
- the default definition.
-
-* mout should group in 10-digit groups.
-* ASCII dependence?
-* Error reporting from I/O functions (linkoping)?
-
-* Make all computation mpz_* functions return a signed int indicating if
- the result was zero, positive, or negative?
-
-* Implement mpz_cmpabs, mpz_xor, mpz_to_double, mpz_to_si, mpz_lcm,
- mpz_dpb, mpz_ldb, various bit string operations like mpz_cntbits. Also
- mpz_@_si for most @??
-
-Brian Beuning proposes:
- 1. An array of small primes
- 3. A function to factor an MINT
- 4. A routine to look for "small" divisors of an MINT
- 5. A 'multiply mod n' routine based on Montgomery's algorithm.
-
-Doug Lea proposes:
- 1. A way to find out if an integer fits into a signed int, and if so, a
- way to convert it out.
- 2. Similarly for double precision float conversion.
- 3. A function to convert the ratio of two integers to a double. This
- can be useful for mixed mode operations with integers, rationals, and
- doubles.
- 5. Bit-setting, clearing, and testing operations, as in
- mpz_setbit(MP_INT* dest, MP_INT* src, unsigned long bit_number),
- and used, for example in
- mpz_setbit(x, x, 123)
- to directly set the 123rd bit of x.
- If these are supported, you don't first have to set up
- an otherwise unnecessary mpz holding a shifted value, then
- do an "or" operation.
-
-Elliptic curve method descrition in the Chapter `Algorithms in Number
-Theory' in the Handbook of Theoretical Computer Science, Elsevier,
-Amsterdam, 1990. Also in Carl Pomerance's lecture notes on Cryptology and
-Computational Number Theory, 1990.
-
-* New function: mpq_get_ifstr (int_str, frac_str, base,
- precision_in_som_way, rational_number). Convert RATIONAL_NUMBER to a
- string in BASE and put the integer part in INT_STR and the fraction part
- in FRAC_STR. (This function would do a division of the numerator and the
- denominator.)
-
-* Should mpz_powm* handle negative exponents?
-
-* udiv_qrnnd: If the denominator is normalized, the n0 argument has very
- little effect on the quotient. Maybe we can assume it is 0, and
- compensate at a later stage?
-
-* Better sqrt: First calculate the reciprocal square root, then multiply by
- the operand to get the square root. The reciprocal square root can be
- obtained through Newton-Raphson without division. The iteration is x :=
- x*(3-a*x^2)/2, where a is the operand.
-
-* Newton-Raphson using multiplication: We get twice as many correct digits
- in each iteration. So if we square x(k) as part of the iteration, the
- result will have the leading digits in common with the entire result from
- iteration k-1. A _mpn_mul_lowpart could implement this.
-
-* Peter Montgomery: If 0 <= a, b < p < 2^31 and I want a modular product
- a*b modulo p and the long long type is unavailable, then I can write
-
- typedef signed long slong;
- typedef unsigned long ulong;
- slong a, b, p, quot, rem;
-
- quot = (slong) (0.5 + (double)a * (double)b / (double)p);
- rem = (slong)((ulong)a * (ulong)b - (ulong)p * (ulong)q);
- if (rem < 0} {rem += p; quot--;}
-
-FFT:
-{
- * Multiplication could be done with Montgomery's method combined with
- the "three primes" method described in Lipson. Maybe this would be
- faster than to Nussbaumer's method with 3 (simple) moduli?
-
- * Maybe the modular tricks below are not needed: We are using very
- special numbers, Fermat numbers with a small base and a large exponent,
- and maybe it's possible to just subtract and add?
-
- * Modify Nussbaumer's convolution algorithm, to use 3 words for each
- coefficient, calculating in 3 relatively prime moduli (e.g.
- 0xffffffff, 0x100000000, and 0x7fff on a 32-bit computer). Both all
- operations and CRR would be very fast with such numbers.
-
- * Optimize the Shoenhage-Stassen multiplication algorithm. Take
- advantage of the real valued input to save half of the operations and
- half of the memory. Try recursive variants with large, optimized base
- cases. Use recursive FFT with large base cases, since recursive FFT
- has better memory locality. A normal FFT get 100% cache miss.
-}
-
-* Speed modulo arithmetic, using Montgomery's method or my pre-invertion
- method. In either case, special arithmetic calls would be needed,
- mpz_mmmul, mpz_mmadd, mpz_mmsub, plus some kind of initialization
- functions.
-
-* mpz_powm* should not use division to reduce the result in the loop, but
- instead pre-compute the reciprocal of the MOD argument and do reduced_val
- = val-val*reciprocal(MOD)*MOD, or use Montgomery's method.
-
-* mpz_mod_2expplussi -- to reduce a bignum modulo (2**n)+s
-
-* It would be a quite important feature never to allocate more memory than
- really necessary for a result. Sometimes we can achieve this cheaply, by
- deferring reallocation until the result size is known.
-
-* New macro in longlong.h: shift_rhl that extracts a word by shifting two
- words as a unit. (Supported by i386, i860, HP-PA, RS6000, 29k.) Useful
- for shifting multiple precision numbers.
-
-* The installation procedure should make a test run of multiplication to
- decide the threshold values for algorithm switching between the available
- methods.
-
-* The gcd algorithm could probably be improved with a divide-and-conquer
- (DAC) approach. At least the bulk of the operations should be done with
- single precision.
-
-* Fast output conversion of x to base B:
- 1. Find n, such that (B^n > x).
- 2. Set y to (x*2^m)/(B^n), where m large enough to make 2^n ~~ B^n
- 3. Multiply the low half of y by B^(n/2), and recursively convert the
- result. Truncate the low half of y and convert that recursively.
- Complexity: O(M(n)log(n))+O(D(n))!
-
-* Extensions for floating-point arithmetic.
-
-* Improve special cases for division.
-
- 1. When the divisor is just one word, normalization is not needed for
- most CPUs, and can be done in the division loop for CPUs that need
- normalization.
-
- 2. Even when the result is going to be very small, (i.e. nsize-dsize is
- small) normalization should also be done in the division loop.
-
- To fix this, a new routine mpn_div_unnormalized is needed.
-
-* Never allocate temporary space for a source param that overlaps with a
- destination param needing reallocation. Instead malloc a new block for
- the destination (and free the source before returning to the caller).
-
-* When any of the source operands overlap with the destination, mult (and
- other routines) slow down. This is so because the need of temporary
- allocation (with alloca) and copying. If a new destination were
- malloc'ed instead (and the overlapping source free'd before return) no
- copying would be needed. Is GNU malloc quick enough to make this faster
- even for reasonably small operands?
-\f
-Local Variables:
-mode: text
-fill-column: 75
-version-control: never
-End:
+++ /dev/null
-GNU MP version 1.3.2
+++ /dev/null
-/* _mpz_get_str (string, base, mp_src) -- Convert the multiple precision
- number MP_SRC to a string STRING of base BASE. If STRING is NULL
- allocate space for the result. In any case, return a pointer to the
- result. If STRING is not NULL, the caller must ensure enough space is
- available to store the result.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-#ifndef UMUL_TIME
-#define UMUL_TIME 1
-#endif
-
-#ifndef UDIV_TIME
-#define UDIV_TIME UMUL_TIME
-#endif
-
-#define udiv_qrnndx(q, r, nh, nl, d, di) \
- do { \
- unsigned long int _q, _ql, _r; \
- unsigned long int _xh, _xl; \
- umul_ppmm (_q, _ql, (nh), (di)); \
- _q += (nh); /* DI is 2**32 too small. Compensate */\
- if (_q < (nh)) \
- { \
- /* Got carry. Propagate it in the multiplication. */ \
- umul_ppmm (_xh, _xl, (d), _q); \
- _xh += (d); \
- } \
- else \
- umul_ppmm (_xh, _xl, (d), _q); \
- sub_ddmmss (_xh, _r, (nh), (nl), _xh, _xl); \
- if (_xh != 0) \
- { \
- sub_ddmmss (_xh, _r, _xh, _r, 0, (d)); \
- _q += 1; \
- if (_xh != 0) \
- { \
- sub_ddmmss (_xh, _r, _xh, _r, 0, (d)); \
- _q += 1; \
- } \
- } \
- if (_r >= (d)) \
- { \
- _r -= (d); \
- _q += 1; \
- } \
- (r) = _r; \
- (q) = _q; \
- } while (0)
-
-char *
-#ifdef __STDC__
-_mpz_get_str (char *str, int base, const MP_INT *m)
-#else
-_mpz_get_str (str, base, m)
- char *str;
- int base;
- const MP_INT *m;
-#endif
-{
- mp_ptr tp;
- mp_size msize;
- mp_limb big_base;
-#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME
-
- int normalization_steps;
-#if UDIV_TIME > 2 * UMUL_TIME
- mp_limb big_base_inverted;
-#endif
-#endif
- unsigned int dig_per_u;
- mp_size out_len;
- char *s;
- char *num_to_ascii;
-
- if (base >= 0)
- {
- if (base == 0)
- base = 10;
- num_to_ascii = "0123456789abcdefghijklmnopqrstuvwxyz";
- }
- else
- {
- base = -base;
- num_to_ascii = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
- }
-
- dig_per_u = __mp_bases[base].chars_per_limb;
- out_len = mpz_sizeinbase (m, base) + 1;
- big_base = __mp_bases[base].big_base;
-
- msize = m->size;
-
- if (str == NULL)
- str = (char *) (*_mp_allocate_func) (out_len + (msize < 0));
-
- if (msize < 0)
- *str++ = '-';
- s = str;
-
- msize = ABS (msize);
-
- /* Special case zero, as the code below doesn't handle it. */
- if (msize == 0)
- {
- s[0] = '0';
- s[1] = 0;
- return str;
- }
-
- if ((base & (base - 1)) == 0)
- {
- /* The base is a power of 2. Make conversion from most
- significant side. */
- mp_limb n1, n0;
- int bits_per_digit = big_base;
- int x;
- int bit_pos;
- int i;
- unsigned mask = (1 << bits_per_digit) - 1;
-
- tp = m->d;
- n1 = tp[msize - 1];
- count_leading_zeros (x, n1);
-
- /* BIT_POS should be R when input ends in least sign. nibble,
- R + bits_per_digit * n when input ends in n:th least significant
- nibble. */
-
- {
- int bits;
-
- bits = BITS_PER_MP_LIMB * msize - x;
- x = bits % bits_per_digit;
- if (x != 0)
- bits += bits_per_digit - x;
- bit_pos = bits - (msize - 1) * BITS_PER_MP_LIMB;
- }
-
- /* Fast loop for bit output. */
- i = msize - 1;
- for (;;)
- {
- bit_pos -= bits_per_digit;
- while (bit_pos >= 0)
- {
- *s++ = num_to_ascii[(n1 >> bit_pos) & mask];
- bit_pos -= bits_per_digit;
- }
- i--;
- if (i < 0)
- break;
- n0 = (n1 << -bit_pos) & mask;
- n1 = tp[i];
- bit_pos += BITS_PER_MP_LIMB;
- *s++ = num_to_ascii[n0 | (n1 >> bit_pos)];
- }
-
- *s = 0;
- }
- else
- {
- /* General case. The base is not a power of 2. Make conversion
- from least significant end. */
-
- /* If udiv_qrnnd only handles divisors with the most significant bit
- set, prepare BIG_BASE for being a divisor by shifting it to the
- left exactly enough to set the most significant bit. */
-#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME
- count_leading_zeros (normalization_steps, big_base);
- big_base <<= normalization_steps;
-#if UDIV_TIME > 2 * UMUL_TIME
- /* Get the fixed-point approximation to 1/BIG_BASE. */
- big_base_inverted = __mp_bases[base].big_base_inverted;
-#endif
-#endif
-
- out_len--; /* now not include terminating \0 */
- s += out_len;
-
- /* Allocate temporary space and move the multi prec number to
- convert there, as we need to overwrite it below, while
- computing the successive remainders. */
- tp = (mp_ptr) alloca ((msize + 1) * BYTES_PER_MP_LIMB);
- MPN_COPY (tp, m->d, msize);
-
- while (msize != 0)
- {
- int i;
- mp_limb n0, n1;
-
-#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME
- /* If we shifted BIG_BASE above, shift the dividend too, to get
- the right quotient. We need to do this every loop,
- as the intermediate quotients are OK, but the quotient from
- one turn in the loop is going to be the dividend in the
- next turn, and the dividend needs to be up-shifted. */
- if (normalization_steps != 0)
- {
- n0 = mpn_lshift (tp, tp, msize, normalization_steps);
-
- /* If the shifting gave a carry out limb, store it and
- increase the length. */
- if (n0 != 0)
- {
- tp[msize] = n0;
- msize++;
- }
- }
-#endif
-
- /* Divide the number at TP with BIG_BASE to get a quotient and a
- remainder. The remainder is our new digit in base BIG_BASE. */
- i = msize - 1;
- n1 = tp[i];
-
- if (n1 >= big_base)
- n1 = 0;
- else
- {
- msize--;
- i--;
- }
-
- for (; i >= 0; i--)
- {
- n0 = tp[i];
-#if UDIV_TIME > 2 * UMUL_TIME
- udiv_qrnndx (tp[i], n1, n1, n0, big_base, big_base_inverted);
-#else
- udiv_qrnnd (tp[i], n1, n1, n0, big_base);
-#endif
- }
-
-#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME
- /* If we shifted above (at previous UDIV_NEEDS_NORMALIZATION tests)
- the remainder will be up-shifted here. Compensate. */
- n1 >>= normalization_steps;
-#endif
-
- /* Convert N1 from BIG_BASE to a string of digits in BASE
- using single precision operations. */
- for (i = dig_per_u - 1; i >= 0; i--)
- {
- *--s = num_to_ascii[n1 % base];
- n1 /= base;
- /* Break from the loop as soon as we would only write zeros. */
- if (n1 == 0 && msize == 0)
- break;
- }
- }
-
- /* There should be no leading zeros. */
- if (*s == '0')
- abort ();
-
- if (s == str)
- {
- /* This should be the common case. */
- s[out_len] = 0;
- }
- else if (s == str + 1)
- {
- /* The string became 1 digit shorter than its maximum. */
- /* Need to copy it back one char pos. */
- out_len--;
-#ifndef HAS_MEMMOVE
- {
- size_t i;
-
- for (i = 0; i < out_len; i++)
- str[i] = s[i];
- }
-#else
- memmove (str, s, out_len);
-#endif
- str[out_len] = 0;
- }
- else
- {
- /* Hopefully never. */
- abort ();
- }
- }
-
- alloca (0);
- /* Ugly, we incremented str for negative numbers. Fix that here. */
- return str - (m->size < 0);
-}
+++ /dev/null
-/* _mpz_set_str(mp_dest, string, base) -- Convert the \0-terminated
- string STRING in base BASE to multiple precision integer in
- MP_DEST. Allow white space in the string. If BASE == 0 determine
- the base in the C standard way, i.e. 0xhh...h means base 16,
- 0oo...o means base 8, otherwise assume base 10.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-enum char_type
-{
- XX = -3,
- SPC = -2,
- EOF = -1
-};
-
-static signed char ascii_to_num[256] =
-{
- EOF,XX, XX, XX, XX, XX, XX, XX, XX, SPC,SPC,XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- SPC,XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, XX, XX, XX, XX, XX, XX,
- XX, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24,
- 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, XX, XX, XX, XX, XX,
- XX, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24,
- 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX,
- XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX, XX
-};
-
-int
-#ifdef __STDC__
-_mpz_set_str (MP_INT *x, const char *str, int base)
-#else
-_mpz_set_str (x, str, base)
- MP_INT *x;
- const char *str;
- int base;
-#endif
-{
- mp_ptr xp;
- mp_size size;
- mp_limb big_base;
- int indigits_per_limb;
- int negative = 0;
- int inp_rawchar;
- mp_limb inp_digit;
- mp_limb res_digit;
- size_t str_len;
- mp_size i;
-
- if (str[0] == '-')
- {
- negative = 1;
- str++;
- }
-
- if (base == 0)
- {
- if (str[0] == '0')
- {
- if (str[1] == 'x' || str[1] == 'X')
- base = 16;
- else
- base = 8;
- }
- else
- base = 10;
- }
-
- big_base = __mp_bases[base].big_base;
- indigits_per_limb = __mp_bases[base].chars_per_limb;
-
- str_len = strlen (str);
-
- size = str_len / indigits_per_limb + 1;
- if (x->alloc < size)
- _mpz_realloc (x, size);
- xp = x->d;
-
- size = 0;
-
- if ((base & (base - 1)) == 0)
- {
- /* The base is a power of 2. Read the input string from
- least to most significant character/digit. */
-
- const char *s;
- int next_bitpos;
- int bits_per_indigit = big_base;
-
- /* Accept and ignore 0x or 0X before hexadecimal numbers. */
- if (base == 16 && str[0] == '0' && (str[1] == 'x' || str[1] == 'X'))
- {
- str += 2;
- str_len -= 2;
- }
-
- res_digit = 0;
- next_bitpos = 0;
-
- for (s = str + str_len - 1; s >= str; s--)
- {
- inp_rawchar = *s;
- inp_digit = ascii_to_num[inp_rawchar];
-
- if (inp_digit >= base)
- {
- /* Was it white space? Just ignore it. */
- if ((char) inp_digit == (char) SPC)
- continue;
-
- /* We found rubbish in the string. Return -1 to indicate
- the error. */
- return -1;
- }
-
- res_digit |= inp_digit << next_bitpos;
- next_bitpos += bits_per_indigit;
- if (next_bitpos >= BITS_PER_MP_LIMB)
- {
- xp[size] = res_digit;
- size++;
- next_bitpos -= BITS_PER_MP_LIMB;
- res_digit = inp_digit >> (bits_per_indigit - next_bitpos);
- }
- }
-
- xp[size] = res_digit;
- size++;
- for (i = size - 1; i >= 0; i--)
- {
- if (xp[i] != 0)
- break;
- }
- size = i + 1;
- }
- else
- {
- /* General case. The base is not a power of 2. */
-
- mp_size i;
- int j;
- mp_limb cy;
-
- for (;;)
- {
- res_digit = 0;
- for (j = 0; j < indigits_per_limb; )
- {
- inp_rawchar = (unsigned char) *str++;
- inp_digit = ascii_to_num[inp_rawchar];
-
- /* Negative means that the character was not a proper digit. */
- if (inp_digit >= base)
- {
- /* Was it white space? Just ignore it. */
- if ((char) inp_digit == (char) SPC)
- continue;
-
- goto end_or_error;
- }
-
- res_digit = res_digit * base + inp_digit;
-
- /* Increment the loop counter here, since it mustn't be
- incremented when we do "continue" above. */
- j++;
- }
-
- cy = res_digit;
-
- /* Insert RES_DIGIT into the result multi prec integer. */
- for (i = 0; i < size; i++)
- {
- mp_limb p1, p0;
- umul_ppmm (p1, p0, big_base, xp[i]);
- p0 += cy;
- cy = p1 + (p0 < cy);
- xp[i] = p0;
- }
- if (cy != 0)
- {
- xp[size] = cy;
- size++;
- }
- }
-
- end_or_error:
- /* We probably have some digits in RES_DIGIT (J tells how many). */
- if ((char) inp_digit != (char) EOF)
- {
- /* Error return. */
- return -1;
- }
-
- /* J contains number of digits (in base BASE) remaining in
- RES_DIGIT. */
- if (j > 0)
- {
- big_base = 1;
- do
- {
- big_base *= base;
- j--;
- }
- while (j > 0);
-
- cy = res_digit;
-
- /* Insert ultimate RES_DIGIT into the result multi prec integer. */
- for (i = 0; i < size; i++)
- {
- mp_limb p1, p0;
- umul_ppmm (p1, p0, big_base, xp[i]);
- p0 += cy;
- cy = p1 + (p0 < cy);
- xp[i] = p0;
- }
- if (cy != 0)
- {
- xp[size] = cy;
- size++;
- }
- }
- }
-
- if (negative)
- size = -size;
- x->size = size;
-
- return 0;
-}
+++ /dev/null
-/* alloca.c -- allocate automatically reclaimed memory
- (Mostly) portable public-domain implementation -- D A Gwyn
-
- This implementation of the PWB library alloca function,
- which is used to allocate space off the run-time stack so
- that it is automatically reclaimed upon procedure exit,
- was inspired by discussions with J. Q. Johnson of Cornell.
- J.Otto Tennant <jot@cray.com> contributed the Cray support.
-
- There are some preprocessor constants that can
- be defined when compiling for your specific system, for
- improved efficiency; however, the defaults should be okay.
-
- The general concept of this implementation is to keep
- track of all alloca-allocated blocks, and reclaim any
- that are found to be deeper in the stack than the current
- invocation. This heuristic does not reclaim storage as
- soon as it becomes invalid, but it will do so eventually.
-
- As a special case, alloca(0) reclaims storage without
- allocating any. It is a good idea to use alloca(0) in
- your main control loop, etc. to force garbage collection. */
-
-#ifdef HAVE_CONFIG_H
-#include "config.h"
-#endif
-
-/* If compiling with GCC, this file's not needed. */
-#ifndef alloca
-
-#ifdef emacs
-#ifdef static
-/* actually, only want this if static is defined as ""
- -- this is for usg, in which emacs must undefine static
- in order to make unexec workable
- */
-#ifndef STACK_DIRECTION
-you
-lose
--- must know STACK_DIRECTION at compile-time
-#endif /* STACK_DIRECTION undefined */
-#endif /* static */
-#endif /* emacs */
-
-#ifdef emacs
-#define free xfree
-#endif
-
-/* If your stack is a linked list of frames, you have to
- provide an "address metric" ADDRESS_FUNCTION macro. */
-
-#ifdef CRAY
-long i00afunc ();
-#define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg))
-#else
-#define ADDRESS_FUNCTION(arg) &(arg)
-#endif
-
-#if __STDC__
-typedef void *pointer;
-#else
-typedef char *pointer;
-#endif
-
-#define NULL 0
-
-extern pointer (*_mp_allocate_func) ();
-extern void (*_mp_free_func) ();
-
-/* Define STACK_DIRECTION if you know the direction of stack
- growth for your system; otherwise it will be automatically
- deduced at run-time.
-
- STACK_DIRECTION > 0 => grows toward higher addresses
- STACK_DIRECTION < 0 => grows toward lower addresses
- STACK_DIRECTION = 0 => direction of growth unknown */
-
-#ifndef STACK_DIRECTION
-#define STACK_DIRECTION 0 /* Direction unknown. */
-#endif
-
-#if STACK_DIRECTION != 0
-
-#define STACK_DIR STACK_DIRECTION /* Known at compile-time. */
-
-#else /* STACK_DIRECTION == 0; need run-time code. */
-
-static int stack_dir; /* 1 or -1 once known. */
-#define STACK_DIR stack_dir
-
-static void
-find_stack_direction ()
-{
- static char *addr = NULL; /* Address of first `dummy', once known. */
- auto char dummy; /* To get stack address. */
-
- if (addr == NULL)
- { /* Initial entry. */
- addr = ADDRESS_FUNCTION (dummy);
-
- find_stack_direction (); /* Recurse once. */
- }
- else
- {
- /* Second entry. */
- if (ADDRESS_FUNCTION (dummy) > addr)
- stack_dir = 1; /* Stack grew upward. */
- else
- stack_dir = -1; /* Stack grew downward. */
- }
-}
-
-#endif /* STACK_DIRECTION == 0 */
-
-/* An "alloca header" is used to:
- (a) chain together all alloca'ed blocks;
- (b) keep track of stack depth.
-
- It is very important that sizeof(header) agree with malloc
- alignment chunk size. The following default should work okay. */
-
-#ifndef ALIGN_SIZE
-#define ALIGN_SIZE sizeof(double)
-#endif
-
-typedef union hdr
-{
- char align[ALIGN_SIZE]; /* To force sizeof(header). */
- struct
- {
- union hdr *next; /* For chaining headers. */
- char *deep; /* For stack depth measure. */
- } h;
-} header;
-
-static header *last_alloca_header = NULL; /* -> last alloca header. */
-
-/* Return a pointer to at least SIZE bytes of storage,
- which will be automatically reclaimed upon exit from
- the procedure that called alloca. Originally, this space
- was supposed to be taken from the current stack frame of the
- caller, but that method cannot be made to work for some
- implementations of C, for example under Gould's UTX/32. */
-
-pointer
-alloca (size)
- unsigned size;
-{
- auto char probe; /* Probes stack depth: */
- register char *depth = ADDRESS_FUNCTION (probe);
-
-#if STACK_DIRECTION == 0
- if (STACK_DIR == 0) /* Unknown growth direction. */
- find_stack_direction ();
-#endif
-
- /* Reclaim garbage, defined as all alloca'd storage that
- was allocated from deeper in the stack than currently. */
-
- {
- register header *hp; /* Traverses linked list. */
-
- for (hp = last_alloca_header; hp != NULL;)
- if ((STACK_DIR > 0 && hp->h.deep > depth)
- || (STACK_DIR < 0 && hp->h.deep < depth))
- {
- register header *np = hp->h.next;
-
- (*_mp_free_func) ((pointer) hp); /* Collect garbage. */
-
- hp = np; /* -> next header. */
- }
- else
- break; /* Rest are not deeper. */
-
- last_alloca_header = hp; /* -> last valid storage. */
- }
-
- if (size == 0)
- return NULL; /* No allocation required. */
-
- /* Allocate combined header + user data storage. */
-
- {
- register pointer new = (*_mp_allocate_func) (sizeof (header) + size);
- /* Address of header. */
-
- ((header *) new)->h.next = last_alloca_header;
- ((header *) new)->h.deep = depth;
-
- last_alloca_header = (header *) new;
-
- /* User storage begins just after header. */
-
- return (pointer) ((char *) new + sizeof (header));
- }
-}
-
-#ifdef CRAY
-
-#ifdef DEBUG_I00AFUNC
-#include <stdio.h>
-#endif
-
-#ifndef CRAY_STACK
-#define CRAY_STACK
-#ifndef CRAY2
-/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */
-struct stack_control_header
- {
- long shgrow:32; /* Number of times stack has grown. */
- long shaseg:32; /* Size of increments to stack. */
- long shhwm:32; /* High water mark of stack. */
- long shsize:32; /* Current size of stack (all segments). */
- };
-
-/* The stack segment linkage control information occurs at
- the high-address end of a stack segment. (The stack
- grows from low addresses to high addresses.) The initial
- part of the stack segment linkage control information is
- 0200 (octal) words. This provides for register storage
- for the routine which overflows the stack. */
-
-struct stack_segment_linkage
- {
- long ss[0200]; /* 0200 overflow words. */
- long sssize:32; /* Number of words in this segment. */
- long ssbase:32; /* Offset to stack base. */
- long:32;
- long sspseg:32; /* Offset to linkage control of previous
- segment of stack. */
- long:32;
- long sstcpt:32; /* Pointer to task common address block. */
- long sscsnm; /* Private control structure number for
- microtasking. */
- long ssusr1; /* Reserved for user. */
- long ssusr2; /* Reserved for user. */
- long sstpid; /* Process ID for pid based multi-tasking. */
- long ssgvup; /* Pointer to multitasking thread giveup. */
- long sscray[7]; /* Reserved for Cray Research. */
- long ssa0;
- long ssa1;
- long ssa2;
- long ssa3;
- long ssa4;
- long ssa5;
- long ssa6;
- long ssa7;
- long sss0;
- long sss1;
- long sss2;
- long sss3;
- long sss4;
- long sss5;
- long sss6;
- long sss7;
- };
-
-#else /* CRAY2 */
-/* The following structure defines the vector of words
- returned by the STKSTAT library routine. */
-struct stk_stat
- {
- long now; /* Current total stack size. */
- long maxc; /* Amount of contiguous space which would
- be required to satisfy the maximum
- stack demand to date. */
- long high_water; /* Stack high-water mark. */
- long overflows; /* Number of stack overflow ($STKOFEN) calls. */
- long hits; /* Number of internal buffer hits. */
- long extends; /* Number of block extensions. */
- long stko_mallocs; /* Block allocations by $STKOFEN. */
- long underflows; /* Number of stack underflow calls ($STKRETN). */
- long stko_free; /* Number of deallocations by $STKRETN. */
- long stkm_free; /* Number of deallocations by $STKMRET. */
- long segments; /* Current number of stack segments. */
- long maxs; /* Maximum number of stack segments so far. */
- long pad_size; /* Stack pad size. */
- long current_address; /* Current stack segment address. */
- long current_size; /* Current stack segment size. This
- number is actually corrupted by STKSTAT to
- include the fifteen word trailer area. */
- long initial_address; /* Address of initial segment. */
- long initial_size; /* Size of initial segment. */
- };
-
-/* The following structure describes the data structure which trails
- any stack segment. I think that the description in 'asdef' is
- out of date. I only describe the parts that I am sure about. */
-
-struct stk_trailer
- {
- long this_address; /* Address of this block. */
- long this_size; /* Size of this block (does not include
- this trailer). */
- long unknown2;
- long unknown3;
- long link; /* Address of trailer block of previous
- segment. */
- long unknown5;
- long unknown6;
- long unknown7;
- long unknown8;
- long unknown9;
- long unknown10;
- long unknown11;
- long unknown12;
- long unknown13;
- long unknown14;
- };
-
-#endif /* CRAY2 */
-#endif /* not CRAY_STACK */
-
-#ifdef CRAY2
-/* Determine a "stack measure" for an arbitrary ADDRESS.
- I doubt that "lint" will like this much. */
-
-static long
-i00afunc (long *address)
-{
- struct stk_stat status;
- struct stk_trailer *trailer;
- long *block, size;
- long result = 0;
-
- /* We want to iterate through all of the segments. The first
- step is to get the stack status structure. We could do this
- more quickly and more directly, perhaps, by referencing the
- $LM00 common block, but I know that this works. */
-
- STKSTAT (&status);
-
- /* Set up the iteration. */
-
- trailer = (struct stk_trailer *) (status.current_address
- + status.current_size
- - 15);
-
- /* There must be at least one stack segment. Therefore it is
- a fatal error if "trailer" is null. */
-
- if (trailer == 0)
- abort ();
-
- /* Discard segments that do not contain our argument address. */
-
- while (trailer != 0)
- {
- block = (long *) trailer->this_address;
- size = trailer->this_size;
- if (block == 0 || size == 0)
- abort ();
- trailer = (struct stk_trailer *) trailer->link;
- if ((block <= address) && (address < (block + size)))
- break;
- }
-
- /* Set the result to the offset in this segment and add the sizes
- of all predecessor segments. */
-
- result = address - block;
-
- if (trailer == 0)
- {
- return result;
- }
-
- do
- {
- if (trailer->this_size <= 0)
- abort ();
- result += trailer->this_size;
- trailer = (struct stk_trailer *) trailer->link;
- }
- while (trailer != 0);
-
- /* We are done. Note that if you present a bogus address (one
- not in any segment), you will get a different number back, formed
- from subtracting the address of the first block. This is probably
- not what you want. */
-
- return (result);
-}
-
-#else /* not CRAY2 */
-/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP.
- Determine the number of the cell within the stack,
- given the address of the cell. The purpose of this
- routine is to linearize, in some sense, stack addresses
- for alloca. */
-
-static long
-i00afunc (long address)
-{
- long stkl = 0;
-
- long size, pseg, this_segment, stack;
- long result = 0;
-
- struct stack_segment_linkage *ssptr;
-
- /* Register B67 contains the address of the end of the
- current stack segment. If you (as a subprogram) store
- your registers on the stack and find that you are past
- the contents of B67, you have overflowed the segment.
-
- B67 also points to the stack segment linkage control
- area, which is what we are really interested in. */
-
- stkl = CRAY_STACKSEG_END ();
- ssptr = (struct stack_segment_linkage *) stkl;
-
- /* If one subtracts 'size' from the end of the segment,
- one has the address of the first word of the segment.
-
- If this is not the first segment, 'pseg' will be
- nonzero. */
-
- pseg = ssptr->sspseg;
- size = ssptr->sssize;
-
- this_segment = stkl - size;
-
- /* It is possible that calling this routine itself caused
- a stack overflow. Discard stack segments which do not
- contain the target address. */
-
- while (!(this_segment <= address && address <= stkl))
- {
-#ifdef DEBUG_I00AFUNC
- fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl);
-#endif
- if (pseg == 0)
- break;
- stkl = stkl - pseg;
- ssptr = (struct stack_segment_linkage *) stkl;
- size = ssptr->sssize;
- pseg = ssptr->sspseg;
- this_segment = stkl - size;
- }
-
- result = address - this_segment;
-
- /* If you subtract pseg from the current end of the stack,
- you get the address of the previous stack segment's end.
- This seems a little convoluted to me, but I'll bet you save
- a cycle somewhere. */
-
- while (pseg != 0)
- {
-#ifdef DEBUG_I00AFUNC
- fprintf (stderr, "%011o %011o\n", pseg, size);
-#endif
- stkl = stkl - pseg;
- ssptr = (struct stack_segment_linkage *) stkl;
- size = ssptr->sssize;
- pseg = ssptr->sspseg;
- result += size;
- }
- return (result);
-}
-
-#endif /* not CRAY2 */
-#endif /* CRAY */
-
-#endif /* no alloca */
+++ /dev/null
-/* cre-conv-tab.c -- Create conversion table in a wordsize-dependent way.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-extern double floor ();
-extern double log ();
-
-static unsigned long int
-upow (b, e)
- unsigned long int b;
- unsigned int e;
-{
- unsigned long int y = 1;
-
- while (e != 0)
- {
- while ((e & 1) == 0)
- {
- b = b * b;
- e >>= 1;
- }
- y = y * b;
- e -= 1;
- }
-
- return y;
-}
-
-unsigned int
-ulog2 (x)
- unsigned long int x;
-{
- unsigned int i;
- for (i = 0; x != 0; i++)
- x >>= 1;
- return i;
-}
-
-main ()
-{
- int i;
- unsigned long idig;
- unsigned long big_base, big_base_inverted;
- double fdig;
- int dummy;
- int normalization_steps;
-
- unsigned long int max_uli;
- int bits_uli;
-
- max_uli = 1;
- for (i = 1; ; i++)
- {
- if ((max_uli << 1) == 0)
- break;
- max_uli <<= 1;
- }
- bits_uli = i;
-
- puts ("/* __mp_bases -- Structure for conversion between internal binary");
- puts (" format and strings in base 2..36. The fields are explained in");
- puts (" gmp-impl.h.");
- puts ("");
- puts (" ***** THIS FILE WAS CREATED BY A PROGRAM. DON'T EDIT IT! *****");
- puts ("");
- puts ("Copyright (C) 1991 Free Software Foundation, Inc.");
- puts ("");
- puts ("This file is part of the GNU MP Library.");
- puts ("");
- puts ("The GNU MP Library is free software; you can redistribute it and/or");
- puts ("modify it under the terms of the GNU General Public License as");
- puts ("published by the Free Software Foundation; either version 2, or");
- puts ("(at your option) any later version.");
- puts ("");
- puts ("The GNU MP Library is distributed in the hope that it will be");
- puts ("useful, but WITHOUT ANY WARRANTY; without even the implied warranty");
- puts ("of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the");
- puts ("GNU General Public License for more details.");
- puts ("");
- puts ("You should have received a copy of the GNU General Public License");
- puts ("along with the GNU MP Library; see the file COPYING. If not, write");
- puts ("to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139,");
- puts ("USA. */");
- puts ("");
- puts ("#include \"gmp.h\"");
- puts ("#include \"gmp-impl.h\"");
- puts ("");
-
- puts ("const struct bases __mp_bases[37] =\n{");
- puts (" /* 0 */ {0, 0, 0, 0.0},");
- puts (" /* 1 */ {0, 0, 0, 0.0},");
- for (i = 2; i <= 36; i++)
- {
- /* The weird expression here is because many /bin/cc compilers
- generate incorrect code for conversions from large unsigned
- integers to double. */
- fdig = log(2.0)/log((double) i);
- idig = floor(bits_uli * fdig);
- if ((i & (i - 1)) == 0)
- {
- big_base = ulog2 (i) - 1;
- big_base_inverted = 0;
- }
- else
- {
- big_base = upow (i, idig);
- for (normalization_steps = 0;
- (long int) (big_base << normalization_steps) >= 0;
- normalization_steps++)
- ;
- udiv_qrnnd (big_base_inverted, dummy,
- -(big_base << normalization_steps), 0,
- big_base << normalization_steps);
- }
- printf (" /* %2u */ {%lu, 0x%lX, 0x%lX, %.8f},\n",
- i, idig, big_base, big_base_inverted, fdig);
- }
- puts ("};");
-
- exit (0);
-}
+++ /dev/null
-/* cre-mparam.c -- Create machine-depedent parameter file.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-
-unsigned int
-ulog2 (x)
- unsigned long int x;
-{
- unsigned int i;
- for (i = 0; x != 0; i++)
- x >>= 1;
- return i;
-}
-
-main ()
-{
- int i;
-
- unsigned long int max_uli;
- int bits_uli;
-
- unsigned long int max_ui;
- int bits_ui;
-
- unsigned long int max_usi;
- int bits_usi;
-
- unsigned long int max_uc;
- int bits_uc;
-
- max_uli = 1;
- for (i = 0; ; i++)
- {
- if (max_uli == 0)
- break;
- max_uli <<= 1;
- }
- bits_uli = i;
-
- max_ui = 1;
- for (i = 0; ; i++)
- {
- if ((unsigned int) max_ui == 0)
- break;
- max_ui <<= 1;
- }
- bits_ui = i;
-
- max_usi = 1;
- for (i = 0; ; i++)
- {
- if ((unsigned short int) max_usi == 0)
- break;
- max_usi <<= 1;
- }
- bits_usi = i;
-
- max_uc = 1;
- for (i = 0; ; i++)
- {
- if ((unsigned char) max_uc == 0)
- break;
- max_uc <<= 1;
- }
- bits_uc = i;
-
- puts ("/* gmp-mparam.h -- Compiler/machine parameter header file.");
- puts ("");
- puts (" ***** THIS FILE WAS CREATED BY A PROGRAM. DON'T EDIT IT! *****");
- puts ("");
- puts ("Copyright (C) 1991 Free Software Foundation, Inc.");
- puts ("");
- puts ("This file is part of the GNU MP Library.");
- puts ("");
- puts ("The GNU MP Library is free software; you can redistribute it and/or");
- puts ("modify it under the terms of the GNU General Public License as");
- puts ("published by the Free Software Foundation; either version 2, or");
- puts ("(at your option) any later version.");
- puts ("");
- puts ("The GNU MP Library is distributed in the hope that it will be");
- puts ("useful, but WITHOUT ANY WARRANTY; without even the implied warranty");
- puts ("of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the");
- puts ("GNU General Public License for more details.");
- puts ("");
- puts ("You should have received a copy of the GNU General Public License");
- puts ("along with the GNU MP Library; see the file COPYING. If not, write");
- puts ("to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139,");
- puts ("USA. */");
- puts ("");
-
- printf ("#define BITS_PER_MP_LIMB %d\n", bits_uli);
- printf ("#define BYTES_PER_MP_LIMB %d\n", sizeof(mp_limb));
-
- printf ("#define BITS_PER_LONGINT %d\n", bits_uli);
- printf ("#define BITS_PER_INT %d\n", bits_ui);
- printf ("#define BITS_PER_SHORTINT %d\n", bits_usi);
- printf ("#define BITS_PER_CHAR %d\n", bits_uc);
-
- exit (0);
-}
+++ /dev/null
-/* cre-stddefh.c -- Check the size of a pointer and output an
- appropriate size_t declaration.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include <stdio.h>
-
-main (argc, argv)
- int argc;
- char **argv;
-{
- if (sizeof (int *) == sizeof (unsigned long int))
- puts ("typedef unsigned long int size_t;");
- else
- if (sizeof (int *) == sizeof (unsigned int))
- puts ("typedef unsigned int size_t;");
- else
- {
- fprintf (stderr,
- "%s: Can't find a reasonable definition for \"size_t\".\n",
- argv[0]);
- exit (1);
- }
-
- exit (0);
-}
+++ /dev/null
-/* Include file for internal GNU MP types and definitions.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#if defined (__GNUC__) || defined (__sparc__) || defined (sparc)
-#define alloca __builtin_alloca
-#endif
-
-#ifndef NULL
-#define NULL 0L
-#endif
-
-#if defined (__GNUC__)
-volatile void abort (void);
-#else
-#define inline /* Empty */
-void *alloca();
-#endif
-
-#define ABS(x) (x >= 0 ? x : -x)
-
-#include "gmp-mparam.h"
-
-/*
- Cosmetic, but when running mkdependC on this under linux-2.x,
- we're warned about redefinition of signed (done in sys/cdefs.h).
- To avoid this wibble, we've weakened the #if below.
- */
-#if defined(__STDC__) || defined(__linux__)
-void *malloc (size_t);
-void *realloc (void *, size_t);
-void free (void *);
-
-extern void * (*_mp_allocate_func) (size_t);
-extern void * (*_mp_reallocate_func) (void *, size_t, size_t);
-extern void (*_mp_free_func) (void *, size_t);
-
-void *_mp_default_allocate (size_t);
-void *_mp_default_reallocate (void *, size_t, size_t);
-void _mp_default_free (void *, size_t);
-
-char *_mpz_get_str (char *, int, const MP_INT *);
-int _mpz_set_str (MP_INT *, const char *, int);
-void _mpz_impl_sqrt (MP_INT *, MP_INT *, const MP_INT *);
-#else
-#define const /* Empty */
-#define signed /* Empty */
-
-void *malloc ();
-void *realloc ();
-void free ();
-
-extern void * (*_mp_allocate_func) ();
-extern void * (*_mp_reallocate_func) ();
-extern void (*_mp_free_func) ();
-
-void *_mp_default_allocate ();
-void *_mp_default_reallocate ();
-void _mp_default_free ();
-
-char *_mpz_get_str ();
-int _mpz_set_str ();
-void _mpz_impl_sqrt ();
-#endif
-
-/* Copy NLIMBS *limbs* from SRC to DST. */
-#define MPN_COPY(DST, SRC, NLIMBS) \
- do { \
- mp_size i; \
- for (i = 0; i < (NLIMBS); i++) \
- (DST)[i] = (SRC)[i]; \
- } while (0)
-/* Zero NLIMBS *limbs* AT DST. */
-#define MPN_ZERO(DST, NLIMBS) \
- do { \
- mp_size i; \
- for (i = 0; i < (NLIMBS); i++) \
- (DST)[i] = 0; \
- } while (0)
-
-/* Initialize the MP_INT X with space for NLIMBS limbs.
- X should be a temporary variable, and it will be automatically
- cleared out when the running function returns. */
-#define MPZ_TMP_INIT(X, NLIMBS) \
- do { \
- (X)->alloc = (NLIMBS); \
- (X)->d = (mp_ptr) alloca ((NLIMBS) * BYTES_PER_MP_LIMB); \
- } while (0)
-
-/* Structure for conversion between internal binary format and
- strings in base 2..36. */
-struct bases
-{
- /* Number of digits in the conversion base that always fits in
- an mp_limb. For example, for base 10 this is 10, since
- 2**32 = 4294967296 has ten digits. */
- int chars_per_limb;
-
- /* big_base is conversion_base**chars_per_limb, i.e. the biggest
- number that fits a word, built by factors of conversion_base.
- Exception: For 2, 4, 8, etc, big_base is log2(base), i.e. the
- number of bits used to represent each digit in the base. */
- mp_limb big_base;
-
- /* big_base_inverted is a BITS_PER_MP_LIMB bit approximation to
- 1/big_base, represented as a fixed-point number. Instead of
- dividing by big_base an application can choose to multiply
- by big_base_inverted. */
- mp_limb big_base_inverted;
-
- /* log(2)/log(conversion_base) */
- float chars_per_bit_exactly;
-};
-
-extern const struct bases __mp_bases[37];
+++ /dev/null
-/* gmp.h -- Definitions for GNU multiple precision functions.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#ifndef __GMP_H__
-#define __GMP_H__
-
-#define __GNU_MP__
-
-#ifndef __MP_H__
-#define __need_size_t
-#include <stddef.h>
-#endif
-
-#ifndef MINT
-#ifndef __MP_SMALL__
-typedef struct
-{
- long int alloc; /* Number of *limbs* allocated and pointed
- to by the D field. */
- long int size; /* abs(SIZE) is the number of limbs
- the last field points to. If SIZE
- is negative this is a negative
- number. */
- unsigned long int *d; /* Pointer to the limbs. */
-} __MP_INT;
-#else
-typedef struct
-{
- short int alloc; /* Number of *limbs* allocated and pointed
- to by the D field. */
- short int size; /* abs(SIZE) is the number of limbs
- the last field points to. If SIZE
- is negative this is a negative
- number. */
- unsigned long int *d; /* Pointer to the limbs. */
-} __MP_INT;
-#endif
-#endif
-
-#define MP_INT __MP_INT
-
-typedef unsigned long int mp_limb;
-typedef long int mp_limb_signed;
-typedef mp_limb * mp_ptr;
-#ifdef __STDC__
-typedef const mp_limb * mp_srcptr;
-#else
-typedef mp_limb * mp_srcptr;
-#endif
-typedef long int mp_size;
-
-/* Structure for rational numbers. Zero is represented as 0/any, i.e.
- the denominator is ignored. Negative numbers have the sign in
- the numerator. */
-typedef struct
-{
- MP_INT num;
- MP_INT den;
-#if 0
- long int num_alloc; /* Number of limbs allocated
- for the numerator. */
- long int num_size; /* The absolute value of this field is the
- length of the numerator; the sign is the
- sign of the entire rational number. */
- mp_ptr num; /* Pointer to the numerator limbs. */
- long int den_alloc; /* Number of limbs allocated
- for the denominator. */
- long int den_size; /* Length of the denominator. (This field
- should always be positive.) */
- mp_ptr den; /* Pointer to the denominator limbs. */
-#endif
-} MP_RAT;
-
-#ifdef __STDC__
-void mp_set_memory_functions (void *(*) (size_t),
- void *(*) (void *, size_t, size_t),
- void (*) (void *, size_t));
-
-/**************** Integer (i.e. Z) routines. ****************/
-
-void mpz_init (MP_INT *);
-void mpz_set (MP_INT *, const MP_INT *);
-void mpz_set_ui (MP_INT *, unsigned long int);
-void mpz_set_si (MP_INT *, signed long int);
-int mpz_set_str (MP_INT *, const char *, int);
-void mpz_init_set (MP_INT *, const MP_INT *);
-void mpz_init_set_ui (MP_INT *, unsigned long int);
-void mpz_init_set_si (MP_INT *, signed long int);
-int mpz_init_set_str (MP_INT *, const char *, int);
-unsigned long int mpz_get_ui (const MP_INT *);
-signed long int mpz_get_si (const MP_INT *);
-char * mpz_get_str (char *, int, const MP_INT *);
-void mpz_clear (MP_INT *);
-void * _mpz_realloc (MP_INT *, mp_size);
-void mpz_add (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_add_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_sub (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_sub_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_mul (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_mul_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_div (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_div_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_mod (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_mod_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_divmod (MP_INT *, MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_divmod_ui (MP_INT *, MP_INT *, const MP_INT *, unsigned long int);
-void mpz_mdiv (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_mdiv_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_mmod (MP_INT *, const MP_INT *, const MP_INT *);
-unsigned long int mpz_mmod_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_mdivmod (MP_INT *, MP_INT *, const MP_INT *, const MP_INT *);
-unsigned long int mpz_mdivmod_ui (MP_INT *, MP_INT *, const MP_INT *,
- unsigned long int);
-void mpz_sqrt (MP_INT *, const MP_INT *);
-void mpz_sqrtrem (MP_INT *, MP_INT *, const MP_INT *);
-int mpz_perfect_square_p (const MP_INT *);
-int mpz_probab_prime_p (const MP_INT *, int);
-void mpz_powm (MP_INT *, const MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_powm_ui (MP_INT *, const MP_INT *, unsigned long int, const MP_INT *);
-void mpz_pow_ui (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_fac_ui (MP_INT *, unsigned long int);
-void mpz_gcd (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_gcdext (MP_INT *, MP_INT *, MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_neg (MP_INT *, const MP_INT *);
-void mpz_com (MP_INT *, const MP_INT *);
-void mpz_abs (MP_INT *, const MP_INT *);
-int mpz_cmp (const MP_INT *, const MP_INT *);
-int mpz_cmp_ui (const MP_INT *, unsigned long int);
-int mpz_cmp_si (const MP_INT *, signed long int);
-void mpz_mul_2exp (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_div_2exp (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_mod_2exp (MP_INT *, const MP_INT *, unsigned long int);
-void mpz_and (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_ior (MP_INT *, const MP_INT *, const MP_INT *);
-void mpz_xor (MP_INT *, const MP_INT *, const MP_INT *);
-
-#if defined (FILE) || defined (_STDIO_H) || defined (__STDIO_H__)
-void mpz_inp_raw (MP_INT *, FILE *);
-void mpz_inp_str (MP_INT *, FILE *, int);
-void mpz_out_raw (FILE *, const MP_INT *);
-void mpz_out_str (FILE *, int, const MP_INT *);
-#endif
-
-void mpz_array_init (MP_INT [], size_t, mp_size);
-void mpz_random (MP_INT *, mp_size);
-void mpz_random2 (MP_INT *, mp_size);
-size_t mpz_size (const MP_INT *);
-size_t mpz_sizeinbase (const MP_INT *, int);
-
-/**************** Rational (i.e. Q) routines. ****************/
-
-void mpq_init (MP_RAT *);
-void mpq_clear (MP_RAT *);
-void mpq_set (MP_RAT *, const MP_RAT *);
-void mpq_set_ui (MP_RAT *, unsigned long int, unsigned long int);
-void mpq_set_si (MP_RAT *, signed long int, unsigned long int);
-void mpq_add (MP_RAT *, const MP_RAT *, const MP_RAT *);
-void mpq_sub (MP_RAT *, const MP_RAT *, const MP_RAT *);
-void mpq_mul (MP_RAT *, const MP_RAT *, const MP_RAT *);
-void mpq_div (MP_RAT *, const MP_RAT *, const MP_RAT *);
-void mpq_neg (MP_RAT *, const MP_RAT *);
-int mpq_cmp (const MP_RAT *, const MP_RAT *);
-void mpq_inv (MP_RAT *, const MP_RAT *);
-void mpq_set_num (MP_RAT *, const MP_INT *);
-void mpq_set_den (MP_RAT *, const MP_INT *);
-void mpq_get_num (MP_INT *, const MP_RAT *);
-void mpq_get_den (MP_INT *, const MP_RAT *);
-
-/************ Low level positive-integer (i.e. N) routines. ************/
-
-mp_limb mpn_add (mp_ptr, mp_srcptr, mp_size, mp_srcptr, mp_size);
-mp_size mpn_sub (mp_ptr, mp_srcptr, mp_size, mp_srcptr, mp_size);
-mp_size mpn_mul (mp_ptr, mp_srcptr, mp_size, mp_srcptr, mp_size);
-mp_size mpn_div (mp_ptr, mp_ptr, mp_size, mp_srcptr, mp_size);
-mp_limb mpn_divmod_1 (mp_ptr, mp_srcptr, mp_size, mp_limb);
-mp_limb mpn_mod_1 (mp_srcptr, mp_size, mp_limb);
-mp_limb mpn_lshift (mp_ptr, mp_srcptr, mp_size, unsigned int);
-mp_size mpn_rshift (mp_ptr, mp_srcptr, mp_size, unsigned int);
-mp_size mpn_rshiftci (mp_ptr, mp_srcptr, mp_size, unsigned int, mp_limb);
-mp_size mpn_sqrt (mp_ptr, mp_ptr, mp_srcptr, mp_size);
-int mpn_cmp (mp_srcptr, mp_srcptr, mp_size);
-
-#else /* ! __STDC__ */
-void mp_set_memory_functions ();
-
-/**************** Integer (i.e. Z) routines. ****************/
-
-void mpz_init ();
-void mpz_set ();
-void mpz_set_ui ();
-void mpz_set_si ();
-int mpz_set_str ();
-void mpz_init_set ();
-void mpz_init_set_ui ();
-void mpz_init_set_si ();
-int mpz_init_set_str ();
-unsigned long int mpz_get_ui ();
-long int mpz_get_si ();
-char * mpz_get_str ();
-void mpz_clear ();
-void * _mpz_realloc ();
-void mpz_add ();
-void mpz_add_ui ();
-void mpz_sub ();
-void mpz_sub_ui ();
-void mpz_mul ();
-void mpz_mul_ui ();
-void mpz_div ();
-void mpz_div_ui ();
-void mpz_mod ();
-void mpz_mod_ui ();
-void mpz_divmod ();
-void mpz_divmod_ui ();
-void mpz_mdiv ();
-void mpz_mdiv_ui ();
-void mpz_mmod ();
-unsigned long int mpz_mmod_ui ();
-void mpz_mdivmod ();
-unsigned long int mpz_mdivmod_ui ();
-void mpz_sqrt ();
-void mpz_sqrtrem ();
-int mpz_perfect_square_p ();
-int mpz_probab_prime_p ();
-void mpz_powm ();
-void mpz_powm_ui ();
-void mpz_pow_ui ();
-void mpz_fac_ui ();
-void mpz_gcd ();
-void mpz_gcdext ();
-void mpz_neg ();
-void mpz_com ();
-void mpz_abs ();
-int mpz_cmp ();
-int mpz_cmp_ui ();
-int mpz_cmp_si ();
-void mpz_mul_2exp ();
-void mpz_div_2exp ();
-void mpz_mod_2exp ();
-void mpz_and ();
-void mpz_ior ();
-void mpz_xor ();
-
-void mpz_inp_raw ();
-void mpz_inp_str ();
-void mpz_out_raw ();
-void mpz_out_str ();
-
-void mpz_array_init ();
-void mpz_random ();
-void mpz_random2 ();
-size_t mpz_size ();
-size_t mpz_sizeinbase ();
-
-/**************** Rational (i.e. Q) routines. ****************/
-
-void mpq_init ();
-void mpq_clear ();
-void mpq_set ();
-void mpq_set_ui ();
-void mpq_set_si ();
-void mpq_add ();
-void mpq_sub ();
-void mpq_mul ();
-void mpq_div ();
-void mpq_neg ();
-int mpq_cmp ();
-void mpq_inv ();
-void mpq_set_num ();
-void mpq_set_den ();
-void mpq_get_num ();
-void mpq_get_den ();
-
-/************ Low level positive-integer (i.e. N) routines. ************/
-
-mp_limb mpn_add ();
-mp_size mpn_sub ();
-mp_size mpn_mul ();
-mp_size mpn_div ();
-mp_limb mpn_lshift ();
-mp_size mpn_rshift ();
-mp_size mpn_rshiftci ();
-int mpn_cmp ();
-#endif /* __STDC__ */
-
-#endif /* __GMP_H__ */
+++ /dev/null
-\input texinfo @c -*-texinfo-*-
-@comment %**start of header
-@setfilename gmp.info
-@settitle GNU MP 1.3.2
-@synindex tp fn
-@c footnotestyle separate
-@c paragraphindent 2
-@comment %**end of header
-
-@c smallbook
-
-@iftex
-@finalout
-@end iftex
-
-@c Note: the edition number is listed in *three* places; please update
-@c all three. Also, update the month and year where appropriate.
-
-@c ==> Update edition number for settitle and subtitle, and in the
-@c ==> following paragraph; update date, too.
-
-@ifinfo
-This file documents GNU MP, a library for arbitrary-precision integer
-and rational number arithmetic.
-
-This is a draft edition of the documentation, last updated May 20 1993.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-Permission is granted to make and distribute verbatim copies of
-this manual provided the copyright notice and this permission notice
-are preserved on all copies.
-
-@ignore
-Permission is granted to process this file through TeX and print the
-results, provided the printed document carries copying permission
-notice identical to this one except for the removal of this paragraph
-(this paragraph not being relevant to the printed manual).
-
-@end ignore
-Permission is granted to copy and distribute modified versions of this
-manual under the conditions for verbatim copying, provided that the entire
-resulting derived work is distributed under the terms of a permission
-notice identical to this one.
-
-Permission is granted to copy and distribute translations of this manual
-into another language, under the above conditions for modified versions,
-except that this permission notice may be stated in a translation approved
-by the Foundation.
-@end ifinfo
-
-@setchapternewpage odd
-@titlepage
-@c use the new format for titles
-
-@title GNU MP
-@subtitle The GNU Multiple Precision Arithmetic Library
-@subtitle Edition 1.3.2
-@subtitle May 1993
-
-@author by Torbj@"orn Granlund
-
-@comment Include the Distribution inside the titlepage so
-@c that headings are turned off.
-
-@page
-@vskip 0pt plus 1filll
-Copyright @copyright{} 1991, 1993 Free Software Foundation, Inc.
-
-@sp 2
-
-Published by the Free Software Foundation @*
-675 Massachusetts Avenue, @*
-Cambridge, MA 02139 USA @*
-
-Permission is granted to make and distribute verbatim copies of
-this manual provided the copyright notice and this permission notice
-are preserved on all copies.
-
-Permission is granted to copy and distribute modified versions of this
-manual under the conditions for verbatim copying, provided that the entire
-resulting derived work is distributed under the terms of a permission
-notice identical to this one.
-
-Permission is granted to copy and distribute translations of this manual
-into another language, under the above conditions for modified versions,
-except that this permission notice may be stated in a translation approved
-by the Foundation.
-@end titlepage
-
-@ifinfo
-@node Top, Copying, (dir), (dir)
-@end ifinfo
-
-@menu
-* Copying:: GMP Copying Conditions.
-* Intro:: Introduction to GMP.
-* Nomenclature:: Terminology and basic data types.
-* Initialization:: Initialization of multi-precision number objects.
-* Integer Functions:: Functions for arithmetic on signed integers.
-* Rational Number Functions:: Functions for arithmetic on rational numbers.
-* Low-level Functions:: Fast functions for natural numbers.
-* BSD Compatible Functions:: All functions found in BSD MP (somewhat faster).
-* Miscellaneous Functions:: Functions that do particular things.
-* Custom Allocation:: How to customize the internal allocation.
-* Reporting Bugs:: Help us to improve this library.
-
-* References::
-* Concept Index::
-* Function Index::
-@end menu
-
-@node Copying, Intro, Top, Top
-@comment node-name, next, previous, up
-@unnumbered GNU MP Copying Conditions
-@cindex Copying conditions
-@cindex Conditions for copying GNU MP
-
-This library is @dfn{free}; this means that everyone is free to use it
-and free to redistribute it on a free basis. The library is not in the
-public domain; it is copyrighted and there are restrictions on its
-distribution, but these restrictions are designed to permit everything
-that a good cooperating citizen would want to do. What is not allowed
-is to try to prevent others from further sharing any version of this
-library that they might get from you.@refill
-
- Specifically, we want to make sure that you have the right to give
-away copies of the library, that you receive source code or else can get
-it if you want it, that you can change this library or use pieces of it
-in new free programs, and that you know you can do these things.@refill
-
- To make sure that everyone has such rights, we have to forbid you to
-deprive anyone else of these rights. For example, if you distribute
-copies of the GMP library, you must give the recipients all the rights
-that you have. You must make sure that they, too, receive or can get
-the source code. And you must tell them their rights.@refill
-
- Also, for our own protection, we must make certain that everyone finds
-out that there is no warranty for the GMP library. If it is modified by
-someone else and passed on, we want their recipients to know that what
-they have is not what we distributed, so that any problems introduced by
-others will not reflect on our reputation.@refill
-
- The precise conditions of the license for the GMP library are found in
-the General Public License that accompany the source code.@refill
-
-@node Intro, Initialization, Copying, Top
-@comment node-name, next, previous, up
-@chapter Introduction to MP
-@cindex Introduction
-@cindex Overview
-
-GNU MP is a portable library for arbitrary precision integer and
-rational number arithmetic.@footnote{The limit of the precision is set by the
-available memory in your computer.} It aims to provide the fastest
-possible arithmetic for all applications that need more than two words
-of integer precision.
-
-Most often, applications tend to use just a few words of precision;
-but some applications may need thousands of words. GNU MP is designed
-to give good performance for both kinds of applications, by choosing
-algorithms based on the sizes of the operands.
-
-There are five groups of functions in the MP library:
-
-@enumerate
-@item
-Functions for signed integer arithmetic, with names
-beginning with @code{mpz_}.
-
-@item
-Functions for rational number arithmetic, with names beginning with
-@code{mpq_}.
-
-@item
-Functions compatible with Berkeley MP, such as @code{itom}, @code{madd},
-and @code{mult}.
-
-@item
-Fast low-level functions that operate on natural numbers. These are
-used by the functions in the preceding groups, and you can also call
-them directly from very time-critical user programs. These functions'
-names begin with @code{mpn_}.
-
-@item
-Miscellaneous functions.
-@end enumerate
-
-As a general rule, all MP functions expect output arguments before input
-arguments. This notation is based on an analogy with the assignment
-operator. (The BSD MP compatibility functions disobey this rule, having
-the output argument(s) last.) Multi-precision numbers, whether
-output or input, are always passed as addresses to the declared type.
-
-@menu
-* Nomenclature::
-* Thanks::
-@end menu
-
-@node Nomenclature, Thanks, Intro, Intro
-@comment node-name, next, previous, up
-@section Nomenclature and Data Types
-@cindex nomenclature
-
-@cindex integer
-@tindex @code{MP_INT}
-In this manual, @dfn{integer} means a multiple precision integer, as
-used in the MP package. The C data type for such integers is
-@code{MP_INT}. For example:
-
-@example
-MP_INT sum;
-
-struct foo @{ MP_INT x, y; @};
-
-MP_INT vec[20];
-@end example
-
-@cindex rational number
-@tindex @code{MP_RAT}
-@dfn{Rational number} means a multiple precision fraction. The C data
-type for these fractions is @code{MP_RAT}. For example:
-
-@example
-MP_RAT quotient;
-@end example
-
-@cindex limb
-A @dfn{limb} means the part of a multi-precision number that fits in a
-single word. (We chose this word because a limb of the human body is
-analogous to a digit, only larger, and containing several digits.)
-Normally a limb contains 32 bits.
-
-@node Thanks,, Nomenclature, Intro
-@comment node-name, next, previous, up
-@section Thanks
-
-I would like to thank Gunnar Sjoedin and Hans Riesel for their help with
-mathematical problems, Richard Stallman for his help with design issues
-and for revising this manual, Brian Beuning and Doug Lea for their
-testing of various versions of the library, and Joachim Hollman for
-his many valuable suggestions.
-
-Special thanks to Brian Beuning, he has shaked out many bugs from early
-versions of the code!
-
-John Amanatides of York University in Canada contributed the function
-@code{mpz_probab_prime_p}.
-
-@node Initialization, Integer Functions, Intro, Top
-@comment node-name, next, previous, up
-@chapter Initialization
-
-Before you can use a variable or object of type @code{MP_INT} or
-@code{MP_RAT}, you must initialize it. This fills in the components
-that point to dynamically allocated space for the limbs of the number.
-
-When you are finished using the object, you should clear out the object.
-This frees the dynamic space that it points to, so the space can be used
-again.
-
-Once you have initialized the object, you need not be concerned about
-allocating additional space. The functions in the MP package
-automatically allocate additional space when the object does not already
-have enough space. They do not, however, reduce the space in use when a
-smaller number is stored in the object. Most of the time, this policy
-is best, since it avoids frequent re-allocation. If you want to reduce
-the space in an object to the minimum needed, you can do
-@code{_mpz_realloc (&@var{object}, mpz_size (&@var{object}))}.
-
-The functions to initialize numbers are @code{mpz_init} (for @code{MP_INT}) and
-@code{mpq_init} (for @code{MP_RAT}).
-
-@code{mpz_init} allocates space for the limbs, and stores a pointer
-to that space in the @code{MP_INT} object. It also stores the value 0
-in the object.
-
-In the same manner, @code{mpq_init} allocates space for the numerator
-and denominator limbs, and stores pointers to these spaces in the @code{MP_RAT}
-object.
-
-To clear out a number object, use @code{mpz_clear} and @code{mpq_clear},
-respectively.
-
-Here is an example of use:
-
-@example
-@{
- MP_INT temp;
- mpz_init (&temp);
-
- @dots{} @r{store and read values in @code{temp} zero or more times} @dots{}
-
- mpz_clear (&temp):
-@}
-@end example
-
-You might be tempted to copy an integer from one object to another like
-this:
-
-@example
-MP_INT x, y;
-
-x = y;
-@end example
-
-Although valid C, @strong{this is an error.} Rather than copying the
-integer value from @code{y} to @code{x} it will make the two variables
-share storage. Subsequent assignments to one variable would change the
-other mysteriously. And if you were to clear out both variables
-subsequently, you would confuse @code{malloc} and cause your program to
-crash.
-
-To copy the value properly, you must use the function @code{mpz_set}.
-(@pxref{Assigning Integers})
-
-@node Integer Functions, Rational Number Functions, Initialization, Top
-@comment node-name, next, previous, up
-@chapter Integer Functions
-@cindex Integer functions
-
-This chapter describes the MP functions for performing integer arithmetic.
-
-The integer functions use arguments and values of type
-pointer-to-@code{MP_INT} (@pxref{Nomenclature}). The type @code{MP_INT}
-is a structure, but applications should not refer directly to its
-components. Include the header @file{gmp.h} to get the definition of
-@code{MP_INT}.
-
-@menu
-* Initializing Integers::
-* Assigning Integers::
-* Simultaneous Integer Init & Assign::
-* Converting Integers::
-* Integer Arithmetic::
-* Logic on Integers::
-* I/O of Integers::
-@end menu
-
-@node Initializing Integers, Assigning Integers, , Integer Functions
-@comment node-name, next, previous, up
-@section Initializing Integer Objects
-
-Most of the functions for integer arithmetic assume that the output is
-stored in an object already initialized. For example, @code{mpz_add}
-stores the result of addition (@pxref{Integer Arithmetic}). Thus, you
-must initialize the object before storing the first value in it. You
-can do this separately by calling the function @code{mpz_init}.
-
-@deftypefun void mpz_init (MP_INT *@var{integer})
-Initialize @var{integer} with limb space and set the initial numeric
-value to 0. Each variable should normally only be initialized once,
-or at least cleared out (using @code{mpz_clear}) between each initialization.
-@end deftypefun
-
-Here is an example of using @code{mpz_init}:
-
-@example
-@{
- MP_INT integ;
- mpz_init (&integ);
- @dots{}
- mpz_add (&integ, @dots{});
- @dots{}
- mpz_sub (&integ, @dots{});
-
- /* Unless you are now exiting the program, do ... */
- mpz_clear (&integ);
-@}
-@end example
-
-@noindent
-As you can see, you can store new values any number of times, once an
-object is initialized.
-
-@deftypefun void mpz_clear (MP_INT *@var{integer})
-Free the limb space occupied by @var{integer}. Make sure to call this
-function for all @code{MP_INT} variables when you are done with them.
-@end deftypefun
-
-@deftypefun {void *} _mpz_realloc (MP_INT *@var{integer}, mp_size @var{new_alloc})
-Change the limb space allocation to @var{new_alloc} limbs. This
-function is not normally called from user code, but it can be used to
-give memory back to the heap, or to increase the space of a variable to
-avoid repeated automatic re-allocation.
-@end deftypefun
-
-@deftypefun void mpz_array_init (MP_INT @var{integer_array}[], size_t @var{array_size}, mp_size @var{fixed_num_limbs})
-Allocate @strong{fixed} limb space for all @var{array_size} integers in
-@var{integer_array}. The fixed allocation for each integer in the array
-is @var{fixed_num_limbs}. This function is useful for decreasing the
-working set for some algorithms that use large integer arrays. If the
-fixed space will be insufficient for storing the result of a subsequent
-calculation, the result is unpredictable.
-
-There is no way to de-allocate the storage allocated by this function. Don't
-call @code{mpz_clear}!
-@end deftypefun
-
-
-@node Assigning Integers, Simultaneous Integer Init & Assign, Initializing Integers, Integer Functions
-@comment node-name, next, previous, up
-@subsection Integer Assignment Functions
-@cindex Integer assignment functions
-
-These functions assign new values to already initialized integers
-(@pxref{Initializing Integers}).
-
-@deftypefun void mpz_set (MP_INT *@var{dest_integer}, MP_INT *@var{src_integer})
-Assign @var{dest_integer} from @var{src_integer}.
-@end deftypefun
-
-@deftypefun void mpz_set_ui (MP_INT *@var{integer}, unsigned long int @var{initial_value})
-Set the value of @var{integer} from @var{initial_value}.
-@end deftypefun
-
-@deftypefun void mpz_set_si (MP_INT *@var{integer}, signed long int @var{initial_value})
-Set the value of @var{integer} from @var{initial_value}.
-@end deftypefun
-
-@deftypefun int mpz_set_str (MP_INT *@var{integer}, char *@var{initial_value}, int @var{base})
-Set the value of @var{integer} from @var{initial_value},
-a '\0'-terminated C string in base @var{base}. White space is allowed in
-the string, and is simply ignored. The base may vary from 2 to 36. If
-@var{base} is 0, the actual base is determined from the leading characters: if
-the first two characters are `0x' or `0X', hexadecimal is assumed,
-otherwise if the first character is `0', octal is assumed, otherwise
-decimal is assumed.
-
-This function returns 0 if the entire string up to the '\0' is a valid
-number in base @var{base}. Otherwise it returns @minus{}1.
-@end deftypefun
-
-
-@node Simultaneous Integer Init & Assign, Converting Integers, Assigning Integers, Integer Functions
-@comment node-name, next, previous, up
-@subsection Combined Initialization and Assignment Functions
-@cindex Initialization and assignment functions, combined
-
-For your convenience, MP provides a parallel series of
-initialize-and-set arithmetic functions which initialize the output and
-then store the value there. These functions' names have the form
-@code{mpz_init_set@dots{}}.
-
-Here is an example of using one:
-
-@example
-@{
- MP_INT integ;
- mpz_init_set_str (&integ, "3141592653589793238462643383279502884", 10);
- @dots{}
- mpz_sub (&integ, @dots{});
-
- mpz_clear (&integ);
-@}
-@end example
-
-Once the integer has been initialized by any of the
-@code{mpz_init_set@dots{}} functions, it can be used as the source or
-destination operand for the ordinary integer functions. Don't use an
-initialize-and-set function on a variable already initialized!
-
-@deftypefun void mpz_init_set (MP_INT *@var{dest_integer}, MP_INT *@var{src_integer})
-Initialize @var{dest_integer} with limb space and set the initial numeric
-value from @var{src_integer}.
-@end deftypefun
-
-@deftypefun void mpz_init_set_ui (MP_INT *@var{dest_integer}, unsigned long int @var{src_ulong})
-Initialize @var{dest_integer} with limb space and set the initial numeric
-value from @var{src_ulong}.
-@end deftypefun
-
-@deftypefun void mpz_init_set_si (MP_INT *@var{dest_integer}, signed long int @var{src_slong})
-Initialize @var{dest_integer} with limb space and set the initial numeric
-value from @var{src_slong}.
-@end deftypefun
-
-@deftypefun int mpz_init_set_str (MP_INT *@var{dest_integer}, char *@var{src_cstring}, int @var{base})
-Initialize @var{dest_integer} with limb space and set the initial
-numeric value from @var{src_cstring}, a '\0'-terminated C string in base
-@var{base}. The base may vary from 2 to 36. There may be white space
-in the string.
-
-If the string is a correct base @var{base} number, the function returns
-0; if an error occurs it returns @minus{}1. @var{dest_integer} is
-initialized even if an error occurs. (I.e., you have to call mpz_clear
-for it.)
-@end deftypefun
-
-
-@node Converting Integers, Integer Arithmetic, Simultaneous Integer Init & Assign, Integer Functions
-@comment node-name, next, previous, up
-@section Conversion Functions
-@cindex Conversion functions
-
-@deftypefun {unsigned long int} mpz_get_ui (MP_INT *@var{src_integer})
-Return the least significant limb from @var{src_integer}. This
-function together with @*
-@code{mpz_div_2exp(@dots{}, @var{src_integer}, CHAR_BIT*sizeof(unsigned
-long int))} can be used to extract the limbs of an integer efficiently.
-@end deftypefun
-
-@deftypefun {signed long int} mpz_get_si (MP_INT *@var{src_integer})
-If @var{src_integer} fits into a @code{signed long int} return the value
-of @var{src_integer}. Otherwise return the least significant bits of
-@var{src_integer}, with the same sign as @var{src_integer}.
-@end deftypefun
-
-@deftypefun {char *} mpz_get_str (char *@var{string}, int @var{base}, MP_INT *@var{integer})
-Convert @var{integer} to a '\0'-terminated C string in @var{string},
-using base @var{base}. The base may vary from 2 to 36. If @var{string}
-is NULL, space for the string is allocated using the default allocation
-function.
-
-If @var{string} is not NULL, it should point to a block of storage
-enough large for the result. To find out the right amount of space to
-provide for @var{string}, use @code{mpz_sizeinbase (@var{integer},
-@var{base}) + 2}. The "+ 2" is for a possible minus sign, and for the
-terminating null character. (@pxref{Miscellaneous Functions}).
-
-This function returns a pointer to the result string.
-@end deftypefun
-
-
-@node Integer Arithmetic, Logic on Integers, Converting Integers, Integer Functions
-@comment node-name, next, previous, up
-@section Integer Arithmetic Functions
-@cindex Integer arithmetic functions
-@cindex Arithmetic functions
-
-@deftypefun void mpz_add (MP_INT *@var{sum}, MP_INT *@var{addend1}, MP_INT *@var{addend2})
-@end deftypefun
-@deftypefun void mpz_add_ui (MP_INT *@var{sum}, MP_INT *@var{addend1}, unsigned long int @var{addend2})
-Set @var{sum} to @var{addend1} + @var{addend2}.
-@end deftypefun
-
-@deftypefun void mpz_sub (MP_INT *@var{difference}, MP_INT *@var{minuend}, MP_INT *@var{subtrahend})
-@end deftypefun
-@deftypefun void mpz_sub_ui (MP_INT *@var{difference}, MP_INT *@var{minuend}, unsigned long int @var{subtrahend})
-Set @var{difference} to @var{minuend} @minus{} @var{subtrahend}.
-@end deftypefun
-
-@deftypefun void mpz_mul (MP_INT *@var{product}, MP_INT *@var{multiplicator}, MP_INT *@var{multiplicand})
-@end deftypefun
-@deftypefun void mpz_mul_ui (MP_INT *@var{product}, MP_INT *@var{multiplicator}, unsigned long int @var{multiplicand})
-Set @var{product} to @var{multiplicator} times @var{multiplicand}.
-@end deftypefun
-
-Division is undefined if the divisor is zero, and passing a zero divisor
-to the divide or modulo functions, as well passing a zero mod argument
-to the powm functions, will make these functions intentionally divide by
-zero. This gives the user the possibility to handle arithmetic
-exceptions in these functions in the same manner as other arithmetic
-exceptions.
-
-@deftypefun void mpz_div (MP_INT *@var{quotient}, MP_INT *@var{dividend}, MP_INT *@var{divisor})
-@end deftypefun
-@deftypefun void mpz_div_ui (MP_INT *@var{quotient}, MP_INT *@var{dividend}, unsigned long int @var{divisor})
-Set @var{quotient} to @var{dividend} / @var{divisor}. The quotient is
-rounded towards 0.
-@end deftypefun
-
-@deftypefun void mpz_mod (MP_INT *@var{remainder}, MP_INT *@var{divdend}, MP_INT *@var{divisor})
-@end deftypefun
-@deftypefun void mpz_mod_ui (MP_INT *@var{remainder}, MP_INT *@var{divdend}, unsigned long int @var{divisor})
-Divide @var{dividend} and @var{divisor} and put the remainder in
-@var{remainder}. The remainder has the same sign as the dividend, and
-its absolute value is less than the absolute value of the divisor.
-@end deftypefun
-
-@deftypefun void mpz_divmod (MP_INT *@var{quotient}, MP_INT *@var{remainder}, MP_INT *@var{dividend}, MP_INT *@var{divisor})
-@end deftypefun
-@deftypefun void mpz_divmod_ui (MP_INT *@var{quotient}, MP_INT *@var{remainder}, MP_INT *@var{dividend}, unsigned long int @var{divisor})
-Divide @var{dividend} and @var{divisor} and put the quotient in
-@var{quotient} and the remainder in @var{remainder}. The quotient is
-rounded towards 0. The remainder has the same sign as the dividend,
-and its absolute value is less than the absolute value of the divisor.
-
-If @var{quotient} and @var{remainder} are the same variable, the results
-are not defined.
-@end deftypefun
-
-@deftypefun void mpz_mdiv (MP_INT *@var{quotient}, MP_INT *@var{dividend}, MP_INT *@var{divisor})
-@end deftypefun
-@deftypefun void mpz_mdiv_ui (MP_INT *@var{quotient}, MP_INT *@var{dividend}, unsigned long int @var{divisor})
-Set @var{quotient} to @var{dividend} / @var{divisor}. The quotient is
-rounded towards @minus{}infinity.
-@end deftypefun
-
-@deftypefun void mpz_mmod (MP_INT *@var{remainder}, MP_INT *@var{divdend}, MP_INT *@var{divisor})
-@end deftypefun
-@deftypefun {unsigned long int} mpz_mmod_ui (MP_INT *@var{remainder}, MP_INT *@var{divdend}, unsigned long int @var{divisor})
-Divide @var{dividend} and @var{divisor} and put the remainder in
-@var{remainder}. The remainder is always positive, and its value is
-less than the value of the divisor.
-
-For @code{mpz_mmod_ui} the remainder is returned, and if @var{remainder} is
-not NULL, also stored there.
-@end deftypefun
-
-@deftypefun void mpz_mdivmod (MP_INT *@var{quotient}, MP_INT *@var{remainder}, MP_INT *@var{dividend}, MP_INT *@var{divisor})
-@end deftypefun
-@deftypefun {unsigned long int} mpz_mdivmod_ui (MP_INT *@var{quotient}, MP_INT *@var{remainder}, MP_INT *@var{dividend}, unsigned long int @var{divisor})
-Divide @var{dividend} and @var{divisor} and put the quotient in
-@var{quotient} and the remainder in @var{remainder}. The quotient is
-rounded towards @minus{}infinity. The remainder is always positive, and its
-value is less than the value of the divisor.
-
-For @code{mpz_mdivmod_ui} the remainder is small enough to fit in an
-@code{unsigned long int}, and is therefore returned. If @var{remainder}
-is not NULL, the remainder is also stored there.
-
-If @var{quotient} and @var{remainder} are the same variable, the results
-are not defined.
-@end deftypefun
-
-@deftypefun void mpz_sqrt (MP_INT *@var{root}, MP_INT *@var{operand})
-Set @var{root} to the square root of @var{operand}. The result is
-rounded towards zero.
-@end deftypefun
-
-@deftypefun void mpz_sqrtrem (MP_INT *@var{root}, MP_INT *@var{remainder}, MP_INT *@var{operand})
-Set @var{root} to the square root of @var{operand}, as with
-@code{mpz_sqrt}. Set @var{remainder} to
-@ifinfo
-@var{operand}@minus{}@var{root}*@var{root},
-@end ifinfo
-@iftex
-@tex
-$operand - root^2$,
-@end tex
-@end iftex
-(i.e@. zero if @var{operand} is a perfect square).
-
-If @var{root} and @var{remainder} are the same variable, the results are
-not defined.
-@end deftypefun
-
-@deftypefun int mpz_perfect_square_p (MP_INT *@var{square})
-Return non-zero if @var{square} is perfect, i.e@. if the square root of
-@var{square} is integral. Return zero otherwise.
-@end deftypefun
-
-@deftypefun int mpz_probab_prime_p (MP_INT *@var{n}, int @var{reps})
-An implementation of the probabilistic primality test found in Knuth's
-Seminumerical Algorithms book. If the function
-@code{mpz_probab_prime_p(@var{n}, @var{reps})} returns 0 then @var{n} is
-not prime. If it returns 1, then @var{n} is `probably' prime. The
-probability of a false positive is (1/4)**@var{reps}, where @var{reps}
-is the number of internal passes of the probabilistic algorithm. Knuth
-indicates that 25 passes are reasonable.
-@end deftypefun
-
-@deftypefun void mpz_powm (MP_INT *@var{res}, MP_INT *@var{base}, MP_INT *@var{exp}, MP_INT *@var{mod})
-@end deftypefun
-@deftypefun void mpz_powm_ui (MP_INT *@var{res}, MP_INT *@var{base}, unsigned long int @var{exp}, MP_INT *@var{mod})
-Set @var{res} to (@var{base} raised to @var{exp}) modulo @var{mod}.
-If @var{exp} is negative, the result is undefined.
-@end deftypefun
-
-@deftypefun void mpz_pow_ui (MP_INT *@var{res}, MP_INT *@var{base}, unsigned long int @var{exp})
-Set @var{res} to @var{base} raised to @var{exp}.
-@end deftypefun
-
-@deftypefun void mpz_fac_ui (MP_INT *@var{res}, unsigned long int @var{n})
-Set @var{res} @var{n}!, the factorial of n.
-@end deftypefun
-
-@deftypefun void mpz_gcd (MP_INT *@var{res}, MP_INT *@var{operand1}, MP_INT *@var{operand2})
-Set @var{res} to the greatest common divisor of @var{operand1} and
-@var{operand2}.
-@end deftypefun
-
-@deftypefun void mpz_gcdext (MP_INT *@var{g}, MP_INT *@var{s}, MP_INT *@var{t}, MP_INT *@var{a}, MP_INT *@var{b})
-Compute @var{g}, @var{s}, and @var{t}, such that @var{a}@var{s} +
-@var{b}@var{t} = @var{g} = @code{gcd} (@var{a}, @var{b}). If @var{t} is
-NULL, that argument is not computed.
-@end deftypefun
-
-@deftypefun void mpz_neg (MP_INT *@var{negated_operand}, MP_INT *@var{operand})
-Set @var{negated_operand} to @minus{}@var{operand}.
-@end deftypefun
-
-@deftypefun void mpz_abs (MP_INT *@var{positive_operand}, MP_INT *@var{signed_operand})
-Set @var{positive_operand} to the absolute value of @var{signed_operand}.
-@end deftypefun
-
-@deftypefun int mpz_cmp (MP_INT *@var{operand1}, MP_INT *@var{operand2})
-@end deftypefun
-@deftypefun int mpz_cmp_ui (MP_INT *@var{operand1}, unsigned long int @var{operand2})
-@end deftypefun
-@deftypefun int mpz_cmp_si (MP_INT *@var{operand1}, signed long int @var{operand2})
-Compare @var{operand1} and @var{operand2}. Return a positive value if
-@var{operand1} > @var{operand2}, zero if @var{operand1} = @var{operand2},
-and a negative value if @var{operand1} < @var{operand2}.
-@end deftypefun
-
-@deftypefun void mpz_mul_2exp (MP_INT *@var{product}, MP_INT *@var{multiplicator}, unsigned long int @var{exponent_of_2})
-Set @var{product} to @var{multiplicator} times 2 raised to
-@var{exponent_of_2}. This operation can also be defined as a left shift,
-@var{exponent_of_2} steps.
-@end deftypefun
-
-@deftypefun void mpz_div_2exp (MP_INT *@var{quotient}, MP_INT *@var{dividend}, unsigned long int @var{exponent_of_2})
-Set @var{quotient} to @var{dividend} divided by 2 raised to
-@var{exponent_of_2}. This operation can also be defined as a right
-shift, @var{exponent_of_2} steps, but unlike the >> operator in
-C, the result is rounded towards 0.
-@end deftypefun
-
-@deftypefun void mpz_mod_2exp (MP_INT *@var{remainder}, MP_INT *@var{dividend}, unsigned long int @var{exponent_of_2})
-Set @var{remainder} to @var{dividend} mod (2 raised to
-@var{exponent_of_2}). The sign of @var{remainder} will have the same sign
-as @var{dividend}.
-
-This operation can also be defined as a masking of the
-@var{exponent_of_2} least significant bits.
-@end deftypefun
-
-@node Logic on Integers, I/O of Integers, Integer Arithmetic, Integer Functions
-@comment node-name, next, previous, up
-@section Logical Functions
-@cindex Logical functions
-
-@deftypefun void mpz_and (MP_INT *@var{conjunction}, MP_INT *@var{operand1}, MP_INT *@var{operand2})
-Set @var{conjunction} to @var{operand1} logical-and @var{operand2}.
-@end deftypefun
-
-@deftypefun void mpz_ior (MP_INT *@var{disjunction}, MP_INT *@var{operand1}, MP_INT *@var{operand2})
-Set @var{disjunction} to @var{operand1} inclusive-or @var{operand2}.
-@end deftypefun
-
-@deftypefun void mpz_xor (MP_INT *@var{disjunction}, MP_INT *@var{operand1}, MP_INT *@var{operand2})
-Set @var{disjunction} to @var{operand1} exclusive-or @var{operand2}.
-
-This function is missing in the current release.
-@end deftypefun
-
-@deftypefun void mpz_com (MP_INT *@var{complemented_operand}, MP_INT *@var{operand})
-Set @var{complemented_operand} to the one's complement of @var{operand}.
-@end deftypefun
-
-@node I/O of Integers,, Logic on Integers, Integer Functions
-@comment node-name, next, previous, up
-@section Input and Output Functions
-@cindex Input and output functions
-@cindex Output functions
-@cindex I/O functions
-
-Functions that perform input from a standard I/O stream, and functions for
-output conversion.
-
-@deftypefun void mpz_inp_raw (MP_INT *@var{integer}, FILE *@var{stream})
-Input from standard I/O stream @var{stream} in the format written by
-@code{mpz_out_raw}, and put the result in @var{integer}.
-@end deftypefun
-
-@deftypefun void mpz_inp_str (MP_INT *@var{integer}, FILE *@var{stream}, int @var{base})
-Input a string in base @var{base} from standard I/O stream @var{stream},
-and put the read integer in @var{integer}. The base may vary from 2 to
-36. If @var{base} is 0, the actual base is determined from the leading
-characters: if the first two characters are `0x' or `0X', hexadecimal is
-assumed, otherwise if the first character is `0', octal is assumed,
-otherwise decimal is assumed.
-@end deftypefun
-
-
-@deftypefun void mpz_out_raw (FILE *@var{stream}, MP_INT *@var{integer})
-Output @var{integer} on standard I/O stream @var{stream}, in raw binary
-format. The integer is written in a portable format, with 4 bytes of
-size information, and that many bytes of limbs. Both the size and the
-limbs are written in decreasing significance order.
-@end deftypefun
-
-@deftypefun void mpz_out_str (FILE *@var{stream}, int @var{base}, MP_INT *@var{integer})
-Output @var{integer} on standard I/O stream @var{stream}, as a string of
-digits in base @var{base}. The base may vary from 2 to 36.
-@end deftypefun
-
-
-@node Rational Number Functions, Low-level Functions, Integer Functions, Top
-@comment node-name, next, previous, up
-@chapter Rational Number Functions
-@cindex Rational number functions
-
-All rational arithmetic functions canonicalize the result, so that the
-denominator and the numerator have no common factors. Zero has the
-unique representation 0/1.
-
-The set of functions is quite small. Maybe it will be extended in a
-future release.
-
-@deftypefun void mpq_init (MP_RAT *@var{dest_rational})
-Initialize @var{dest_rational} with limb space and set the initial
-numeric value to 0/1. Each variable should normally only be initialized
-once, or at least cleared out (using the function @code{mpq_clear})
-between each initialization.
-@end deftypefun
-
-@deftypefun void mpq_clear (MP_RAT *@var{rational_number})
-Free the limb space occupied by @var{rational_number}. Make sure to
-call this function for all @code{MP_RAT} variables when you are done
-with them.
-@end deftypefun
-
-@deftypefun void mpq_set (MP_RAT *@var{dest_rational}, MP_RAT *@var{src_rational})
-Assign @var{dest_rational} from @var{src_rational}.
-@end deftypefun
-
-@deftypefun void mpq_set_ui (MP_RAT *@var{rational_number}, unsigned long int @var{numerator}, unsigned long int @var{denominator})
-Set the value of @var{rational_number} to
-@var{numerator}/@var{denominator}. If @var{numerator} and
-@var{denominator} have common factors, they are divided out before
-@var{rational_number} is assigned.
-@end deftypefun
-
-@deftypefun void mpq_set_si (MP_RAT *@var{rational_number}, signed long int @var{numerator}, unsigned long int @var{denominator})
-Like @code{mpq_set_ui}, but @var{numerator} is signed.
-@end deftypefun
-
-@deftypefun void mpq_add (MP_RAT *@var{sum}, MP_RAT *@var{addend1}, MP_RAT *@var{addend2})
-Set @var{sum} to @var{addend1} + @var{addend2}.
-@end deftypefun
-
-@deftypefun void mpq_sub (MP_RAT *@var{difference}, MP_RAT *@var{minuend}, MP_RAT *@var{subtrahend})
-Set @var{difference} to @var{minuend} @minus{} @var{subtrahend}.
-@end deftypefun
-
-@deftypefun void mpq_mul (MP_RAT *@var{product}, MP_RAT *@var{multiplicator}, MP_RAT *@var{multiplicand})
-Set @var{product} to @var{multiplicator} * @var{multiplicand}
-@end deftypefun
-
-@deftypefun void mpq_div (MP_RAT *@var{quotient}, MP_RAT *@var{dividend}, MP_RAT *@var{divisor})
-Set @var{quotient} to @var{dividend} / @var{divisor}.
-@end deftypefun
-
-@deftypefun void mpq_neg (MP_RAT *@var{negated_operand}, MP_RAT *@var{operand})
-Set @var{negated_operand} to @minus{}@var{operand}.
-@end deftypefun
-
-@deftypefun int mpq_cmp (MP_RAT *@var{operand1}, MP_RAT *@var{operand2})
-Compare @var{operand1} and @var{operand2}. Return a positive value if
-@var{operand1} > @var{operand2}, zero if @var{operand1} = @var{operand2},
-and a negative value if @var{operand1} < @var{operand2}.
-@end deftypefun
-
-@deftypefun void mpq_inv (MP_RAT *@var{inverted_number}, MP_RAT *@var{number})
-Invert @var{number} by swapping the numerator and denominator. If the
-new denominator becomes zero, this routine will divide by zero.
-@end deftypefun
-
-@deftypefun void mpq_set_num (MP_RAT *@var{rational_number}, MP_INT *@var{numerator})
-Make @var{numerator} become the numerator of @var{rational_number} by
-copying.
-@end deftypefun
-
-@deftypefun void mpq_set_den (MP_RAT *@var{rational_number}, MP_INT *@var{denominator})
-Make @var{denominator} become the denominator of @var{rational_number}
-by copying. If @var{denominator} < 0 the denominator of
-@var{rational_number} is set to the absolute value of @var{denominator},
-and the sign of the numerator of @var{rational_number} is changed.
-@end deftypefun
-
-@deftypefun void mpq_get_num (MP_INT *@var{numerator}, MP_RAT *@var{rational_number})
-Copy the numerator of @var{rational_number} to the integer
-@var{numerator}, to prepare for integer operations on the numerator.
-@end deftypefun
-
-@deftypefun void mpq_get_den (MP_INT *@var{denominator}, MP_RAT *@var{rational_number})
-Copy the denominator of @var{rational_number} to the integer
-@var{denominator}, to prepare for integer operations on the denominator.
-@end deftypefun
-
-
-@node Low-level Functions, BSD Compatible Functions, Rational Number Functions, Top
-@comment node-name, next, previous, up
-@chapter Low-level Functions
-@cindex Low-level functions
-
-@c 1. Some of these function clobber input operands.
-@c
-
-@strong{The next release of the GNU MP library (2.0) will include
-changes to some mpn functions. Programs that use these functions
-according to the descriptions below will therefore not work with the
-next release.}
-
-The low-level function layer is designed to be as fast as possible,
-@strong{not} to provide a coherent calling interface. The different
-functions have similar interfaces, but there are variations that might
-be confusing. These functions do as little as possible apart from the
-real multiple precision computation, so that no time is spent on things
-that not all callers need.
-
-A source operand is specified by a pointer to the least significant limb
-and a limb count. A destination operand is specified by just a pointer.
-It is the responsability of the caller to ensure that the destination
-has enough space for storing the result.
-
-With this way of specifying source operands, it is possible to perform
-computations on subranges of an argument, and store the result into a
-subrange of a destination.
-
-All these functions require that the operands are normalized in the
-sense that the most significant limb must be non-zero. (A future release
-of might drop this requirement.)
-
-The low-level layer is the base for the implementation of the
-@code{mpz_} and @code{mpq_} layers.
-
-The code below adds the number beginning at @var{src1_ptr} and the
-number beginning at @var{src2_ptr} and writes the sum at @var{dest_ptr}.
-A constraint for @code{mpn_add} is that @var{src1_size} must not be
-smaller that @var{src2_size}.
-
-@example
-mpn_add (dest_ptr, src1_ptr, src1_size, src2_ptr, src2_size)
-@end example
-
-In the description below, a source operand is identified by the pointer
-to the least significant limb, and the limb count in braces.
-
-@deftypefun mp_size mpn_add (mp_ptr @var{dest_ptr}, mp_srcptr @var{src1_ptr}, mp_size @var{src1_size}, mp_srcptr @var{src2_ptr}, mp_size @var{src2_size})
-Add @{@var{src1_ptr}, @var{src1_size}@} and @{@var{src2_ptr},
-@var{src2_size}@}, and write the @var{src1_size} least significant limbs
-of the result to @var{dest_ptr}. Carry-out, either 0 or 1, is returned.
-
-This function requires that @var{src1_size} is greater than or equal to
-@var{src2_size}.
-@end deftypefun
-
-@deftypefun mp_size mpn_sub (mp_ptr @var{dest_ptr}, mp_srcptr @var{src1_ptr}, mp_size @var{src1_size}, mp_srcptr @var{src2_ptr}, mp_size @var{src2_size})
-Subtarct @{@var{src2_ptr}, @var{src2_size}@} from @{@var{src1_ptr},
-@var{src1_size}@}, and write the result to @var{dest_ptr}.
-
-Return 1 if the minuend < the subtrahend. Otherwise, return the
-negative difference between the number of words in the result and the
-minuend. I.e@. return 0 if the result has @var{src1_size} words, @minus{}1 if
-it has @var{src1_size} @minus{} 1 words, etc.
-
-This function requires that @var{src1_size} is greater than or equal to
-@var{src2_size}.
-@end deftypefun
-
-@deftypefun mp_size mpn_mul (mp_ptr @var{dest_ptr}, mp_srcptr @var{src1_ptr}, mp_size @var{src1_size}, mp_srcptr @var{src2_ptr}, mp_size @var{src2_size})
-Multiply @{@var{src1_ptr}, @var{src1_size}@} and @{@var{src2_ptr},
-@var{src2_size}@}, and write the result to @var{dest_ptr}. The exact
-size of the result is returned.
-
-The destination has to have space for @var{src1_size} + @var{src1_size}
-limbs, even if the result might be one limb smaller.
-
-This function requires that @var{src1_size} is greater than or equal to
-@var{src2_size}. The destination must be distinct from either input
-operands.
-@end deftypefun
-
-@deftypefun mp_size mpn_div (mp_ptr @var{dest_ptr}, mp_ptr @var{src1_ptr}, mp_size @var{src1_size}, mp_srcptr @var{src2_ptr}, mp_size @var{src2_size})
-Divide @{@var{src1_ptr}, @var{src1_size}@} by @{@var{src2_ptr},
-@var{src2_size}@}, and write the quotient to @var{dest_ptr}, and the
-remainder to @var{src1_ptr}.
-
-Return 0 if the quotient size is at most (@var{src1_size} @minus{}
-@var{src2_size}), and 1 if the quotient size is at most (@var{src1_size}
-@minus{} @var{src2_size} + 1). The caller has to check the most significant limb
-to find out the exact size.
-
-The most significant bit of the most significant limb of the divisor
-has to be set.
-
-This function requires that @var{src1_size} is greater than or equal to
-@var{src2_size}. The quotient, pointed to by @var{dest_ptr}, must be
-distinct from either input operands.
-@end deftypefun
-
-@deftypefun mp_limb mpn_lshift (mp_ptr @var{dest_ptr}, mp_srcptr @var{src_ptr}, mp_size @var{src_size}, unsigned long int @var{count})
-Shift @{@var{src_ptr}, @var{src_size}@} @var{count} bits to the left, and
-write the @var{src_size} least significant limbs of the result to
-@var{dest_ptr}. @var{count} might be in the range 1 to n @minus{} 1, on an n-bit
-machine. The limb shifted out is returned.
-
-Overlapping of the destination space and the source space is allowed in this
-function, provdied @var{dest_ptr} >= @var{src_ptr}.
-@end deftypefun
-
-@deftypefun mp_size mpn_rshift (mp_ptr @var{dest_ptr}, mp_srcptr @var{src_ptr}, mp_size @var{src_size}, unsigned long int @var{count})
-Shift @{@var{src_ptr}, @var{src_size}@} @var{count} bits to the right, and
-write the @var{src_size} least significant limbs of the result to
-@var{dest_ptr}. @var{count} might be in the range 1 to n @minus{} 1, on an n-bit
-machine. The size of the result is returned.
-
-Overlaping of the destination space and the source space is allowed in this
-function, provdied @var{dest_ptr} <= @var{src_ptr}.
-@end deftypefun
-
-@deftypefun mp_size mpn_rshiftci (mp_ptr @var{dest_ptr}, mp_srcptr @var{src_ptr}, mp_size @var{src_size}, unsigned long int @var{count}, mp_limb @var{inlimb})
-Like mpn_rshift, but use @var{inlimb} to feed the least significant end
-of the destination.
-@end deftypefun
-
-@deftypefun int mpn_cmp (mp_srcptr @var{src1_ptr}, mp_srcptr @var{src2_ptr}, mp_size @var{size})
-Compare @{@var{src1_ptr}, @var{size}@} and @{@var{src2_ptr}, @var{size}@}
-and return a positive value if src1 > src2, 0 of they are equal,
-and a negative value if src1 < src2.
-@end deftypefun
-
-
-@node BSD Compatible Functions, Miscellaneous Functions, Low-level Functions, Top
-@comment node-name, next, previous, up
-@chapter Berkeley MP Compatible Functions
-@cindex BSD MP compatible functions
-
-These functions are intended to be fully compatible with the Berkeley MP
-library which is available on many BSD derived U*ix systems.
-
-The original Berkeley MP library has a usage restriction: you cannot use
-the same variable as both source and destination in a single function
-call. The compatible functions in GNU MP do not share this
-restriction---inputs and outputs may overlap.
-
-It is not recommended that new programs are written using these
-functions. Apart from the incomplete set of functions, the interface
-for initializing @code{MINT} objects is more error prone, and the
-@code{pow} function collides with @code{pow} in @file{libm.a}.
-
-Include the header @file{mp.h} to get the definition of the necessary
-types and functions. If you are on a BSD derived system, make sure to
-include GNU @file{mp.h} if you are going to link the GNU @file{libmp.a}
-to you program. This means that you probably need to give the -I<dir>
-option to the compiler, where <dir> is the directory where you have GNU
-@file{mp.h}.
-
-@deftypefun {MINT *} itom (signed short int @var{initial_value})
-Allocate an integer consisting of a @code{MINT} object and dynamic limb
-space. Initialize the integer to @var{initial_value}. Return a pointer
-to the @code{MINT} object.
-@end deftypefun
-
-@deftypefun {MINT *} xtom (char *@var{initial_value})
-Allocate an integer consisting of a @code{MINT} object and dynamic limb
-space. Initialize the integer from @var{initial_value}, a hexadecimal,
-'\0'-terminate C string. Return a pointer to the @code{MINT} object.
-@end deftypefun
-
-@deftypefun void move (MINT *@var{src}, MINT *@var{dest})
-Set @var{dest} to @var{src} by copying. Both variables must be
-previously initialized.
-@end deftypefun
-
-@deftypefun void madd (MINT *@var{src_1}, MINT *@var{src_2}, MINT *@var{destination})
-Add @var{src_1} and @var{src_2} and put the sum in @var{destination}.
-@end deftypefun
-
-@deftypefun void msub (MINT *@var{src_1}, MINT *@var{src_2}, MINT *@var{destination})
-Subtract @var{src_2} from @var{src_1} and put the difference in
-@var{destination}.
-@end deftypefun
-
-@deftypefun void mult (MINT *@var{src_1}, MINT *@var{src_2}, MINT *@var{destination})
-Multiply @var{src_1} and @var{src_2} and put the product in
-@var{destination}.
-@end deftypefun
-
-@deftypefun void mdiv (MINT *@var{dividend}, MINT *@var{divisor}, MINT *@var{quotient}, MINT *@var{remainder})
-@end deftypefun
-@deftypefun void sdiv (MINT *@var{dividend}, signed short int @var{divisor}, MINT *@var{quotient}, signed short int *@var{remainder})
-Set @var{quotient} to @var{dividend} / @var{divisor}, and
-@var{remainder} to @var{dividend} mod @var{divisor}. The quotient is
-rounded towards zero; the remainder has the same sign as the dividend.
-
-Some implementations of this function return a remainder whose sign is
-inverted if the divisor is negative. Such a definition makes little
-sense from a mathematical point of view. GNU MP might be considered
-incompatible with the traditional MP in this respect.
-@end deftypefun
-
-@deftypefun void msqrt (MINT *@var{operand}, MINT *@var{root}, MINT *@var{remainder})
-Set @var{root} to the square root of @var{operand}, as with
-@code{mpz_sqrt}. Set @var{remainder} to
-@ifinfo
-@var{operand}-@var{root}*@var{root},
-@end ifinfo
-@iftex
-@tex
-$operand - root^2$,
-@end tex
-@end iftex
-(i.e@. zero if @var{operand} is a perfect square).
-@end deftypefun
-
-@deftypefun void pow (MINT *@var{base}, MINT *@var{exp}, MINT *@var{mod}, MINT *@var{dest})
-Set @var{dest} to (@var{base} raised to @var{exp}) modulo @var{mod}.
-@end deftypefun
-
-@deftypefun void rpow (MINT *@var{base}, signed short int @var{exp}, MINT *@var{dest})
-Set @var{dest} to @var{base} raised to @var{exp}.
-@end deftypefun
-
-@deftypefun void gcd (MINT *@var{operand1}, MINT *@var{operand2}, MINT *@var{res})
-Set @var{res} to the greatest common divisor of @var{operand1} and
-@var{operand2}.
-@end deftypefun
-
-@deftypefun int mcmp (MINT *@var{operand1}, MINT *@var{operand2})
-Compare @var{operand1} and @var{operand2}. Return a positive value if
-@var{operand1} > @var{operand2}, zero if @var{operand1} =
-@var{operand2}, and a negative value if @var{operand1} < @var{operand2}.
-@end deftypefun
-
-@deftypefun void min (MINT *@var{dest})
-Input a decimal string from stdin, and put the read integer in
-@var{dest}. SPC and TAB are allowed in the number string, and are
-ignored.
-@end deftypefun
-
-@deftypefun void mout (MINT *@var{src})
-Output @var{src} to stdout, as a decimal string. Also output a newline.
-@end deftypefun
-
-@deftypefun {char *} mtox (MINT *@var{operand})
-Convert @var{operand} to a hexadecimal string, and return a pointer to
-the string. The returned string is allocated using the default memory
-allocation function, @code{malloc} by default. (@xref{Initialization},
-for an explanation of the memory allocation in MP).
-@end deftypefun
-
-@deftypefun void mfree (MINT *@var{operand})
-De-allocate, the space used by @var{operand}. @strong{This function
-should only be passed a value returned by @code{itom} or @code{xtom}.}
-@end deftypefun
-
-@node Miscellaneous Functions, Custom Allocation, BSD Compatible Functions, Top
-@comment node-name, next, previous, up
-@chapter Miscellaneous Functions
-@cindex Miscellaneous functions
-
-@deftypefun void mpz_random (MP_INT *@var{random_integer}, mp_size @var{max_size})
-Generate a random integer of at most @var{max_size} limbs. The generated
-random number doesn't satisfy any particular requirements of randomness.
-@end deftypefun
-
-@deftypefun void mpz_random2 (MP_INT *@var{random_integer}, mp_size @var{max_size})
-Generate a random integer of at most @var{max_size} limbs, with long
-strings of zeros and ones in the binary representation. Useful for
-testing functions and algorithms, since this kind of random numbers have
-proven to be more likely to trigger bugs.
-@end deftypefun
-
-@deftypefun size_t mpz_size (MP_INT *@var{integer})
-Return the size of @var{integer} measured in number of limbs. If
-@var{integer} is zero, the returned value will be zero, if @var{integer}
-has one limb, the returned value will be one, etc.
-(@xref{Nomenclature}, for an explanation of the concept @dfn{limb}.)
-@end deftypefun
-
-@deftypefun size_t mpz_sizeinbase (MP_INT *@var{integer}, int @var{base})
-Return the size of @var{integer} measured in number of digits in base
-@var{base}. The base may vary from 2 to 36. The returned value will be
-exact or 1 too big. If @var{base} is a power of 2, the returned value
-will always be exact.
-
-This function is useful in order to allocate the right amount of space
-before converting @var{integer} to a string. The right amount of
-allocation is normally two more than the value returned by
-@code{mpz_sizeinbase} (one extra for a minus sign and one for the
-terminating '\0').
-@end deftypefun
-
-@node Custom Allocation, Reporting Bugs, Miscellaneous Functions, Top
-@comment node-name, next, previous, up
-@section Custom Allocation
-
-By default, the initialization functions use @code{malloc},
-@code{realloc}, and @code{free} to do their work. If @code{malloc} or
-@code{realloc} fails, the MP package terminates execution after a
-printing fatal error message on standard error.
-
-In some applications, you may wish to allocate memory in other ways, or
-you may not want to have a fatal error when there is no more memory
-available. To accomplish this, you can specify alternative functions
-for allocating and de-allocating memory. Use
-@code{mp_set_memory_functions} to do this.
-
-@findex mp_set_memory_functions
-@code{mp_set_memory_functions} has three arguments,
-@var{allocate_function}, @var{reallocate_function}, and
-@var{deallocate_function}, in that order. If an argument is NULL,
-the corresponding default function is retained.
-
-The functions you supply should fit the following declarations:
-
-@table @code
-@item void * @var{allocate_function} (size_t @var{alloc_size})
-This function should return a pointer to newly allocated space with at
-least @var{alloc_size} storage units.
-
-@item void * @var{reallocate_function} (void *@var{ptr}, size_t @var{old_size}, size_t @var{new_size})
-This function should return a pointer to newly allocated space of at
-least @var{new_size} storage units, after copying the first
-@var{old_size} storage units from @var{ptr}. It should also de-allocate the
-space at @var{ptr}.
-
-You can assume that the space at @var{ptr} was formely returned from
-@var{allocate_function} or @var{reallocate_function}, for a
-request for @var{old_size} storage units.
-
-@item void @var{deallocate_function} (void *@var{ptr}, size_t @var{size})
-De-allocate the space pointed to by @var{ptr}.
-
-You can assume that the space at @var{ptr} was formely returned from
-@var{allocate_function} or @var{reallocate_function}, for a
-request for @var{size} storage units.
-@end table
-
-(A @dfn{storage unit} is the unit in which the @code{sizeof} operator
-returns the size of an object, normally an 8 bit byte.)
-
-@strong{NOTE: call @code{mp_set_memory_functions} only before calling
-any other MP functions.} Otherwise, the user-defined allocation
-functions may be asked to re-allocate or de-allocate something
-previously allocated by the default allocation functions.
-
-@node Reporting Bugs, , Custom Allocation, Top
-@comment node-name, next, previous, up
-@chapter Reporting Bugs
-@cindex Reporting bugs
-
-If you think you have found a bug in the GNU MP library, please
-investigate it and report it. We have made this library available to
-you, and it is not to ask too much from you, to ask you to report the
-bugs that you find.
-
-Please make sure that the bug is really in the GNU MP library.
-
-You have to send us a test case that makes it possible for us to
-reproduce the bug.
-
-You also have to explain what is wrong; if you get a crash, or if the
-results printed are not good and in that case, in what way.
-
-Make sure that the bug report includes all information you would
-need to fix this kind of bug for someone else. Think twice.
-
-If your bug report is good, we will do our best to help you to get a
-corrected version of the library; if the bug report is poor, we won't do
-anything about it (aside of chiding you to send better bug reports).
-
-Send your bug report to: tege@@gnu.ai.mit.edu.
-
-If you think something in this manual is unclear, or downright
-incorrect, or if the language needs to be improved, please send a note
-to the same address.
-
-
-@node References, , , Top
-@comment node-name, next, previous, up
-@unnumbered References
-
-@itemize @bullet
-
-@item
-Donald E@. Knuth, "The Art of Computer Programming", vol 2,
-"Seminumerical Algorithms", 2nd edition, Addison-Wesley, 1981.
-
-@item
-John D@. Lipson, "Elements of Algebra and Algebraic Computing",
-The Benjamin Cummins Publishing Company Inc, 1981.
-
-@item
-Richard M@. Stallman, "Using and Porting GCC", Free Software Foundation,
-1993.
-
-@item
-Peter L@. Montgomery, "Modular Multiplication Without Trial Division",
-Mathematics of Computation, volume 44, number 170, April 1985.
-
-@end itemize
-
-@node Concept Index, , , Top
-@comment node-name, next, previous, up
-@unnumbered Concept Index
-@printindex cp
-
-@node Function Index, , , Top
-@comment node-name, next, previous, up
-@unnumbered Function and Type Index
-@printindex fn
-
-
-@contents
-@bye
+++ /dev/null
-/* itom -- BSD compatible allocate and initiate a MINT.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-
-MINT *
-#ifdef __STDC__
-itom (signed short int n)
-#else
-itom (n)
- short int n;
-#endif
-{
- MINT *x;
- mp_ptr xp;
-
- x = (MINT *) (*_mp_allocate_func) (sizeof (MINT));
- x->alloc = 1;
- x->d = xp = (mp_ptr) (*_mp_allocate_func) (x->alloc * BYTES_PER_MP_LIMB);
- if (n > 0)
- {
- x->size = 1;
- xp[0] = n;
- }
- else if (n < 0)
- {
- x->size = -1;
- xp[0] = -n;
- }
- else
- x->size = 0;
-
- return x;
-}
+++ /dev/null
-/* longlong.h -- definitions for mixed size 32/64 bit arithmetic.
- Copyright (C) 1991, 1992, 1993 Free Software Foundation, Inc.
-
- This definition file is free software; you can redistribute it
- and/or modify it under the terms of the GNU General Public
- License as published by the Free Software Foundation; either
- version 2, or (at your option) any later version.
-
- This definition file is distributed in the hope that it will be
- useful, but WITHOUT ANY WARRANTY; without even the implied
- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- See the GNU General Public License for more details.
-
- 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. */
-
-#ifndef LONG_TYPE_SIZE
-#ifdef BITS_PER_LONGINT
-#define LONG_TYPE_SIZE BITS_PER_LONGINT
-#else
-#define LONG_TYPE_SIZE 32
-#endif
-#endif
-
-#define __BITS4 (LONG_TYPE_SIZE / 4)
-#define __ll_B (1L << (LONG_TYPE_SIZE / 2))
-#define __ll_lowpart(t) ((unsigned long int) (t) % __ll_B)
-#define __ll_highpart(t) ((unsigned long int) (t) / __ll_B)
-
-/* Define auxiliary asm macros.
-
- 1) umul_ppmm(high_prod, low_prod, multipler, multiplicand)
- multiplies two unsigned long integers MULTIPLER and MULTIPLICAND,
- and generates a two unsigned word product in HIGH_PROD and
- LOW_PROD.
-
- 2) __umulsidi3(a,b) multiplies two unsigned long integers A and B,
- and returns a long long product. This is just a variant of umul_ppmm.
-
- 3) udiv_qrnnd(quotient, remainder, high_numerator, low_numerator,
- denominator) divides a two-word unsigned integer, composed by the
- integers HIGH_NUMERATOR and LOW_NUMERATOR, by DENOMINATOR and
- places the quotient in QUOTIENT and the remainder in REMAINDER.
- HIGH_NUMERATOR must be less than DENOMINATOR for correct operation.
- If, in addition, the most significant bit of DENOMINATOR must be 1,
- then the pre-processor symbol UDIV_NEEDS_NORMALIZATION is defined to 1.
-
- 4) sdiv_qrnnd(quotient, remainder, high_numerator, low_numerator,
- denominator). Like udiv_qrnnd but the numbers are signed. The
- quotient is rounded towards 0.
-
- 5) count_leading_zeros(count, x) counts the number of zero-bits from
- the msb to the first non-zero bit. This is the number of steps X
- needs to be shifted left to set the msb. Undefined for X == 0.
-
- 6) add_ssaaaa(high_sum, low_sum, high_addend_1, low_addend_1,
- high_addend_2, low_addend_2) adds two two-word unsigned integers,
- composed by HIGH_ADDEND_1 and LOW_ADDEND_1, and HIGH_ADDEND_2 and
- LOW_ADDEND_2 respectively. The result is placed in HIGH_SUM and
- LOW_SUM. Overflow (i.e. carry out) is not stored anywhere, and is
- lost.
-
- 7) sub_ddmmss(high_difference, low_difference, high_minuend,
- low_minuend, high_subtrahend, low_subtrahend) subtracts two
- two-word unsigned integers, composed by HIGH_MINUEND_1 and
- LOW_MINUEND_1, and HIGH_SUBTRAHEND_2 and LOW_SUBTRAHEND_2
- respectively. The result is placed in HIGH_DIFFERENCE and
- LOW_DIFFERENCE. Overflow (i.e. carry out) is not stored anywhere,
- and is lost.
-
- If any of these macros are left undefined for a particular CPU,
- C macros are used. */
-
-/* The CPUs come in alphabetical order below.
-
- Please add support for more CPUs here, or improve the current support
- for the CPUs below! */
-
-#if defined (__GNUC__) && !defined (NO_ASM)
-
-/* We sometimes need to clobber "cc" with gcc2, but that would not be
- understood by gcc1. Use cpp to avoid major code duplication. */
-#if __GNUC__ < 2
-#define __CLOBBER_CC
-#define __AND_CLOBBER_CC
-#else /* __GNUC__ >= 2 */
-#define __CLOBBER_CC : "cc"
-#define __AND_CLOBBER_CC , "cc"
-#endif /* __GNUC__ < 2 */
-
-#if defined (__a29k__) || defined (___AM29K__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("add %1,%4,%5
- addc %0,%2,%3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%r" ((unsigned long int)(ah)), \
- "rI" ((unsigned long int)(bh)), \
- "%r" ((unsigned long int)(al)), \
- "rI" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("sub %1,%4,%5
- subc %0,%2,%3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "r" ((unsigned long int)(ah)), \
- "rI" ((unsigned long int)(bh)), \
- "r" ((unsigned long int)(al)), \
- "rI" ((unsigned long int)(bl)))
-#define umul_ppmm(xh, xl, m0, m1) \
- do { \
- unsigned long int __m0 = (m0), __m1 = (m1); \
- __asm__ ("multiplu %0,%1,%2" \
- : "=r" ((unsigned long int)(xl)) \
- : "r" (__m0), \
- "r" (__m1)); \
- __asm__ ("multmu %0,%1,%2" \
- : "=r" ((unsigned long int)(xh)) \
- : "r" (__m0), \
- "r" (__m1)); \
- } while (0)
-#define udiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("dividu %0,%3,%4" \
- : "=r" ((unsigned long int)(q)), \
- "=q" ((unsigned long int)(r)) \
- : "1" ((unsigned long int)(n1)), \
- "r" ((unsigned long int)(n0)), \
- "r" ((unsigned long int)(d)))
-#define count_leading_zeros(count, x) \
- __asm__ ("clz %0,%1" \
- : "=r" ((unsigned long int)(count)) \
- : "r" ((unsigned long int)(x)))
-#endif /* __a29k__ */
-
-#if defined (__alpha__)
-#define umul_ppmm(ph, pl, m0, m1) \
- do { \
- unsigned long int __m0 = (m0), __m1 = (m1); \
- __asm__ ("umulh %r1,%2,%0" \
- : "=r" ((unsigned long int) ph) \
- : "%rJ" (__m0), \
- "rI" (__m1)); \
- (pl) = (unsigned long int) (__m0) * (unsigned long int) (__m1); \
- } while (0)
-#define UMUL_TIME 46
-#define UDIV_TIME 500
-#endif
-
-#if defined (__arm__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("adds %1,%4,%5
- adc %0,%2,%3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%r" ((unsigned long int)(ah)), \
- "rI" ((unsigned long int)(bh)), \
- "%r" ((unsigned long int)(al)), \
- "rI" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("subs %1,%4,%5
- sbc %0,%2,%3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "r" ((unsigned long int)(ah)), \
- "rI" ((unsigned long int)(bh)), \
- "r" ((unsigned long int)(al)), \
- "rI" ((unsigned long int)(bl)))
-#endif /* __arm__ */
-
-#if defined (__gmicro__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("add.w %5,%1
- addx %3,%0" \
- : "=g" ((unsigned long int)(sh)), \
- "=&g" ((unsigned long int)(sl)) \
- : "%0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "%1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("sub.w %5,%1
- subx %3,%0" \
- : "=g" ((unsigned long int)(sh)), \
- "=&g" ((unsigned long int)(sl)) \
- : "0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define umul_ppmm(ph, pl, m0, m1) \
- __asm__ ("mulx %3,%0,%1" \
- : "=g" ((unsigned long int)(ph)), \
- "=r" ((unsigned long int)(pl)) \
- : "%0" ((unsigned long int)(m0)), \
- "g" ((unsigned long int)(m1)))
-#define udiv_qrnnd(q, r, nh, nl, d) \
- __asm__ ("divx %4,%0,%1" \
- : "=g" ((unsigned long int)(q)), \
- "=r" ((unsigned long int)(r)) \
- : "1" ((unsigned long int)(nh)), \
- "0" ((unsigned long int)(nl)), \
- "g" ((unsigned long int)(d)))
-#define count_leading_zeros(count, x) \
- __asm__ ("bsch/1 %1,%0" \
- : "=g" (count) \
- : "g" ((unsigned long int)(x)), \
- "0" (0UL))
-#endif
-
-#if defined (__hppa)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("add %4,%5,%1
- addc %2,%3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%rM" ((unsigned long int)(ah)), \
- "rM" ((unsigned long int)(bh)), \
- "%rM" ((unsigned long int)(al)), \
- "rM" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("sub %4,%5,%1
- subb %2,%3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "rM" ((unsigned long int)(ah)), \
- "rM" ((unsigned long int)(bh)), \
- "rM" ((unsigned long int)(al)), \
- "rM" ((unsigned long int)(bl)))
-#if defined (_PA_RISC1_1)
-#define umul_ppmm(wh, wl, u, v) \
- do { \
- union {long long int __ll; \
- struct {unsigned long int __h, __l;} __i; \
- } __xx; \
- __asm__ ("xmpyu %1,%2,%0" \
- : "=x" (__xx.__ll) \
- : "x" ((unsigned long int)(u)), \
- "x" ((unsigned long int)(v))); \
- (wh) = __xx.__i.__h; \
- (wl) = __xx.__i.__l; \
- } while (0)
-#define UMUL_TIME 8
-#define UDIV_TIME 60
-#else
-#define UMUL_TIME 40
-#define UDIV_TIME 80
-#endif
-#define count_leading_zeros(count, x) \
- do { \
- unsigned long int __tmp; \
- __asm__ ( \
- "ldi 1,%0
- extru,= %1,15,16,%%r0 ; Bits 31..16 zero?
- extru,tr %1,15,16,%1 ; No. Shift down, skip add.
- ldo 16(%0),%0 ; Yes. Perform add.
- extru,= %1,23,8,%%r0 ; Bits 15..8 zero?
- extru,tr %1,23,8,%1 ; No. Shift down, skip add.
- ldo 8(%0),%0 ; Yes. Perform add.
- extru,= %1,27,4,%%r0 ; Bits 7..4 zero?
- extru,tr %1,27,4,%1 ; No. Shift down, skip add.
- ldo 4(%0),%0 ; Yes. Perform add.
- extru,= %1,29,2,%%r0 ; Bits 3..2 zero?
- extru,tr %1,29,2,%1 ; No. Shift down, skip add.
- ldo 2(%0),%0 ; Yes. Perform add.
- extru %1,30,1,%1 ; Extract bit 1.
- sub %0,%1,%0 ; Subtract it.
- " : "=r" (count), "=r" (__tmp) : "1" (x)); \
- } while (0)
-#endif
-
-#if defined (__i386__) || defined (__i486__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("addl %5,%1
- adcl %3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "%1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("subl %5,%1
- sbbl %3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define umul_ppmm(w1, w0, u, v) \
- __asm__ ("mull %3" \
- : "=a" ((unsigned long int)(w0)), \
- "=d" ((unsigned long int)(w1)) \
- : "%0" ((unsigned long int)(u)), \
- "rm" ((unsigned long int)(v)))
-#define udiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("divl %4" \
- : "=a" ((unsigned long int)(q)), \
- "=d" ((unsigned long int)(r)) \
- : "0" ((unsigned long int)(n0)), \
- "1" ((unsigned long int)(n1)), \
- "rm" ((unsigned long int)(d)))
-#define count_leading_zeros(count, x) \
- do { \
- unsigned long int __cbtmp; \
- __asm__ ("bsrl %1,%0" \
- : "=r" (__cbtmp) : "rm" ((unsigned long int)(x))); \
- (count) = __cbtmp ^ 31; \
- } while (0)
-#define UMUL_TIME 40
-#define UDIV_TIME 40
-#endif /* 80x86 */
-
-#if defined (__i860__)
-#if 0
-/* Make sure these patterns really improve the code before
- switching them on. */
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- do { \
- union \
- { \
- long long int ll; \
- struct {unsigned long int l, h;} i; \
- } __a, __b, __s; \
- __a.i.l = (al); __a.i.h = (ah); \
- __b.i.l = (bl); __b.i.h = (bh); \
- __asm__ ("fiadd.dd %1,%2,%0" \
- : "=f" (__s.ll) \
- : "%f" (__a.ll), "f" (__b.ll)); \
- (sh) = __s.i.h; (sl) = __s.i.l; \
- } while (0)
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- do { \
- union \
- { \
- long long int ll; \
- struct {unsigned long int l, h;} i; \
- } __a, __b, __s; \
- __a.i.l = (al); __a.i.h = (ah); \
- __b.i.l = (bl); __b.i.h = (bh); \
- __asm__ ("fisub.dd %1,%2,%0" \
- : "=f" (__s.ll) \
- : "%f" (__a.ll), "f" (__b.ll)); \
- (sh) = __s.i.h; (sl) = __s.i.l; \
- } while (0)
-#endif
-#endif /* __i860__ */
-
-#if defined (__i960__)
-#define umul_ppmm(w1, w0, u, v) \
- ({union {long long int __ll; \
- struct {unsigned long int __l, __h;} __i; \
- } __xx; \
- __asm__ ("emul %2,%1,%0" \
- : "=d" (__xx.__ll) \
- : "%dI" ((unsigned long int)(u)), \
- "dI" ((unsigned long int)(v))); \
- (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;})
-#define __umulsidi3(u, v) \
- ({long long int __w; \
- __asm__ ("emul %2,%1,%0" \
- : "=d" (__w) \
- : "%dI" ((unsigned long int)(u)), \
- "dI" ((unsigned long int)(v))); \
- __w; })
-#endif /* __i960__ */
-
-#if defined (___IBMR2__) /* IBM RS6000 */
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("a%I5 %1,%4,%5
- ae %0,%2,%3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%r" ((unsigned long int)(ah)), \
- "r" ((unsigned long int)(bh)), \
- "%r" ((unsigned long int)(al)), \
- "rI" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("sf%I4 %1,%5,%4
- sfe %0,%3,%2" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "r" ((unsigned long int)(ah)), \
- "r" ((unsigned long int)(bh)), \
- "rI" ((unsigned long int)(al)), \
- "r" ((unsigned long int)(bl)))
-#define umul_ppmm(xh, xl, m0, m1) \
- do { \
- unsigned long int __m0 = (m0), __m1 = (m1); \
- __asm__ ("mul %0,%2,%3" \
- : "=r" ((unsigned long int)(xh)), \
- "=q" ((unsigned long int)(xl)) \
- : "r" (__m0), \
- "r" (__m1)); \
- (xh) += ((((signed long int) __m0 >> 31) & __m1) \
- + (((signed long int) __m1 >> 31) & __m0)); \
- } while (0)
-#define smul_ppmm(xh, xl, m0, m1) \
- __asm__ ("mul %0,%2,%3" \
- : "=r" ((unsigned long int)(xh)), \
- "=q" ((unsigned long int)(xl)) \
- : "r" (m0), \
- "r" (m1))
-#define UMUL_TIME 8
-#define sdiv_qrnnd(q, r, nh, nl, d) \
- __asm__ ("div %0,%2,%4" \
- : "=r" (q), "=q" (r) \
- : "r" (nh), "1" (nl), "r" (d))
-#define UDIV_TIME 100
-#define count_leading_zeros(count, x) \
- __asm__ ("cntlz %0,%1" \
- : "=r" ((unsigned long int)(count)) \
- : "r" ((unsigned long int)(x)))
-#endif /* ___IBMR2__ */
-
-#if defined (__mc68000__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("add%.l %5,%1
- addx%.l %3,%0" \
- : "=d" ((unsigned long int)(sh)), \
- "=&d" ((unsigned long int)(sl)) \
- : "%0" ((unsigned long int)(ah)), \
- "d" ((unsigned long int)(bh)), \
- "%1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("sub%.l %5,%1
- subx%.l %3,%0" \
- : "=d" ((unsigned long int)(sh)), \
- "=&d" ((unsigned long int)(sl)) \
- : "0" ((unsigned long int)(ah)), \
- "d" ((unsigned long int)(bh)), \
- "1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#if defined (__mc68020__) || defined (__NeXT__) || defined(mc68020)
-#define umul_ppmm(w1, w0, u, v) \
- __asm__ ("mulu%.l %3,%1:%0" \
- : "=d" ((unsigned long int)(w0)), \
- "=d" ((unsigned long int)(w1)) \
- : "%0" ((unsigned long int)(u)), \
- "dmi" ((unsigned long int)(v)))
-#define UMUL_TIME 45
-#define udiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("divu%.l %4,%1:%0" \
- : "=d" ((unsigned long int)(q)), \
- "=d" ((unsigned long int)(r)) \
- : "0" ((unsigned long int)(n0)), \
- "1" ((unsigned long int)(n1)), \
- "dmi" ((unsigned long int)(d)))
-#define UDIV_TIME 90
-#define sdiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("divs%.l %4,%1:%0" \
- : "=d" ((unsigned long int)(q)), \
- "=d" ((unsigned long int)(r)) \
- : "0" ((unsigned long int)(n0)), \
- "1" ((unsigned long int)(n1)), \
- "dmi" ((unsigned long int)(d)))
-#define count_leading_zeros(count, x) \
- __asm__ ("bfffo %1{%b2:%b2},%0" \
- : "=d" ((unsigned long int)(count)) \
- : "od" ((unsigned long int)(x)), "n" (0))
-#else /* not mc68020 */
-/* This ought to be improved by relying on reload to move inputs and
- outputs to their positions. */
-#define umul_ppmm(xh, xl, a, b) \
- __asm__ ("| Inlined umul_ppmm
- movel %2,d0
- movel %3,d1
- movel d0,d2
- swap d0
- movel d1,d3
- swap d1
- movew d2,d4
- mulu d3,d4
- mulu d1,d2
- mulu d0,d3
- mulu d0,d1
- movel d4,d0
- eorw d0,d0
- swap d0
- addl d0,d2
- addl d3,d2
- jcc 1f
- addl #65536,d1
-1: swap d2
- moveq #0,d0
- movew d2,d0
- movew d4,d2
- movel d2,%1
- addl d1,d0
- movel d0,%0" \
- : "=g" ((unsigned long int)(xh)), \
- "=g" ((unsigned long int)(xl)) \
- : "g" ((unsigned long int)(a)), \
- "g" ((unsigned long int)(b)) \
- : "d0", "d1", "d2", "d3", "d4")
-#define UMUL_TIME 100
-#define UDIV_TIME 400
-#endif /* not mc68020 */
-#endif /* mc68000 */
-
-#if defined (__m88000__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("addu.co %1,%r4,%r5
- addu.ci %0,%r2,%r3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%rJ" ((unsigned long int)(ah)), \
- "rJ" ((unsigned long int)(bh)), \
- "%rJ" ((unsigned long int)(al)), \
- "rJ" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("subu.co %1,%r4,%r5
- subu.ci %0,%r2,%r3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "rJ" ((unsigned long int)(ah)), \
- "rJ" ((unsigned long int)(bh)), \
- "rJ" ((unsigned long int)(al)), \
- "rJ" ((unsigned long int)(bl)))
-#define UMUL_TIME 17
-#define UDIV_TIME 150
-#define count_leading_zeros(count, x) \
- do { \
- unsigned long int __cbtmp; \
- __asm__ ("ff1 %0,%1" \
- : "=r" (__cbtmp) \
- : "r" ((unsigned long int)(x))); \
- (count) = __cbtmp ^ 31; \
- } while (0)
-#if defined (__mc88110__)
-#define umul_ppmm(wh, wl, u, v) \
- do { \
- union {long long int __ll; \
- struct {unsigned long int __h, __l;} __i; \
- } __xx; \
- __asm__ ("mulu.d %0,%1,%2" \
- : "=r" (__xx.__ll) \
- : "r" ((unsigned long int)(u)), \
- "r" ((unsigned long int)(v))); \
- (wh) = __xx.__i.__h; \
- (wl) = __xx.__i.__l; \
- } while (0)
-
-#define udiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("or r10,%2,0
- or r11,%3,0
- divu.d r10,r10,%4
- mulu %1,%4,r11
- subu %1,%3,%1
- or %0,r11,0" \
- : "=r" (q), \
- "=&r" (r) \
- : "r" (n1), \
- "r" (n0), \
- "r" (d) \
- : "r10", "r11")
-#endif
-#endif /* __m88000__ */
-
-#if defined (__mips__)
-/* The LO and HI registers are fixed in gcc/mips.h, for some reason. */
-#if 0 && __GNUC__ >= 2
-#define umul_ppmm(w1, w0, u, v) \
- __asm__ ("multu %2,%3" \
- : "=l" ((unsigned long int)(w0)), \
- "=h" ((unsigned long int)(w1)) \
- : "d" ((unsigned long int)(u)), \
- "d" ((unsigned long int)(v)))
-#else
-#define umul_ppmm(w1, w0, u, v) \
- __asm__ ("multu %2,%3
- mflo %0
- mfhi %1" \
- : "=d" ((unsigned long int)(w0)), \
- "=d" ((unsigned long int)(w1)) \
- : "d" ((unsigned long int)(u)), \
- "d" ((unsigned long int)(v)))
-#endif
-#define UMUL_TIME 10
-#define UDIV_TIME 100
-#endif /* __mips__ */
-
-#if defined (__ns32000__)
-#define umul_ppmm(w1, w0, u, v) \
- ({union {long long int __ll; \
- struct {unsigned long int __l, __h;} __i; \
- } __xx; \
- __asm__ ("meid %2,%0" \
- : "=g" (__xx.__ll) \
- : "%0" ((unsigned long int)(u)), \
- "g" ((unsigned long int)(v))); \
- (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;})
-#define __umulsidi3(u, v) \
- ({long long int __w; \
- __asm__ ("meid %2,%0" \
- : "=g" (__w) \
- : "%0" ((unsigned long int)(u)), \
- "g" ((unsigned long int)(v))); \
- __w; })
-#define udiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("movd %2,r0
- movd %3,r1
- deid %4,r0
- movd r1,%0
- movd r0,%1" \
- : "=g" ((unsigned long int)(q)), \
- "=g" ((unsigned long int)(r)) \
- : "g" ((unsigned long int)(n0)), \
- "g" ((unsigned long int)(n1)), \
- "g" ((unsigned long int)(d)) \
- : "r0", "r1")
-#endif /* __ns32000__ */
-
-#if defined (__pyr__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("addw %5,%1
- addwc %3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "%1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("subw %5,%1
- subwb %3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-/* This insn doesn't work on ancient pyramids. */
-#define umul_ppmm(w1, w0, u, v) \
- ({union {long long int __ll; \
- struct {unsigned long int __h, __l;} __i; \
- } __xx; \
- __xx.__i.__l = u; \
- __asm__ ("uemul %3,%0" \
- : "=r" (__xx.__i.__h), \
- "=r" (__xx.__i.__l) \
- : "1" (__xx.__i.__l), \
- "g" (v)); \
- (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;})
-#endif /* __pyr__ */
-
-#if defined (__ibm032__) /* RT/ROMP */
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("a %1,%5
- ae %0,%3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%0" ((unsigned long int)(ah)), \
- "r" ((unsigned long int)(bh)), \
- "%1" ((unsigned long int)(al)), \
- "r" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("s %1,%5
- se %0,%3" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "0" ((unsigned long int)(ah)), \
- "r" ((unsigned long int)(bh)), \
- "1" ((unsigned long int)(al)), \
- "r" ((unsigned long int)(bl)))
-#define umul_ppmm(ph, pl, m0, m1) \
- do { \
- unsigned long int __m0 = (m0), __m1 = (m1); \
- __asm__ ( \
- "s r2,r2
- mts r10,%2
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- m r2,%3
- cas %0,r2,r0
- mfs r10,%1" \
- : "=r" ((unsigned long int)(ph)), \
- "=r" ((unsigned long int)(pl)) \
- : "%r" (__m0), \
- "r" (__m1) \
- : "r2"); \
- (ph) += ((((signed long int) __m0 >> 31) & __m1) \
- + (((signed long int) __m1 >> 31) & __m0)); \
- } while (0)
-#define UMUL_TIME 20
-#define UDIV_TIME 200
-#define count_leading_zeros(count, x) \
- do { \
- if ((x) >= 0x10000) \
- __asm__ ("clz %0,%1" \
- : "=r" ((unsigned long int)(count)) \
- : "r" ((unsigned long int)(x) >> 16)); \
- else \
- { \
- __asm__ ("clz %0,%1" \
- : "=r" ((unsigned long int)(count)) \
- : "r" ((unsigned long int)(x))); \
- (count) += 16; \
- } \
- } while (0)
-#endif
-
-#if defined (__sparc__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("addcc %4,%5,%1
- addx %2,%3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "%r" ((unsigned long int)(ah)), \
- "rI" ((unsigned long int)(bh)), \
- "%r" ((unsigned long int)(al)), \
- "rI" ((unsigned long int)(bl)) \
- __CLOBBER_CC)
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("subcc %4,%5,%1
- subx %2,%3,%0" \
- : "=r" ((unsigned long int)(sh)), \
- "=&r" ((unsigned long int)(sl)) \
- : "r" ((unsigned long int)(ah)), \
- "rI" ((unsigned long int)(bh)), \
- "r" ((unsigned long int)(al)), \
- "rI" ((unsigned long int)(bl)) \
- __CLOBBER_CC)
-#if defined (__sparc_v8__)
-#define umul_ppmm(w1, w0, u, v) \
- __asm__ ("umul %2,%3,%1;rd %%y,%0" \
- : "=r" ((unsigned long int)(w1)), \
- "=r" ((unsigned long int)(w0)) \
- : "r" ((unsigned long int)(u)), \
- "r" ((unsigned long int)(v)))
-/* We might want to leave this undefined for `SuperSPARC (tm)' since
- its implementation is crippled and often traps. */
-#define udiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("mov %2,%%y;nop;nop;nop;udiv %3,%4,%0;umul %0,%4,%1;sub %3,%1,%1"\
- : "=&r" ((unsigned long int)(q)), \
- "=&r" ((unsigned long int)(r)) \
- : "r" ((unsigned long int)(n1)), \
- "r" ((unsigned long int)(n0)), \
- "r" ((unsigned long int)(d)))
-#define UMUL_TIME 6
-#define UDIV_TIME 25
-#else
-/* SPARC without integer multiplication and divide instructions.
- (i.e. at least Sun4/20,40,60,65,75,110,260,280,330,360,380,470,490) */
-#define umul_ppmm(w1, w0, u, v) \
- __asm__ ("! Inlined umul_ppmm
- wr %%g0,%2,%%y ! SPARC has 0-3 delay insn after a wr
- sra %3,31,%%g2 ! Don't move this insn
- and %2,%%g2,%%g2 ! Don't move this insn
- andcc %%g0,0,%%g1 ! Don't move this insn
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,%3,%%g1
- mulscc %%g1,0,%%g1
- add %%g1,%%g2,%0
- rd %%y,%1" \
- : "=r" ((unsigned long int)(w1)), \
- "=r" ((unsigned long int)(w0)) \
- : "%rI" ((unsigned long int)(u)), \
- "r" ((unsigned long int)(v)) \
- : "%g1", "%g2" __AND_CLOBBER_CC)
-#define UMUL_TIME 39 /* 39 instructions */
-/* It's quite necessary to add this much assembler for the sparc.
- The default udiv_qrnnd (in C) is more than 10 times slower! */
-#define udiv_qrnnd(q, r, n1, n0, d) \
- __asm__ ("! Inlined udiv_qrnnd
- mov 32,%%g1
- subcc %1,%2,%%g0
-1: bcs 5f
- addxcc %0,%0,%0 ! shift n1n0 and a q-bit in lsb
- sub %1,%2,%1 ! this kills msb of n
- addx %1,%1,%1 ! so this can't give carry
- subcc %%g1,1,%%g1
-2: bne 1b
- subcc %1,%2,%%g0
- bcs 3f
- addxcc %0,%0,%0 ! shift n1n0 and a q-bit in lsb
- b 3f
- sub %1,%2,%1 ! this kills msb of n
-4: sub %1,%2,%1
-5: addxcc %1,%1,%1
- bcc 2b
- subcc %%g1,1,%%g1
-! Got carry from n. Subtract next step to cancel this carry.
- bne 4b
- addcc %0,%0,%0 ! shift n1n0 and a 0-bit in lsb
- sub %1,%2,%1
-3: xnor %0,0,%0
- ! End of inline udiv_qrnnd" \
- : "=&r" ((unsigned long int)(q)), \
- "=&r" ((unsigned long int)(r)) \
- : "r" ((unsigned long int)(d)), \
- "1" ((unsigned long int)(n1)), \
- "0" ((unsigned long int)(n0)) : "%g1" __AND_CLOBBER_CC)
-#define UDIV_TIME (3+7*32) /* 7 instructions/iteration. 32 iterations. */
-#endif /* __sparc8__ */
-#endif /* __sparc__ */
-
-#if defined (__vax__)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- __asm__ ("addl2 %5,%1
- adwc %3,%0" \
- : "=g" ((unsigned long int)(sh)), \
- "=&g" ((unsigned long int)(sl)) \
- : "%0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "%1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- __asm__ ("subl2 %5,%1
- sbwc %3,%0" \
- : "=g" ((unsigned long int)(sh)), \
- "=&g" ((unsigned long int)(sl)) \
- : "0" ((unsigned long int)(ah)), \
- "g" ((unsigned long int)(bh)), \
- "1" ((unsigned long int)(al)), \
- "g" ((unsigned long int)(bl)))
-#define umul_ppmm(xh, xl, m0, m1) \
- do { \
- union {long long int __ll; \
- struct {unsigned long int __l, __h;} __i; \
- } __xx; \
- unsigned long int __m0 = (m0), __m1 = (m1); \
- __asm__ ("emul %1,%2,$0,%0" \
- : "=g" (__xx.__ll) \
- : "g" (__m0), \
- "g" (__m1)); \
- (xh) = __xx.__i.__h; (xl) = __xx.__i.__l; \
- (xh) += ((((signed long int) __m0 >> 31) & __m1) \
- + (((signed long int) __m1 >> 31) & __m0)); \
- } while (0)
-#define sdiv_qrnnd(q, r, n1, n0, d) \
- do { \
- union {long long int __ll; \
- struct {unsigned long int __l, __h;} __i; \
- } __xx; \
- __xx.__i.__h = n1; __xx.__i.__l = n0; \
- __asm__ ("ediv %3,%2,%0,%1" \
- : "=g" (q), "=g" (r) \
- : "g" (__n1n0.ll), "g" (d)); \
- } while (0)
-#endif /* __vax__ */
-
-#endif /* __GNUC__ */
-
-
-#if !defined (umul_ppmm) && defined (__umulsidi3)
-#define umul_ppmm(ph, pl, m0, m1) \
- { \
- unsigned long long int __ll = __umulsidi3 (m0, m1); \
- ph = (unsigned long int) (__ll >> LONG_TYPE_SIZE); \
- pl = (unsigned long int) __ll; \
- }
-#endif
-
-#if !defined (__umulsidi3)
-#define __umulsidi3(u, v) \
- ({long __hi, __lo; \
- umul_ppmm (__hi, __lo, u, v); \
- ((unsigned long long) __hi << LONG_TYPE_SIZE) | __lo; })
-#endif
-
-/* If this machine has no inline assembler, use C macros. */
-
-#if !defined (add_ssaaaa)
-#define add_ssaaaa(sh, sl, ah, al, bh, bl) \
- do { \
- unsigned long int __x; \
- __x = (al) + (bl); \
- (sh) = (ah) + (bh) + (__x < (al)); \
- (sl) = __x; \
- } while (0)
-#endif
-
-#if !defined (sub_ddmmss)
-#define sub_ddmmss(sh, sl, ah, al, bh, bl) \
- do { \
- unsigned long int __x; \
- __x = (al) - (bl); \
- (sh) = (ah) - (bh) - (__x > (al)); \
- (sl) = __x; \
- } while (0)
-#endif
-
-#if !defined (umul_ppmm)
-#define umul_ppmm(w1, w0, u, v) \
- do { \
- unsigned long int __x0, __x1, __x2, __x3; \
- unsigned int __ul, __vl, __uh, __vh; \
- \
- __ul = __ll_lowpart (u); \
- __uh = __ll_highpart (u); \
- __vl = __ll_lowpart (v); \
- __vh = __ll_highpart (v); \
- \
- __x0 = (unsigned long int) __ul * __vl; \
- __x1 = (unsigned long int) __ul * __vh; \
- __x2 = (unsigned long int) __uh * __vl; \
- __x3 = (unsigned long int) __uh * __vh; \
- \
- __x1 += __ll_highpart (__x0);/* this can't give carry */ \
- __x1 += __x2; /* but this indeed can */ \
- if (__x1 < __x2) /* did we get it? */ \
- __x3 += __ll_B; /* yes, add it in the proper pos. */ \
- \
- (w1) = __x3 + __ll_highpart (__x1); \
- (w0) = __ll_lowpart (__x1) * __ll_B + __ll_lowpart (__x0); \
- } while (0)
-#endif
-
-/* Define this unconditionally, so it can be used for debugging. */
-#define __udiv_qrnnd_c(q, r, n1, n0, d) \
- do { \
- unsigned long int __d1, __d0, __q1, __q0, __r1, __r0, __m; \
- __d1 = __ll_highpart (d); \
- __d0 = __ll_lowpart (d); \
- \
- __r1 = (n1) % __d1; \
- __q1 = (n1) / __d1; \
- __m = (unsigned long int) __q1 * __d0; \
- __r1 = __r1 * __ll_B | __ll_highpart (n0); \
- if (__r1 < __m) \
- { \
- __q1--, __r1 += (d); \
- if (__r1 >= (d)) /* i.e. we didn't get carry when adding to __r1 */\
- if (__r1 < __m) \
- __q1--, __r1 += (d); \
- } \
- __r1 -= __m; \
- \
- __r0 = __r1 % __d1; \
- __q0 = __r1 / __d1; \
- __m = (unsigned long int) __q0 * __d0; \
- __r0 = __r0 * __ll_B | __ll_lowpart (n0); \
- if (__r0 < __m) \
- { \
- __q0--, __r0 += (d); \
- if (__r0 >= (d)) \
- if (__r0 < __m) \
- __q0--, __r0 += (d); \
- } \
- __r0 -= __m; \
- \
- (q) = (unsigned long int) __q1 * __ll_B | __q0; \
- (r) = __r0; \
- } while (0)
-
-/* If udiv_qrnnd was not defined for this processor, use __udiv_qrnnd_c. */
-#if !defined (udiv_qrnnd)
-#define UDIV_NEEDS_NORMALIZATION 1
-#define udiv_qrnnd __udiv_qrnnd_c
-#endif
-
-#if !defined (count_leading_zeros)
-extern
-#ifdef __STDC__
-const
-#endif
-unsigned char __clz_tab[];
-#define count_leading_zeros(count, x) \
- do { \
- unsigned long int __xr = (x); \
- unsigned int __a; \
- \
- if (LONG_TYPE_SIZE <= 32) \
- { \
- __a = __xr < (1<<2*__BITS4) \
- ? (__xr < (1<<__BITS4) ? 0 : __BITS4) \
- : (__xr < (1<<3*__BITS4) ? 2*__BITS4 : 3*__BITS4); \
- } \
- else \
- { \
- for (__a = LONG_TYPE_SIZE - 8; __a > 0; __a -= 8) \
- if (((__xr >> __a) & 0xff) != 0) \
- break; \
- } \
- \
- (count) = LONG_TYPE_SIZE - (__clz_tab[__xr >> __a] + __a); \
- } while (0)
-#endif
-
-#ifndef UDIV_NEEDS_NORMALIZATION
-#define UDIV_NEEDS_NORMALIZATION 0
-#endif
+++ /dev/null
-/* mdiv -- BSD compatible divide producing both remainder and quotient.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mdiv (const MINT *num, const MINT *den, MINT *quot, MINT *rem)
-#else
-mdiv (num, den, quot, rem)
- const MINT *num;
- const MINT *den;
- MINT *quot;
- MINT *rem;
-#endif
-
-#define COMPUTE_QUOTIENT
-#include "mpz_dmincl.c"
+++ /dev/null
-/* Memory allocation routines.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include <stdio.h>
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#ifdef __NeXT__
-#define static
-#endif
-
-#ifdef __STDC__
-void * (*_mp_allocate_func) (size_t) = _mp_default_allocate;
-void * (*_mp_reallocate_func) (void *, size_t, size_t)
- = _mp_default_reallocate;
-void (*_mp_free_func) (void *, size_t) = _mp_default_free;
-#else
-void * (*_mp_allocate_func) () = _mp_default_allocate;
-void * (*_mp_reallocate_func) () = _mp_default_reallocate;
-void (*_mp_free_func) () = _mp_default_free;
-#endif
-
-/* Default allocation functions. In case of failure to allocate/reallocate
- an error message is written to stderr and the program aborts. */
-
-void *
-#ifdef __STDC__
-_mp_default_allocate (size_t size)
-#else
-_mp_default_allocate (size)
- size_t size;
-#endif
-{
- void *ret;
-
- ret = malloc (size);
- if (ret == 0)
- {
- perror ("cannot allocate in libmp");
- abort ();
- }
-
- return ret;
-}
-
-void *
-#ifdef __STDC__
-_mp_default_reallocate (void *oldptr, size_t old_size, size_t new_size)
-#else
-_mp_default_reallocate (oldptr, old_size, new_size)
- void *oldptr;
- size_t old_size;
- size_t new_size;
-#endif
-{
- void *ret;
-
- ret = realloc (oldptr, new_size);
- if (ret == 0)
- {
- perror ("cannot allocate in libmp");
- abort ();
- }
-
- return ret;
-}
-
-void
-#ifdef __STDC__
-_mp_default_free (void *blk_ptr, size_t blk_size)
-#else
-_mp_default_free (blk_ptr, blk_size)
- void *blk_ptr;
- size_t blk_size;
-#endif
-{
- free (blk_ptr);
-}
+++ /dev/null
-/* mfree -- BSD compatible mfree.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mfree (MINT *m)
-#else
-mfree (m)
- MINT *m;
-#endif
-{
- (*_mp_free_func) (m->d, m->alloc * BYTES_PER_MP_LIMB);
- (*_mp_free_func) (m, sizeof (MINT));
-}
+++ /dev/null
-/* min(MINT) -- Do decimal input from standard input and store result in
- MINT.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include <stdio.h>
-#include <ctype.h>
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-min (MINT *x)
-#else
-min (x)
- MINT *x;
-#endif
-{
- char *str;
- size_t str_size;
- size_t i;
- int c;
-
- str_size = 100;
- str = (char *) (*_mp_allocate_func) (str_size);
-
- for (i = 0; ; i++)
- {
- if (i >= str_size)
- {
- size_t old_str_size = str_size;
- str_size = str_size * 3 / 2;
- str = (char *) (*_mp_reallocate_func) (str, old_str_size, str_size);
- }
- c = getc (stdin);
- if (!(isdigit(c) || c == ' ' || c == '\t'))
- break;
- str[i] = c;
- }
-
- ungetc (c, stdin);
-
- str[i] = 0;
- _mpz_set_str (x, str, 10);
-
- (*_mp_free_func) (str, str_size);
-}
+++ /dev/null
-/* mout(MINT) -- Do decimal output of MINT to standard output.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mout (const MINT *x)
-#else
-mout (x)
- const MINT *x;
-#endif
-{
- char *str;
- size_t str_size;
-
- str_size = ((size_t) (ABS (x->size) * BITS_PER_MP_LIMB
- * __mp_bases[10].chars_per_bit_exactly)) + 3;
- str = (char *) alloca (str_size);
- _mpz_get_str (str, 10, x);
- puts (str);
- alloca (0);
-}
+++ /dev/null
-/* move -- BSD compatible assignment.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-move (const MINT *u, MINT *w)
-#else
-move (u, w)
- const MINT *u;
- MINT *w;
-#endif
-{
- mp_size usize;
- mp_size abs_usize;
-
- usize = u->size;
- abs_usize = ABS (usize);
-
- if (w->alloc < abs_usize)
- _mpz_realloc (w, abs_usize);
-
- w->size = usize;
- MPN_COPY (w->d, u->d, abs_usize);
-}
+++ /dev/null
-/* mp.h -- Definitions for Berkeley compatible multiple precision functions.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#ifndef __MP_H__
-#define __MP_H__
-
-#define __GNU_MP__
-
-#ifndef __GMP_H__
-#define __need_size_t
-#include <stddef.h>
-#endif
-
-#ifndef MP_INT
-#ifndef __MP_SMALL__
-typedef struct
-{
- long int alloc; /* Number of *limbs* allocated and pointed
- to by the D field. */
- long int size; /* abs(SIZE) is the number of limbs
- the last field points to. If SIZE
- is negative this is a negative
- number. */
- unsigned long int *d; /* Pointer to the limbs. */
-} __MP_INT;
-#else
-typedef struct
-{
- short int alloc; /* Number of *limbs* allocated and pointed
- to by the D field. */
- short int size; /* abs(SIZE) is the number of limbs
- the last field points to. If SIZE
- is negative this is a negative
- number. */
- unsigned long int *d; /* Pointer to the limbs. */
-} __MP_INT;
-#endif
-#endif
-
-#define MINT __MP_INT
-
-#ifdef __STDC__
-void mp_set_memory_functions (void *(*) (size_t),
- void *(*) (void *, size_t, size_t),
- void (*) (void *, size_t));
-MINT *itom (signed short int);
-MINT *xtom (const char *);
-void move (const MINT *, MINT *);
-void madd (const MINT *, const MINT *, MINT *);
-void msub (const MINT *, const MINT *, MINT *);
-void mult (const MINT *, const MINT *, MINT *);
-void mdiv (const MINT *, const MINT *, MINT *, MINT *);
-void sdiv (const MINT *, signed short int, MINT *, signed short int *);
-void msqrt (const MINT *, MINT *, MINT *);
-void pow (const MINT *, const MINT *, const MINT *, MINT *);
-void rpow (const MINT *, signed short int, MINT *);
-void gcd (const MINT *, const MINT *, MINT *);
-int mcmp (const MINT *, const MINT *);
-void min (MINT *);
-void mout (const MINT *);
-char *mtox (const MINT *);
-void mfree (MINT *);
-
-#else
-
-void mp_set_memory_functions ();
-MINT *itom ();
-MINT *xtom ();
-void move ();
-void madd ();
-void msub ();
-void mult ();
-void mdiv ();
-void sdiv ();
-void msqrt ();
-void pow ();
-void rpow ();
-void gcd ();
-int mcmp ();
-void min ();
-void mout ();
-char *mtox ();
-void mfree ();
-#endif
-
-#endif /* __MP_H__ */
+++ /dev/null
-/* __clz_tab -- support for longlong.h
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* BOTCH: This ought to be made machine-independent. */
-
-const unsigned char __clz_tab[] =
-{
- 0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
- 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
- 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
- 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
- 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
-};
+++ /dev/null
-/* mp_set_memory_functions -- Set the allocate, reallocate, and free functions
- for use by the mp package.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mp_set_memory_functions (void *(*alloc_func) (size_t),
- void *(*realloc_func) (void *, size_t, size_t),
- void (*free_func) (void *, size_t))
-#else
-mp_set_memory_functions (alloc_func, realloc_func, free_func)
- void *(*alloc_func) ();
- void *(*realloc_func) ();
- void (*free_func) ();
-#endif
-{
- if (alloc_func == 0)
- alloc_func = _mp_default_allocate;
- if (realloc_func == 0)
- realloc_func = _mp_default_reallocate;
- if (free_func == 0)
- free_func = _mp_default_free;
-
- _mp_allocate_func = alloc_func;
- _mp_reallocate_func = realloc_func;
- _mp_free_func = free_func;
-}
+++ /dev/null
-/* mpn_add -- Add two low-level integers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* Add ADD1_PTR/ADD1_SIZE and ADD2_PTR/ADD2_SIZE and store the first
- ADD1_SIZE words of the result at SUM_PTR.
-
- Return 1 if carry out was generated, return 0 otherwise.
-
- Argument constraint: ADD1_SIZE >= ADD2_SIZE.
-
- The size of SUM can be calculated as ADD1_SIZE + the return value. */
-
-mp_limb
-#ifdef __STDC__
-mpn_add (mp_ptr sum_ptr,
- mp_srcptr add1_ptr, mp_size add1_size,
- mp_srcptr add2_ptr, mp_size add2_size)
-#else
-mpn_add (sum_ptr, add1_ptr, add1_size, add2_ptr, add2_size)
- mp_ptr sum_ptr;
- mp_srcptr add1_ptr;
- mp_size add1_size;
- mp_srcptr add2_ptr;
- mp_size add2_size;
-#endif
-{
- mp_limb a1, a2, sum;
- mp_size j;
-
- /* The loop counter and index J goes from some negative value to zero.
- This way the loops become faster. Need to offset the base pointers
- to take care of the negative indices. */
-
- j = -add2_size;
- if (j == 0)
- goto add2_finished;
-
- add1_ptr -= j;
- add2_ptr -= j;
- sum_ptr -= j;
-
- /* There are two do-loops, marked NON-CARRY LOOP and CARRY LOOP that
- jump between each other. The first loop is for when the previous
- addition didn't produce a carry-out; the second is for the
- complementary case. */
-
- /* NON-CARRY LOOP */
- do
- {
- a1 = add1_ptr[j];
- a2 = add2_ptr[j];
- sum = a1 + a2;
- sum_ptr[j] = sum;
- if (sum < a2)
- goto cy_loop;
- ncy_loop:
- j++;
- }
- while (j < 0);
-
- /* We have exhausted ADD2. Just copy ADD1 to SUM, and return
- 0 as an indication of no carry-out. */
-
- add2_finished:
- /* Immediate return if the copy would be a no-op. */
- if (sum_ptr == add1_ptr)
- return 0;
-
- j = add2_size - add1_size;
- add1_ptr -= j;
- sum_ptr -= j;
-
- while (j < 0)
- {
- sum_ptr[j] = add1_ptr[j];
- j++;
- }
- return 0;
-
- /* CARRY LOOP */
- do
- {
- a1 = add1_ptr[j];
- a2 = add2_ptr[j];
- sum = a1 + a2 + 1;
- sum_ptr[j] = sum;
- if (sum > a2)
- goto ncy_loop;
- cy_loop:
- j++;
- }
- while (j < 0);
-
- j = add2_size - add1_size;
- add1_ptr -= j;
- sum_ptr -= j;
-
- while (j < 0)
- {
- a1 = add1_ptr[j];
- sum = a1 + 1;
- sum_ptr[j] = sum;
- if (sum > 0)
- goto copy_add1;
- j++;
- }
- return 1;
-
- copy_add1:
- if (sum_ptr == add1_ptr)
- return 0;
-
- j++;
- while (j < 0)
- {
- sum_ptr[j] = add1_ptr[j];
- j++;
- }
-
- return 0;
-}
+++ /dev/null
-/* mpn_cmp -- Compare two low-level natural-number integers.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* Compare OP1_PTR/OP1_SIZE with OP2_PTR/OP2_SIZE.
- There are no restrictions on the relative sizes of
- the two arguments.
- Return 1 if OP1 > OP2, 0 if they are equal, and -1 if OP1 < OP2. */
-
-int
-#ifdef __STDC__
-mpn_cmp (mp_srcptr op1_ptr, mp_srcptr op2_ptr, mp_size size)
-#else
-mpn_cmp (op1_ptr, op2_ptr, size)
- mp_srcptr op1_ptr;
- mp_srcptr op2_ptr;
- mp_size size;
-#endif
-{
- mp_size i;
- mp_limb op1_word, op2_word;
-
- for (i = size - 1; i >= 0; i--)
- {
- op1_word = op1_ptr[i];
- op2_word = op2_ptr[i];
- if (op1_word != op2_word)
- goto diff;
- }
- return 0;
- diff:
- return (op1_word > op2_word) ? 1 : -1;
-}
+++ /dev/null
-/* mpn_div -- Divide natural numbers, producing both remainder and
- quotient.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-/* Divide num (NUM_PTR/NUM_SIZE) by den (DEN_PTR/DEN_SIZE) and write
- the quotient at QUOT_PTR and the remainder at NUM_PTR.
-
- Return 0 or 1, depending on if the quotient size is (NSIZE - DSIZE)
- or (NSIZE - DSIZE + 1).
-
- Argument constraints:
- 1. The most significant bit of d must be set.
- 2. QUOT_PTR != DEN_PTR and QUOT_PTR != NUM_PTR, i.e. the quotient storage
- area must be distinct from either input operands.
-
- The exact sizes of the quotient and remainder must be determined
- by the caller, in spite of the return value. The return value just
- informs the caller about if the highest digit is written or not, and
- it may very well be 0. */
-
-/* THIS WILL BE IMPROVED SOON. MORE COMMENTS AND FASTER CODE. */
-
-mp_size
-#ifdef __STDC__
-mpn_div (mp_ptr quot_ptr,
- mp_ptr num_ptr, mp_size num_size,
- mp_srcptr den_ptr, mp_size den_size)
-#else
-mpn_div (quot_ptr, num_ptr, num_size, den_ptr, den_size)
- mp_ptr quot_ptr;
- mp_ptr num_ptr;
- mp_size num_size;
- mp_srcptr den_ptr;
- mp_size den_size;
-#endif
-{
- mp_size q_is_long = 0;
-
- switch (den_size)
- {
- case 0:
- /* We are asked to divide by zero, so go ahead and do it!
- (To make the compiler not remove this statement, assign NUM_SIZE
- and fall through.) */
- num_size = 1 / den_size;
-
- case 1:
- {
- mp_size i;
- mp_limb n1, n0;
- mp_limb d;
-
- d = den_ptr[0];
- i = num_size - 1;
- n1 = num_ptr[i];
- i--;
-
- if (n1 >= d)
- {
- q_is_long = 1;
- n1 = 0;
- i++;
- }
-
- for (; i >= 0; i--)
- {
- n0 = num_ptr[i];
- udiv_qrnnd (quot_ptr[i], n1, n1, n0, d);
- }
-
- num_ptr[0] = n1;
- }
- break;
-
- case 2:
- {
- mp_size i;
- mp_limb n0, n1, n2;
- mp_limb d0, d1;
-
- num_ptr += num_size - 2;
- d0 = den_ptr[1];
- d1 = den_ptr[0];
- n0 = num_ptr[1];
- n1 = num_ptr[0];
-
- if (n0 >= d0)
- {
- q_is_long = 1;
- n1 = n0;
- n0 = 0;
- num_ptr++;
- num_size++;
- }
-
- for (i = num_size - den_size - 1; i >= 0; i--)
- {
- mp_limb q;
- mp_limb r;
-
- num_ptr--;
- if (n0 == d0)
- {
- /* Q should be either 111..111 or 111..110. Need special
- treatment of this rare case as normal division would
- give overflow. */
- q = ~0;
-
- r = n1 + d0;
- if (r < d0) /* Carry in the addition? */
- {
- n2 = num_ptr[0];
-
- add_ssaaaa (n0, n1, r - d1, n2, 0, d1);
- quot_ptr[i] = q;
- continue;
- }
- n0 = d1 - (d1 != 0);
- n1 = -d1;
- }
- else
- {
- udiv_qrnnd (q, r, n0, n1, d0);
- umul_ppmm (n0, n1, d1, q);
- }
-
- n2 = num_ptr[0];
- q_test:
- if (n0 > r || (n0 == r && n1 > n2))
- {
- /* The estimated Q was too large. */
- q--;
-
- sub_ddmmss (n0, n1, n0, n1, 0, d1);
- r += d0;
- if (r >= d0) /* If not carry, test q again. */
- goto q_test;
- }
-
- quot_ptr[i] = q;
- sub_ddmmss (n0, n1, r, n2, n0, n1);
- }
- num_ptr[1] = n0;
- num_ptr[0] = n1;
- }
- break;
-
- default:
- {
- mp_size i;
- mp_limb d0 = den_ptr[den_size - 1];
- mp_limb d1 = den_ptr[den_size - 2];
- mp_limb n0 = num_ptr[num_size - 1];
- int ugly_hack_flag = 0;
-
- if (n0 >= d0)
- {
-
- /* There's a problem with this case, which shows up later in the
- code. q becomes 1 (and sometimes 0) the first time when
- we've been here, and w_cy == 0 after the main do-loops below.
- But c = num_ptr[j] reads rubbish outside the num_ptr vector!
- Maybe I can solve this cleanly when I fix the early-end
- optimization here in the default case. For now, I change the
- add_back entering condition, to kludge. Leaving the stray
- memref behind!
-
- HACK: Added ugly_hack_flag to make it work. */
-
- q_is_long = 1;
- n0 = 0;
- num_size++;
- ugly_hack_flag = 1;
- }
-
- num_ptr += num_size;
- den_ptr += den_size;
- for (i = num_size - den_size - 1; i >= 0; i--)
- {
- mp_limb q;
- mp_limb n1;
- mp_limb w_cy;
- mp_limb d, c;
- mp_size j;
-
- num_ptr--;
- if (n0 == d0)
- /* This might over-estimate q, but it's probably not worth
- the extra code here to find out. */
- q = ~0;
- else
- {
- mp_limb r;
-
- udiv_qrnnd (q, r, n0, num_ptr[-1], d0);
- umul_ppmm (n1, n0, d1, q);
-
- while (n1 > r || (n1 == r && n0 > num_ptr[-2]))
- {
- q--;
- r += d0;
- if (r < d0) /* I.e. "carry in previous addition?" */
- break;
- n1 -= n0 < d1;
- n0 -= d1;
- }
- }
-
- w_cy = 0;
- j = -den_size;
- do
- {
- d = den_ptr[j];
- c = num_ptr[j];
- umul_ppmm (n1, n0, d, q);
- n0 += w_cy;
- w_cy = (n0 < w_cy) + n1;
- n0 = c - n0;
- num_ptr[j] = n0;
- if (n0 > c)
- goto cy_loop;
- ncy_loop:
- j++;
- }
- while (j < 0);
-
- if (ugly_hack_flag)
- {
- c = 0;
- ugly_hack_flag = 0;
- }
- else
- c = num_ptr[j];
- if (c >= w_cy)
- goto store_q;
- goto add_back;
-
- do
- {
- d = den_ptr[j];
- c = num_ptr[j];
- umul_ppmm (n1, n0, d, q);
- n0 += w_cy;
- w_cy = (n0 < w_cy) + n1;
- n0 = c - n0 - 1;
- num_ptr[j] = n0;
- if (n0 < c)
- goto ncy_loop;
- cy_loop:
- j++;
- }
- while (j < 0);
-
- if (ugly_hack_flag)
- {
- c = 0;
- ugly_hack_flag = 0;
- }
- else
- c = num_ptr[j];
- w_cy++;
- if (c >= w_cy)
- goto store_q;
-
- add_back:
- j = -den_size;
- do
- {
- d = den_ptr[j];
- n0 = num_ptr[j] + d;
- num_ptr[j] = n0;
- if (n0 < d)
- goto ab_cy_loop;
- ab_ncy_loop:
- j++;
- }
- while (j < 0);
- abort (); /* We should always have a carry out! */
-
- do
- {
- d = den_ptr[j];
- n0 = num_ptr[j] + d + 1;
- num_ptr[j] = n0;
- if (n0 > d)
- goto ab_ncy_loop;
- ab_cy_loop:
- j++;
- }
- while (j < 0);
- q--;
-
- store_q:
- quot_ptr[i] = q;
- }
- }
- }
-
- return q_is_long;
-}
+++ /dev/null
-/* mpn_divmod_1(quot_ptr, dividend_ptr, dividend_size, divisor_limb) --
- Divide (DIVIDEND_PTR,,DIVIDEND_SIZE) by DIVISOR_LIMB.
- Write DIVIDEND_SIZE limbs of quotient at QUOT_PTR.
- Return the single-limb remainder.
- There are no constraints on the value of the divisor.
-
- QUOT_PTR and DIVIDEND_PTR might point to the same limb.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-#ifndef UMUL_TIME
-#define UMUL_TIME 1
-#endif
-
-#ifndef UDIV_TIME
-#define UDIV_TIME UMUL_TIME
-#endif
-
-#if UDIV_TIME > 2 * UMUL_TIME
-#undef UDIV_NEEDS_NORMALIZATION
-#define UDIV_NEEDS_NORMALIZATION 1
-#endif
-
-#define udiv_qrnnd_preinv(q, r, nh, nl, d, di) \
- do { \
- unsigned long int _q, _ql, _r; \
- unsigned long int _xh, _xl; \
- umul_ppmm (_q, _ql, (nh), (di)); \
- _q += (nh); /* DI is 2**BITS_PER_MP_LIMB too small. */\
- umul_ppmm (_xh, _xl, _q, (d)); \
- sub_ddmmss (_xh, _r, (nh), (nl), _xh, _xl); \
- if (_xh != 0) \
- { \
- sub_ddmmss (_xh, _r, _xh, _r, 0, (d)); \
- _q += 1; \
- if (_xh != 0) \
- { \
- sub_ddmmss (_xh, _r, _xh, _r, 0, (d)); \
- _q += 1; \
- } \
- } \
- if (_r >= (d)) \
- { \
- _r -= (d); \
- _q += 1; \
- } \
- (r) = _r; \
- (q) = _q; \
- } while (0)
-
-mp_limb
-#ifdef __STDC__
-mpn_divmod_1 (mp_ptr quot_ptr,
- mp_srcptr dividend_ptr, mp_size dividend_size,
- unsigned long int divisor_limb)
-#else
-mpn_divmod_1 (quot_ptr, dividend_ptr, dividend_size, divisor_limb)
- mp_ptr quot_ptr;
- mp_srcptr dividend_ptr;
- mp_size dividend_size;
- unsigned long int divisor_limb;
-#endif
-{
- mp_size i;
- mp_limb n1, n0, r;
-
- /* Botch: Should this be handled at all? Rely on callers? */
- if (dividend_size == 0)
- return 0;
-
- if (UDIV_NEEDS_NORMALIZATION)
- {
- int normalization_steps;
-
- count_leading_zeros (normalization_steps, divisor_limb);
- if (normalization_steps != 0)
- {
- divisor_limb <<= normalization_steps;
-
- n1 = dividend_ptr[dividend_size - 1];
- r = n1 >> (BITS_PER_MP_LIMB - normalization_steps);
-
- /* Possible optimization:
- if (r == 0
- && divisor_limb > ((n1 << normalization_steps)
- | (dividend_ptr[dividend_size - 2] >> ...)))
- ...one division less...
- [Don't forget to zero most sign. quotient limb!] */
-
- /* If multiplication is much faster than division, and the
- dividend is large, pre-invert the divisor, and use
- only multiplications in the inner loop. */
- if (UDIV_TIME > 2 * UMUL_TIME && dividend_size >= 4)
- {
- mp_limb divisor_limb_inverted;
- int dummy;
- /* Compute (2**64 - 2**32 * DIVISOR_LIMB) / DIVISOR_LIMB.
- The result is an 33-bit approximation to 1/DIVISOR_LIMB,
- with the most significant bit (weight 2**32) implicit. */
-
- /* Special case for DIVISOR_LIMB == 100...000. */
- if (divisor_limb << 1 == 0)
- divisor_limb_inverted = ~0;
- else
- udiv_qrnnd (divisor_limb_inverted, dummy,
- -divisor_limb, 0, divisor_limb);
-
- for (i = dividend_size - 2; i >= 0; i--)
- {
- n0 = dividend_ptr[i];
- udiv_qrnnd_preinv (quot_ptr[i + 1], r, r,
- ((n1 << normalization_steps)
- | (n0 >> (BITS_PER_MP_LIMB - normalization_steps))),
- divisor_limb, divisor_limb_inverted);
- n1 = n0;
- }
- udiv_qrnnd_preinv (quot_ptr[0], r, r,
- n1 << normalization_steps,
- divisor_limb, divisor_limb_inverted);
- return r >> normalization_steps;
- }
- else
- {
- for (i = dividend_size - 2; i >= 0; i--)
- {
- n0 = dividend_ptr[i];
- udiv_qrnnd (quot_ptr[i + 1], r, r,
- ((n1 << normalization_steps)
- | (n0 >> (BITS_PER_MP_LIMB - normalization_steps))),
- divisor_limb);
- n1 = n0;
- }
- udiv_qrnnd (quot_ptr[0], r, r,
- n1 << normalization_steps,
- divisor_limb);
- return r >> normalization_steps;
- }
- }
- }
-
- /* No normalization needed, either because udiv_qrnnd doesn't require
- it, or because DIVISOR_LIMB is already normalized. */
-
- i = dividend_size - 1;
- r = dividend_ptr[i];
-
- if (r >= divisor_limb)
- {
- r = 0;
- }
- else
- {
- /* Callers expect the quotient to be DIVIDEND_SIZE limbs. Store
- a leading zero to make that expectation come true. */
- quot_ptr[i] = 0;
- i--;
- }
-
- for (; i >= 0; i--)
- {
- n0 = dividend_ptr[i];
- udiv_qrnnd (quot_ptr[i], r, r, n0, divisor_limb);
- }
- return r;
-}
+++ /dev/null
-/* mpn_lshift -- Shift left low level.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* Shift U (pointed to by UP and USIZE digits long) CNT bits to the left
- and store the USIZE least significant digits of the result at WP.
- Return the bits shifted out from the most significant digit.
-
- Argument constraints:
- 0. U must be normalized (i.e. it's most significant digit != 0).
- 1. 0 <= CNT < BITS_PER_MP_LIMB
- 2. If the result is to be written over the input, WP must be >= UP.
-*/
-
-mp_limb
-#ifdef __STDC__
-mpn_lshift (mp_ptr wp,
- mp_srcptr up, mp_size usize,
- unsigned cnt)
-#else
-mpn_lshift (wp, up, usize, cnt)
- mp_ptr wp;
- mp_srcptr up;
- mp_size usize;
- unsigned cnt;
-#endif
-{
- mp_limb high_limb, low_limb;
- unsigned sh_1, sh_2;
- mp_size i;
- mp_limb retval;
-
- if (usize == 0)
- return 0;
-
- sh_1 = cnt;
- if (sh_1 == 0)
- {
- if (wp != up)
- {
- /* Copy from high end to low end, to allow specified input/output
- overlapping. */
- for (i = usize - 1; i >= 0; i--)
- wp[i] = up[i];
- }
- return 0;
- }
-
- wp += 1;
- sh_2 = BITS_PER_MP_LIMB - sh_1;
- i = usize - 1;
- low_limb = up[i];
- retval = low_limb >> sh_2;
- high_limb = low_limb;
- while (--i >= 0)
- {
- low_limb = up[i];
- wp[i] = (high_limb << sh_1) | (low_limb >> sh_2);
- high_limb = low_limb;
- }
- wp[i] = high_limb << sh_1;
-
- return retval;
-}
+++ /dev/null
-/* mpn_mod_1(dividend_ptr, dividend_size, divisor_limb) --
- Divide (DIVIDEND_PTR,,DIVIDEND_SIZE) by DIVISOR_LIMB.
- Return the single-limb remainder.
- There are no constraints on the value of the divisor.
-
- QUOT_PTR and DIVIDEND_PTR might point to the same limb.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-mp_limb
-#ifdef __STDC__
-mpn_mod_1 (mp_srcptr dividend_ptr, mp_size dividend_size,
- unsigned long int divisor_limb)
-#else
-mpn_mod_1 (dividend_ptr, dividend_size, divisor_limb)
- mp_srcptr dividend_ptr;
- mp_size dividend_size;
- unsigned long int divisor_limb;
-#endif
-{
- int normalization_steps;
- mp_size i;
- mp_limb n1, n0, r;
- int dummy;
-
- /* Botch: Should this be handled at all? Rely on callers? */
- if (dividend_size == 0)
- return 0;
-
- if (UDIV_NEEDS_NORMALIZATION)
- {
- count_leading_zeros (normalization_steps, divisor_limb);
- if (normalization_steps != 0)
- {
- divisor_limb <<= normalization_steps;
-
- n1 = dividend_ptr[dividend_size - 1];
- r = n1 >> (BITS_PER_MP_LIMB - normalization_steps);
-
- /* Possible optimization:
- if (r == 0
- && divisor_limb > ((n1 << normalization_steps)
- | (dividend_ptr[dividend_size - 2] >> ...)))
- ...one division less...
- */
-
- for (i = dividend_size - 2; i >= 0; i--)
- {
- n0 = dividend_ptr[i];
- udiv_qrnnd (dummy, r, r,
- ((n1 << normalization_steps)
- | (n0 >> (BITS_PER_MP_LIMB - normalization_steps))),
- divisor_limb);
- n1 = n0;
- }
- udiv_qrnnd (dummy, r, r,
- n1 << normalization_steps,
- divisor_limb);
- return r >> normalization_steps;
- }
- }
-
- /* No normalization needed, either because udiv_qrnnd doesn't require
- it, or because DIVISOR_LIMB is already normalized. */
-
- i = dividend_size - 1;
- r = dividend_ptr[i];
-
- if (r >= divisor_limb)
- {
- r = 0;
- }
- else
- {
- i--;
- }
-
- for (; i >= 0; i--)
- {
- n0 = dividend_ptr[i];
- udiv_qrnnd (dummy, r, r, n0, divisor_limb);
- }
- return r;
-}
+++ /dev/null
-/* mpn_mul -- Multiply two natural numbers.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-#ifdef GMP_DEBUG /* partain: was DEBUG */
-#define MPN_MUL_VERIFY(res_ptr,res_size,op1_ptr,op1_size,op2_ptr,op2_size) \
- mpn_mul_verify (res_ptr, res_size, op1_ptr, op1_size, op2_ptr, op2_size)
-
-#include <stdio.h>
-static void
-mpn_mul_verify (res_ptr, res_size, op1_ptr, op1_size, op2_ptr, op2_size)
- mp_ptr res_ptr, op1_ptr, op2_ptr;
- mp_size res_size, op1_size, op2_size;
-{
- mp_ptr tmp_ptr;
- mp_size tmp_size;
- tmp_ptr = alloca ((op1_size + op2_size) * BYTES_PER_MP_LIMB);
- if (op1_size >= op2_size)
- tmp_size = mpn_mul_classic (tmp_ptr,
- op1_ptr, op1_size, op2_ptr, op2_size);
- else
- tmp_size = mpn_mul_classic (tmp_ptr,
- op2_ptr, op2_size, op1_ptr, op1_size);
- if (tmp_size != res_size
- || mpn_cmp (tmp_ptr, res_ptr, tmp_size) != 0)
- {
- fprintf (stderr, "GNU MP internal error: Wrong result in mpn_mul.\n");
- fprintf (stderr, "op1{%d} = ", op1_size); mpn_dump (op1_ptr, op1_size);
- fprintf (stderr, "op2{%d} = ", op2_size); mpn_dump (op2_ptr, op2_size);
- abort ();
- }
-}
-#else
-#define MPN_MUL_VERIFY(a,b,c,d,e,f)
-#endif
-
-/* Multiply the natural numbers u (pointed to by UP, with USIZE limbs)
- and v (pointed to by VP, with VSIZE limbs), and store the result at
- PRODP. USIZE + VSIZE limbs are always stored, but if the input
- operands are normalized, the return value will reflect the true
- result size (which is either USIZE + VSIZE, or USIZE + VSIZE -1).
-
- NOTE: The space pointed to by PRODP is overwritten before finished
- with U and V, so overlap is an error.
-
- Argument constraints:
- 1. USIZE >= VSIZE.
- 2. PRODP != UP and PRODP != VP, i.e. the destination
- must be distinct from the multiplier and the multiplicand. */
-
-/* If KARATSUBA_THRESHOLD is not already defined, define it to a
- value which is good on most machines. */
-#ifndef KARATSUBA_THRESHOLD
-#define KARATSUBA_THRESHOLD 8
-#endif
-
-/* The code can't handle KARATSUBA_THRESHOLD smaller than 4. */
-#if KARATSUBA_THRESHOLD < 4
-#undef KARATSUBA_THRESHOLD
-#define KARATSUBA_THRESHOLD 4
-#endif
-
-mp_size
-#ifdef __STDC__
-mpn_mul (mp_ptr prodp,
- mp_srcptr up, mp_size usize,
- mp_srcptr vp, mp_size vsize)
-#else
-mpn_mul (prodp, up, usize, vp, vsize)
- mp_ptr prodp;
- mp_srcptr up;
- mp_size usize;
- mp_srcptr vp;
- mp_size vsize;
-#endif
-{
- mp_size n;
- mp_size prod_size;
- mp_limb cy;
-
- if (vsize < KARATSUBA_THRESHOLD)
- {
- /* Handle simple cases with traditional multiplication.
-
- This is the most critical code of the entire function. All
- multiplies rely on this, both small and huge. Small ones arrive
- here immediately. Huge ones arrive here as this is the base case
- for the recursive algorithm below. */
- mp_size i, j;
- mp_limb prod_low, prod_high;
- mp_limb cy_limb;
- mp_limb v_limb;
-
- if (vsize == 0)
- return 0;
-
- /* Offset UP and PRODP so that the inner loop can be faster. */
- up += usize;
- prodp += usize;
-
- /* Multiply by the first limb in V separately, as the result can
- be stored (not added) to PROD. We also avoid a loop for zeroing. */
- v_limb = vp[0];
- if (v_limb <= 1)
- {
- if (v_limb == 1)
- MPN_COPY (prodp - usize, up - usize, usize);
- else
- MPN_ZERO (prodp - usize, usize);
- cy_limb = 0;
- }
- else
- {
- cy_limb = 0;
- j = -usize;
- do
- {
- umul_ppmm (prod_high, prod_low, up[j], v_limb);
- add_ssaaaa (cy_limb, prodp[j], prod_high, prod_low, 0, cy_limb);
- j++;
- }
- while (j < 0);
- }
-
- prodp[0] = cy_limb;
- prodp++;
-
- /* For each iteration in the outer loop, multiply one limb from
- U with one limb from V, and add it to PROD. */
- for (i = 1; i < vsize; i++)
- {
- v_limb = vp[i];
- if (v_limb <= 1)
- {
- cy_limb = 0;
- if (v_limb == 1)
- cy_limb = mpn_add (prodp - usize,
- prodp - usize, usize, up - usize, usize);
- }
- else
- {
- cy_limb = 0;
- j = -usize;
-
- do
- {
- umul_ppmm (prod_high, prod_low, up[j], v_limb);
- add_ssaaaa (cy_limb, prod_low,
- prod_high, prod_low, 0, cy_limb);
- add_ssaaaa (cy_limb, prodp[j],
- cy_limb, prod_low, 0, prodp[j]);
- j++;
- }
- while (j < 0);
- }
-
- prodp[0] = cy_limb;
- prodp++;
- }
-
- return usize + vsize - (cy_limb == 0);
- }
-
- n = (usize + 1) / 2;
-
- /* Is USIZE larger than 1.5 times VSIZE? Avoid Karatsuba's algorithm. */
- if (2 * usize > 3 * vsize)
- {
- /* If U has at least twice as many limbs as V. Split U in two
- pieces, U1 and U0, such that U = U0 + U1*(2**BITS_PER_MP_LIMB)**N,
- and recursively multiply the two pieces separately with V. */
-
- mp_size u0_size;
- mp_ptr tmp;
- mp_size tmp_size;
-
- /* V1 (the high part of V) is zero. */
-
- /* Calculate the length of U0. It is normally equal to n, but
- of course not for sure. */
- for (u0_size = n; u0_size > 0 && up[u0_size - 1] == 0; u0_size--)
- ;
-
- /* Perform (U0 * V). */
- if (u0_size >= vsize)
- prod_size = mpn_mul (prodp, up, u0_size, vp, vsize);
- else
- prod_size = mpn_mul (prodp, vp, vsize, up, u0_size);
- MPN_MUL_VERIFY (prodp, prod_size, up, u0_size, vp, vsize);
-
- /* We have to zero-extend the lower partial product to n limbs,
- since the mpn_add some lines below expect the first n limbs
- to be well defined. (This is normally a no-op. It may
- do something when U1 has many leading 0 limbs.) */
- while (prod_size < n)
- prodp[prod_size++] = 0;
-
- tmp = (mp_ptr) alloca ((usize + vsize - n) * BYTES_PER_MP_LIMB);
-
- /* Perform (U1 * V). Make sure the first source argument to mpn_mul
- is not less than the second source argument. */
- if (vsize <= usize - n)
- tmp_size = mpn_mul (tmp, up + n, usize - n, vp, vsize);
- else
- tmp_size = mpn_mul (tmp, vp, vsize, up + n, usize - n);
- MPN_MUL_VERIFY (tmp, tmp_size, up + n, usize - n, vp, vsize);
-
- /* In this addition hides a potentially large copying of TMP. */
- if (prod_size - n >= tmp_size)
- cy = mpn_add (prodp + n, prodp + n, prod_size - n, tmp, tmp_size);
- else
- cy = mpn_add (prodp + n, tmp, tmp_size, prodp + n, prod_size - n);
- if (cy)
- abort (); /* prodp[prod_size] = cy; */
-
- alloca (0);
- return tmp_size + n;
- }
- else
- {
- /* Karatsuba's divide-and-conquer algorithm.
-
- Split U in two pieces, U1 and U0, such that
- U = U0 + U1*(B**n),
- and V in V1 and V0, such that
- V = V0 + V1*(B**n).
-
- UV is then computed recursively using the identity
-
- 2n n n n
- UV = (B + B )U V + B (U -U )(V -V ) + (B + 1)U V
- 1 1 1 0 0 1 0 0
-
- Where B = 2**BITS_PER_MP_LIMB.
- */
-
- /* It's possible to decrease the temporary allocation by using the
- prodp area for temporary storage of the middle term, and doing
- that recursive multiplication first. (Do this later.) */
-
- mp_size u0_size;
- mp_size v0_size;
- mp_size u0v0_size;
- mp_size u1v1_size;
- mp_ptr temp;
- mp_size temp_size;
- mp_size utem_size;
- mp_size vtem_size;
- mp_ptr ptem;
- mp_size ptem_size;
- int negflg;
- mp_ptr pp;
-
- pp = (mp_ptr) alloca (4 * n * BYTES_PER_MP_LIMB);
-
- /* Calculate the lengths of U0 and V0. They are normally equal
- to n, but of course not for sure. */
- for (u0_size = n; u0_size > 0 && up[u0_size - 1] == 0; u0_size--)
- ;
- for (v0_size = n; v0_size > 0 && vp[v0_size - 1] == 0; v0_size--)
- ;
-
- /*** 1. PROD]2n..0] := U0 x V0
- (Recursive call to mpn_mul may NOT overwrite input operands.)
- ________________ ________________
- |________________||____U0 x V0_____| */
-
- if (u0_size >= v0_size)
- u0v0_size = mpn_mul (pp, up, u0_size, vp, v0_size);
- else
- u0v0_size = mpn_mul (pp, vp, v0_size, up, u0_size);
- MPN_MUL_VERIFY (pp, u0v0_size, up, u0_size, vp, v0_size);
-
- /* Zero-extend to 2n limbs. */
- while (u0v0_size < 2 * n)
- pp[u0v0_size++] = 0;
-
-
- /*** 2. PROD]4n..2n] := U1 x V1
- (Recursive call to mpn_mul may NOT overwrite input operands.)
- ________________ ________________
- |_____U1 x V1____||____U0 x V0_____| */
-
- u1v1_size = mpn_mul (pp + 2*n,
- up + n, usize - n,
- vp + n, vsize - n);
- MPN_MUL_VERIFY (pp + 2*n, u1v1_size,
- up + n, usize - n, vp + n, vsize - n);
- prod_size = 2 * n + u1v1_size;
-
-
- /*** 3. PTEM]2n..0] := (U1-U0) x (V0-V1)
- (Recursive call to mpn_mul may overwrite input operands.)
- ________________
- |_(U1-U0)(V0-V1)_| */
-
- temp = (mp_ptr) alloca ((2 * n + 1) * BYTES_PER_MP_LIMB);
- if (usize - n > u0_size
- || (usize - n == u0_size
- && mpn_cmp (up + n, up, u0_size) >= 0))
- {
- utem_size = usize - n
- + mpn_sub (temp, up + n, usize - n, up, u0_size);
- negflg = 0;
- }
- else
- {
- utem_size = u0_size
- + mpn_sub (temp, up, u0_size, up + n, usize - n);
- negflg = 1;
- }
- if (vsize - n > v0_size
- || (vsize - n == v0_size
- && mpn_cmp (vp + n, vp, v0_size) >= 0))
- {
- vtem_size = vsize - n
- + mpn_sub (temp + n, vp + n, vsize - n, vp, v0_size);
- negflg ^= 1;
- }
- else
- {
- vtem_size = v0_size
- + mpn_sub (temp + n, vp, v0_size, vp + n, vsize - n);
- /* No change of NEGFLG. */
- }
- ptem = (mp_ptr) alloca (2 * n * BYTES_PER_MP_LIMB);
- if (utem_size >= vtem_size)
- ptem_size = mpn_mul (ptem, temp, utem_size, temp + n, vtem_size);
- else
- ptem_size = mpn_mul (ptem, temp + n, vtem_size, temp, utem_size);
- MPN_MUL_VERIFY (ptem, ptem_size, temp, utem_size, temp + n, vtem_size);
-
- /*** 4. TEMP]2n..0] := PROD]2n..0] + PROD]4n..2n]
- ________________
- |_____U1 x V1____|
- ________________
- |_____U0_x_V0____| */
-
- cy = mpn_add (temp, pp, 2*n, pp + 2*n, u1v1_size);
- if (cy != 0)
- {
- temp[2*n] = cy;
- temp_size = 2*n + 1;
- }
- else
- {
- /* Normalize temp. pp[2*n-1] might have been zero in the
- mpn_add call above, and thus temp might be unnormalized. */
- for (temp_size = 2*n; temp_size > 0 && temp[temp_size - 1] == 0;
- temp_size--)
- ;
- }
-
- if (prod_size - n >= temp_size)
- cy = mpn_add (pp + n, pp + n, prod_size - n, temp, temp_size);
- else
- {
- /* This is a weird special case that should not happen (often)! */
- cy = mpn_add (pp + n, temp, temp_size, pp + n, prod_size - n);
- prod_size = temp_size + n;
- }
- if (cy != 0)
- {
- pp[prod_size] = cy;
- prod_size++;
- }
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- if (prod_size > 4 * n)
- abort();
-#endif
- if (negflg)
- prod_size = prod_size
- + mpn_sub (pp + n, pp + n, prod_size - n, ptem, ptem_size);
- else
- {
- if (prod_size - n < ptem_size)
- abort();
- cy = mpn_add (pp + n, pp + n, prod_size - n, ptem, ptem_size);
- if (cy != 0)
- {
- pp[prod_size] = cy;
- prod_size++;
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- if (prod_size > 4 * n)
- abort();
-#endif
- }
- }
-
- MPN_COPY (prodp, pp, prod_size);
- alloca (0);
- return prod_size;
- }
-}
+++ /dev/null
-/* mpn_mul -- Multiply two natural numbers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-/* Multiply the natural numbers u (pointed to by UP, with USIZE limbs)
- and v (pointed to by VP, with VSIZE limbs), and store the result at
- PRODP. USIZE + VSIZE limbs are always stored, but if the input
- operands are normalized, the return value will reflect the true
- result size (which is either USIZE + VSIZE, or USIZE + VSIZE -1).
-
- NOTE: The space pointed to by PRODP is overwritten before finished
- with U and V, so overlap is an error.
-
- Argument constraints:
- 1. USIZE >= VSIZE.
- 2. PRODP != UP and PRODP != VP, i.e. the destination
- must be distinct from the multiplier and the multiplicand. */
-
-mp_size_t
-mpn_mul_classic (mp_ptr prodp,
- mp_srcptr up, mp_size_t usize,
- mp_srcptr vp, mp_size_t vsize)
-{
- mp_size_t n;
- mp_size_t prod_size;
- mp_limb cy;
- int i, j;
- mp_limb prod_low, prod_high;
- mp_limb cy_dig;
- mp_limb v_limb, c;
-
- if (vsize == 0)
- return 0;
-
- /* Offset UP and PRODP so that the inner loop can be faster. */
- up += usize;
- prodp += usize;
-
- /* Multiply by the first limb in V separately, as the result can
- be stored (not added) to PROD. We also avoid a loop for zeroing. */
- v_limb = vp[0];
- cy_dig = 0;
- j = -usize;
- do
- {
- umul_ppmm (prod_high, prod_low, up[j], v_limb);
- add_ssaaaa (cy_dig, prodp[j], prod_high, prod_low, 0, cy_dig);
- j++;
- }
- while (j < 0);
-
- prodp[j] = cy_dig;
- prodp++;
-
- /* For each iteration in the outer loop, multiply one limb from
- U with one limb from V, and add it to PROD. */
- for (i = 1; i < vsize; i++)
- {
- v_limb = vp[i];
- cy_dig = 0;
- j = -usize;
-
- /* Inner loops. Simulate the carry flag by jumping between
- these loops. The first is used when there was no carry
- in the previois iteration; the second when there was carry. */
-
- do
- {
- umul_ppmm (prod_high, prod_low, up[j], v_limb);
- add_ssaaaa (cy_dig, prod_low, prod_high, prod_low, 0, cy_dig);
- c = prodp[j];
- prod_low += c;
- prodp[j] = prod_low;
- if (prod_low < c)
- goto cy_loop;
- ncy_loop:
- j++;
- }
- while (j < 0);
-
- prodp[j] = cy_dig;
- prodp++;
- continue;
-
- do
- {
- umul_ppmm (prod_high, prod_low, up[j], v_limb);
- add_ssaaaa (cy_dig, prod_low, prod_high, prod_low, 0, cy_dig);
- c = prodp[j];
- prod_low += c + 1;
- prodp[j] = prod_low;
- if (prod_low > c)
- goto ncy_loop;
- cy_loop:
- j++;
- }
- while (j < 0);
-
- cy_dig += 1;
- prodp[j] = cy_dig;
- prodp++;
- }
-
- return usize + vsize - (cy_dig == 0);
-}
+++ /dev/null
-/* mpn_rshift -- Shift right a low-level natural-number integer.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* Shift U (pointed to by UP and USIZE limbs long) CNT bits to the right
- and store the USIZE least significant limbs of the result at WP.
- Return the size of the result.
-
- Argument constraints:
- 0. U must be normalized (i.e. it's most significant limb != 0).
- 1. 0 <= CNT < BITS_PER_MP_LIMB
- 2. If the result is to be written over the input, WP must be <= UP.
-*/
-
-mp_size
-#ifdef __STDC__
-mpn_rshift (mp_ptr wp,
- mp_srcptr up, mp_size usize,
- unsigned cnt)
-#else
-mpn_rshift (wp, up, usize, cnt)
- mp_ptr wp;
- mp_srcptr up;
- mp_size usize;
- unsigned cnt;
-#endif
-{
- mp_limb high_limb, low_limb;
-/* The following #ifdef hackery is from Lennart (0.999.6) [WDP 94/10] */
-/* bug in the c compiler */
-#ifdef __alpha
- unsigned long
-#else
- unsigned
-#endif
- sh_1, sh_2;
- mp_size i;
-
- if (usize == 0)
- return 0;
-
- sh_1 = cnt;
- if (sh_1 == 0)
- {
- if (wp != up)
- {
- /* Copy from low end to high end, to allow specified input/output
- overlapping. */
- for (i = 0; i < usize; i++)
- wp[i] = up[i];
- }
- return usize;
- }
-
- wp -= 1;
- sh_2 = BITS_PER_MP_LIMB - sh_1;
- high_limb = up[0];
-#if 0
- if (cy_limb != NULL)
- *cy_limb = high_limb << sh_2;
-#endif
- low_limb = high_limb;
-
- for (i = 1; i < usize; i++)
- {
- high_limb = up[i];
- wp[i] = (low_limb >> sh_1) | (high_limb << sh_2);
- low_limb = high_limb;
- }
- low_limb >>= sh_1;
- if (low_limb != 0)
- {
- wp[i] = low_limb;
- return usize;
- }
-
- return usize - 1;
-}
+++ /dev/null
-/* mpn_rshiftci -- Shift a low level natural-number integer with carry in.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* Shift U (pointed to by UP and USIZE digits long) CNT bits to the right
- and store the USIZE least significant digits of the result at WP.
- Return the size of the result.
-
- Argument constraints:
- 0. U must be normalized (i.e. it's most significant digit != 0).
- 1. 0 <= CNT < BITS_PER_MP_LIMB
- 2. If the result is to be written over the input, WP must be <= UP.
-*/
-
-mp_size
-#ifdef __STDC__
-mpn_rshiftci (mp_ptr wp,
- mp_srcptr up, mp_size usize,
- unsigned cnt,
- mp_limb carry_in)
-#else
-mpn_rshiftci (wp, up, usize, cnt, carry_in)
- mp_ptr wp;
- mp_srcptr up;
- mp_size usize;
- unsigned cnt;
- mp_limb carry_in;
-#endif
-{
- mp_limb high_limb, low_limb;
- unsigned sh_1, sh_2;
- mp_size i;
-
- if (usize <= 0)
- return 0;
-
- sh_1 = cnt;
- if (sh_1 == 0)
- {
- if (wp != up)
- {
- /* Copy from low end to high end, to allow specified input/output
- overlapping. */
- for (i = 0; i < usize; i++)
- wp[i] = up[i];
- }
- return usize;
- }
-
- wp -= 1;
- sh_2 = BITS_PER_MP_LIMB - sh_1;
- low_limb = up[0];
- for (i = 1; i < usize; i++)
- {
- high_limb = up[i];
- wp[i] = (low_limb >> sh_1) | (high_limb << sh_2);
- low_limb = high_limb;
- }
- low_limb = (low_limb >> sh_1) | (carry_in << sh_2);
- if (low_limb != 0)
- {
- wp[i] = low_limb;
- return usize;
- }
-
- return usize - 1;
-}
+++ /dev/null
-/* mpn_sqrt(root_ptr, rem_ptr, op_ptr, op_size)
-
- Write the square root of {OP_PTR, OP_SIZE} at ROOT_PTR.
- Write the remainder at REM_PTR, if REM_PTR != NULL.
- Return the size of the remainder.
- (The size of the root is always half of the size of the operand.)
-
- OP_PTR and ROOT_PTR may not point to the same object.
- OP_PTR and REM_PTR may point to the same object.
-
- If REM_PTR is NULL, only the root is computed and the return value of
- the function is 0 if OP is a perfect square, and *any* non-zero number
- otherwise.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-/* This code is just correct if "unsigned char" has at least 8 bits. It
- doesn't help to use CHAR_BIT from limits.h, as the real problem is
- the static arrays. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-/* Square root algorithm:
-
- 1. Shift OP (the input) to the left an even number of bits s.t. there
- are an even number of words and either (or both) of the most
- significant bits are set. This way, sqrt(OP) has exactly half as
- many words as OP, and has its most significant bit set.
-
- 2. Get a 9-bit approximation to sqrt(OP) using the pre-computed tables.
- This approximation is used for the first single-precision
- iterations of Newton's method, yielding a full-word approximation
- to sqrt(OP).
-
- 3. Perform multiple-precision Newton iteration until we have the
- exact result. Only about half of the input operand is used in
- this calculation, as the square root is perfectly determinable
- from just the higher half of a number. */
-\f
-/* Define this macro for IEEE P854 machines with a fast sqrt instruction. */
-#if defined __GNUC__
-
-#if defined __sparc__
-#define SQRT(a) \
- ({ \
- double __sqrt_res; \
- asm ("fsqrtd %1,%0" : "=f" (__sqrt_res) : "f" (a)); \
- __sqrt_res; \
- })
-#endif
-
-#if defined __HAVE_68881__
-#define SQRT(a) \
- ({ \
- double __sqrt_res; \
- asm ("fsqrtx %1,%0" : "=f" (__sqrt_res) : "f" (a)); \
- __sqrt_res; \
- })
-#endif
-
-#if defined __hppa
-#define SQRT(a) \
- ({ \
- double __sqrt_res; \
- asm ("fsqrt,dbl %1,%0" : "=fx" (__sqrt_res) : "fx" (a)); \
- __sqrt_res; \
- })
-#endif
-
-#endif
-
-#ifndef SQRT
-
-/* Tables for initial approximation of the square root. These are
- indexed with bits 1-8 of the operand for which the square root is
- calculated, where bit 0 is the most significant non-zero bit. I.e.
- the most significant one-bit is not used, since that per definition
- is one. Likewise, the tables don't return the highest bit of the
- result. That bit must be inserted by or:ing the returned value with
- 0x100. This way, we get a 9-bit approximation from 8-bit tables! */
-
-/* Table to be used for operands with an even total number of bits.
- (Exactly as in the decimal system there are similarities between the
- square root of numbers with the same initial digits and an even
- difference in the total number of digits. Consider the square root
- of 1, 10, 100, 1000, ...) */
-static unsigned char even_approx_tab[256] =
-{
- 0x6a, 0x6a, 0x6b, 0x6c, 0x6c, 0x6d, 0x6e, 0x6e,
- 0x6f, 0x70, 0x71, 0x71, 0x72, 0x73, 0x73, 0x74,
- 0x75, 0x75, 0x76, 0x77, 0x77, 0x78, 0x79, 0x79,
- 0x7a, 0x7b, 0x7b, 0x7c, 0x7d, 0x7d, 0x7e, 0x7f,
- 0x80, 0x80, 0x81, 0x81, 0x82, 0x83, 0x83, 0x84,
- 0x85, 0x85, 0x86, 0x87, 0x87, 0x88, 0x89, 0x89,
- 0x8a, 0x8b, 0x8b, 0x8c, 0x8d, 0x8d, 0x8e, 0x8f,
- 0x8f, 0x90, 0x90, 0x91, 0x92, 0x92, 0x93, 0x94,
- 0x94, 0x95, 0x96, 0x96, 0x97, 0x97, 0x98, 0x99,
- 0x99, 0x9a, 0x9b, 0x9b, 0x9c, 0x9c, 0x9d, 0x9e,
- 0x9e, 0x9f, 0xa0, 0xa0, 0xa1, 0xa1, 0xa2, 0xa3,
- 0xa3, 0xa4, 0xa4, 0xa5, 0xa6, 0xa6, 0xa7, 0xa7,
- 0xa8, 0xa9, 0xa9, 0xaa, 0xaa, 0xab, 0xac, 0xac,
- 0xad, 0xad, 0xae, 0xaf, 0xaf, 0xb0, 0xb0, 0xb1,
- 0xb2, 0xb2, 0xb3, 0xb3, 0xb4, 0xb5, 0xb5, 0xb6,
- 0xb6, 0xb7, 0xb7, 0xb8, 0xb9, 0xb9, 0xba, 0xba,
- 0xbb, 0xbb, 0xbc, 0xbd, 0xbd, 0xbe, 0xbe, 0xbf,
- 0xc0, 0xc0, 0xc1, 0xc1, 0xc2, 0xc2, 0xc3, 0xc3,
- 0xc4, 0xc5, 0xc5, 0xc6, 0xc6, 0xc7, 0xc7, 0xc8,
- 0xc9, 0xc9, 0xca, 0xca, 0xcb, 0xcb, 0xcc, 0xcc,
- 0xcd, 0xce, 0xce, 0xcf, 0xcf, 0xd0, 0xd0, 0xd1,
- 0xd1, 0xd2, 0xd3, 0xd3, 0xd4, 0xd4, 0xd5, 0xd5,
- 0xd6, 0xd6, 0xd7, 0xd7, 0xd8, 0xd9, 0xd9, 0xda,
- 0xda, 0xdb, 0xdb, 0xdc, 0xdc, 0xdd, 0xdd, 0xde,
- 0xde, 0xdf, 0xe0, 0xe0, 0xe1, 0xe1, 0xe2, 0xe2,
- 0xe3, 0xe3, 0xe4, 0xe4, 0xe5, 0xe5, 0xe6, 0xe6,
- 0xe7, 0xe7, 0xe8, 0xe8, 0xe9, 0xea, 0xea, 0xeb,
- 0xeb, 0xec, 0xec, 0xed, 0xed, 0xee, 0xee, 0xef,
- 0xef, 0xf0, 0xf0, 0xf1, 0xf1, 0xf2, 0xf2, 0xf3,
- 0xf3, 0xf4, 0xf4, 0xf5, 0xf5, 0xf6, 0xf6, 0xf7,
- 0xf7, 0xf8, 0xf8, 0xf9, 0xf9, 0xfa, 0xfa, 0xfb,
- 0xfb, 0xfc, 0xfc, 0xfd, 0xfd, 0xfe, 0xfe, 0xff,
-};
-
-/* Table to be used for operands with an odd total number of bits.
- (Further comments before previous table.) */
-static unsigned char odd_approx_tab[256] =
-{
- 0x00, 0x00, 0x00, 0x01, 0x01, 0x02, 0x02, 0x03,
- 0x03, 0x04, 0x04, 0x05, 0x05, 0x06, 0x06, 0x07,
- 0x07, 0x08, 0x08, 0x09, 0x09, 0x0a, 0x0a, 0x0b,
- 0x0b, 0x0c, 0x0c, 0x0d, 0x0d, 0x0e, 0x0e, 0x0f,
- 0x0f, 0x10, 0x10, 0x10, 0x11, 0x11, 0x12, 0x12,
- 0x13, 0x13, 0x14, 0x14, 0x15, 0x15, 0x16, 0x16,
- 0x16, 0x17, 0x17, 0x18, 0x18, 0x19, 0x19, 0x1a,
- 0x1a, 0x1b, 0x1b, 0x1b, 0x1c, 0x1c, 0x1d, 0x1d,
- 0x1e, 0x1e, 0x1f, 0x1f, 0x20, 0x20, 0x20, 0x21,
- 0x21, 0x22, 0x22, 0x23, 0x23, 0x23, 0x24, 0x24,
- 0x25, 0x25, 0x26, 0x26, 0x27, 0x27, 0x27, 0x28,
- 0x28, 0x29, 0x29, 0x2a, 0x2a, 0x2a, 0x2b, 0x2b,
- 0x2c, 0x2c, 0x2d, 0x2d, 0x2d, 0x2e, 0x2e, 0x2f,
- 0x2f, 0x30, 0x30, 0x30, 0x31, 0x31, 0x32, 0x32,
- 0x32, 0x33, 0x33, 0x34, 0x34, 0x35, 0x35, 0x35,
- 0x36, 0x36, 0x37, 0x37, 0x37, 0x38, 0x38, 0x39,
- 0x39, 0x39, 0x3a, 0x3a, 0x3b, 0x3b, 0x3b, 0x3c,
- 0x3c, 0x3d, 0x3d, 0x3d, 0x3e, 0x3e, 0x3f, 0x3f,
- 0x40, 0x40, 0x40, 0x41, 0x41, 0x41, 0x42, 0x42,
- 0x43, 0x43, 0x43, 0x44, 0x44, 0x45, 0x45, 0x45,
- 0x46, 0x46, 0x47, 0x47, 0x47, 0x48, 0x48, 0x49,
- 0x49, 0x49, 0x4a, 0x4a, 0x4b, 0x4b, 0x4b, 0x4c,
- 0x4c, 0x4c, 0x4d, 0x4d, 0x4e, 0x4e, 0x4e, 0x4f,
- 0x4f, 0x50, 0x50, 0x50, 0x51, 0x51, 0x51, 0x52,
- 0x52, 0x53, 0x53, 0x53, 0x54, 0x54, 0x54, 0x55,
- 0x55, 0x56, 0x56, 0x56, 0x57, 0x57, 0x57, 0x58,
- 0x58, 0x59, 0x59, 0x59, 0x5a, 0x5a, 0x5a, 0x5b,
- 0x5b, 0x5b, 0x5c, 0x5c, 0x5d, 0x5d, 0x5d, 0x5e,
- 0x5e, 0x5e, 0x5f, 0x5f, 0x60, 0x60, 0x60, 0x61,
- 0x61, 0x61, 0x62, 0x62, 0x62, 0x63, 0x63, 0x63,
- 0x64, 0x64, 0x65, 0x65, 0x65, 0x66, 0x66, 0x66,
- 0x67, 0x67, 0x67, 0x68, 0x68, 0x68, 0x69, 0x69,
-};
-#endif
-
-\f
-mp_size
-#ifdef __STDC__
-mpn_sqrt (mp_ptr root_ptr, mp_ptr rem_ptr, mp_srcptr op_ptr, mp_size op_size)
-#else
-mpn_sqrt (root_ptr, rem_ptr, op_ptr, op_size)
- mp_ptr root_ptr;
- mp_ptr rem_ptr;
- mp_srcptr op_ptr;
- mp_size op_size;
-#endif
-{
- /* R (root result) */
- mp_ptr rp; /* Pointer to least significant word */
- mp_size rsize; /* The size in words */
-
- /* T (OP shifted to the left a.k.a. normalized) */
- mp_ptr tp; /* Pointer to least significant word */
- mp_size tsize; /* The size in words */
- mp_ptr t_end_ptr; /* Pointer right beyond most sign. word */
- mp_limb t_high0, t_high1; /* The two most significant words */
-
- /* TT (temporary for numerator/remainder) */
- mp_ptr ttp; /* Pointer to least significant word */
-
- /* X (temporary for quotient in main loop) */
- mp_ptr xp; /* Pointer to least significant word */
- mp_size xsize; /* The size in words */
-
- unsigned cnt;
- mp_limb initial_approx; /* Initially made approximation */
- mp_size tsizes[BITS_PER_MP_LIMB]; /* Successive calculation precisions */
- mp_size tmp;
- mp_size i;
-
- /* If OP is zero, both results are zero. */
- if (op_size == 0)
- return 0;
-
- count_leading_zeros (cnt, op_ptr[op_size - 1]);
- tsize = op_size;
- if ((tsize & 1) != 0)
- {
- cnt += BITS_PER_MP_LIMB;
- tsize++;
- }
-
- rsize = tsize / 2;
- rp = root_ptr;
-
- /* Shift OP an even number of bits into T, such that either the most or
- the second most significant bit is set, and such that the number of
- words in T becomes even. This way, the number of words in R=sqrt(OP)
- is exactly half as many as in OP, and the most significant bit of R
- is set.
-
- Also, the initial approximation is simplified by this up-shifted OP.
-
- Finally, the Newtonian iteration which is the main part of this
- program performs division by R. The fast division routine expects
- the divisor to be "normalized" in exactly the sense of having the
- most significant bit set. */
-
- tp = (mp_ptr) alloca (tsize * BYTES_PER_MP_LIMB);
-
- t_high0 = mpn_lshift (tp + cnt / BITS_PER_MP_LIMB, op_ptr, op_size,
- (cnt & ~1) % BITS_PER_MP_LIMB);
- if (cnt >= BITS_PER_MP_LIMB)
- tp[0] = 0;
-
- t_high0 = tp[tsize - 1];
- t_high1 = tp[tsize - 2]; /* Never stray. TSIZE is >= 2. */
-
-/* Is there a fast sqrt instruction defined for this machine? */
-#ifdef SQRT
- {
- initial_approx = SQRT (t_high0 * 2.0
- * ((mp_limb) 1 << (BITS_PER_MP_LIMB - 1))
- + t_high1);
- /* If t_high0,,t_high1 is big, the result in INITIAL_APPROX might have
- become incorrect due to overflow in the conversion from double to
- mp_limb above. It will typically be zero in that case, but might be
- a small number on some machines. The most significant bit of
- INITIAL_APPROX should be set, so that bit is a good overflow
- indication. */
- if ((mp_limb_signed) initial_approx >= 0)
- initial_approx = ~0;
- }
-#else
- /* Get a 9 bit approximation from the tables. The tables expect to
- be indexed with the 8 high bits right below the highest bit.
- Also, the highest result bit is not returned by the tables, and
- must be or:ed into the result. The scheme gives 9 bits of start
- approximation with just 256-entry 8 bit tables. */
-
- if ((cnt & 1) == 0)
- {
- /* The most sign bit of t_high0 is set. */
- initial_approx = t_high0 >> (BITS_PER_MP_LIMB - 8 - 1);
- initial_approx &= 0xff;
- initial_approx = even_approx_tab[initial_approx];
- }
- else
- {
- /* The most significant bit of T_HIGH0 is unset,
- the second most significant is set. */
- initial_approx = t_high0 >> (BITS_PER_MP_LIMB - 8 - 2);
- initial_approx &= 0xff;
- initial_approx = odd_approx_tab[initial_approx];
- }
- initial_approx |= 0x100;
- initial_approx <<= BITS_PER_MP_LIMB - 8 - 1;
-
- /* Perform small precision Newtonian iterations to get a full word
- approximation. For small operands, these iteration will make the
- entire job. */
- if (t_high0 == ~0)
- initial_approx = t_high0;
- else
- {
- mp_limb quot;
-
- if (t_high0 >= initial_approx)
- initial_approx = t_high0 + 1;
-
- /* First get about 18 bits with pure C arithmetics. */
- quot = t_high0 / (initial_approx >> BITS_PER_MP_LIMB/2) << BITS_PER_MP_LIMB/2;
- initial_approx = (initial_approx + quot) / 2;
- initial_approx |= (mp_limb) 1 << (BITS_PER_MP_LIMB - 1);
-
- /* Now get a full word by one (or for > 36 bit machines) several
- iterations. */
- for (i = 16; i < BITS_PER_MP_LIMB; i <<= 1)
- {
- mp_limb ignored_remainder;
-
- udiv_qrnnd (quot, ignored_remainder,
- t_high0, t_high1, initial_approx);
- initial_approx = (initial_approx + quot) / 2;
- initial_approx |= (mp_limb) 1 << (BITS_PER_MP_LIMB - 1);
- }
- }
-#endif
-
- rp[0] = initial_approx;
- rsize = 1;
-
- xp = (mp_ptr) alloca (tsize * BYTES_PER_MP_LIMB);
- ttp = (mp_ptr) alloca (tsize * BYTES_PER_MP_LIMB);
-
- t_end_ptr = tp + tsize;
-
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- printf ("\n\nT = ");
- _mp_mout (tp, tsize);
-#endif
-
- if (tsize > 2)
- {
- /* Determine the successive precisions to use in the iteration. We
- minimize the precisions, beginning with the highest (i.e. last
- iteration) to the lowest (i.e. first iteration). */
-
- tmp = tsize / 2;
- for (i = 0;;i++)
- {
- tsize = (tmp + 1) / 2;
- if (tmp == tsize)
- break;
- tsizes[i] = tsize + tmp;
- tmp = tsize;
- }
-
- /* Main Newton iteration loop. For big arguments, most of the
- time is spent here. */
-
- /* It is possible to do a great optimization here. The successive
- divisors in the mpn_div call below has more and more leading
- words equal to its predecessor. Therefore the beginning of
- each division will repeat the same work as did the last
- division. If we could guarantee that the leading words of two
- consecutive divisors are the same (i.e. in this case, a later
- divisor has just more digits at the end) it would be a simple
- matter of just using the old remainder of the last division in
- a subsequent division, to take care of this optimization. This
- idea would surely make a difference even for small arguments. */
-
- /* Loop invariants:
-
- R <= shiftdown_to_same_size(floor(sqrt(OP))) < R + 1.
- X - 1 < shiftdown_to_same_size(floor(sqrt(OP))) <= X.
- R <= shiftdown_to_same_size(X). */
-
- while (--i >= 0)
- {
- mp_limb cy;
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- mp_limb old_least_sign_r = rp[0];
- mp_size old_rsize = rsize;
-
- printf ("R = ");
- _mp_mout (rp, rsize);
-#endif
- tsize = tsizes[i];
-
- /* Need to copy the numerator into temporary space, as
- mpn_div overwrites its numerator argument with the
- remainder (which we currently ignore). */
- MPN_COPY (ttp, t_end_ptr - tsize, tsize);
- cy = mpn_div (xp, ttp, tsize, rp, rsize);
- xsize = tsize - rsize;
- cy = cy ? xp[xsize] : 0;
-
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- printf ("X =%d", cy);
- _mp_mout (xp, xsize);
-#endif
-
- /* Add X and R with the most significant limbs aligned,
- temporarily ignoring at least one limb at the low end of X. */
- tmp = xsize - rsize;
- cy += mpn_add (xp + tmp, rp, rsize, xp + tmp, rsize);
-
- /* If T begins with more than 2 x BITS_PER_MP_LIMB of ones, we get
- intermediate roots that'd need an extra bit. We don't want to
- handle that since it would make the subsequent divisor
- non-normalized, so round such roots down to be only ones in the
- current precision. */
- if (cy == 2)
- {
- mp_size j;
- for (j = xsize; j >= 0; j--)
- xp[j] = ~(mp_limb)0;
- }
-
- /* Divide X by 2 and put the result in R. This is the new
- approximation. Shift in the carry from the addition. */
- rsize = mpn_rshiftci (rp, xp, xsize, 1, (mp_limb) 1);
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- if (old_least_sign_r != rp[rsize - old_rsize])
- printf (">>>>>>>> %d: %08x, %08x <<<<<<<<\n",
- i, old_least_sign_r, rp[rsize - old_rsize]);
-#endif
- }
- }
-
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- printf ("(final) R = ");
- _mp_mout (rp, rsize);
-#endif
-
- /* We computed the square root of OP * 2**(2*floor(cnt/2)).
- This has resulted in R being 2**floor(cnt/2) to large.
- Shift it down here to fix that. */
- rsize = mpn_rshift (rp, rp, rsize, cnt/2);
-
- /* Calculate the remainder. */
- tsize = mpn_mul (tp, rp, rsize, rp, rsize);
- if (op_size < tsize
- || (op_size == tsize && mpn_cmp (op_ptr, tp, op_size) < 0))
- {
- /* R is too large. Decrement it. */
- mp_limb one = 1;
-
- tsize = tsize + mpn_sub (tp, tp, tsize, rp, rsize);
- tsize = tsize + mpn_sub (tp, tp, tsize, rp, rsize);
- tsize = tsize + mpn_add (tp, tp, tsize, &one, 1);
-
- (void) mpn_sub (rp, rp, rsize, &one, 1);
-
-#ifdef GMP_DEBUG /* partain: was DEBUG */
- printf ("(adjusted) R = ");
- _mp_mout (rp, rsize);
-#endif
- }
-
- if (rem_ptr != NULL)
- {
- mp_size retval = op_size + mpn_sub (rem_ptr, op_ptr, op_size, tp, tsize);
- alloca (0);
- return retval;
- }
- else
- {
- mp_size retval = (op_size != tsize || mpn_cmp (op_ptr, tp, op_size));
- alloca (0);
- return retval;
- }
-}
-
-#ifdef GMP_DEBUG /* partain: was DEBUG */
-_mp_mout (mp_srcptr p, mp_size size)
-{
- mp_size ii;
- for (ii = size - 1; ii >= 0; ii--)
- printf ("%08X", p[ii]);
-
- puts ("");
-}
-#endif
+++ /dev/null
-/* mpn_sub -- Subtract two low-level natural-number integers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* Subtract SUB_PTR/SUB_SIZE from MIN_PTR/MIN_SIZE and store the
- result (MIN_SIZE words) at DIF_PTR.
-
- Return 1 if min < sub (result is negative). Otherwise, return the
- negative difference between the number of words in dif and min.
- (I.e. return 0 if the result has MIN_SIZE words, -1 if it has
- MIN_SIZE - 1 words, etc.)
-
- Argument constraint: MIN_SIZE >= SUB_SIZE.
-
- The size of DIF can be calculated as MIN_SIZE + the return value. */
-
-mp_size
-#ifdef __STDC__
-mpn_sub (mp_ptr dif_ptr,
- mp_srcptr min_ptr, mp_size min_size,
- mp_srcptr sub_ptr, mp_size sub_size)
-#else
-mpn_sub (dif_ptr, min_ptr, min_size, sub_ptr, sub_size)
- mp_ptr dif_ptr;
- mp_srcptr min_ptr;
- mp_size min_size;
- mp_srcptr sub_ptr;
- mp_size sub_size;
-#endif
-{
- mp_limb m, s, dif;
- mp_size j;
-
- /* The loop counter and index J goes from some negative value to zero.
- This way the loops are faster. Need to offset the base pointers
- to take care of the negative indices. */
-
- j = -sub_size;
- if (j == 0)
- goto sub_finished;
-
- min_ptr -= j;
- sub_ptr -= j;
- dif_ptr -= j;
-
- /* There are two do-loops, marked NON-CARRY LOOP and CARRY LOOP that
- jump between each other. The first loop is for when the previous
- subtraction didn't produce a carry-out; the second is for the
- complementary case. */
-
- /* NON-CARRY LOOP */
- do
- {
- m = min_ptr[j];
- s = sub_ptr[j];
- dif = m - s;
- dif_ptr[j] = dif;
- if (dif > m)
- goto cy_loop;
- ncy_loop:
- j++;
- }
- while (j < 0);
-
- /* We have exhausted SUB, with no carry out. Copy remaining part of
- MIN to DIF. */
-
- sub_finished:
- j = sub_size - min_size;
-
- /* If there's no difference between the length of the operands, the
- last words might have become zero, and re-normalization is needed. */
- if (j == 0)
- goto normalize;
-
- min_ptr -= j;
- dif_ptr -= j;
-
- goto copy;
-
- /* CARRY LOOP */
- do
- {
- m = min_ptr[j];
- s = sub_ptr[j];
- dif = m - s - 1;
- dif_ptr[j] = dif;
- if (dif < m)
- goto ncy_loop;
- cy_loop:
- j++;
- }
- while (j < 0);
-
- /* We have exhausted SUB, but need to propagate carry. */
-
- j = sub_size - min_size;
- if (j == 0)
- return 1; /* min < sub. Flag it to the caller */
-
- min_ptr -= j;
- dif_ptr -= j;
-
- /* Propagate carry. Sooner or later the carry will cancel with a
- non-zero word, because the minuend is normalized. Considering this,
- there's no need to test the index J. */
- for (;;)
- {
- m = min_ptr[j];
- dif = m - 1;
- dif_ptr[j] = dif;
- j++;
- if (dif < m)
- break;
- }
-
- if (j == 0)
- goto normalize;
-
- copy:
- /* Don't copy the remaining words of MIN to DIF if MIN_PTR and DIF_PTR
- are equal. It would just be a no-op copying. Return 0, as the length
- of the result equals that of the minuend. */
- if (dif_ptr == min_ptr)
- return 0;
-
- do
- {
- dif_ptr[j] = min_ptr[j];
- j++;
- }
- while (j < 0);
- return 0;
-
- normalize:
- for (j = -1; j >= -min_size; j--)
- {
- if (dif_ptr[j] != 0)
- return j + 1;
- }
-
- return -min_size;
-}
+++ /dev/null
-/* mpq_add -- add two rational numbers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_add (MP_RAT *sum, const MP_RAT *a1, const MP_RAT *a2)
-#else
-mpq_add (sum, a1, a2)
- MP_RAT *sum;
- const MP_RAT *a1;
- const MP_RAT *a2;
-#endif
-{
- MP_INT gcd1, gcd2;
- MP_INT tmp1, tmp2;
-
- mpz_init (&gcd1);
- mpz_init (&gcd2);
- mpz_init (&tmp1);
- mpz_init (&tmp2);
-
- /* SUM might be identical to either operand, so don't store the
- result there until we are finished with the input operands. We
- dare to overwrite the numerator of SUM when we are finished
- with the numerators of A1 and A2. */
-
- mpz_gcd (&gcd1, &(a1->den), &(a2->den));
- if (gcd1.size > 1 || gcd1.d[0] != 1)
- {
- MP_INT t;
-
- mpz_init (&t);
-
- mpz_div (&tmp1, &(a2->den), &gcd1);
- mpz_mul (&tmp1, &(a1->num), &tmp1);
-
- mpz_div (&tmp2, &(a1->den), &gcd1);
- mpz_mul (&tmp2, &(a2->num), &tmp2);
-
- mpz_add (&t, &tmp1, &tmp2);
- mpz_gcd (&gcd2, &t, &gcd1);
-
- mpz_div (&(sum->num), &t, &gcd2);
-
- mpz_div (&tmp1, &(a1->den), &gcd1);
- mpz_div (&tmp2, &(a2->den), &gcd2);
- mpz_mul (&(sum->den), &tmp1, &tmp2);
-
- mpz_clear (&t);
- }
- else
- {
- /* The common divisior is 1. This is the case (for random input) with
- probability 6/(pi**2). */
- mpz_mul (&tmp1, &(a1->num), &(a2->den));
- mpz_mul (&tmp2, &(a2->num), &(a1->den));
- mpz_add (&(sum->num), &tmp1, &tmp2);
- mpz_mul (&(sum->den), &(a1->den), &(a2->den));
- }
-
- mpz_clear (&tmp2);
- mpz_clear (&tmp1);
- mpz_clear (&gcd2);
- mpz_clear (&gcd1);
-}
+++ /dev/null
-/* mpq_clear -- free the space occupied by a MP_RAT.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_clear (MP_RAT *m)
-#else
-mpq_clear (m)
- MP_RAT *m;
-#endif
-{
- (*_mp_free_func) (m->num.d, m->num.alloc * BYTES_PER_MP_LIMB);
- (*_mp_free_func) (m->den.d, m->den.alloc * BYTES_PER_MP_LIMB);
-}
+++ /dev/null
-/* mpq_cmp(u,v) -- Compare U, V. Return positive, zero, or negative
- based on if U > V, U == V, or U < V.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-int
-#ifdef __STDC__
-mpq_cmp (const MP_RAT *op1, const MP_RAT *op2)
-#else
-mpq_cmp (op1, op2)
- const MP_RAT *op1;
- const MP_RAT *op2;
-#endif
-{
- mp_size num1_size = op1->num.size;
- mp_size den1_size = op1->den.size;
- mp_size num2_size = op2->num.size;
- mp_size den2_size = op2->den.size;
- mp_size tmp1_size, tmp2_size;
- mp_ptr tmp1_ptr, tmp2_ptr;
- mp_size num1_sign;
- int cc;
-
- if (num1_size == 0)
- return -num2_size;
- if (num2_size == 0)
- return num1_size;
- if ((num1_size ^ num2_size) < 0) /* I.e. are the signs different? */
- return num1_size;
-
- num1_sign = num1_size;
- num1_size = ABS (num1_size);
- num2_size = ABS (num2_size);
-
- tmp1_size = num1_size + den2_size;
- tmp2_size = num2_size + den1_size;
-
- if (tmp1_size != tmp2_size)
- return (tmp1_size - tmp2_size) ^ num1_sign;
-
- tmp1_ptr = (mp_ptr) alloca (tmp1_size * BYTES_PER_MP_LIMB);
- tmp2_ptr = (mp_ptr) alloca (tmp2_size * BYTES_PER_MP_LIMB);
-
- tmp1_size = (num1_size >= den2_size)
- ? mpn_mul (tmp1_ptr, op1->num.d, num1_size, op2->den.d, den2_size)
- : mpn_mul (tmp1_ptr, op2->den.d, den2_size, op1->num.d, num1_size);
-
- tmp2_size = (num2_size >= den1_size)
- ? mpn_mul (tmp2_ptr, op2->num.d, num2_size, op1->den.d, den1_size)
- : mpn_mul (tmp2_ptr, op1->den.d, den1_size, op2->num.d, num2_size);
-
- cc = tmp1_size - tmp2_size != 0
- ? tmp1_size - tmp2_size : mpn_cmp (tmp1_ptr, tmp2_ptr, tmp1_size);
-
- alloca (0);
- return (num1_sign < 0) ? -cc : cc;
-}
+++ /dev/null
-/* mpq_div -- divide two rational numbers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_div (MP_RAT *quot, const MP_RAT *dividend, const MP_RAT *divisor)
-#else
-mpq_div (quot, dividend, divisor)
- MP_RAT *quot;
- const MP_RAT *dividend;
- const MP_RAT *divisor;
-#endif
-{
- MP_INT gcd1, gcd2;
- MP_INT tmp1, tmp2;
- MP_INT numtmp;
-
- mpz_init (&gcd1);
- mpz_init (&gcd2);
- mpz_init (&tmp1);
- mpz_init (&tmp2);
- mpz_init (&numtmp);
-
- /* QUOT might be identical to either operand, so don't store the
- result there until we are finished with the input operands. We
- dare to overwrite the numerator of QUOT when we are finished
- with the numerators of DIVIDEND and DIVISOR. */
-
- mpz_gcd (&gcd1, &(dividend->num), &(divisor->num));
- mpz_gcd (&gcd2, &(divisor->den), &(dividend->den));
-
- if (gcd1.size > 1 || gcd1.d[0] != 1)
- mpz_div (&tmp1, &(dividend->num), &gcd1);
- else
- mpz_set (&tmp1, &(dividend->num));
-
- if (gcd2.size > 1 || gcd2.d[0] != 1)
- mpz_div (&tmp2, &(divisor->den), &gcd2);
- else
- mpz_set (&tmp2, &(divisor->den));
-
- mpz_mul (&numtmp, &tmp1, &tmp2);
-
- if (gcd1.size > 1 || gcd1.d[0] != 1)
- mpz_div (&tmp1, &(divisor->num), &gcd1);
- else
- mpz_set (&tmp1, &(divisor->num));
-
- if (gcd2.size > 1 || gcd2.d[0] != 1)
- mpz_div (&tmp2, &(dividend->den), &gcd2);
- else
- mpz_set (&tmp2, &(dividend->den));
-
- mpz_mul (&(quot->den), &tmp1, &tmp2);
-
- /* We needed to go via NUMTMP to take care of QUOT being the same
- as either input operands. Now move NUMTMP to QUOT->NUM. */
- mpz_set (&(quot->num), &numtmp);
-
- /* Keep the denominator positive. */
- if (quot->den.size < 0)
- {
- quot->den.size = -quot->den.size;
- quot->num.size = -quot->num.size;
- }
-
- mpz_clear (&numtmp);
- mpz_clear (&tmp2);
- mpz_clear (&tmp1);
- mpz_clear (&gcd2);
- mpz_clear (&gcd1);
-}
+++ /dev/null
-/* mpq_get_den(den,rat_src) -- Set DEN to the denominator of RAT_SRC.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_get_den (MP_INT *den, const MP_RAT *src)
-#else
-mpq_get_den (den, src)
- MP_INT *den;
- const MP_RAT *src;
-#endif
-{
- mp_size size = src->den.size;
-
- if (den->alloc < size)
- _mpz_realloc (den, size);
-
- MPN_COPY (den->d, src->den.d, size);
- den->size = size;
-}
+++ /dev/null
- /* mpq_get_num(num,rat_src) -- Set NUM to the numerator of RAT_SRC.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_get_num (MP_INT *num, const MP_RAT *src)
-#else
-mpq_get_num (num, src)
- MP_INT *num;
- const MP_RAT *src;
-#endif
-{
- mp_size size = src->num.size;
- mp_size abs_size = ABS (size);
-
- if (num->alloc < abs_size)
- _mpz_realloc (num, abs_size);
-
- MPN_COPY (num->d, src->num.d, abs_size);
- num->size = size;
-}
+++ /dev/null
-/* mpq_init -- Make a new rational number with value 0/1.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_init (MP_RAT *x)
-#else
-mpq_init (x)
- MP_RAT *x;
-#endif
-{
- x->num.alloc = 1;
- x->num.d = (mp_ptr) (*_mp_allocate_func) (BYTES_PER_MP_LIMB * x->num.alloc);
- x->num.size = 0;
- x->den.alloc = 1;
- x->den.d = (mp_ptr) (*_mp_allocate_func) (BYTES_PER_MP_LIMB * x->den.alloc);
- x->den.d[0] = 1;
- x->den.size = 1;
-}
+++ /dev/null
-/* mpq_inv(dest,src) -- invert a rational number, i.e. set DEST to SRC
- with the numerator and denominator swapped.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_inv (MP_RAT *dest, const MP_RAT *src)
-#else
-mpq_inv (dest, src)
- MP_RAT *dest;
- const MP_RAT *src;
-#endif
-{
- mp_size num_size = src->num.size;
- mp_size den_size = src->den.size;
-
- if (num_size == 0)
- num_size = 1 / num_size; /* Divide by zero! */
-
- if (num_size < 0)
- {
- num_size = -num_size;
- den_size = -den_size;
- }
- dest->den.size = num_size;
- dest->num.size = den_size;
-
- /* If dest == src we may just swap the numerator and denominator, but
- we have to ensure the new denominator is positive. */
-
- if (dest == src)
- {
- mp_size alloc = dest->num.alloc;
- mp_ptr limb_ptr = dest->num.d;
-
- dest->num.alloc = dest->den.alloc;
- dest->num.d = dest->den.d;
-
- dest->den.alloc = alloc;
- dest->den.d = limb_ptr;
- }
- else
- {
- den_size = ABS (den_size);
- if (dest->num.alloc < den_size)
- _mpz_realloc (&(dest->num), den_size);
-
- if (dest->den.alloc < num_size)
- _mpz_realloc (&(dest->den), num_size);
-
- MPN_COPY (dest->num.d, src->den.d, den_size);
- MPN_COPY (dest->den.d, src->num.d, num_size);
- }
-}
+++ /dev/null
-/* mpq_mul -- mutiply two rational numbers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_mul (MP_RAT *prod, const MP_RAT *m1, const MP_RAT *m2)
-#else
-mpq_mul (prod, m1, m2)
- MP_RAT *prod;
- const MP_RAT *m1;
- const MP_RAT *m2;
-#endif
-{
- MP_INT gcd1, gcd2;
- MP_INT tmp1, tmp2;
-
- mpz_init (&gcd1);
- mpz_init (&gcd2);
- mpz_init (&tmp1);
- mpz_init (&tmp2);
-
- /* PROD might be identical to either operand, so don't store the
- result there until we are finished with the input operands. We
- dare to overwrite the numerator of PROD when we are finished
- with the numerators of M1 and M1. */
-
- mpz_gcd (&gcd1, &(m1->num), &(m2->den));
- mpz_gcd (&gcd2, &(m2->num), &(m1->den));
-
- if (gcd1.size > 1 || gcd1.d[0] != 1)
- mpz_div (&tmp1, &(m1->num), &gcd1);
- else
- mpz_set (&tmp1, &(m1->num));
-
- if (gcd2.size > 1 || gcd2.d[0] != 1)
- mpz_div (&tmp2, &(m2->num), &gcd2);
- else
- mpz_set (&tmp2, &(m2->num));
-
- mpz_mul (&(prod->num), &tmp1, &tmp2);
-
- if (gcd1.size > 1 || gcd1.d[0] != 1)
- mpz_div (&tmp1, &(m2->den), &gcd1);
- else
- mpz_set (&tmp1, &(m2->den));
-
- if (gcd2.size > 1 || gcd2.d[0] != 1)
- mpz_div (&tmp2, &(m1->den), &gcd2);
- else
- mpz_set (&tmp2, &(m1->den));
-
- mpz_mul (&(prod->den), &tmp1, &tmp2);
-
- mpz_clear (&tmp2);
- mpz_clear (&tmp1);
- mpz_clear (&gcd2);
- mpz_clear (&gcd1);
-}
+++ /dev/null
-/* mpq_neg(dst, src) -- Assign the negated value of SRC to DST.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_neg (MP_RAT *dst, const MP_RAT *src)
-#else
-mpq_neg (dst, src)
- MP_RAT *dst;
- const MP_RAT *src;
-#endif
-{
- mpz_neg (&dst->num, &src->num);
- mpz_set (&dst->den, &src->den);
-}
+++ /dev/null
-/* mpq_set(dest,src) -- Set DEST to SRC.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_set (MP_RAT *dest, const MP_RAT *src)
-#else
-mpq_set (dest, src)
- MP_RAT *dest;
- const MP_RAT *src;
-#endif
-{
- mp_size num_size, den_size;
- mp_size abs_num_size;
-
- num_size = src->num.size;
- abs_num_size = ABS (num_size);
- if (dest->num.alloc < abs_num_size)
- _mpz_realloc (&(dest->num), abs_num_size);
- MPN_COPY (dest->num.d, src->num.d, abs_num_size);
- dest->num.size = num_size;
-
- den_size = src->den.size;
- if (dest->den.alloc < den_size)
- _mpz_realloc (&(dest->den), den_size);
- MPN_COPY (dest->den.d, src->den.d, den_size);
- dest->den.size = den_size;
-}
+++ /dev/null
-/* mpq_set_den(dest,den) -- Set the denominator of DEST from DEN.
- If DEN < 0 change the sign of the numerator of DEST.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_set_den (MP_RAT *dest, const MP_INT *den)
-#else
-mpq_set_den (dest, den)
- MP_RAT *dest;
- const MP_INT *den;
-#endif
-{
- mp_size size = den->size;
- mp_size abs_size = ABS (size);
-
- if (dest->den.alloc < abs_size)
- _mpz_realloc (&(dest->den), abs_size);
-
- MPN_COPY (dest->den.d, den->d, abs_size);
- dest->den.size = abs_size;
-
- /* The denominator is always positive; move the sign to the numerator. */
- if (size < 0)
- dest->num.size = -dest->num.size;
-}
+++ /dev/null
-/* mpq_set_num(dest,num) -- Set the numerator of DEST from NUM.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_set_num (MP_RAT *dest, const MP_INT *num)
-#else
-mpq_set_num (dest, num)
- MP_RAT *dest;
- const MP_INT *num;
-#endif
-{
- mp_size size = num->size;
- mp_size abs_size = ABS (size);
-
- if (dest->num.alloc < abs_size)
- _mpz_realloc (&(dest->num), abs_size);
-
- MPN_COPY (dest->num.d, num->d, abs_size);
- dest->num.size = size;
-}
+++ /dev/null
-/* mpq_set_si(dest,ulong_num,ulong_den) -- Set DEST to the retional number
- ULONG_NUM/ULONG_DEN.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-static unsigned long int
-gcd (x, y)
- unsigned long int x, y;
-{
- for (;;)
- {
- x = x % y;
- if (x == 0)
- return y;
- y = y % x;
- if (y == 0)
- return x;
- }
-}
-
-void
-#ifdef __STDC__
-mpq_set_si (MP_RAT *dest, signed long int num, unsigned long int den)
-#else
-mpq_set_si (dest, num, den)
- MP_RAT *dest;
- signed long int num;
- unsigned long int den;
-#endif
-{
- unsigned long int g;
- unsigned long int abs_num;
-
- abs_num = ABS (num);
-
- if (num == 0)
- {
- /* Canonicalize 0/d to 0/1. */
- den = 1;
- dest->num.size = 0;
- }
- else
- {
- /* Remove any common factor in NUM and DEN. */
- /* Pass DEN as the second argument to gcd, in order to make the
- gcd function divide by zero if DEN is zero. */
- g = gcd (abs_num, den);
- abs_num /= g;
- den /= g;
-
- dest->num.d[0] = abs_num;
- dest->num.size = num > 0 ? 1 : -1;
- }
-
- dest->den.d[0] = den;
- dest->den.size = 1;
-}
+++ /dev/null
-/* mpq_set_ui(dest,ulong_num,ulong_den) -- Set DEST to the retional number
- ULONG_NUM/ULONG_DEN.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-static unsigned long int
-gcd (x, y)
- unsigned long int x, y;
-{
- for (;;)
- {
- x = x % y;
- if (x == 0)
- return y;
- y = y % x;
- if (y == 0)
- return x;
- }
-}
-
-void
-#ifdef __STDC__
-mpq_set_ui (MP_RAT *dest, unsigned long int num, unsigned long int den)
-#else
-mpq_set_ui (dest, num, den)
- MP_RAT *dest;
- unsigned long int num;
- unsigned long int den;
-#endif
-{
- unsigned long int g;
-
- if (num == 0)
- {
- /* Canonicalize 0/n to 0/1. */
- den = 1;
- dest->num.size = 0;
- }
- else
- {
- /* Remove any common factor in NUM and DEN. */
- /* Pass DEN as the second argument to gcd, in order to make the
- gcd function divide by zero if DEN is zero. */
- g = gcd (num, den);
- num /= g;
- den /= g;
-
- dest->num.d[0] = num;
- dest->num.size = 1;
- }
-
- dest->den.d[0] = den;
- dest->den.size = 1;
-}
+++ /dev/null
-/* mpq_sub -- subtract two rational numbers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpq_sub (MP_RAT *dif, const MP_RAT *min, const MP_RAT *sub)
-#else
-mpq_sub (dif, min, sub)
- MP_RAT *dif;
- const MP_RAT *min;
- const MP_RAT *sub;
-#endif
-{
- MP_INT gcd1, gcd2;
- MP_INT tmp1, tmp2;
-
- mpz_init (&gcd1);
- mpz_init (&gcd2);
- mpz_init (&tmp1);
- mpz_init (&tmp2);
-
- /* DIF might be identical to either operand, so don't store the
- result there until we are finished with the input operands. We
- dare to overwrite the numerator of DIF when we are finished
- with the numerators of MIN and SUB. */
-
- mpz_gcd (&gcd1, &(min->den), &(sub->den));
- if (gcd1.size > 1 || gcd1.d[0] != 1)
- {
- MP_INT t;
-
- mpz_init (&t);
-
- mpz_div (&tmp1, &(sub->den), &gcd1);
- mpz_mul (&tmp1, &(min->num), &tmp1);
-
- mpz_div (&tmp2, &(min->den), &gcd1);
- mpz_mul (&tmp2, &(sub->num), &tmp2);
-
- mpz_sub (&t, &tmp1, &tmp2);
- mpz_gcd (&gcd2, &t, &gcd1);
-
- mpz_div (&(dif->num), &t, &gcd2);
-
- mpz_div (&tmp1, &(min->den), &gcd1);
- mpz_div (&tmp2, &(sub->den), &gcd2);
- mpz_mul (&(dif->den), &tmp1, &tmp2);
-
- mpz_clear (&t);
- }
- else
- {
- /* The common divisior is 1. This is the case (for random input) with
- probability 6/(pi**2). */
- mpz_mul (&tmp1, &(min->num), &(sub->den));
- mpz_mul (&tmp2, &(sub->num), &(min->den));
- mpz_sub (&(dif->num), &tmp1, &tmp2);
- mpz_mul (&(dif->den), &(min->den), &(sub->den));
- }
-
- mpz_clear (&tmp2);
- mpz_clear (&tmp1);
- mpz_clear (&gcd2);
- mpz_clear (&gcd1);
-}
+++ /dev/null
-/* mpz_abs(MP_INT *dst, MP_INT *src) -- Assign the absolute value of SRC to DST.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_abs (MP_INT *dst, const MP_INT *src)
-#else
-mpz_abs (dst, src)
- MP_INT *dst;
- const MP_INT *src;
-#endif
-{
- mp_size src_size = ABS (src->size);
-
- if (src != dst)
- {
- if (dst->alloc < src_size)
- _mpz_realloc (dst, src_size);
-
- MPN_COPY (dst->d, src->d, src_size);
- }
-
- dst->size = src_size;
-}
+++ /dev/null
-/* mpz_add -- Add two integers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#ifndef BERKELEY_MP
-void
-#ifdef __STDC__
-mpz_add (MP_INT *sum, const MP_INT *u, const MP_INT *v)
-#else
-mpz_add (sum, u, v)
- MP_INT *sum;
- const MP_INT *u;
- const MP_INT *v;
-#endif
-#else /* BERKELEY_MP */
-void
-#ifdef __STDC__
-madd (const MP_INT *u, const MP_INT *v, MP_INT *sum)
-#else
-madd (u, v, sum)
- const MP_INT *u;
- const MP_INT *v;
- MP_INT *sum;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_srcptr up, vp;
- mp_ptr sump;
- mp_size usize, vsize, sumsize;
- mp_size abs_usize;
- mp_size abs_vsize;
-
- usize = u->size;
- vsize = v->size;
- abs_usize = ABS (usize);
- abs_vsize = ABS (vsize);
-
- if (abs_usize < abs_vsize)
- {
- /* Swap U and V. */
- {const MP_INT *t = u; u = v; v = t;}
- {mp_size t = usize; usize = vsize; vsize = t;}
- {mp_size t = abs_usize; abs_usize = abs_vsize; abs_vsize = t;}
- }
-
- /* True: abs(USIZE) >= abs(VSIZE) */
-
- /* If not space for sum (and possible carry), increase space. */
- sumsize = abs_usize + 1;
- if (sum->alloc < sumsize)
- _mpz_realloc (sum, sumsize);
-
- /* These must be after realloc (u or v may be the same as sum). */
- up = u->d;
- vp = v->d;
- sump = sum->d;
-
- if (usize >= 0)
- {
- if (vsize >= 0)
- {
- sumsize = mpn_add (sump, up, abs_usize, vp, abs_vsize);
- if (sumsize != 0)
- sump[abs_usize] = 1;
- sumsize = sumsize + abs_usize;
- }
- else
- {
- /* The signs are different. Need exact comparision to determine
- which operand to subtract from which. */
- if (abs_usize == abs_vsize && mpn_cmp (up, vp, abs_usize) < 0)
- sumsize = -(abs_usize
- + mpn_sub (sump, vp, abs_usize, up, abs_usize));
- else
- sumsize = (abs_usize
- + mpn_sub (sump, up, abs_usize, vp, abs_vsize));
- }
- }
- else
- {
- if (vsize >= 0)
- {
- /* The signs are different. Need exact comparision to determine
- which operand to subtract from which. */
- if (abs_usize == abs_vsize && mpn_cmp (up, vp, abs_usize) < 0)
- sumsize = (abs_usize
- + mpn_sub (sump, vp, abs_usize, up, abs_usize));
- else
- sumsize = -(abs_usize
- + mpn_sub (sump, up, abs_usize, vp, abs_vsize));
- }
- else
- {
- sumsize = mpn_add (sump, up, abs_usize, vp, abs_vsize);
- if (sumsize != 0)
- sump[abs_usize] = 1;
- sumsize = -(sumsize + abs_usize);
- }
- }
-
- sum->size = sumsize;
-}
+++ /dev/null
-/* mpz_add_ui -- Add an MP_INT and an unsigned one-word integer.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_add_ui (MP_INT *sum, const MP_INT *add1, mp_limb add2)
-#else
-mpz_add_ui (sum, add1, add2)
- MP_INT *sum;
- const MP_INT *add1;
- mp_limb add2;
-#endif
-{
- mp_srcptr add1p;
- mp_ptr sump;
- mp_size add1size, sumsize;
- mp_size abs_add1size;
-
- add1size = add1->size;
- abs_add1size = ABS (add1size);
-
- /* If not space for SUM (and possible carry), increase space. */
- sumsize = abs_add1size + 1;
- if (sum->alloc < sumsize)
- _mpz_realloc (sum, sumsize);
-
- /* These must be after realloc (ADD1 may be the same as SUM). */
- add1p = add1->d;
- sump = sum->d;
-
- if (add2 == 0)
- {
- MPN_COPY (sump, add1p, abs_add1size);
- sum->size = add1size;
- return;
- }
- if (abs_add1size == 0)
- {
- sump[0] = add2;
- sum->size = 1;
- return;
- }
-
- if (add1size >= 0)
- {
- sumsize = mpn_add (sump, add1p, abs_add1size, &add2, 1);
- if (sumsize != 0)
- sump[abs_add1size] = 1;
- sumsize = sumsize + abs_add1size;
- }
- else
- {
- /* The signs are different. Need exact comparision to determine
- which operand to subtract from which. */
- if (abs_add1size == 1 && add1p[0] < add2)
- sumsize = (abs_add1size
- + mpn_sub (sump, &add2, 1, add1p, 1));
- else
- sumsize = -(abs_add1size
- + mpn_sub (sump, add1p, abs_add1size, &add2, 1));
- }
-
- sum->size = sumsize;
-}
+++ /dev/null
-/* mpz_and -- Logical and.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#define min(l,o) ((l) < (o) ? (l) : (o))
-#define max(h,i) ((h) > (i) ? (h) : (i))
-
-void
-#ifdef __STDC__
-mpz_and (MP_INT *res, const MP_INT *op1, const MP_INT *op2)
-#else
-mpz_and (res, op1, op2)
- MP_INT *res;
- const MP_INT *op1;
- const MP_INT *op2;
-#endif
-{
- mp_srcptr op1_ptr, op2_ptr;
- mp_size op1_size, op2_size;
- mp_ptr res_ptr;
- mp_size res_size;
- mp_size i;
-
- op1_size = op1->size;
- op2_size = op2->size;
-
- op1_ptr = op1->d;
- op2_ptr = op2->d;
- res_ptr = res->d;
-
- if (op1_size >= 0)
- {
- if (op2_size >= 0)
- {
- res_size = min (op1_size, op2_size);
- /* First loop finds the size of the result. */
- for (i = res_size - 1; i >= 0; i--)
- if ((op1_ptr[i] & op2_ptr[i]) != 0)
- break;
- res_size = i + 1;
-
- /* Handle allocation, now when we know exactly how much space is
- needed for the result. */
- if (res->alloc < res_size)
- {
- _mpz_realloc (res, res_size);
- op1_ptr = op1->d;
- op2_ptr = op2->d;
- res_ptr = res->d;
- }
-
- /* Second loop computes the real result. */
- for (i = res_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] & op2_ptr[i];
-
- res->size = res_size;
- return;
- }
- else /* op2_size < 0 */
- /* Fall through to the code at the end of the function. */
- ;
- }
- else
- {
- if (op2_size < 0)
- {
- mp_ptr opx;
- mp_limb cy;
- mp_limb one = 1;
- mp_size res_alloc;
-
- /* Both operands are negative, so will be the result.
- -((-OP1) & (-OP2)) = -(~(OP1 - 1) & ~(OP2 - 1)) =
- = ~(~(OP1 - 1) & ~(OP2 - 1)) + 1 =
- = ((OP1 - 1) | (OP2 - 1)) + 1 */
-
- op1_size = -op1_size;
- op2_size = -op2_size;
-
- res_alloc = 1 + max (op1_size, op2_size);
-
- opx = (mp_ptr) alloca (op1_size * BYTES_PER_MP_LIMB);
- op1_size += mpn_sub (opx, op1_ptr, op1_size, &one, 1);
- op1_ptr = opx;
-
- opx = (mp_ptr) alloca (op2_size * BYTES_PER_MP_LIMB);
- op2_size += mpn_sub (opx, op2_ptr, op2_size, &one, 1);
- op2_ptr = opx;
-
- if (res->alloc < res_alloc)
- {
- _mpz_realloc (res, res_alloc);
- res_ptr = res->d;
- /* Don't re-read OP1_PTR and OP2_PTR. They point to
- temporary space--never to the space RES->D used
- to point to before reallocation. */
- }
-
- if (op1_size >= op2_size)
- {
- MPN_COPY (res_ptr + op2_size, op1_ptr + op2_size,
- op1_size - op2_size);
- for (i = op2_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] | op2_ptr[i];
- res_size = op1_size;
- }
- else
- {
- MPN_COPY (res_ptr + op1_size, op2_ptr + op1_size,
- op2_size - op1_size);
- for (i = op1_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] | op2_ptr[i];
- res_size = op2_size;
- }
-
- if (res_size != 0)
- {
- cy = mpn_add (res_ptr, res_ptr, res_size, &one, 1);
- if (cy)
- {
- res_ptr[res_size] = cy;
- res_size++;
- }
- }
- else
- {
- res_ptr[0] = 1;
- res_size = 1;
- }
-
- res->size = -res_size;
- return;
- }
- else
- {
- /* We should compute -OP1 & OP2. Swap OP1 and OP2 and fall
- through to the code that handles OP1 & -OP2. */
- {const MP_INT *t = op1; op1 = op2; op2 = t;}
- {mp_srcptr t = op1_ptr; op1_ptr = op2_ptr; op2_ptr = t;}
- {mp_size t = op1_size; op1_size = op2_size; op2_size = t;}
- }
-
- }
-
- {
-#if 0
- mp_size op2_lim;
-
- /* OP2 must be negated as with infinite precision.
-
- Scan from the low end for a non-zero limb. The first non-zero
- limb is simply negated (two's complement). Any subsequent
- limbs are one's complemented. Of course, we don't need to
- handle more limbs than there are limbs in the other, positive
- operand as the result for those limbs is going to become zero
- anyway. */
-
- /* Scan for the least significant. non-zero OP2 limb, and zero the
- result meanwhile for those limb positions. (We will surely
- find a non-zero limb, so we can write the loop with one
- termination condition only.) */
- for (i = 0; op2_ptr[i] == 0; i++)
- res_ptr[i] = 0;
- op2_lim = i;
-
- op2_size = -op2_size;
-
- if (op1_size <= op2_size)
- {
- /* The ones-extended OP2 is >= than the zero-extended OP1.
- RES_SIZE <= OP1_SIZE. Find the exact size. */
- for (i = op1_size - 1; i > op2_lim; i--)
- if ((op1_ptr[i] & ~op2_ptr[i]) != 0)
- break;
- res_size = i + 1;
- }
- else
- {
- /* The ones-extended OP2 is < than the zero-extended OP1.
- RES_SIZE == OP1_SIZE, since OP1 is normalized. */
- res_size = op1_size;
- }
-#endif
-
- /* OP1 is positive and zero-extended,
- OP2 is negative and ones-extended.
- The result will be positive.
- OP1 & -OP2 = OP1 & ~(OP2 - 1). */
-
- mp_ptr opx;
- const mp_limb one = 1;
-
- op2_size = -op2_size;
- opx = (mp_ptr) alloca (op2_size * BYTES_PER_MP_LIMB);
- op2_size += mpn_sub (opx, op2_ptr, op2_size, &one, 1);
- op2_ptr = opx;
-
- if (op1_size > op2_size)
- {
- /* The result has the same size as OP1, since OP1 is normalized
- and longer than the ones-extended OP2. */
- res_size = op1_size;
-
- /* Handle allocation, now when we know exactly how much space is
- needed for the result. */
- if (res->alloc < res_size)
- {
- _mpz_realloc (res, res_size);
- res_ptr = res->d;
- op1_ptr = op1->d;
- /* Don't re-read OP2_PTR. It points to temporary space--never
- to the space RES->D used to point to before reallocation. */
- }
-
- MPN_COPY (res_ptr + op2_size, op1_ptr + op2_size,
- res_size - op2_size);
- for (i = op2_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] & ~op2_ptr[i];
-
- res->size = res_size;
- }
- else
- {
- /* Find out the exact result size. Ignore the high limbs of OP2,
- OP1 is zero-extended and would make the result zero. */
- for (i = op1_size - 1; i >= 0; i--)
- if ((op1_ptr[i] & ~op2_ptr[i]) != 0)
- break;
- res_size = i + 1;
-
- /* Handle allocation, now when we know exactly how much space is
- needed for the result. */
- if (res->alloc < res_size)
- {
- _mpz_realloc (res, res_size);
- res_ptr = res->d;
- op1_ptr = op1->d;
- /* Don't re-read OP2_PTR. It points to temporary space--never
- to the space RES->D used to point to before reallocation. */
- }
-
- for (i = res_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] & ~op2_ptr[i];
-
- res->size = res_size;
- }
- }
-}
+++ /dev/null
-/* mpz_clear -- de-allocate the space occupied by the dynamic digit space of
- an integer.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_clear (MP_INT *m)
-#else
-mpz_clear (m)
- MP_INT *m;
-#endif
-{
- (*_mp_free_func) (m->d, m->alloc * BYTES_PER_MP_LIMB);
-}
+++ /dev/null
-/* mpz_clrbit -- clear a specified bit.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#define MPN_NORMALIZE(p, size) \
- do { \
- mp_size i; \
- for (i = (size) - 1; i >= 0; i--) \
- if ((p)[i] != 0) \
- break; \
- (size) = i + 1; \
- } while (0)
-
-void
-#ifdef __STDC__
-mpz_clrbit (MP_INT *d, unsigned long int bit_index)
-#else
-mpz_clrbit (d, bit_index)
- MP_INT *d;
- unsigned long int bit_index;
-#endif
-{
- mp_size dsize = d->size;
- mp_ptr dp = d->d;
- mp_size limb_index;
-
- limb_index = bit_index / BITS_PER_MP_LIMB;
- if (dsize >= 0)
- {
- if (limb_index < dsize)
- {
- dp[limb_index] &= ~((mp_limb) 1 << (bit_index % BITS_PER_MP_LIMB));
- MPN_NORMALIZE (dp, dsize);
- d->size = dsize;
- }
- else
- ;
- }
- else
- {
- mp_size zero_bound;
-
- /* Simulate two's complement arithmetic, i.e. simulate
- 1. Set OP = ~(OP - 1) [with infinitely many leading ones].
- 2. clear the bit.
- 3. Set OP = ~OP + 1. */
-
- dsize = -dsize;
-
- /* No upper bound on this loop, we're sure there's a non-zero limb
- sooner ot later. */
- for (zero_bound = 0; ; zero_bound++)
- if (dp[zero_bound] != 0)
- break;
-
- if (limb_index > zero_bound)
- {
- if (limb_index < dsize)
- {
- dp[limb_index] |= ((mp_limb) 1 << (bit_index % BITS_PER_MP_LIMB));
- }
- else
- {
- /* Ugh. The bit should be cleared outside of the end of the
- number. We have to increase the size of the number. */
- if (d->alloc < limb_index + 1)
- {
- _mpz_realloc (d, limb_index + 1);
- dp = d->d;
- }
- MPN_ZERO (dp + dsize, limb_index - dsize);
- dp[limb_index] = ((mp_limb) 1 << (bit_index % BITS_PER_MP_LIMB));
- d->size = -(limb_index + 1);
- }
- }
- else if (limb_index == zero_bound)
- {
- dp[limb_index] = ((dp[limb_index] - 1)
- | ((mp_limb) 1 << (bit_index % BITS_PER_MP_LIMB))) + 1;
- if (dp[limb_index] == 0)
- {
- mp_size i;
- for (i = limb_index + 1; i < dsize; i++)
- {
- dp[i] += 1;
- if (dp[i] != 0)
- goto fin;
- }
- /* We got carry all way out beyond the end of D. Increase
- its size (and allocation if necessary). */
- dsize++;
- if (d->alloc < dsize)
- {
- _mpz_realloc (d, dsize);
- dp = d->d;
- }
- dp[i] = 1;
- d->size = -dsize;
- fin:;
- }
- }
- else
- ;
- }
-}
+++ /dev/null
-/* mpz_cmp(u,v) -- Compare U, V. Return postive, zero, or negative
- based on if U > V, U == V, or U < V.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#ifdef BERKELEY_MP
-#include "mp.h"
-#endif
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#ifndef BERKELEY_MP
-int
-#ifdef __STDC__
-mpz_cmp (const MP_INT *u, const MP_INT *v)
-#else
-mpz_cmp (u, v)
- const MP_INT *u;
- const MP_INT *v;
-#endif
-#else /* BERKELEY_MP */
-int
-#ifdef __STDC__
-mcmp (const MP_INT *u, const MP_INT *v)
-#else
-mcmp (u, v)
- const MP_INT *u;
- const MP_INT *v;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_size usize = u->size;
- mp_size vsize = v->size;
- mp_size size;
- mp_size i;
- mp_limb a, b;
- mp_srcptr up, vp;
-
- if (usize != vsize)
- return usize - vsize;
-
- if (usize == 0)
- return 0;
-
- size = ABS (usize);
-
- up = u->d;
- vp = v->d;
-
- i = size - 1;
- do
- {
- a = up[i];
- b = vp[i];
- i--;
- if (i < 0)
- break;
- }
- while (a == b);
-
- if (a == b)
- return 0;
-
- if ((a < b) == (usize < 0))
- return 1;
- else
- return -1;
-}
+++ /dev/null
-/* mpz_cmp_si(u,v) -- Compare an integer U with a single-word int V.
- Return positive, zero, or negative based on if U > V, U == V, or U < V.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-int
-#ifdef __STDC__
-mpz_cmp_si (const MP_INT *u, signed long int v_digit)
-#else
-mpz_cmp_si (u, v_digit)
- const MP_INT *u;
- signed long int v_digit;
-#endif
-{
- mp_size usize = u->size;
- mp_size vsize;
- mp_limb u_digit;
-
- vsize = 0;
- if (v_digit > 0)
- vsize = 1;
- else if (v_digit < 0)
- {
- vsize = -1;
- v_digit = -v_digit;
- }
-
- if (usize != vsize)
- return usize - vsize;
-
- if (usize == 0)
- return 0;
-
- u_digit = u->d[0];
-
- if (u_digit == v_digit)
- return 0;
-
- if ((u_digit < v_digit) == (usize < 0))
- return 1;
- else
- return -1;
-}
+++ /dev/null
-/* mpz_cmp_ui.c -- Compare a MP_INT a with an mp_limb b. Return positive,
- zero, or negative based on if a > b, a == b, or a < b.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-int
-#ifdef __STDC__
-mpz_cmp_ui (const MP_INT *u, mp_limb v_digit)
-#else
-mpz_cmp_ui (u, v_digit)
- const MP_INT *u;
- mp_limb v_digit;
-#endif
-{
- mp_size usize = u->size;
-
- if (usize == 0)
- return -(v_digit != 0);
-
- if (usize == 1)
- {
- mp_limb u_digit;
-
- u_digit = u->d[0];
- if (u_digit > v_digit)
- return 1;
- if (u_digit < v_digit)
- return -1;
- return 0;
- }
-
- return (usize > 0) ? 1 : -1;
-}
+++ /dev/null
-/* mpz_com(MP_INT *dst, MP_INT *src) -- Assign the bit-complemented value of
- SRC to DST.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_com (MP_INT *dst, const MP_INT *src)
-#else
-mpz_com (dst, src)
- MP_INT *dst;
- const MP_INT *src;
-#endif
-{
- mp_size size = src->size;
- mp_srcptr src_ptr;
- mp_ptr dst_ptr;
-
- if (size >= 0)
- {
- /* As with infinite precision: one's complement, two's complement.
- But this can be simplified using the identity -x = ~x + 1.
- So we're going to compute (~~x) + 1 = x + 1! */
-
- if (dst->alloc < size + 1)
- _mpz_realloc (dst, size + 1);
-
- src_ptr = src->d;
- dst_ptr = dst->d;
-
- if (size == 0)
- {
- /* Special case, as mpn_add wants the first arg's size >= the
- second arg's size. */
- dst_ptr[0] = 1;
- dst->size = -1;
- return;
- }
-
- {
- mp_limb one = 1;
- int cy;
-
- cy = mpn_add (dst_ptr, src_ptr, size, &one, 1);
- if (cy)
- {
- dst_ptr[size] = cy;
- size++;
- }
- }
-
- /* Store a negative size, to indicate ones-extension. */
- dst->size = -size;
- }
- else
- {
- /* As with infinite precision: two's complement, then one's complement.
- But that can be simplified using the identity -x = ~(x - 1).
- So we're going to compute ~~(x - 1) = x - 1! */
- size = -size;
-
- if (dst->alloc < size)
- _mpz_realloc (dst, size);
-
- src_ptr = src->d;
- dst_ptr = dst->d;
-
- {
- mp_limb one = 1;
-
- size += mpn_sub (dst_ptr, src_ptr, size, &one, 1);
- }
-
- /* Store a positive size, to indicate zero-extension. */
- dst->size = size;
- }
-}
+++ /dev/null
-/* mpz_div -- divide two integers and produce a quotient.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_div (MP_INT *quot, const MP_INT *num, const MP_INT *den)
-#else
-mpz_div (quot, num, den)
- MP_INT *quot;
- const MP_INT *num;
- const MP_INT *den;
-#endif
-{
- mp_srcptr np, dp;
- mp_ptr qp, rp;
- mp_size nsize = num->size;
- mp_size dsize = den->size;
- mp_size qsize, rsize;
- mp_size sign_quotient = nsize ^ dsize;
- unsigned normalization_steps;
-
- nsize = ABS (nsize);
- dsize = ABS (dsize);
-
- /* Ensure space is enough for quotient. */
-
- qsize = nsize - dsize + 1; /* qsize cannot be bigger than this. */
- if (qsize <= 0)
- {
- quot->size = 0;
- return;
- }
-
- if (quot->alloc < qsize)
- _mpz_realloc (quot, qsize);
-
- qp = quot->d;
- np = num->d;
- dp = den->d;
- rp = (mp_ptr) alloca ((nsize + 1) * BYTES_PER_MP_LIMB);
-
- count_leading_zeros (normalization_steps, dp[dsize - 1]);
-
- /* Normalize the denominator and the numerator. */
- if (normalization_steps != 0)
- {
- mp_ptr tp;
- mp_limb ndigit;
-
- /* Shift up the denominator setting the most significant bit of
- the most significant word. Use temporary storage not to clobber
- the original contents of the denominator. */
- tp = (mp_ptr) alloca (dsize * BYTES_PER_MP_LIMB);
- (void) mpn_lshift (tp, dp, dsize, normalization_steps);
- dp = tp;
-
- /* Shift up the numerator, possibly introducing a new most
- significant word. Move the shifted numerator in the remainder
- meanwhile. */
- ndigit = mpn_lshift (rp, np, nsize, normalization_steps);
- if (ndigit != 0)
- {
- rp[nsize] = ndigit;
- rsize = nsize + 1;
- }
- else
- rsize = nsize;
- }
- else
- {
- /* The denominator is already normalized, as required.
- Copy it to temporary space if it overlaps with the quotient. */
- if (dp == qp)
- {
- dp = (mp_ptr) alloca (dsize * BYTES_PER_MP_LIMB);
- MPN_COPY ((mp_ptr) dp, qp, dsize);
- }
-
- /* Move the numerator to the remainder. */
- MPN_COPY (rp, np, nsize);
- rsize = nsize;
- }
-
- qsize = rsize - dsize + mpn_div (qp, rp, rsize, dp, dsize);
-
- /* Normalize the quotient. We may have at most one leading
- zero-word, so no loop is needed. */
- if (qsize > 0)
- qsize -= (qp[qsize - 1] == 0);
-
- if (sign_quotient < 0)
- qsize = -qsize;
- quot->size = qsize;
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_div_2exp -- Divide a bignum by 2**CNT
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_div_2exp (MP_INT *w, const MP_INT *u, unsigned long int cnt)
-#else
-mpz_div_2exp (w, u, cnt)
- MP_INT *w;
- const MP_INT *u;
- unsigned long int cnt;
-#endif
-{
- mp_size usize = u->size;
- mp_size wsize;
- mp_size abs_usize = ABS (usize);
- mp_size limb_cnt;
-
- limb_cnt = cnt / BITS_PER_MP_LIMB;
- wsize = abs_usize - limb_cnt;
- if (wsize <= 0)
- wsize = 0;
- else
- {
- if (w->alloc < wsize)
- _mpz_realloc (w, wsize);
-
- wsize = mpn_rshift (w->d, u->d + limb_cnt, abs_usize - limb_cnt,
- cnt % BITS_PER_MP_LIMB);
- }
-
- w->size = (usize >= 0) ? wsize : -wsize;
-}
+++ /dev/null
-/* mpz_div_ui(quot, dividend, divisor_limb)
- -- Divide DIVIDEND by DIVISOR_LIMB and store the result in QUOT.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_div_ui (MP_INT *quot, const MP_INT *dividend, unsigned long int divisor_limb)
-#else
-mpz_div_ui (quot, dividend, divisor_limb)
- MP_INT *quot;
- const MP_INT *dividend;
- unsigned long int divisor_limb;
-#endif
-{
- mp_size sign_dividend;
- mp_size dividend_size, quot_size;
- mp_ptr dividend_ptr, quot_ptr;
-
- sign_dividend = dividend->size;
- dividend_size = ABS (dividend->size);
-
- if (dividend_size == 0)
- {
- quot->size = 0;
- return;
- }
-
- /* No need for temporary allocation and copying if QUOT == DIVIDEND as
- the divisor is just one limb, and thus no intermediate remainders
- need to be stored. */
-
- if (quot->alloc < dividend_size)
- _mpz_realloc (quot, dividend_size);
-
- quot_ptr = quot->d;
- dividend_ptr = dividend->d;
-
- mpn_divmod_1 (quot_ptr, dividend_ptr, dividend_size, divisor_limb);
-
- /* The quotient is DIVIDEND_SIZE limbs, but the most significant
- might be zero. Set QUOT_SIZE properly. */
- quot_size = dividend_size - (quot_ptr[dividend_size - 1] == 0);
- quot->size = sign_dividend >= 0 ? quot_size : -quot_size;
-}
+++ /dev/null
-/* mpz_divmod(quot,rem,dividend,divisor) -- Set QUOT to DIVIDEND/DIVISOR,
- and REM to DIVIDEND mod DIVISOR.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_divmod (MP_INT *quot, MP_INT *rem, const MP_INT *num, const MP_INT *den)
-#else
-mpz_divmod (quot, rem, num, den)
- MP_INT *quot;
- MP_INT *rem;
- const MP_INT *num;
- const MP_INT *den;
-#endif
-
-#define COMPUTE_QUOTIENT
-#include "mpz_dmincl.c"
+++ /dev/null
-/* mpz_divmod_ui(quot,rem,dividend,short_divisor) --
- Set QUOT to DIVIDEND / SHORT_DIVISOR
- and REM to DIVIDEND mod SHORT_DIVISOR.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_divmod_ui (MP_INT *quot, MP_INT *rem,
- const MP_INT *dividend, unsigned long int divisor_limb)
-#else
-mpz_divmod_ui (quot, rem, dividend, divisor_limb)
- MP_INT *quot;
- MP_INT *rem;
- const MP_INT *dividend;
- unsigned long int divisor_limb;
-#endif
-{
- mp_size sign_dividend;
- mp_size dividend_size, quot_size;
- mp_ptr dividend_ptr, quot_ptr;
- mp_limb remainder_limb;
-
- sign_dividend = dividend->size;
- dividend_size = ABS (dividend->size);
-
- if (dividend_size == 0)
- {
- quot->size = 0;
- rem->size = 0;
- return;
- }
-
- /* No need for temporary allocation and copying if QUOT == DIVIDEND as
- the divisor is just one limb, and thus no intermediate remainders
- need to be stored. */
-
- if (quot->alloc < dividend_size)
- _mpz_realloc (quot, dividend_size);
-
- quot_ptr = quot->d;
- dividend_ptr = dividend->d;
-
- remainder_limb = mpn_divmod_1 (quot_ptr,
- dividend_ptr, dividend_size, divisor_limb);
-
- if (remainder_limb == 0)
- rem->size = 0;
- else
- {
- /* Store the single-limb remainder. We don't check if there's space
- for just one limb, since no function ever makes zero space. */
- rem->size = sign_dividend >= 0 ? 1 : -1;
- rem->d[0] = remainder_limb;
- }
-
- /* The quotient is DIVIDEND_SIZE limbs, but the most significant
- might be zero. Set QUOT_SIZE properly. */
- quot_size = dividend_size - (quot_ptr[dividend_size - 1] == 0);
- quot->size = sign_dividend >= 0 ? quot_size : -quot_size;
-}
+++ /dev/null
-/* mpz_dmincl.c -- include file for mpz_dm.c, mpz_mod.c, mdiv.c.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-/* THIS CODE IS OBSOLETE. IT WILL SOON BE REPLACED BY CLEANER CODE WITH
- LESS MEMORY ALLOCATION OVERHEAD. */
-
-/* If den == quot, den needs temporary storage.
- If den == rem, den needs temporary storage.
- If num == quot, num needs temporary storage.
- If den has temporary storage, it can be normalized while being copied,
- i.e no extra storage should be allocated. */
-
-/* This is the function body of mdiv, mpz_divmod, and mpz_mod.
-
- If COMPUTE_QUOTIENT is defined, the quotient is put in the MP_INT
- object quot, otherwise that variable is not referenced at all.
-
- The remainder is always computed, and the result is put in the MP_INT
- object rem. */
-
-{
- mp_ptr np, dp;
- mp_ptr qp, rp;
- mp_size nsize = num->size;
- mp_size dsize = den->size;
- mp_size qsize, rsize;
- mp_size sign_remainder = nsize;
-#ifdef COMPUTE_QUOTIENT
- mp_size sign_quotient = nsize ^ dsize;
-#endif
- unsigned normalization_steps;
-
- nsize = ABS (nsize);
- dsize = ABS (dsize);
-
- /* Ensure space is enough for quotient and remainder. */
-
- /* We need space for an extra limb in the remainder, because it's
- up-shifted (normalized) below. */
- rsize = nsize + 1;
- if (rem->alloc < rsize)
- _mpz_realloc (rem, rsize);
-
- qsize = nsize - dsize + 1; /* qsize cannot be bigger than this. */
- if (qsize <= 0)
- {
-#ifdef COMPUTE_QUOTIENT
- quot->size = 0;
-#endif
- if (num != rem)
- {
- rem->size = num->size;
- MPN_COPY (rem->d, num->d, nsize);
- }
- return;
- }
-
-#ifdef COMPUTE_QUOTIENT
- if (quot->alloc < qsize)
- _mpz_realloc (quot, qsize);
- qp = quot->d;
-#else
- qp = (mp_ptr) alloca (qsize * BYTES_PER_MP_LIMB);
-#endif
- np = num->d;
- dp = den->d;
- rp = rem->d;
-
- /* Make sure quot and num are different. Otherwise the numerator
- would be successively overwritten by the quotient digits. */
- if (qp == np)
- {
- np = (mp_ptr) alloca (nsize * BYTES_PER_MP_LIMB);
- MPN_COPY (np, qp, nsize);
- }
-
- count_leading_zeros (normalization_steps, dp[dsize - 1]);
-
- /* Normalize the denominator, i.e. make its most significant bit set by
- shifting it NORMALIZATION_STEPS bits to the left. Also shift the
- numerator the same number of steps (to keep the quotient the same!). */
- if (normalization_steps != 0)
- {
- mp_ptr tp;
- mp_limb ndigit;
-
- /* Shift up the denominator setting the most significant bit of
- the most significant word. Use temporary storage not to clobber
- the original contents of the denominator. */
- tp = (mp_ptr) alloca (dsize * BYTES_PER_MP_LIMB);
- (void) mpn_lshift (tp, dp, dsize, normalization_steps);
- dp = tp;
-
- /* Shift up the numerator, possibly introducing a new most
- significant word. Move the shifted numerator in the remainder
- meanwhile. */
- ndigit = mpn_lshift (rp, np, nsize, normalization_steps);
- if (ndigit != 0)
- {
- rp[nsize] = ndigit;
- rsize = nsize + 1;
- }
- else
- rsize = nsize;
- }
- else
- {
-#ifdef COMPUTE_QUOTIENT
- if (rem == den || quot == den)
-#else
- if (rem == den)
-#endif
- {
- mp_ptr tp;
-
- tp = (mp_ptr) alloca (dsize * BYTES_PER_MP_LIMB);
- MPN_COPY (tp, dp, dsize);
- dp = tp;
- }
-
- /* Move the numerator to the remainder. */
- if (rp != np)
- MPN_COPY (rp, np, nsize);
-
- rsize = nsize;
- }
-
- qsize = rsize - dsize + mpn_div (qp, rp, rsize, dp, dsize);
-
- rsize = dsize;
-
- /* Normalize the remainder. */
- while (rsize > 0)
- {
- if (rp[rsize - 1] != 0)
- break;
- rsize--;
- }
-
- if (normalization_steps != 0)
- rsize = mpn_rshift (rp, rp, rsize, normalization_steps);
-
- rem->size = (sign_remainder >= 0) ? rsize : -rsize;
-
-#ifdef COMPUTE_QUOTIENT
- /* Normalize the quotient. We may have at most one leading
- zero-word, so no loop is needed. */
- if (qsize > 0)
- qsize -= (qp[qsize - 1] == 0);
-
- quot->size = (sign_quotient >= 0) ? qsize : -qsize;
-#endif
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_fac_ui(result, n) -- Set RESULT to N!.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#ifdef DBG
-#include <stdio.h>
-#endif
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_fac_ui (MP_INT *result, unsigned long int n)
-#else
-mpz_fac_ui (result, n)
- MP_INT *result;
- unsigned long int n;
-#endif
-{
-#if SIMPLE_FAC
-
- /* Be silly. Just multiply the numbers in ascending order. O(n**2). */
-
- mp_limb k;
-
- mpz_set_ui (result, (mp_limb) 1);
-
- for (k = 2; k <= n; k++)
- mpz_mul_ui (result, result, k);
-#else
-
- /* Be smarter. Multiply groups of numbers in ascending order until the
- product doesn't fit in a limb. Multiply these partial products in a
- balanced binary tree fashion, to make the operand have as equal sizes
- as possible. (When the operands have about the same size, mpn_mul
- becomes faster.) */
-
- mp_limb k;
- mp_limb p1, p0, p;
-
- /* Stack of partial products, used to make the computation balanced
- (i.e. make the sizes of the multiplication operands equal). The
- topmost position of MP_STACK will contain a one-limb partial product,
- the second topmost will contain a two-limb partial product, and so
- on. MP_STACK[0] will contain a partial product with 2**t limbs.
- To compute n! MP_STACK needs to be less than
- log(n)**2/log(BITS_PER_MP_LIMB), so 30 is surely enough. */
-#define MP_STACK_SIZE 30
- MP_INT mp_stack[MP_STACK_SIZE];
-
- /* TOP is an index into MP_STACK, giving the topmost element.
- TOP_LIMIT_SO_FAR is the largets value it has taken so far. */
- int top, top_limit_so_far;
-
- /* Count of the total number of limbs put on MP_STACK so far. This
- variable plays an essential role in making the compututation balanced.
- See below. */
- unsigned int tree_cnt;
-
- top = top_limit_so_far = -1;
- tree_cnt = 0;
- p = 1;
- for (k = 2; k <= n; k++)
- {
- /* Multiply the partial product in P with K. */
- umul_ppmm (p1, p0, p, k);
-
- /* Did we get overflow into the high limb, i.e. is the partial
- product now more than one limb? */
- if (p1 != 0)
- {
- tree_cnt++;
-
- if (tree_cnt % 2 == 0)
- {
- mp_size i;
-
- /* TREE_CNT is even (i.e. we have generated an even number of
- one-limb partial products), which means that we have a
- single-limb product on the top of MP_STACK. */
-
- mpz_mul_ui (&mp_stack[top], &mp_stack[top], p);
-
- /* If TREE_CNT is divisable by 4, 8,..., we have two
- similar-sized partial products with 2, 4,... limbs at
- the topmost two positions of MP_STACK. Multiply them
- to form a new partial product with 4, 8,... limbs. */
- for (i = 4; (tree_cnt & (i - 1)) == 0; i <<= 1)
- {
- mpz_mul (&mp_stack[top - 1],
- &mp_stack[top], &mp_stack[top - 1]);
- top--;
- }
- }
- else
- {
- /* Put the single-limb partial product in P on the stack.
- (The next time we get a single-limb product, we will
- multiply the two together.) */
- top++;
- if (top > top_limit_so_far)
- {
- if (top > MP_STACK_SIZE)
- abort();
- /* The stack is now bigger than ever, initialize the top
- element. */
- mpz_init_set_ui (&mp_stack[top], p);
- top_limit_so_far++;
- }
- else
- mpz_set_ui (&mp_stack[top], p);
- }
-
- /* We ignored the last result from umul_ppmm. Put K in P as the
- first component of the next single-limb partial product. */
- p = k;
- }
- else
- /* We didn't get overflow in umul_ppmm. Put p0 in P and try
- with one more value of K. */
- p = p0;
- }
-
- /* We have partial products in mp_stack[0..top], in descending order.
- We also have a small partial product in p.
- Their product is the final result. */
- if (top < 0)
- mpz_set_ui (result, p);
- else
- mpz_mul_ui (result, &mp_stack[top--], p);
- while (top >= 0)
- mpz_mul (result, result, &mp_stack[top--]);
-
- /* Free the storage allocated for MP_STACK. */
- for (top = top_limit_so_far; top >= 0; top--)
- mpz_clear (&mp_stack[top]);
-#endif
-}
+++ /dev/null
-/* mpz_gcd -- Calculate the greatest common divisior of two integers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-#ifndef BERKELEY_MP
-void
-#ifdef __STDC__
-mpz_gcd (MP_INT *w, const MP_INT *u, const MP_INT *v)
-#else
-mpz_gcd (w, u, v)
- MP_INT *w;
- const MP_INT *u;
- const MP_INT *v;
-#endif
-#else /* BERKELEY_MP */
-void
-#ifdef __STDC__
-gcd (const MP_INT *u, const MP_INT *v, MP_INT *w)
-#else
-gcd (u, v, w)
- const MP_INT *u;
- const MP_INT *v;
- MP_INT *w;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_size usize, vsize, wsize;
- mp_ptr up_in, vp_in;
- mp_ptr up, vp;
- mp_ptr wp;
- mp_size i;
- mp_limb d;
- int bcnt;
- mp_size w_bcnt;
- mp_limb cy_digit;
-
- usize = ABS (u->size);
- vsize = ABS (v->size);
-
- /* GCD(0,v) == v. */
- if (usize == 0)
- {
- if (w->alloc < vsize)
- _mpz_realloc (w, vsize);
-
- w->size = vsize;
- MPN_COPY (w->d, v->d, vsize);
- return;
- }
-
- /* GCD(0,u) == u. */
- if (vsize == 0)
- {
- if (w->alloc < usize)
- _mpz_realloc (w, usize);
-
- w->size = usize;
- MPN_COPY (w->d, u->d, usize);
- return;
- }
-
- /* Make U odd by shifting it down as many bit positions as there
- are zero bits. Put the result in temporary space. */
- up = (mp_ptr) alloca (usize * BYTES_PER_MP_LIMB);
- up_in = u->d;
- for (i = 0; (d = up_in[i]) == 0; i++)
- ;
- count_leading_zeros (bcnt, d & -d);
- bcnt = BITS_PER_MP_LIMB - 1 - bcnt;
- usize = mpn_rshift (up, up_in + i, usize - i, bcnt);
-
- bcnt += i * BITS_PER_MP_LIMB;
- w_bcnt = bcnt;
-
- /* Make V odd by shifting it down as many bit positions as there
- are zero bits. Put the result in temporary space. */
- vp = (mp_ptr) alloca (vsize * BYTES_PER_MP_LIMB);
- vp_in = v->d;
- for (i = 0; (d = vp_in[i]) == 0; i++)
- ;
- count_leading_zeros (bcnt, d & -d);
- bcnt = BITS_PER_MP_LIMB - 1 - bcnt;
- vsize = mpn_rshift (vp, vp_in + i, vsize - i, bcnt);
-
- /* W_BCNT is set to the minimum of the number of zero bits in U and V.
- Thus it represents the number of common 2 factors. */
- bcnt += i * BITS_PER_MP_LIMB;
- if (bcnt < w_bcnt)
- w_bcnt = bcnt;
-
- for (;;)
- {
- int cmp;
-
- cmp = usize - vsize != 0 ? usize - vsize : mpn_cmp (up, vp, usize);
-
- /* If U and V have become equal, we have found the GCD. */
- if (cmp == 0)
- break;
-
- if (cmp > 0)
- {
- /* Replace U by (U - V) >> cnt, with cnt being the least value
- making U odd again. */
-
- usize += mpn_sub (up, up, usize, vp, vsize);
- for (i = 0; (d = up[i]) == 0; i++)
- ;
- count_leading_zeros (bcnt, d & -d);
- bcnt = BITS_PER_MP_LIMB - 1 - bcnt;
- usize = mpn_rshift (up, up + i, usize - i, bcnt);
- }
- else
- {
- /* Replace V by (V - U) >> cnt, with cnt being the least value
- making V odd again. */
-
- vsize += mpn_sub (vp, vp, vsize, up, usize);
- for (i = 0; (d = vp[i]) == 0; i++)
- ;
- count_leading_zeros (bcnt, d & -d);
- bcnt = BITS_PER_MP_LIMB - 1 - bcnt;
- vsize = mpn_rshift (vp, vp + i, vsize - i, bcnt);
- }
- }
-
- /* GCD(U_IN, V_IN) now is U * 2**W_BCNT. */
-
- wsize = usize + w_bcnt / BITS_PER_MP_LIMB + 1;
- if (w->alloc < wsize)
- _mpz_realloc (w, wsize);
-
- wp = w->d;
-
- MPN_ZERO (wp, w_bcnt / BITS_PER_MP_LIMB);
-
- cy_digit = mpn_lshift (wp + w_bcnt / BITS_PER_MP_LIMB, up, usize,
- w_bcnt % BITS_PER_MP_LIMB);
- wsize = usize + w_bcnt / BITS_PER_MP_LIMB;
- if (cy_digit != 0)
- {
- wp[wsize] = cy_digit;
- wsize++;
- }
-
- w->size = wsize;
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_gcdext(g, s, t, a, b) -- Set G to gcd(a, b), and S and T such that
- g = as + bt.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-/* Botch: SLOW! */
-
-void
-#ifdef __STDC__
-mpz_gcdext (MP_INT *g, MP_INT *s, MP_INT *t, const MP_INT *a, const MP_INT *b)
-#else
-mpz_gcdext (g, s, t, a, b)
- MP_INT *g;
- MP_INT *s;
- MP_INT *t;
- const MP_INT *a;
- const MP_INT *b;
-#endif
-{
- MP_INT s0, s1, q, r, x, d0, d1;
-
- mpz_init_set_ui (&s0, 1);
- mpz_init_set_ui (&s1, 0);
- mpz_init (&q);
- mpz_init (&r);
- mpz_init (&x);
- mpz_init_set (&d0, a);
- mpz_init_set (&d1, b);
-
- while (d1.size != 0)
- {
- mpz_divmod (&q, &r, &d0, &d1);
- mpz_set (&d0, &d1);
- mpz_set (&d1, &r);
-
- mpz_mul (&x, &s1, &q);
- mpz_sub (&x, &s0, &x);
- mpz_set (&s0, &s1);
- mpz_set (&s1, &x);
- }
-
- if (t != NULL)
- {
- mpz_mul (&x, &s0, a);
- mpz_sub (&x, &d0, &x);
- if (b->size == 0)
- t->size = 0;
- else
- mpz_div (t, &x, b);
- }
- mpz_set (s, &s0);
- mpz_set (g, &d0);
-
- mpz_clear (&s0);
- mpz_clear (&s1);
- mpz_clear (&q);
- mpz_clear (&r);
- mpz_clear (&x);
- mpz_clear (&d0);
- mpz_clear (&d1);
-}
+++ /dev/null
-/* mpz_get_si(integer) -- Return the least significant digit from INTEGER.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-signed long int
-#ifdef __STDC__
-mpz_get_si (const MP_INT *integer)
-#else
-mpz_get_si (integer)
- const MP_INT *integer;
-#endif
-{
- mp_size size = integer->size;
-
- if (size > 0)
- return integer->d[0] % ((mp_limb) 1 << (BITS_PER_MP_LIMB - 1));
- else if (size < 0)
- return ~((integer->d[0] - 1) % ((mp_limb) 1 << (BITS_PER_MP_LIMB - 1)));
- else
- return 0;
-}
+++ /dev/null
-/* mpz_get_str (string, base, mp_src) -- Convert the multiple precision
- number MP_SRC to a string STRING of base BASE. If STRING is NULL
- allocate space for the result. In any case, return a pointer to the
- result. If STRING is not NULL, the caller must ensure enough space is
- available to store the result.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-char *
-#ifdef __STDC__
-mpz_get_str (char *str, int base, const MP_INT *m)
-#else
-mpz_get_str (str, base, m)
- char *str;
- int base;
- const MP_INT *m;
-#endif
-{
- return _mpz_get_str (str, base, m);
-}
+++ /dev/null
-/* mpz_get_ui(integer) -- Return the least significant digit from INTEGER.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-unsigned long int
-#ifdef __STDC__
-mpz_get_ui (const MP_INT *integer)
-#else
-mpz_get_ui (integer)
- const MP_INT *integer;
-#endif
-{
- if (integer->size == 0)
- return 0;
- else
- return integer->d[0];
-}
+++ /dev/null
-/* mpz_init() -- Make a new multiple precision number with value 0.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_init (MP_INT *x)
-#else
-mpz_init (x)
- MP_INT *x;
-#endif
-{
- x->alloc = 1;
- x->d = (mp_ptr) (*_mp_allocate_func) (BYTES_PER_MP_LIMB * x->alloc);
- x->size = 0;
-}
+++ /dev/null
-/* mpz_inp_raw -- Input a MP_INT in raw, but endianess, and wordsize
- independent format (as output by mpz_out_raw).
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include <stdio.h>
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_inp_raw (MP_INT *x, FILE *file)
-#else
-mpz_inp_raw (x, file)
- MP_INT *x;
- FILE *file;
-#endif
-{
- int i;
- mp_size s;
- mp_size xsize;
- mp_ptr xp;
- unsigned int c;
- mp_limb x_digit;
- mp_size x_index;
-
- xsize = 0;
- for (i = 4 - 1; i >= 0; i--)
- {
- c = fgetc (file);
- xsize = (xsize << BITS_PER_CHAR) | c;
- }
-
- /* ??? Sign extend xsize for non-32 bit machines? */
-
- x_index = (ABS (xsize) + BYTES_PER_MP_LIMB - 1) / BYTES_PER_MP_LIMB - 1;
-
- if (x->alloc < x_index)
- _mpz_realloc (x, x_index);
-
- xp = x->d;
- x->size = xsize / BYTES_PER_MP_LIMB;
- x_digit = 0;
- for (s = ABS (xsize) - 1; s >= 0; s--)
- {
- i = s % BYTES_PER_MP_LIMB;
- c = fgetc (file);
- x_digit = (x_digit << BITS_PER_CHAR) | c;
- if (i == 0)
- {
- xp[x_index--] = x_digit;
- x_digit = 0;
- }
- }
-}
+++ /dev/null
-/* mpz_inp_str(dest_integer, stream, base) -- Input a number in base
- BASE from stdio stream STREAM and store the result in DEST_INTEGER.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include <stdio.h>
-#include <ctype.h>
-#include "gmp.h"
-#include "gmp-impl.h"
-
-static int
-char_ok_for_base (c, base)
- int c;
- int base;
-{
- if (isdigit (c))
- return (unsigned) c - '0' < base;
- if (islower (c))
- return (unsigned) c - 'a' + 10 < base;
- if (isupper (c))
- return (unsigned) c - 'A' + 10 < base;
-
- return 0;
-}
-
-void
-#ifdef __STDC__
-mpz_inp_str (MP_INT *dest, FILE *stream, int base)
-#else
-mpz_inp_str (dest, stream, base)
- MP_INT *dest;
- FILE *stream;
- int base;
-#endif
-{
- char *str;
- size_t str_size;
- size_t i;
- int c;
- int negative = 0;
-
- str_size = 100;
- str = (char *) (*_mp_allocate_func) (str_size);
-
- c = getc (stream);
- if (c == '-')
- {
- negative = 1;
- c = getc (stream);
- }
-
- /* If BASE is 0, try to find out the base by looking at the initial
- characters. */
- if (base == 0)
- {
- base = 10;
- if (c == '0')
- {
- base = 8;
- c = getc (stream);
- if (c == 'x' || c == 'X')
- {
- base = 16;
- c = getc (stream);
- }
- }
- }
-
- for (i = 0; char_ok_for_base (c, base); i++)
- {
- if (i >= str_size)
- {
- size_t old_str_size = str_size;
- str_size = str_size * 3 / 2;
- str = (char *) (*_mp_reallocate_func) (str, old_str_size, str_size);
- }
- str[i] = c;
- c = getc (stream);
- }
-
- ungetc (c, stream);
-
- str[i] = 0;
- _mpz_set_str (dest, str, base);
- if (negative)
- dest->size = -dest->size;
-
- (*_mp_free_func) (str, str_size);
-}
+++ /dev/null
-/* mpz_ior -- Logical inclusive or.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#define min(l,o) ((l) < (o) ? (l) : (o))
-#define max(h,i) ((h) > (i) ? (h) : (i))
-
-void
-#ifdef __STDC__
-mpz_ior (MP_INT *res, const MP_INT *op1, const MP_INT *op2)
-#else
-mpz_ior (res, op1, op2)
- MP_INT *res;
- const MP_INT *op1;
- const MP_INT *op2;
-#endif
-{
- mp_srcptr op1_ptr, op2_ptr;
- mp_size op1_size, op2_size;
- mp_ptr res_ptr;
- mp_size res_size;
- mp_size i;
-
- op1_size = op1->size;
- op2_size = op2->size;
-
- op1_ptr = op1->d;
- op2_ptr = op2->d;
- res_ptr = res->d;
-
- if (op1_size >= 0)
- {
- if (op2_size >= 0)
- {
- if (op1_size >= op2_size)
- {
- if (res->alloc < op1_size)
- {
- _mpz_realloc (res, op1_size);
- op1_ptr = op1->d;
- op2_ptr = op2->d;
- res_ptr = res->d;
- }
-
- if (res_ptr != op1_ptr)
- MPN_COPY (res_ptr + op2_size, op1_ptr + op2_size,
- op1_size - op2_size);
- for (i = op2_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] | op2_ptr[i];
- res_size = op1_size;
- }
- else
- {
- if (res->alloc < op2_size)
- {
- _mpz_realloc (res, op2_size);
- op1_ptr = op1->d;
- op2_ptr = op2->d;
- res_ptr = res->d;
- }
-
- if (res_ptr != op2_ptr)
- MPN_COPY (res_ptr + op1_size, op2_ptr + op1_size,
- op2_size - op1_size);
- for (i = op1_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] | op2_ptr[i];
- res_size = op2_size;
- }
-
- res->size = res_size;
- return;
- }
- else /* op2_size < 0 */
- /* Fall through to the code at the end of the function. */
- ;
- }
- else
- {
- if (op2_size < 0)
- {
- mp_ptr opx;
- mp_limb cy;
- mp_limb one = 1;
-
- /* Both operands are negative, so will be the result.
- -((-OP1) | (-OP2)) = -(~(OP1 - 1) | ~(OP2 - 1)) =
- = ~(~(OP1 - 1) | ~(OP2 - 1)) + 1 =
- = ((OP1 - 1) & (OP2 - 1)) + 1 */
-
- op1_size = -op1_size;
- op2_size = -op2_size;
-
- res_size = min (op1_size, op2_size);
-
- /* Possible optimization: Decrease mpn_sub precision,
- as we won't use the entire res of both. */
- opx = (mp_ptr) alloca (op1_size * BYTES_PER_MP_LIMB);
- op1_size += mpn_sub (opx, op1_ptr, op1_size, &one, 1);
- op1_ptr = opx;
-
- opx = (mp_ptr) alloca (op2_size * BYTES_PER_MP_LIMB);
- op2_size += mpn_sub (opx, op2_ptr, op2_size, &one, 1);
- op2_ptr = opx;
-
- if (res->alloc < res_size)
- {
- _mpz_realloc (res, res_size);
- res_ptr = res->d;
- /* Don't re-read OP1_PTR and OP2_PTR. They point to
- temporary space--never to the space RES->D used
- to point to before reallocation. */
- }
-
- /* First loop finds the size of the result. */
- for (i = res_size - 1; i >= 0; i--)
- if ((op1_ptr[i] & op2_ptr[i]) != 0)
- break;
- res_size = i + 1;
-
- /* Second loop computes the real result. */
- for (i = res_size - 1; i >= 0; i--)
- res_ptr[i] = op1_ptr[i] & op2_ptr[i];
-
- if (res_size != 0)
- {
- cy = mpn_add (res_ptr, res_ptr, res_size, &one, 1);
- if (cy)
- {
- res_ptr[res_size] = cy;
- res_size++;
- }
- }
- else
- {
- res_ptr[0] = 1;
- res_size = 1;
- }
-
- res->size = -res_size;
- return;
- }
- else
- {
- /* We should compute -OP1 | OP2. Swap OP1 and OP2 and fall
- through to the code that handles OP1 | -OP2. */
- {const MP_INT *t = op1; op1 = op2; op2 = t;}
- {mp_srcptr t = op1_ptr; op1_ptr = op2_ptr; op2_ptr = t;}
- {mp_size t = op1_size; op1_size = op2_size; op2_size = t;}
- }
- }
-
- {
- mp_ptr opx;
- mp_limb cy;
- mp_limb one = 1;
- mp_size res_alloc;
-
- /* Operand 2 negative, so will be the result.
- -(OP1 | (-OP2)) = -(OP1 | ~(OP2 - 1)) =
- = ~(OP1 | ~(OP2 - 1)) + 1 =
- = (~OP1 & (OP2 - 1)) + 1 */
-
- op2_size = -op2_size;
-
- res_alloc = op2_size;
-
- opx = (mp_ptr) alloca (op2_size * BYTES_PER_MP_LIMB);
- op2_size += mpn_sub (opx, op2_ptr, op2_size, &one, 1);
- op2_ptr = opx;
-
- if (res->alloc < res_alloc)
- {
- _mpz_realloc (res, res_alloc);
- op1_ptr = op1->d;
- res_ptr = res->d;
- /* Don't re-read OP2_PTR. It points to temporary space--never
- to the space RES->D used to point to before reallocation. */
- }
-
- if (op1_size >= op2_size)
- {
- /* We can just ignore the part of OP1 that stretches above OP2,
- because the result limbs are zero there. */
-
- /* First loop finds the size of the result. */
- for (i = op2_size - 1; i >= 0; i--)
- if ((~op1_ptr[i] & op2_ptr[i]) != 0)
- break;
- res_size = i + 1;
- }
- else
- {
- res_size = op2_size;
-
- /* Copy the part of OP2 that stretches above OP1, to RES. */
- MPN_COPY (res_ptr + op1_size, op2_ptr + op1_size,
- op2_size - op1_size);
- }
-
- /* Second loop computes the real result. */
- for (i = res_size - 1; i >= 0; i--)
- res_ptr[i] = ~op1_ptr[i] & op2_ptr[i];
-
- if (res_size != 0)
- {
- cy = mpn_add (res_ptr, res_ptr, res_size, &one, 1);
- if (cy)
- {
- res_ptr[res_size] = cy;
- res_size++;
- }
- }
- else
- {
- res_ptr[0] = 1;
- res_size = 1;
- }
-
- res->size = -res_size;
- alloca (0);
- return;
- }
-}
+++ /dev/null
-/* mpz_init_set (src_integer) -- Make a new multiple precision number with
- a value copied from SRC_INTEGER.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_init_set (MP_INT *x, const MP_INT *src)
-#else
-mpz_init_set (x, src)
- MP_INT *x;
- const MP_INT *src;
-#endif
-{
- mp_size size;
- mp_size abs_size;
-
- size = src->size;
- abs_size = ABS (size);
-
- x->alloc = abs_size == 0 ? 1 : abs_size;
- x->d = (mp_ptr) (*_mp_allocate_func) (BYTES_PER_MP_LIMB * x->alloc);
-
- MPN_COPY (x->d, src->d, abs_size);
- x->size = size;
-}
+++ /dev/null
-/* mpz_init_set_si(val) -- Make a new multiple precision number with
- value val.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_init_set_si (MP_INT *x, signed long int val)
-#else
-mpz_init_set_si (x, val)
- MP_INT *x;
- signed long int val;
-#endif
-{
- x->alloc = 1;
- x->d = (mp_ptr) (*_mp_allocate_func) (BYTES_PER_MP_LIMB * x->alloc);
- if (val > 0)
- {
- x->d[0] = val;
- x->size = 1;
- }
- else if (val < 0)
- {
- x->d[0] = -val;
- x->size = -1;
- }
- else
- x->size = 0;
-}
+++ /dev/null
-/* mpz_init_set_str(mpz, string, base) -- Initialize MPZ and set it to the
- value in the \0-terminated ascii string STRING in base BASE. Return 0 if
- the string was accepted, -1 if an error occured. If BASE == 0 determine
- the base in the C standard way, i.e. 0xhh...h means base 16, 0oo...o
- means base 8, otherwise assume base 10.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-int
-#ifdef __STDC__
-mpz_init_set_str (MP_INT *x, const char *str, int base)
-#else
-mpz_init_set_str (x, str, base)
- MP_INT *x;
- const char *str;
- int base;
-#endif
-{
- x->alloc = 1;
- x->d = (mp_ptr) (*_mp_allocate_func) (BYTES_PER_MP_LIMB * x->alloc);
-
- return _mpz_set_str (x, str, base);
-}
+++ /dev/null
-/* mpz_init_set_ui(val) -- Make a new multiple precision number with
- value val.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_init_set_ui (MP_INT *x, unsigned long int val)
-#else
-mpz_init_set_ui (x, val)
- MP_INT *x;
- unsigned long int val;
-#endif
-{
- x->alloc = 1;
- x->d = (mp_ptr) (*_mp_allocate_func) (BYTES_PER_MP_LIMB * x->alloc);
- if (val > 0)
- {
- x->d[0] = val;
- x->size = 1;
- }
- else
- x->size = 0;
-}
+++ /dev/null
-/* mpz_mdiv -- Mathematical DIVision and MODulo, i.e. division that rounds
- the quotient towards -infinity.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_mdiv (MP_INT *quot,
- const MP_INT *dividend, const MP_INT *divisor)
-#else
-mpz_mdiv (quot, dividend, divisor)
- MP_INT *quot;
- const MP_INT *dividend;
- const MP_INT *divisor;
-#endif
-{
- if ((dividend->size ^ divisor->size) >= 0)
- {
- /* When the dividend and the divisor has same sign, this function
- gives same result as mpz_div. */
- mpz_div (quot, dividend, divisor);
- }
- else
- {
- MP_INT rem;
-
- MPZ_TMP_INIT (&rem, 1 + ABS (dividend->size));
-
- mpz_divmod (quot, &rem, dividend, divisor);
- if (rem.size != 0)
- mpz_sub_ui (quot, quot, 1);
- }
-}
+++ /dev/null
-/* mpz_mdiv_ui -- Mathematical DIVision and MODulo, i.e. division that rounds
- the quotient towards -infinity.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_mdiv_ui (MP_INT *quot,
- const MP_INT *dividend, unsigned long int divisor)
-#else
-mpz_mdiv_ui (quot, dividend, divisor)
- MP_INT *quot;
- const MP_INT *dividend;
- unsigned long int divisor;
-#endif
-{
- MP_INT rem;
-
- MPZ_TMP_INIT (&rem, 1 + ABS (dividend->size));
-
- mpz_divmod_ui (quot, &rem, dividend, divisor);
- if (rem.size < 0)
- mpz_sub_ui (quot, quot, 1);
-}
+++ /dev/null
-/* mpz_mdivmod -- Mathematical DIVision and MODulo, i.e. division that rounds
- the quotient towards -infinity, and with the remainder non-negative.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_mdivmod (MP_INT *quot, MP_INT *rem,
- const MP_INT *dividend, const MP_INT *divisor)
-#else
-mpz_mdivmod (quot, rem, dividend, divisor)
- MP_INT *quot;
- MP_INT *rem;
- const MP_INT *dividend;
- const MP_INT *divisor;
-#endif
-{
- if ((dividend->size ^ divisor->size) >= 0)
- {
- /* When the dividend and the divisor has same sign, this function
- gives same result as mpz_divmod. */
- mpz_divmod (quot, rem, dividend, divisor);
- }
- else
- {
- MP_INT temp_divisor; /* N.B.: lives until function returns! */
-
- /* We need the original value of the divisor after the quotient and
- remainder have been preliminary calculated. We have to copy it to
- temporary space if it's the same variable as either QUOT or REM. */
- if (quot == divisor || rem == divisor)
- {
- MPZ_TMP_INIT (&temp_divisor, ABS (divisor->size));
- mpz_set (&temp_divisor, divisor);
- divisor = &temp_divisor;
- }
-
- mpz_divmod (quot, rem, dividend, divisor);
- if (rem->size != 0)
- {
- mpz_sub_ui (quot, quot, 1);
- mpz_add (rem, rem, divisor);
- }
- }
-}
+++ /dev/null
-/* mpz_mdivmod -- Mathematical DIVision and MODulo, i.e. division that rounds
- the quotient towards -infinity, and with the remainder non-negative.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-unsigned long int
-#ifdef __STDC__
-mpz_mdivmod_ui (MP_INT *quot, MP_INT *rem,
- const MP_INT *dividend, unsigned long int divisor)
-#else
-mpz_mdivmod_ui (quot, rem, dividend, divisor)
- MP_INT *quot;
- MP_INT *rem;
- const MP_INT *dividend;
- unsigned long int divisor;
-#endif
-{
- MP_INT temp_rem; /* N.B.: lives until function returns! */
-
- /* If the user doesn't want the remainder to be stored in an integer
- object, allocate a scratch variable for it. */
- if (rem == NULL)
- {
- MPZ_TMP_INIT (&temp_rem, 1 + ABS (dividend->size));
- rem = &temp_rem;
- }
-
- mpz_divmod_ui (quot, rem, dividend, divisor);
-
- if (rem->size < 0)
- {
- mpz_sub_ui (quot, quot, 1);
- mpz_add_ui (rem, rem, divisor);
- }
-
- if (rem->size == 0)
- return 0;
- return rem->d[0];
-}
+++ /dev/null
-/* mpz_mmod -- Mathematical MODulo, i.e. with the remainder
- non-negative.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_mmod (MP_INT *rem,
- const MP_INT *dividend, const MP_INT *divisor)
-#else
-mpz_mmod (rem, dividend, divisor)
- MP_INT *rem;
- const MP_INT *dividend;
- const MP_INT *divisor;
-#endif
-{
- if ((dividend->size ^ divisor->size) >= 0)
- {
- /* When the dividend and the divisor has same sign, this function
- gives same result as mpz_mod. */
- mpz_mod (rem, dividend, divisor);
- }
- else
- {
- MP_INT temp_divisor; /* N.B.: lives until function returns! */
-
- /* We need the original value of the divisor after the remainder has
- been preliminary calculated. We have to copy it to temporary
- space if it's the same variable as REM. */
- if (rem == divisor)
- {
- MPZ_TMP_INIT (&temp_divisor, ABS (divisor->size));
- mpz_set (&temp_divisor, divisor);
- divisor = &temp_divisor;
- }
-
- mpz_mod (rem, dividend, divisor);
- if (rem->size != 0)
- mpz_add (rem, rem, divisor);
- }
-}
+++ /dev/null
-/* mpz_mmod -- Mathematical MODulo, i.e. with the remainder
- non-negative.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-unsigned long int
-#ifdef __STDC__
-mpz_mmod_ui (MP_INT *rem,
- const MP_INT *dividend, unsigned long int divisor)
-#else
-mpz_mmod_ui (rem, dividend, divisor)
- MP_INT *rem;
- const MP_INT *dividend;
- unsigned long int divisor;
-#endif
-{
- MP_INT temp_rem; /* N.B.: lives until function returns! */
-
- if (rem == NULL)
- {
- MPZ_TMP_INIT (&temp_rem, 1 + ABS (dividend->size));
- rem = &temp_rem;
- }
-
- mpz_mod_ui (rem, dividend, divisor);
-
- if (rem->size < 0)
- mpz_add_ui (rem, rem, divisor);
-
- if (rem->size == 0)
- return 0;
- return rem->d[0];
-}
+++ /dev/null
-/* mpz_mod(rem, dividend, divisor) -- Set REM to DIVIDEND mod DIVISOR.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_mod (MP_INT *rem, const MP_INT *num, const MP_INT *den)
-#else
-mpz_mod (rem, num, den)
- MP_INT *rem;
- const MP_INT *num;
- const MP_INT *den;
-#endif
-
-#undef COMPUTE_QUOTIENT
-#include "mpz_dmincl.c"
+++ /dev/null
-/* mpz_mod_2exp -- divide a MP_INT by 2**n and produce a remainder.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_mod_2exp (MP_INT *res, const MP_INT *in, unsigned long int cnt)
-#else
-mpz_mod_2exp (res, in, cnt)
- MP_INT *res;
- const MP_INT *in;
- unsigned long int cnt;
-#endif
-{
- mp_size in_size = ABS (in->size);
- mp_size res_size;
- mp_size limb_cnt = cnt / BITS_PER_MP_LIMB;
- mp_srcptr in_ptr = in->d;
-
- if (in_size > limb_cnt)
- {
- /* The input operand is (probably) greater than 2**CNT. */
- mp_limb x;
-
- x = in_ptr[limb_cnt] & (((mp_limb) 1 << cnt % BITS_PER_MP_LIMB) - 1);
- if (x != 0)
- {
- res_size = limb_cnt + 1;
- if (res->alloc < res_size)
- _mpz_realloc (res, res_size);
-
- res->d[limb_cnt] = x;
- }
- else
- {
- mp_size i;
-
- for (i = limb_cnt - 1; i >= 0; i--)
- if (in_ptr[i] != 0)
- break;
- res_size = i + 1;
-
- if (res->alloc < res_size)
- _mpz_realloc (res, res_size);
-
- limb_cnt = res_size;
- }
- }
- else
- {
- /* The input operand is smaller than 2**CNT. We perform a no-op,
- apart from that we might need to copy IN to RES. */
- res_size = in_size;
- if (res->alloc < res_size)
- _mpz_realloc (res, res_size);
-
- limb_cnt = res_size;
- }
-
- if (res != in)
- MPN_COPY (res->d, in->d, limb_cnt);
- res->size = (in->size >= 0) ? res_size : -res_size;
-}
+++ /dev/null
-/* mpz_mod_ui(rem, dividend, divisor_limb)
- -- Set REM to DIVDEND mod DIVISOR_LIMB.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_mod_ui (MP_INT *rem, const MP_INT *dividend,
- unsigned long int divisor_limb)
-#else
-mpz_mod_ui (rem, dividend, divisor_limb)
- MP_INT *rem;
- const MP_INT *dividend;
- unsigned long int divisor_limb;
-#endif
-{
- mp_size sign_dividend;
- mp_size dividend_size;
- mp_limb remainder_limb;
-
- sign_dividend = dividend->size;
- dividend_size = ABS (dividend->size);
-
- if (dividend_size == 0)
- {
- rem->size = 0;
- return;
- }
-
- /* No need for temporary allocation and copying if QUOT == DIVIDEND as
- the divisor is just one limb, and thus no intermediate remainders
- need to be stored. */
-
- remainder_limb = mpn_mod_1 (dividend->d, dividend_size, divisor_limb);
-
- if (remainder_limb == 0)
- rem->size = 0;
- else
- {
- /* Store the single-limb remainder. We don't check if there's space
- for just one limb, since no function ever makes zero space. */
- rem->size = sign_dividend >= 0 ? 1 : -1;
- rem->d[0] = remainder_limb;
- }
-}
+++ /dev/null
-/* mpz_mul -- Multiply two integers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#ifndef BERKELEY_MP
-void
-#ifdef __STDC__
-mpz_mul (MP_INT *w, const MP_INT *u, const MP_INT *v)
-#else
-mpz_mul (w, u, v)
- MP_INT *w;
- const MP_INT *u;
- const MP_INT *v;
-#endif
-#else /* BERKELEY_MP */
-void
-#ifdef __STDC__
-mult (const MP_INT *u, const MP_INT *v, MP_INT *w)
-#else
-mult (u, v, w)
- const MP_INT *u;
- const MP_INT *v;
- MP_INT *w;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_size usize = u->size;
- mp_size vsize = v->size;
- mp_size wsize;
- mp_size sign_product;
- mp_ptr up, vp;
- mp_ptr wp;
- mp_ptr free_me = NULL;
- size_t free_me_size;
-
- sign_product = usize ^ vsize;
- usize = ABS (usize);
- vsize = ABS (vsize);
-
- if (usize < vsize)
- {
- /* Swap U and V. */
- {const MP_INT *t = u; u = v; v = t;}
- {mp_size t = usize; usize = vsize; vsize = t;}
- }
-
- up = u->d;
- vp = v->d;
- wp = w->d;
-
- /* Ensure W has space enough to store the result. */
- wsize = usize + vsize;
- if (w->alloc < wsize)
- {
- if (wp == up || wp == vp)
- {
- free_me = wp;
- free_me_size = w->alloc;
- }
- else
- (*_mp_free_func) (wp, w->alloc * BYTES_PER_MP_LIMB);
-
- w->alloc = wsize;
- wp = (mp_ptr) (*_mp_allocate_func) (wsize * BYTES_PER_MP_LIMB);
- w->d = wp;
- }
- else
- {
- /* Make U and V not overlap with W. */
- if (wp == up)
- {
- /* W and U are identical. Allocate temporary space for U. */
- up = (mp_ptr) alloca (usize * BYTES_PER_MP_LIMB);
- /* Is V identical too? Keep it identical with U. */
- if (wp == vp)
- vp = up;
- /* Copy to the temporary space. */
- MPN_COPY (up, wp, usize);
- }
- else if (wp == vp)
- {
- /* W and V are identical. Allocate temporary space for V. */
- vp = (mp_ptr) alloca (vsize * BYTES_PER_MP_LIMB);
- /* Copy to the temporary space. */
- MPN_COPY (vp, wp, vsize);
- }
- }
-
- wsize = mpn_mul (wp, up, usize, vp, vsize);
- w->size = sign_product < 0 ? -wsize : wsize;
- if (free_me != NULL)
- (*_mp_free_func) (free_me, free_me_size * BYTES_PER_MP_LIMB);
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_mul_2exp -- Multiply a bignum by 2**CNT
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_mul_2exp (MP_INT *w, const MP_INT *u, unsigned long int cnt)
-#else
-mpz_mul_2exp (w, u, cnt)
- MP_INT *w;
- const MP_INT *u;
- unsigned long int cnt;
-#endif
-{
- mp_size usize = u->size;
- mp_size abs_usize = ABS (usize);
- mp_size wsize;
- mp_size limb_cnt;
- mp_ptr wp;
- mp_limb wdigit;
-
- if (usize == 0)
- {
- w->size = 0;
- return;
- }
-
- limb_cnt = cnt / BITS_PER_MP_LIMB;
- wsize = abs_usize + limb_cnt + 1;
- if (w->alloc < wsize)
- _mpz_realloc (w, wsize);
- wp = w->d;
-
- wdigit = mpn_lshift (wp + limb_cnt, u->d, abs_usize,
- cnt % BITS_PER_MP_LIMB);
- wsize = abs_usize + limb_cnt;
-
- if (wdigit != 0)
- {
- wp[wsize] = wdigit;
- wsize++;
- }
-
- /* Zero all whole digits at low end. Do it here and not before calling
- mpn_lshift, not to loose for U == W. */
- MPN_ZERO (wp, limb_cnt);
-
- w->size = (usize >= 0) ? wsize : -wsize;
-}
+++ /dev/null
-/* mpz_mul_ui(product, multiplier, small_multiplicand) -- Set
- PRODUCT to MULTIPLICATOR times SMALL_MULTIPLICAND.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_mul_ui (MP_INT *prod, const MP_INT *mult,
- unsigned long int small_mult)
-#else
-mpz_mul_ui (prod, mult, small_mult)
- MP_INT *prod;
- const MP_INT *mult;
- unsigned long int small_mult;
-#endif
-{
- mp_size mult_size = mult->size;
- mp_size sign_product = mult_size;
- mp_size i;
- mp_limb cy;
- mp_size prod_size;
- mp_srcptr mult_ptr;
- mp_ptr prod_ptr;
-
- mult_size = ABS (mult_size);
-
- if (mult_size == 0 || small_mult == 0)
- {
- prod->size = 0;
- return;
- }
-
- prod_size = mult_size + 1;
- if (prod->alloc < prod_size)
- _mpz_realloc (prod, prod_size);
-
- mult_ptr = mult->d;
- prod_ptr = prod->d;
-
- cy = 0;
- for (i = 0; i < mult_size; i++)
- {
- mp_limb p1, p0;
- umul_ppmm (p1, p0, small_mult, mult_ptr[i]);
- p0 += cy;
- cy = p1 + (p0 < cy);
- prod_ptr[i] = p0;
- }
-
- prod_size = mult_size;
- if (cy != 0)
- {
- prod_ptr[mult_size] = cy;
- prod_size++;
- }
-
- prod->size = sign_product > 0 ? prod_size : -prod_size;
-}
+++ /dev/null
-/* mpz_neg(MP_INT *dst, MP_INT *src) -- Assign the negated value of SRC to DST.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_neg (MP_INT *dst, const MP_INT *src)
-#else
-mpz_neg (dst, src)
- MP_INT *dst;
- const MP_INT *src;
-#endif
-{
- mp_size src_size = src->size;
-
- if (src != dst)
- {
- mp_size abs_src_size = ABS (src_size);
-
- if (dst->alloc < abs_src_size)
- _mpz_realloc (dst, abs_src_size);
-
- MPN_COPY (dst->d, src->d, abs_src_size);
- }
-
- dst->size = -src_size;
-}
+++ /dev/null
-/* mpz_out_raw -- Output a MP_INT in raw, but endianess-independent format.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include <stdio.h>
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_out_raw (FILE *file, const MP_INT *x)
-#else
-mpz_out_raw (file, x)
- FILE *file;
- const MP_INT *x;
-#endif
-{
- int i;
- mp_size s;
- mp_size xsize = x->size;
- mp_srcptr xp = x->d;
- mp_size out_size = xsize * BYTES_PER_MP_LIMB;
-
- /* Make the size 4 bytes on all machines, to make the format portable. */
- for (i = 4 - 1; i >= 0; i--)
- fputc ((out_size >> (i * BITS_PER_CHAR)) % (1 << BITS_PER_CHAR), file);
-
- /* Output from the most significant digit to the least significant digit,
- with each digit also output in decreasing significance order. */
- for (s = ABS (xsize) - 1; s >= 0; s--)
- {
- mp_limb x_digit;
-
- x_digit = xp[s];
- for (i = BYTES_PER_MP_LIMB - 1; i >= 0; i--)
- fputc ((x_digit >> (i * BITS_PER_CHAR)) % (1 << BITS_PER_CHAR), file);
- }
-}
+++ /dev/null
-/* mpz_out_str(stream, base, integer) -- Output to STREAM the multi prec.
- integer INTEGER in base BASE.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include <stdio.h>
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_out_str (FILE *stream, int base, const MP_INT *x)
-#else
-mpz_out_str (stream, base, x)
- FILE *stream;
- int base;
- const MP_INT *x;
-#endif
-{
- char *str;
- size_t str_size;
-
- str_size = ((size_t) (ABS (x->size) * BITS_PER_MP_LIMB
- * __mp_bases[ABS (base)].chars_per_bit_exactly)) + 3;
- str = (char *) alloca (str_size);
- _mpz_get_str (str, base, x);
- fputs (str, stream);
- alloca (0);
-}
+++ /dev/null
-/* mpz_perfect_square_p(arg) -- Return non-zero if ARG is a pefect square,
- zero otherwise.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-#if BITS_PER_MP_LIMB == 32
-static unsigned int primes[] = {3, 5, 7, 11, 13, 17, 19, 23, 29};
-static unsigned long int residue_map[] =
-{0x3, 0x13, 0x17, 0x23b, 0x161b, 0x1a317, 0x30af3, 0x5335f, 0x13d122f3};
-
-#define PP 0xC0CFD797L /* 3 x 5 x 7 x 11 x 13 x ... x 29 */
-#endif
-
-/* sq_res_0x100[x mod 0x100] == 1 iff x mod 0x100 is a quadratic residue
- modulo 0x100. */
-static char sq_res_0x100[0x100] =
-{
- 1,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
- 0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
- 1,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
- 0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
- 0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
- 0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
- 0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
- 0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
-};
-
-int
-#ifdef __STDC__
-mpz_perfect_square_p (const MP_INT *a)
-#else
-mpz_perfect_square_p (a)
- const MP_INT *a;
-#endif
-{
- mp_limb n1, n0;
- mp_size i;
- mp_size asize = a->size;
- mp_srcptr aptr = a->d;
- mp_limb rem;
- mp_ptr root_ptr;
-
- /* No negative numbers are perfect squares. */
- if (asize < 0)
- return 0;
-
- /* The first test excludes 55/64 (85.9%) of the perfect square candidates
- in O(1) time. */
- if (sq_res_0x100[aptr[0] % 0x100] == 0)
- return 0;
-
-#if BITS_PER_MP_LIMB == 32
- /* The second test excludes 30652543/30808063 (99.5%) of the remaining
- perfect square candidates in O(n) time. */
-
- /* Firstly, compute REM = A mod PP. */
- n1 = aptr[asize - 1];
- if (n1 >= PP)
- {
- n1 = 0;
- i = asize - 1;
- }
- else
- i = asize - 2;
-
- for (; i >= 0; i--)
- {
- mp_limb dummy;
-
- n0 = aptr[i];
- udiv_qrnnd (dummy, n1, n1, n0, PP);
- }
- rem = n1;
-
- /* We have A mod PP in REM. Now decide if REM is a quadratic residue
- modulo the factors in PP. */
- for (i = 0; i < (sizeof primes) / sizeof (int); i++)
- {
- unsigned int p;
-
- p = primes[i];
- rem %= p;
- if ((residue_map[i] & (1L << rem)) == 0)
- return 0;
- }
-#endif
-
- /* For the third and last test, we finally compute the square root,
- to make sure we've really got a perfect square. */
- root_ptr = (mp_ptr) alloca ((asize + 1) / 2 * BYTES_PER_MP_LIMB);
-
- /* Iff mpn_sqrt returns zero, the square is perfect. */
- {
- int retval = !mpn_sqrt (root_ptr, NULL, aptr, asize);
- alloca (0);
- return retval;
- }
-}
+++ /dev/null
-/* mpz_pow_ui(res, base, exp) -- Set RES to BASE**EXP.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-#ifndef BERKELEY_MP
-void
-#ifdef __STDC__
-mpz_pow_ui (MP_INT *r, const MP_INT *b, unsigned long int e)
-#else
-mpz_pow_ui (r, b, e)
- MP_INT *r;
- const MP_INT *b;
- unsigned long int e;
-#endif
-#else /* BERKELEY_MP */
-void
-#ifdef __STDC__
-rpow (const MP_INT *b, signed short int e, MP_INT *r)
-#else
-rpow (b, e, r)
- const MP_INT *b;
- signed short int e;
- MP_INT *r;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_ptr rp, bp, tp, xp;
- mp_size rsize, bsize;
- int cnt, i;
-
- bsize = ABS (b->size);
-
- /* Single out cases that give result == 0 or 1. These tests are here
- to simplify the general code below, not to optimize. */
- if (bsize == 0
-#ifdef BERKELEY_MP
- || e < 0
-#endif
- )
- {
- r->size = 0;
- return;
- }
- if (e == 0)
- {
- r->d[0] = 1;
- r->size = 1;
- return;
- }
-
- /* Count the number of leading zero bits of the base's most
- significant limb. */
- count_leading_zeros (cnt, b->d[bsize - 1]);
-
- /* Over-estimate space requirements and allocate enough space for the
- final result in two temporary areas. The two areas are used to
- alternately hold the input and recieve the product for mpn_mul.
- (This scheme is used to fulfill the requirements of mpn_mul; that
- the product space may not be the same as any of the input operands.) */
- rsize = bsize * e - cnt * e / BITS_PER_MP_LIMB;
-
- rp = (mp_ptr) alloca (rsize * BYTES_PER_MP_LIMB);
- tp = (mp_ptr) alloca (rsize * BYTES_PER_MP_LIMB);
- bp = b->d;
-
- MPN_COPY (rp, bp, bsize);
- rsize = bsize;
- count_leading_zeros (cnt, e);
-
- for (i = BITS_PER_MP_LIMB - cnt - 2; i >= 0; i--)
- {
- rsize = mpn_mul (tp, rp, rsize, rp, rsize);
- xp = tp; tp = rp; rp = xp;
-
- if ((e & ((mp_limb) 1 << i)) != 0)
- {
- rsize = mpn_mul (tp, rp, rsize, bp, bsize);
- xp = tp; tp = rp; rp = xp;
- }
- }
-
- /* Now then we know the exact space requirements, reallocate if
- necessary. */
- if (r->alloc < rsize)
- _mpz_realloc (r, rsize);
-
- MPN_COPY (r->d, rp, rsize);
- r->size = (e & 1) == 0 || b->size >= 0 ? rsize : -rsize;
- alloca (0);
-}
+++ /dev/null
-/* mpz_powm(res,base,exp,mod) -- Set RES to (base**exp) mod MOD.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-#ifndef BERKELEY_MP
-void
-#ifdef __STDC__
-mpz_powm (MP_INT *res, const MP_INT *base, const MP_INT *exp,
- const MP_INT *mod)
-#else
-mpz_powm (res, base, exp, mod)
- MP_INT *res;
- const MP_INT *base;
- const MP_INT *exp;
- const MP_INT *mod;
-#endif
-#else /* BERKELEY_MP */
-void
-#ifdef __STDC__
-pow (const MP_INT *base, const MP_INT *exp, const MP_INT *mod, MP_INT *res)
-#else
-pow (base, exp, mod, res)
- const MP_INT *base;
- const MP_INT *exp;
- const MP_INT *mod;
- MP_INT *res;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_ptr rp, ep, mp, bp;
- mp_size esize, msize, bsize, rsize;
- mp_size size;
- int mod_shift_cnt;
- int negative_result;
- mp_limb *free_me = NULL;
- size_t free_me_size;
-
- esize = ABS (exp->size);
- msize = ABS (mod->size);
- size = 2 * msize;
-
- rp = res->d;
- ep = exp->d;
-
- /* Normalize MOD (i.e. make its most significant bit set) as required by
- mpn_div. This will make the intermediate values in the calculation
- slightly larger, but the correct result is obtained after a final
- reduction using the original MOD value. */
-
- mp = (mp_ptr) alloca (msize * BYTES_PER_MP_LIMB);
- count_leading_zeros (mod_shift_cnt, mod->d[msize - 1]);
- if (mod_shift_cnt != 0)
- (void) mpn_lshift (mp, mod->d, msize, mod_shift_cnt);
- else
- MPN_COPY (mp, mod->d, msize);
-
- bsize = ABS (base->size);
- if (bsize > msize)
- {
- /* The base is larger than the module. Reduce it. */
-
- /* Allocate (BSIZE + 1) with space for remainder and quotient.
- (The quotient is (bsize - msize + 1) limbs.) */
- bp = (mp_ptr) alloca ((bsize + 1) * BYTES_PER_MP_LIMB);
- MPN_COPY (bp, base->d, bsize);
- /* We don't care about the quotient, store it above the remainder,
- at BP + MSIZE. */
- mpn_div (bp + msize, bp, bsize, mp, msize);
- bsize = msize;
- while (bsize > 0 && bp[bsize - 1] == 0)
- bsize--;
- }
- else
- {
- bp = base->d;
- bsize = ABS (base->size);
- }
-
- if (res->alloc < size)
- {
- /* We have to allocate more space for RES. If any of the input
- parameters are identical to RES, defer deallocation of the old
- space. */
-
- if (rp == ep || rp == mp || rp == bp)
- {
- free_me = rp;
- free_me_size = res->alloc;
- }
- else
- (*_mp_free_func) (rp, res->alloc * BYTES_PER_MP_LIMB);
-
- rp = (mp_ptr) (*_mp_allocate_func) (size * BYTES_PER_MP_LIMB);
- res->alloc = size;
- res->d = rp;
- }
- else
- {
- /* Make BASE, EXP and MOD not overlap with RES. */
- if (rp == bp)
- {
- /* RES and BASE are identical. Allocate temp. space for BASE. */
- bp = (mp_ptr) alloca (bsize * BYTES_PER_MP_LIMB);
- MPN_COPY (bp, rp, bsize);
- }
- if (rp == ep)
- {
- /* RES and EXP are identical. Allocate temp. space for EXP. */
- ep = (mp_ptr) alloca (esize * BYTES_PER_MP_LIMB);
- MPN_COPY (ep, rp, esize);
- }
- if (rp == mp)
- {
- /* RES and MOD are identical. Allocate temporary space for MOD. */
- mp = (mp_ptr) alloca (msize * BYTES_PER_MP_LIMB);
- MPN_COPY (mp, rp, msize);
- }
- }
-
- if (esize == 0)
- {
- rp[0] = 1;
- res->size = 1;
- return;
- }
-
- MPN_COPY (rp, bp, bsize);
- rsize = bsize;
-
- {
- mp_size i;
- mp_size xsize;
- mp_ptr dummyp = (mp_ptr) alloca ((msize + 1) * BYTES_PER_MP_LIMB);
- mp_ptr xp = (mp_ptr) alloca (2 * (msize + 1) * BYTES_PER_MP_LIMB);
- int c;
- mp_limb e;
- mp_limb carry_limb;
-
- negative_result = (ep[0] & 1) && base->size < 0;
-
- i = esize - 1;
- e = ep[i];
- count_leading_zeros (c, e);
- e <<= (c + 1); /* shift the exp bits to the left, loose msb */
- c = BITS_PER_MP_LIMB - 1 - c;
-
- /* Main loop.
-
- Make the result be pointed to alternatingly by XP and RP. This
- helps us avoid block copying, which would otherwise be necessary
- with the overlap restrictions of mpn_div. With 50% probability
- the result after this loop will be in the area originally pointed
- by RP (==RES->D), and with 50% probability in the area originally
- pointed to by XP. */
-
- for (;;)
- {
- while (c != 0)
- {
- mp_ptr tp;
- mp_size tsize;
-
- xsize = mpn_mul (xp, rp, rsize, rp, rsize);
- mpn_div (dummyp, xp, xsize, mp, msize);
-
- /* Remove any leading zero words from the result. */
- if (xsize > msize)
- xsize = msize;
- while (xsize > 0 && xp[xsize - 1] == 0)
- xsize--;
-
- tp = rp; rp = xp; xp = tp;
- tsize = rsize; rsize = xsize; xsize = tsize;
-
- if ((mp_limb_signed) e < 0)
- {
- if (rsize > bsize)
- xsize = mpn_mul (xp, rp, rsize, bp, bsize);
- else
- xsize = mpn_mul (xp, bp, bsize, rp, rsize);
- mpn_div (dummyp, xp, xsize, mp, msize);
-
- /* Remove any leading zero words from the result. */
- if (xsize > msize)
- xsize = msize;
- while (xsize > 0 && xp[xsize - 1] == 0)
- xsize--;
-
- tp = rp; rp = xp; xp = tp;
- tsize = rsize; rsize = xsize; xsize = tsize;
- }
- e <<= 1;
- c--;
- }
-
- i--;
- if (i < 0)
- break;
- e = ep[i];
- c = BITS_PER_MP_LIMB;
- }
-
- /* We shifted MOD, the modulo reduction argument, left MOD_SHIFT_CNT
- steps. Adjust the result by reducing it with the original MOD.
-
- Also make sure the result is put in RES->D (where it already
- might be, see above). */
-
- carry_limb = mpn_lshift (res->d, rp, rsize, mod_shift_cnt);
- rp = res->d;
- if (carry_limb != 0)
- {
- rp[rsize] = carry_limb;
- rsize++;
- }
- mpn_div (dummyp, rp, rsize, mp, msize);
- /* Remove any leading zero words from the result. */
- if (rsize > msize)
- rsize = msize;
- while (rsize > 0 && rp[rsize - 1] == 0)
- rsize--;
- rsize = mpn_rshift (rp, rp, rsize, mod_shift_cnt);
- }
-
- res->size = negative_result >= 0 ? rsize : -rsize;
-
- if (free_me != NULL)
- (*_mp_free_func) (free_me, free_me_size * BYTES_PER_MP_LIMB);
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_powm_ui(res,base,exp,mod) -- Set RES to (base**exp) mod MOD.
-
-Copyright (C) 1991, 1992 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-mpz_powm_ui (MP_INT *res, const MP_INT *base, unsigned long int exp,
- const MP_INT *mod)
-#else
-mpz_powm_ui (res, base, exp, mod)
- MP_INT *res;
- const MP_INT *base;
- unsigned long int exp;
- const MP_INT *mod;
-#endif
-{
- mp_ptr rp, mp, bp;
- mp_size msize, bsize, rsize;
- mp_size size;
- int mod_shift_cnt;
- int negative_result;
- mp_limb *free_me = NULL;
- size_t free_me_size;
-
- msize = ABS (mod->size);
- size = 2 * msize;
-
- rp = res->d;
-
- /* Normalize MOD (i.e. make its most significant bit set) as required by
- mpn_div. This will make the intermediate values in the calculation
- slightly larger, but the correct result is obtained after a final
- reduction using the original MOD value. */
-
- mp = (mp_ptr) alloca (msize * BYTES_PER_MP_LIMB);
- count_leading_zeros (mod_shift_cnt, mod->d[msize - 1]);
- if (mod_shift_cnt != 0)
- (void) mpn_lshift (mp, mod->d, msize, mod_shift_cnt);
- else
- MPN_COPY (mp, mod->d, msize);
-
- bsize = ABS (base->size);
- if (bsize > msize)
- {
- /* The base is larger than the module. Reduce it. */
-
- /* Allocate (BSIZE + 1) with space for remainder and quotient.
- (The quotient is (bsize - msize + 1) limbs.) */
- bp = (mp_ptr) alloca ((bsize + 1) * BYTES_PER_MP_LIMB);
- MPN_COPY (bp, base->d, bsize);
- /* We don't care about the quotient, store it above the remainder,
- at BP + MSIZE. */
- mpn_div (bp + msize, bp, bsize, mp, msize);
- bsize = msize;
- while (bsize > 0 && bp[bsize - 1] == 0)
- bsize--;
- }
- else
- {
- bp = base->d;
- bsize = ABS (base->size);
- }
-
- if (res->alloc < size)
- {
- /* We have to allocate more space for RES. If any of the input
- parameters are identical to RES, defer deallocation of the old
- space. */
-
- if (rp == mp || rp == bp)
- {
- free_me = rp;
- free_me_size = res->alloc;
- }
- else
- (*_mp_free_func) (rp, res->alloc * BYTES_PER_MP_LIMB);
-
- rp = (mp_ptr) (*_mp_allocate_func) (size * BYTES_PER_MP_LIMB);
- res->alloc = size;
- res->d = rp;
- }
- else
- {
- /* Make BASE, EXP and MOD not overlap with RES. */
- if (rp == bp)
- {
- /* RES and BASE are identical. Allocate temp. space for BASE. */
- bp = (mp_ptr) alloca (bsize * BYTES_PER_MP_LIMB);
- MPN_COPY (bp, rp, bsize);
- }
- if (rp == mp)
- {
- /* RES and MOD are identical. Allocate temporary space for MOD. */
- mp = (mp_ptr) alloca (msize * BYTES_PER_MP_LIMB);
- MPN_COPY (mp, rp, msize);
- }
- }
-
- if (exp == 0)
- {
- rp[0] = 1;
- res->size = 1;
- return;
- }
-
- MPN_COPY (rp, bp, bsize);
- rsize = bsize;
-
- {
- mp_size xsize;
- mp_ptr dummyp = (mp_ptr) alloca ((msize + 1) * BYTES_PER_MP_LIMB);
- mp_ptr xp = (mp_ptr) alloca (2 * (msize + 1) * BYTES_PER_MP_LIMB);
- int c;
- mp_limb e;
- mp_limb carry_limb;
-
- negative_result = (exp & 1) && base->size < 0;
-
- e = exp;
- count_leading_zeros (c, e);
- e <<= (c + 1); /* shift the exp bits to the left, loose msb */
- c = BITS_PER_MP_LIMB - 1 - c;
-
- /* Main loop.
-
- Make the result be pointed to alternately by XP and RP. This
- helps us avoid block copying, which would otherwise be necessary
- with the overlap restrictions of mpn_div. With 50% probability
- the result after this loop will be in the area originally pointed
- by RP (==RES->D), and with 50% probability in the area originally
- pointed to by XP. */
-
- while (c != 0)
- {
- mp_ptr tp;
- mp_size tsize;
-
- xsize = mpn_mul (xp, rp, rsize, rp, rsize);
- mpn_div (dummyp, xp, xsize, mp, msize);
-
- /* Remove any leading zero words from the result. */
- if (xsize > msize)
- xsize = msize;
- while (xsize > 0 && xp[xsize - 1] == 0)
- xsize--;
-
- tp = rp; rp = xp; xp = tp;
- tsize = rsize; rsize = xsize; xsize = tsize;
-
- if ((mp_limb_signed) e < 0)
- {
- if (rsize > bsize)
- xsize = mpn_mul (xp, rp, rsize, bp, bsize);
- else
- xsize = mpn_mul (xp, bp, bsize, rp, rsize);
- mpn_div (dummyp, xp, xsize, mp, msize);
-
- /* Remove any leading zero words from the result. */
- if (xsize > msize)
- xsize = msize;
- while (xsize > 0 && xp[xsize - 1] == 0)
- xsize--;
-
- tp = rp; rp = xp; xp = tp;
- tsize = rsize; rsize = xsize; xsize = tsize;
- }
- e <<= 1;
- c--;
- }
-
- /* We shifted MOD, the modulo reduction argument, left MOD_SHIFT_CNT
- steps. Adjust the result by reducing it with the original MOD.
-
- Also make sure the result is put in RES->D (where it already
- might be, see above). */
-
- carry_limb = mpn_lshift (res->d, rp, rsize, mod_shift_cnt);
- rp = res->d;
- if (carry_limb != 0)
- {
- rp[rsize] = carry_limb;
- rsize++;
- }
- mpn_div (dummyp, rp, rsize, mp, msize);
- /* Remove any leading zero words from the result. */
- if (rsize > msize)
- rsize = msize;
- while (rsize > 0 && rp[rsize - 1] == 0)
- rsize--;
- rsize = mpn_rshift (rp, rp, rsize, mod_shift_cnt);
- }
-
- res->size = negative_result >= 0 ? rsize : -rsize;
-
- if (free_me != NULL)
- (*_mp_free_func) (free_me, free_me_size * BYTES_PER_MP_LIMB);
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_probab_prime_p --
- An implementation of the probabilistic primality test found in Knuth's
- Seminumerical Algorithms book. If the function mpz_probab_prime_p()
- returns 0 then n is not prime. If it returns 1, then n is 'probably'
- prime. The probability of a false positive is (1/4)**reps, where
- reps is the number of internal passes of the probabilistic algorithm.
- Knuth indicates that 25 passes are reasonable.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-Contributed by John Amanatides.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-static int
-possibly_prime (n, n_minus_1, x, y, q, k)
- MP_INT *n, *n_minus_1, *x, *y, *q;
- int k;
-{
- int i;
-
- /* find random x s.t. 1 < x < n */
- do
- {
- mpz_random (x, mpz_size (n));
- mpz_mmod (x, x, n);
- }
- while (mpz_cmp_ui (x, 1) <= 0);
-
- mpz_powm (y, x, q, n);
-
- if (mpz_cmp_ui (y, 1) == 0 || mpz_cmp (y, n_minus_1) == 0)
- return 1;
-
- for (i = 1; i < k; i++)
- {
- mpz_powm_ui (y, y, 2, n);
- if (mpz_cmp (y, n_minus_1) == 0)
- return 1;
- if (mpz_cmp_ui (y, 1) == 0)
- return 0;
- }
- return 0;
-}
-
-int
-mpz_probab_prime_p (m, reps)
- const MP_INT *m;
- int reps;
-{
- MP_INT n, n_minus_1, x, y, q;
- int i, k, is_prime;
-
- mpz_init (&n);
- /* Take the absolute value of M, to handle positive and negative primes. */
- mpz_abs (&n, m);
-
- if (mpz_cmp_ui (&n, 3) <= 0)
- {
- if (mpz_cmp_ui (&n, 1) <= 0)
- return 0; /* smallest prime is 2 */
- else
- return 1;
- }
- if ((mpz_get_ui (&n) & 1) == 0)
- return 0; /* even */
-
- mpz_init (&n_minus_1);
- mpz_sub_ui (&n_minus_1, &n, 1);
- mpz_init (&x);
- mpz_init (&y);
-
- /* find q and k, s.t. n = 1 + 2**k * q */
- mpz_init_set (&q, &n_minus_1);
- k = 0;
- while ((mpz_get_ui (&q) & 1) == 0)
- {
- k++;
- mpz_div_2exp (&q, &q, 1);
- }
-
- is_prime = 1;
- for (i = 0; i < reps && is_prime; i++)
- is_prime &= possibly_prime (&n, &n_minus_1, &x, &y, &q, k);
-
- mpz_clear (&n_minus_1);
- mpz_clear (&n);
- mpz_clear (&x);
- mpz_clear (&y);
- mpz_clear (&q);
- return is_prime;
-}
+++ /dev/null
-/* mpz_random -- Generate a random MP_INT of specified size.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#if !defined(__GNUC__)
-#define __inline__ inline
-#endif
-
-#if defined (hpux) || defined (__alpha__)
-/* HPUX lacks random(). DEC Alpha's random() returns a double. */
-static __inline__ long
-urandom ()
-{
- return mrand48 ();
-}
-#else
-long random ();
-
-static __inline__ long
-urandom ()
-{
- /* random() returns 31 bits, we want 32. */
- return random() ^ (random() << 1);
-}
-#endif
-
-void
-#ifdef __STDC__
-mpz_random (MP_INT *x, mp_size size)
-#else
-mpz_random (x, size)
- MP_INT *x;
- mp_size size;
-#endif
-{
- mp_size i;
- mp_limb ran;
-
- if (x->alloc < size)
- _mpz_realloc (x, size);
-
- for (i = 0; i < size; i++)
- {
- ran = urandom ();
- x->d[i] = ran;
- }
-
- for (i = size - 1; i >= 0; i--)
- if (x->d[i] != 0)
- break;
-
- x->size = i + 1;
-}
+++ /dev/null
-/* mpz_random2 -- Generate a positive random MP_INT of specified size, with
- long runs of consecutive ones and zeros in the binary representation.
- Meant for testing of other MP routines.
-
-Copyright (C) 1991, 1993 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#if !defined(__GNUC__)
-#define __inline__ inline
-#endif
-
-#if defined (hpux) || defined (__alpha__)
-/* HPUX lacks random(). DEC Alpha's random() returns a double. */
-static __inline__ long
-random ()
-{
- return mrand48 ();
-}
-#else
-long random ();
-#endif
-
-void
-#ifdef __STDC__
-mpz_random2 (MP_INT *x, mp_size size)
-#else
-mpz_random2 (x, size)
- MP_INT *x;
- mp_size size;
-#endif
-{
- mp_limb ran, cy_limb;
- mp_ptr xp;
- mp_size xsize, abs_size;
- int n_bits;
-
- abs_size = ABS (size);
-
- if (abs_size != 0)
- {
- if (x->alloc < abs_size)
- _mpz_realloc (x, abs_size);
- xp = x->d;
-
- xp[0] = 1;
- for (xsize = 1;; )
- {
- ran = random ();
- n_bits = (ran >> 1) % BITS_PER_MP_LIMB;
-
- if (n_bits == 0)
- {
- if (xsize == abs_size)
- break;
- }
- else
- {
- /* Would we get a too large result in mpn_lshift? */
- if (xsize == abs_size
- && (xp[xsize - 1] >> (BITS_PER_MP_LIMB - n_bits)) != 0)
- break;
-
- cy_limb = mpn_lshift (xp, xp, xsize, n_bits);
- if (cy_limb != 0)
- xp[xsize++] = cy_limb;
-
- if (ran & 1)
- xp[0] |= ((mp_limb) 1 << n_bits) - 1;
- }
- }
- }
-
- x->size = size;
-}
+++ /dev/null
-/* _mpz_realloc -- make the MP_INT have NEW_SIZE digits allocated.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void *
-#ifdef __STDC__
-_mpz_realloc (MP_INT *m, mp_size new_size)
-#else
-_mpz_realloc (m, new_size)
- MP_INT *m;
- mp_size new_size;
-#endif
-{
- /* Never allocate zero space. */
- if (new_size == 0)
- new_size = 1;
-
- m->d = (mp_ptr) (*_mp_reallocate_func) (m->d, m->alloc * BYTES_PER_MP_LIMB,
- new_size * BYTES_PER_MP_LIMB);
- m->alloc = new_size;
-
-#if 0
- /* This might break some code that reads the size field after
- reallocation, in the case the reallocated destination and a
- source argument are identical. */
- if (ABS (m->size) > new_size)
- m->size = 0;
-#endif
-
- return (void *) m->d;
-}
+++ /dev/null
-/* mpz_set (dest_integer, src_integer) -- Assign DEST_INTEGER from SRC_INTEGER.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_set (MP_INT *w, const MP_INT *u)
-#else
-mpz_set (w, u)
- MP_INT *w;
- const MP_INT *u;
-#endif
-{
- mp_size usize;
- mp_size abs_usize;
-
- usize = u->size;
- abs_usize = ABS (usize);
-
- /* If not space for sum (and possible carry), increase space. */
- if (w->alloc < abs_usize)
- _mpz_realloc (w, abs_usize);
-
- w->size = usize;
- MPN_COPY (w->d, u->d, abs_usize);
-}
+++ /dev/null
-/* mpz_set_si(integer, val) -- Assign INTEGER with a small value VAL.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_set_si (MP_INT *dest, signed long int val)
-#else
-mpz_set_si (dest, val)
- MP_INT *dest;
- signed long int val;
-#endif
-{
- /* We don't check if the allocation is enough, since the rest of the
- package ensures it's at least 1, which is what we need here. */
- if (val > 0)
- {
- dest->d[0] = val;
- dest->size = 1;
- }
- else if (val < 0)
- {
- dest->d[0] = -val;
- dest->size = -1;
- }
- else
- dest->size = 0;
-}
+++ /dev/null
-/* mpz_set_str(mp_dest, string, base) -- Convert the \0-terminated
- string STRING in base BASE to multiple precision integer in
- MP_DEST. Allow white space in the string. If BASE == 0 determine
- the base in the C standard way, i.e. 0xhh...h means base 16,
- 0oo...o means base 8, otherwise assume base 10.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-int
-#ifdef __STDC__
-mpz_set_str (MP_INT *x, const char *str, int base)
-#else
-mpz_set_str (x, str, base)
- MP_INT *x;
- const char *str;
- int base;
-#endif
-{
- /* Go via _mpz_set_str, as that can be used by BSD compatible functions. */
- return _mpz_set_str (x, str, base);
-}
+++ /dev/null
-/* mpz_set_ui(integer, val) -- Assign INTEGER with a small value VAL.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_set_ui (MP_INT *dest, unsigned long int val)
-#else
-mpz_set_ui (dest, val)
- MP_INT *dest;
- unsigned long int val;
-#endif
-{
- /* We don't check if the allocation is enough, since the rest of the
- package ensures it's at least 1, which is what we need here. */
- if (val > 0)
- {
- dest->d[0] = val;
- dest->size = 1;
- }
- else
- dest->size = 0;
-}
+++ /dev/null
-/* mpz_size(x) -- return the number of lims currently used by the
- value of integer X.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-size_t
-#ifdef __STDC__
-mpz_size (const MP_INT *x)
-#else
-mpz_size (x)
- const MP_INT *x;
-#endif
-{
- return ABS (x->size);
-}
+++ /dev/null
-/* mpz_sizeinbase(x, base) -- return an approximation to the number of
- character the integer X would have printed in base BASE. The
- approximation is never too small.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-size_t
-#ifdef __STDC__
-mpz_sizeinbase (const MP_INT *x, int base)
-#else
-mpz_sizeinbase (x, base)
- const MP_INT *x;
- int base;
-#endif
-{
- mp_size size = ABS (x->size);
- int lb_base, cnt;
- size_t totbits;
-
- /* Special case for X == 0. */
- if (size == 0)
- return 1;
-
- /* Calculate the total number of significant bits of X. */
- count_leading_zeros (cnt, x->d[size - 1]);
- totbits = size * BITS_PER_MP_LIMB - cnt;
-
- if ((base & (base - 1)) == 0)
- {
- /* Special case for powers of 2, giving exact result. */
-
- count_leading_zeros (lb_base, base);
- lb_base = BITS_PER_MP_LIMB - lb_base - 1;
-
- return (totbits + lb_base - 1) / lb_base;
- }
- else
- return (size_t) (totbits * __mp_bases[base].chars_per_bit_exactly) + 1;
-}
+++ /dev/null
-/* mpz_sqrt(root, u) -- Set ROOT to floor(sqrt(U)).
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-/* This code is just correct if "unsigned char" has at least 8 bits. It
- doesn't help to use CHAR_BIT from limits.h, as the real problem is
- the static arrays. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_sqrt (MP_INT *root, const MP_INT *op)
-#else
-mpz_sqrt (root, op)
- MP_INT *root;
- const MP_INT *op;
-#endif
-{
- mp_size op_size, root_size;
- mp_ptr root_ptr, op_ptr;
- mp_ptr free_me = NULL;
- mp_size free_me_size;
-
- op_size = op->size;
- if (op_size < 0)
- op_size = 1 / op_size > 0; /* Divide by zero for negative OP. */
-
- /* The size of the root is accurate after this simple calculation. */
- root_size = (op_size + 1) / 2;
-
- root_ptr = root->d;
- op_ptr = op->d;
-
- if (root->alloc < root_size)
- {
- if (root_ptr == op_ptr)
- {
- free_me = root_ptr;
- free_me_size = root->alloc;
- }
- else
- (*_mp_free_func) (root_ptr, root->alloc * BYTES_PER_MP_LIMB);
-
- root->alloc = root_size;
- root_ptr = (mp_ptr) (*_mp_allocate_func) (root_size * BYTES_PER_MP_LIMB);
- root->d = root_ptr;
- }
- else
- {
- /* Make OP not overlap with ROOT. */
- if (root_ptr == op_ptr)
- {
- /* ROOT and OP are identical. Allocate temporary space for OP. */
- op_ptr = (mp_ptr) alloca (op_size * BYTES_PER_MP_LIMB);
- /* Copy to the temporary space. Hack: Avoid temporary variable
- by using ROOT_PTR. */
- MPN_COPY (op_ptr, root_ptr, op_size);
- }
- }
-
- mpn_sqrt (root_ptr, NULL, op_ptr, op_size);
-
- root->size = root_size;
-
- if (free_me != NULL)
- (*_mp_free_func) (free_me, free_me_size * BYTES_PER_MP_LIMB);
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_sqrtrem(root,rem,x) -- Set ROOT to floor(sqrt(X)) and REM
- to the remainder, i.e. X - ROOT**2.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#ifndef BERKELEY_MP
-void
-#ifdef __STDC__
-mpz_sqrtrem (MP_INT *root, MP_INT *rem, const MP_INT *op)
-#else
-mpz_sqrtrem (root, rem, op)
- MP_INT *root;
- MP_INT *rem;
- const MP_INT *op;
-#endif
-#else /* BERKELEY_MP */
-void
-#ifdef __STDC__
-msqrt (const MP_INT *op, MP_INT *root, MP_INT *rem)
-#else
-msqrt (op, root, rem)
- const MP_INT *op;
- MP_INT *root;
- MP_INT *rem;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_size op_size, root_size, rem_size;
- mp_ptr root_ptr, op_ptr;
- mp_ptr free_me = NULL;
- mp_size free_me_size;
-
- op_size = op->size;
- if (op_size < 0)
- op_size = 1 / (op_size > 0); /* Divide by zero for negative OP. */
-
- if (rem->alloc < op_size)
- _mpz_realloc (rem, op_size);
-
- /* The size of the root is accurate after this simple calculation. */
- root_size = (op_size + 1) / 2;
-
- root_ptr = root->d;
- op_ptr = op->d;
-
- if (root->alloc < root_size)
- {
- if (root_ptr == op_ptr)
- {
- free_me = root_ptr;
- free_me_size = root->alloc;
- }
- else
- (*_mp_free_func) (root_ptr, root->alloc * BYTES_PER_MP_LIMB);
-
- root->alloc = root_size;
- root_ptr = (mp_ptr) (*_mp_allocate_func) (root_size * BYTES_PER_MP_LIMB);
- root->d = root_ptr;
- }
- else
- {
- /* Make OP not overlap with ROOT. */
- if (root_ptr == op_ptr)
- {
- /* ROOT and OP are identical. Allocate temporary space for OP. */
- op_ptr = (mp_ptr) alloca (op_size * BYTES_PER_MP_LIMB);
- /* Copy to the temporary space. Hack: Avoid temporary variable
- by using ROOT_PTR. */
- MPN_COPY (op_ptr, root_ptr, op_size);
- }
- }
-
- rem_size = mpn_sqrt (root_ptr, rem->d, op_ptr, op_size);
-
- root->size = root_size;
-
- /* Write remainder size last, to enable us to define this function to
- give only the square root remainder, if the user calles if with
- ROOT == REM. */
- rem->size = rem_size;
-
- if (free_me != NULL)
- (*_mp_free_func) (free_me, free_me_size * BYTES_PER_MP_LIMB);
-
- alloca (0);
-}
+++ /dev/null
-/* mpz_sub -- Subtract two integers.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-#ifndef BERKELEY_MP
-void
-#ifdef __STDC__
-mpz_sub (MP_INT *w, const MP_INT *u, const MP_INT *v)
-#else
-mpz_sub (w, u, v)
- MP_INT *w;
- const MP_INT *u;
- const MP_INT *v;
-#endif
-#else /* BERKELEY_MP */
-void
-#ifdef __STDC__
-msub (const MP_INT *u, const MP_INT *v, MP_INT *w)
-#else
-msub (u, v, w)
- const MP_INT *u;
- const MP_INT *v;
- MP_INT *w;
-#endif
-#endif /* BERKELEY_MP */
-{
- mp_srcptr up, vp;
- mp_ptr wp;
- mp_size usize, vsize, wsize;
- mp_size abs_usize;
- mp_size abs_vsize;
-
- usize = u->size;
- vsize = -v->size; /* The "-" makes the difference from mpz_add */
- abs_usize = ABS (usize);
- abs_vsize = ABS (vsize);
-
- if (abs_usize < abs_vsize)
- {
- /* Swap U and V. */
- {const MP_INT *t = u; u = v; v = t;}
- {mp_size t = usize; usize = vsize; vsize = t;}
- {mp_size t = abs_usize; abs_usize = abs_vsize; abs_vsize = t;}
- }
-
- /* True: abs(USIZE) >= abs(VSIZE) */
-
- /* If not space for sum (and possible carry), increase space. */
- wsize = abs_usize + 1;
- if (w->alloc < wsize)
- _mpz_realloc (w, wsize);
-
- /* These must be after realloc (u or v may be the same as w). */
- up = u->d;
- vp = v->d;
- wp = w->d;
-
- if (usize >= 0)
- {
- if (vsize >= 0)
- {
- wsize = mpn_add (wp, up, abs_usize, vp, abs_vsize);
- if (wsize != 0)
- wp[abs_usize] = 1;
- wsize = wsize + abs_usize;
- }
- else
- {
- /* The signs are different. Need exact comparision to determine
- which operand to subtract from which. */
- if (abs_usize == abs_vsize && mpn_cmp (up, vp, abs_usize) < 0)
- wsize = -(abs_usize + mpn_sub (wp, vp, abs_usize, up, abs_usize));
- else
- wsize = abs_usize + mpn_sub (wp, up, abs_usize, vp, abs_vsize);
- }
- }
- else
- {
- if (vsize >= 0)
- {
- /* The signs are different. Need exact comparision to determine
- which operand to subtract from which. */
- if (abs_usize == abs_vsize && mpn_cmp (up, vp, abs_usize) < 0)
- wsize = abs_usize + mpn_sub (wp, vp, abs_usize, up, abs_usize);
- else
- wsize = -(abs_usize + mpn_sub (wp, up, abs_usize, vp, abs_vsize));
- }
- else
- {
- wsize = mpn_add (wp, up, abs_usize, vp, abs_vsize);
- if (wsize != 0)
- wp[abs_usize] = 1;
- wsize = -(wsize + abs_usize);
- }
- }
-
- w->size = wsize;
-}
+++ /dev/null
-/* mpz_sub_ui -- Subtract an unsigned one-word integer from an MP_INT.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "gmp.h"
-#include "gmp-impl.h"
-
-void
-#ifdef __STDC__
-mpz_sub_ui (MP_INT *dif, const MP_INT *min, mp_limb sub)
-#else
-mpz_sub_ui (dif, min, sub)
- MP_INT *dif;
- const MP_INT *min;
- mp_limb sub;
-#endif
-{
- mp_srcptr minp;
- mp_ptr difp;
- mp_size minsize, difsize;
- mp_size abs_minsize;
-
- minsize = min->size;
- abs_minsize = ABS (minsize);
-
- /* If not space for SUM (and possible carry), increase space. */
- difsize = abs_minsize + 1;
- if (dif->alloc < difsize)
- _mpz_realloc (dif, difsize);
-
- /* These must be after realloc (ADD1 may be the same as SUM). */
- minp = min->d;
- difp = dif->d;
-
- if (sub == 0)
- {
- MPN_COPY (difp, minp, abs_minsize);
- dif->size = minsize;
- return;
- }
- if (abs_minsize == 0)
- {
- difp[0] = sub;
- dif->size = -1;
- return;
- }
-
- if (minsize < 0)
- {
- difsize = mpn_add (difp, minp, abs_minsize, &sub, 1);
- if (difsize != 0)
- difp[abs_minsize] = 1;
- difsize = -(difsize + abs_minsize);
- }
- else
- {
- /* The signs are different. Need exact comparision to determine
- which operand to subtract from which. */
- if (abs_minsize == 1 && minp[0] < sub)
- difsize = -(abs_minsize
- + mpn_sub (difp, &sub, 1, minp, 1));
- else
- difsize = (abs_minsize
- + mpn_sub (difp, minp, abs_minsize, &sub, 1));
- }
-
- dif->size = difsize;
-}
+++ /dev/null
-/* mtox -- Convert OPERAND to hexadecimal and return a malloc'ed string
- with the result of the conversion.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-
-char *
-#ifdef __STDC__
-mtox (const MINT *operand)
-#else
-mtox (operand)
- const MINT *operand;
-#endif
-{
- /* Call MP_GET_STR with a NULL pointer as string argument, so that it
- allocates space for the result. */
- return _mpz_get_str ((char *) 0, 16, operand);
-}
+++ /dev/null
-/* sdiv -- Divide a MINT by a short integer. Produce a MINT quotient
- and a short remainder.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-#include "longlong.h"
-
-void
-#ifdef __STDC__
-sdiv (const MINT *dividend, signed short int divisor_short, MINT *quot, short *rem_ptr)
-#else
-sdiv (dividend, divisor_short, quot, rem_ptr)
- const MINT *dividend;
- short int divisor_short;
- MINT *quot;
- short *rem_ptr;
-#endif
-{
- mp_size sign_dividend;
- signed long int sign_divisor;
- mp_size dividend_size, quot_size;
- mp_ptr dividend_ptr, quot_ptr;
- mp_limb divisor_limb;
- mp_limb remainder_limb;
-
- sign_dividend = dividend->size;
- dividend_size = ABS (dividend->size);
-
- if (dividend_size == 0)
- {
- quot->size = 0;
- *rem_ptr = 0;
- return;
- }
-
- sign_divisor = divisor_short;
- divisor_limb = ABS (divisor_short);
-
- /* No need for temporary allocation and copying even if QUOT == DIVIDEND
- as the divisor is just one limb, and thus no intermediate remainders
- need to be stored. */
-
- if (quot->alloc < dividend_size)
- _mpz_realloc (quot, dividend_size);
-
- quot_ptr = quot->d;
- dividend_ptr = dividend->d;
-
- remainder_limb = mpn_divmod_1 (quot_ptr,
- dividend_ptr, dividend_size, divisor_limb);
-
- *rem_ptr = sign_dividend >= 0 ? remainder_limb : -remainder_limb;
- /* The quotient is DIVIDEND_SIZE limbs, but the most significant
- might be zero. Set QUOT_SIZE properly. */
- quot_size = dividend_size - (quot_ptr[dividend_size - 1] == 0);
- quot->size = (sign_divisor ^ sign_dividend) >= 0 ? quot_size : -quot_size;
-}
+++ /dev/null
-#include <stddef.h>
-main(){size_t foo=sizeof(size_t);exit(0);}
+++ /dev/null
-/* xtom -- convert a hexadecimal string to a MINT, and return a pointer to
- the MINT.
-
-Copyright (C) 1991 Free Software Foundation, Inc.
-
-This file is part of the GNU MP Library.
-
-The GNU MP Library is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-The GNU MP Library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with the GNU MP Library; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "mp.h"
-#include "gmp.h"
-#include "gmp-impl.h"
-
-MINT *
-#ifdef __STDC__
-xtom (const char *hex_str)
-#else
-xtom (hex_str)
- const char *hex_str;
-#endif
-{
- MINT *x = (MINT *) (*_mp_allocate_func) (sizeof (MINT));
-
- x->alloc = 1;
- x->d = (mp_ptr) (*_mp_allocate_func) (x->alloc * BYTES_PER_MP_LIMB);
-
- _mpz_set_str (x, hex_str, 16);
- return x;
-}
+++ /dev/null
-%
-% (c) Parade/AQUA Projects, Glasgow University, 1995
-% Kevin Hammond, February 15th. 1995
-%
-% This is for GUM only.
-%
-%************************************************************************
-%* *
-\section[FetchMe.lhc]{Reading Closures}
-%* *
-%************************************************************************
-
-This module defines routines for handling remote pointers (@FetchMe@s)
-in GUM. It is threaded (@.lhc@) because @FetchMe_entry@ will be
-called during evaluation.
-
-\begin{code}
-#ifdef PAR /* whole file */
-
-#define MAIN_REG_MAP /* STG world */
-#include "rtsdefs.h"
-\end{code}
-
-\begin{code}
-
-EXTDATA_RO(BH_UPD_info);
-EXTDATA_RO(FetchMe_info);
-
-EXTFUN(EnterNodeCode);
-
-STGFUN(FetchMe_entry)
-{
- globalAddr *rGA;
- globalAddr *lGA;
- globalAddr fmbqGA;
-
-# if defined(GRAN)
- STGCALL0(void,(),GranSimBlock); /* Do this before losing its TSO_LINK */
-# endif
-
- rGA = FETCHME_GA(Node);
- ASSERT(rGA->loc.gc.gtid != mytid);
-
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;
- SET_INFO_PTR(Node, FMBQ_info);
- FMBQ_ENTRIES(Node) = (W_) CurrentTSO;
-
- LivenessReg = LIVENESS_R1;
- SaveAllStgRegs();
- TSO_PC1(CurrentTSO) = EnterNodeCode;
-
- /* Calls out are now safe */
-
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
-
- if (RTSflags.ParFlags.granSimStats) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- TIME now = CURRENT_TIME;
- TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
- TSO_FETCHCOUNT(CurrentTSO)++;
- TSO_QUEUE(CurrentTSO) = Q_FETCHING;
- TSO_BLOCKEDAT(CurrentTSO) = now;
- /* DumpGranEventAndNode(GR_FETCH, CurrentTSO, (SAVE_R1).p,
- taskIDtoPE(rGA->loc.gc.gtid)); */
- DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(rGA->loc.gc.gtid),GR_FETCH,
- CurrentTSO,(SAVE_R1).p,0);
- }
-
- /* Assign a brand-new global address to the newly created FMBQ */
- lGA = MakeGlobal((SAVE_R1).p, rtsFalse);
- splitWeight(&fmbqGA, lGA);
- ASSERT(fmbqGA.weight == 1L << (BITS_IN(unsigned) - 1));
-
- sendFetch(rGA, &fmbqGA, 0/*load*/);
-
- ReSchedule(0);
- FE_
-}
-
-FETCHME_ITBL(FetchMe_info,FetchMe_entry);
-
-\end{code}
-
-And for migrated FetchMes that are now blocked on remote blocking queues...
-
-\begin{code}
-
-STGFUN(BF_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fprintf(stderr, "Panic: Entered a BlockedFetch\n");
- EXIT(EXIT_FAILURE);
- FE_
-}
-
-BF_ITBL();
-
-\end{code}
-
-@FMBQ@ nodes are @FetchMe@s with blocking queues attached. The fetch has
-been sent, but no reply has been received yet.
-
-\begin{code}
-
-EXTFUN(EnterNodeCode);
-
-STGFUN(FMBQ_entry)
-{
- FB_
-
-#if defined(GRAN)
- STGCALL0(void,(),GranSimBlock); /* Before overwriting TSO_LINK */
-#endif
-
- TSO_LINK(CurrentTSO) = (P_) FMBQ_ENTRIES(Node);
- FMBQ_ENTRIES(Node) = (W_) CurrentTSO;
-
- LivenessReg = LIVENESS_R1;
- SaveAllStgRegs();
- TSO_PC1(CurrentTSO) = EnterNodeCode;
-
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
-
- if (RTSflags.ParFlags.granSimStats) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- TIME now = CURRENT_TIME;
- TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
- TSO_FETCHCOUNT(CurrentTSO)++;
- TSO_QUEUE(CurrentTSO) = Q_FETCHING;
- TSO_BLOCKEDAT(CurrentTSO) = now;
- DumpGranEvent(GR_FETCH, CurrentTSO);
- }
-
- ReSchedule(0);
- FE_
-}
-
-FMBQ_ITBL();
-
-#endif /* PAR -- whole file */
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA/Parade Projects, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section[GlobAddr.lc]{Global Address Manipulation}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef PAR /* whole file */
-
-#include "rtsdefs.h"
-\end{code}
-
-@globalAddr@ structures are allocated in chunks to reduce malloc overhead.
-
-\begin{code}
-
-GALA *freeGALAList = NULL;
-
-#define GCHUNK (1024 * sizeof(W_) / sizeof(GALA))
- /* Number of globalAddr cells to allocate in one go */
-
-static GALA *
-allocGALA(STG_NO_ARGS)
-{
- GALA *gl, *p;
-
- if ((gl = freeGALAList) != NULL) {
- freeGALAList = gl->next;
- } else {
- gl = (GALA *) stgMallocBytes(GCHUNK * sizeof(GALA), "allocGALA");
-
- freeGALAList = gl + 1;
- for (p = freeGALAList; p < gl + GCHUNK - 1; p++)
- p->next = p + 1;
- p->next = NULL;
- }
- return gl;
-}
-
-\end{code}
-
-We don't really like GLOBAL_TASK_ID, so we keep a table of TASK_ID to
-PE mappings. The idea is that a PE identifier will fit in 16 bits, whereas
-a TASK_ID may not.
-
-\begin{code}
-
-HashTable *taskIDtoPEtable = NULL;
-
-static int nextPE = 0;
-
-W_
-taskIDtoPE(GLOBAL_TASK_ID gtid)
-{
- return (W_) lookupHashTable(taskIDtoPEtable, gtid);
-}
-
-int thisPE;
-
-void
-registerTask(gtid)
-GLOBAL_TASK_ID gtid;
-{
- if (gtid == mytid)
- thisPE = nextPE;
-
- insertHashTable(taskIDtoPEtable, gtid, (void *) (W_) nextPE++);
-}
-
-\end{code}
-
-The local address to global address mapping returns a globalAddr structure
-(pe task id, slot, weight) for any closure in the local heap which has a
-global identity. Such closures may be copies of normal form objects with
-a remote `master' location, @FetchMe@ nodes referencing remote objects, or
-globally visible objects in the local heap (for which we are the master).
-
-\begin{code}
-
-HashTable *LAtoGALAtable = NULL;
-
-globalAddr *
-LAGAlookup(addr)
-P_ addr;
-{
- GALA *gala;
-
- /* We never look for GA's on indirections */
- ASSERT(INFO_PTR(addr) != (W_) Ind_info_TO_USE);
- if ((gala = lookupHashTable(LAtoGALAtable, (W_) addr)) == NULL)
- return NULL;
- else
- return &(gala->ga);
-}
-
-\end{code}
-
-We also manage a mapping of global addresses to local addresses, so that
-we can ``common up'' multiple references to the same object as they arrive
-in data packets from remote PEs.
-
-The global address to local address mapping is actually managed via a
-``packed global address'' to GALA hash table. The packed global
-address takes the interesting part of the @globalAddr@ structure
-(i.e. the pe and slot fields) and packs them into a single word
-suitable for hashing.
-
-\begin{code}
-
-HashTable *pGAtoGALAtable = NULL;
-
-P_
-GALAlookup(ga)
-globalAddr *ga;
-{
- W_ pga = PackGA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
- GALA *gala;
- P_ la;
-
- if ((gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga)) == NULL)
- return NULL;
- else {
- la = gala->la;
- /*
- * Bypass any indirections when returning a local closure to
- * the caller. Note that we do not short-circuit the entry in
- * the GALA tables right now, because we would have to do a
- * hash table delete and insert in the LAtoGALAtable to keep
- * that table up-to-date for preferred GALA pairs. That's
- * probably a bit expensive.
- */
- while (IS_INDIRECTION(INFO_PTR(la)))
- la = (P_) IND_CLOSURE_PTR(la);
- return la;
- }
-}
-
-\end{code}
-
-External references to our globally-visible closures are managed through an
-indirection table. The idea is that the closure may move about as the result
-of local garbage collections, but its global identity is determined by its
-slot in the indirection table, which never changes.
-
-The indirection table is maintained implicitly as part of the global
-address to local address table. We need only keep track of the
-highest numbered indirection index allocated so far, along with a free
-list of lower numbered indices no longer in use.
-
-\begin{code}
-
-static I_ nextIndirection = 0;
-
-GALA *freeIndirections = NULL;
-
-\end{code}
-
-Allocate an indirection slot for the closure currently at address @addr@.
-
-\begin{code}
-
-static GALA *
-allocIndirection(P_ addr)
-{
- GALA *gala;
-
- if ((gala = freeIndirections) != NULL) {
- freeIndirections = gala->next;
- } else {
- gala = allocGALA();
- gala->ga.loc.gc.gtid = mytid;
- gala->ga.loc.gc.slot = nextIndirection++;
- }
- gala->ga.weight = MAX_GA_WEIGHT;
- gala->la = addr;
- return gala;
-}
-
-\end{code}
-
-Make a local closure at @addr@ globally visible. We have to allocate an
-indirection slot for it, and update both the local address to global address
-and global address to local address maps.
-
-\begin{code}
-
-GALA *liveIndirections = NULL;
-
-globalAddr *
-MakeGlobal(addr, preferred)
-P_ addr;
-rtsBool preferred;
-{
- GALA *oldGALA = lookupHashTable(LAtoGALAtable, (W_) addr);
- GALA *newGALA = allocIndirection(addr);
- W_ pga = PackGA(thisPE, newGALA->ga.loc.gc.slot);
-
- ASSERT(GALAlookup(&(newGALA->ga)) == NULL);
-
- newGALA->la = addr;
- newGALA->preferred = preferred;
-
- if (preferred) {
- /* The new GA is now the preferred GA for the LA */
- if (oldGALA != NULL) {
- oldGALA->preferred = rtsFalse;
- (void) removeHashTable(LAtoGALAtable, (W_) addr, (void *) oldGALA);
- }
- insertHashTable(LAtoGALAtable, (W_) addr, (void *) newGALA);
- }
-
- newGALA->next = liveIndirections;
- liveIndirections = newGALA;
-
- insertHashTable(pGAtoGALAtable, pga, (void *) newGALA);
-
- return &(newGALA->ga);
-}
-
-\end{code}
-
-Assign an existing remote global address to an existing closure.
-We do not retain the @globalAddr@ structure that's passed in as an argument,
-so it can be a static in the calling routine.
-
-\begin{code}
-
-GALA *liveRemoteGAs = NULL;
-
-globalAddr *
-setRemoteGA(addr, ga, preferred)
-P_ addr;
-globalAddr *ga;
-rtsBool preferred;
-{
- GALA *oldGALA = lookupHashTable(LAtoGALAtable, (W_) addr);
- GALA *newGALA = allocGALA();
- W_ pga = PackGA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
-
- ASSERT(ga->loc.gc.gtid != mytid);
- ASSERT(ga->weight > 0);
- ASSERT(GALAlookup(ga) == NULL);
-
- newGALA->ga = *ga;
- newGALA->la = addr;
- newGALA->preferred = preferred;
-
- if (preferred) {
- /* The new GA is now the preferred GA for the LA */
- if (oldGALA != NULL) {
- oldGALA->preferred = rtsFalse;
- (void) removeHashTable(LAtoGALAtable, (W_) addr, (void *) oldGALA);
- }
- insertHashTable(LAtoGALAtable, (W_) addr, (void *) newGALA);
- }
- newGALA->next = liveRemoteGAs;
- liveRemoteGAs = newGALA;
-
- insertHashTable(pGAtoGALAtable, pga, (void *) newGALA);
-
- ga->weight = 0;
-
- return &(newGALA->ga);
-}
-\end{code}
-
-Give me a bit of weight to give away on a new reference to a particular global
-address. If we run down to nothing, we have to assign a new GA.
-
-\begin{code}
-
-void
-splitWeight(to, from)
-globalAddr *to, *from;
-{
- /* Make sure we have enough weight to split */
- if (from->weight == 1)
- from = MakeGlobal(GALAlookup(from), rtsTrue);
-
- to->loc = from->loc;
-
- if (from->weight == 0)
- to->weight = 1L << (BITS_IN(unsigned) - 1);
- else
- to->weight = from->weight / 2;
-
- from->weight -= to->weight;
-}
-
-\end{code}
-
-Here, I am returning a bit of weight that a remote PE no longer needs.
-
-\begin{code}
-
-globalAddr *
-addWeight(ga)
-globalAddr *ga;
-{
- W_ pga = PackGA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
- GALA *gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga);
-
-#ifdef DEBUG_WEIGHT
- fprintf(stderr, "Adding weight %x to (%x, %d, %x), preferred = %d\n", ga->weight,
- gala->ga.loc.gc.gtid, gala->ga.loc.gc.slot, gala->ga.weight, gala->preferred);
-#endif
- gala->ga.weight += ga->weight;
- ga->weight = 0;
-
- return &(gala->ga);
-}
-
-\end{code}
-
-Initialize all of the global address structures: the task ID to PE id
-map, the local address to global address map, the global address to
-local address map, and the indirection table.
-
-\begin{code}
-
-void
-initGAtables(STG_NO_ARGS)
-{
- taskIDtoPEtable = allocHashTable();
- LAtoGALAtable = allocHashTable();
- pGAtoGALAtable = allocHashTable();
-}
-
-\end{code}
-
-Rebuild the LA->GA table, assuming that the addresses in the GALAs are correct.
-
-\begin{code}
-
-void
-RebuildLAGAtable(STG_NO_ARGS)
-{
- GALA *gala;
-
- /* The old LA->GA table is worthless */
- freeHashTable(LAtoGALAtable, NULL);
- LAtoGALAtable = allocHashTable();
-
- for (gala = liveIndirections; gala != NULL; gala = gala->next) {
- if (gala->preferred)
- insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
- }
-
- for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
- if (gala->preferred)
- insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
- }
-}
-\end{code}
-
-\begin{code}
-W_
-PackGA (pe, slot)
- W_ pe;
- int slot;
-{
- int pe_shift = (BITS_IN(W_)*3)/4;
- int pe_bits = BITS_IN(W_) - pe_shift;
-
- if ( pe_bits < 8 || slot >= (1L << pe_shift) ) { /* big trouble */
- fflush(stdout);
- fprintf(stderr, "PackGA: slot# too big (%d) or not enough pe_bits (%d)\n",slot,pe_bits);
- EXIT(EXIT_FAILURE);
- }
-
- return((((W_)(pe)) << pe_shift) | ((W_)(slot)));
-
- /* the idea is to use 3/4 of the bits (e.g., 24) for indirection-
- table "slot", and 1/4 for the pe# (e.g., 8).
-
- We check for too many bits in "slot", and double-check (at
- compile-time?) that we have enough bits for "pe". We *don't*
- check for too many bits in "pe", because SysMan enforces a
- MAX_PEs limit at the very very beginning.
-
- Phil & Will 95/08
- */
-}
-
-#endif /* PAR -- whole file */
-\end{code}
+++ /dev/null
-/****************************************************************
-* *
-* High Level Communications Routines (HLComms.lc) *
-* *
-* Contains the high-level routines (i.e. communication *
-* subsystem independent) used by GUM *
-* (c) The Parade/AQUA Projects, Glasgow University, 1995 *
-* Phil Trinder, Glasgow University, 12 December 1994 *
-* *
-*****************************************************************/
-\begin{code}
-#ifdef PAR /* whole file */
-
-#ifndef _AIX
-#define NON_POSIX_SOURCE /* so says Solaris */
-#endif
-
-#include "rtsdefs.h"
-#include "HLC.h"
-\end{code}
-
-\section{GUM Message Sending and Unpacking Functions}
-
-
-@SendFetch@ packs the two global addresses and a load into a message +
-sends it.
-
-\begin{code}
-static W_ *gumPackBuffer;
-
-void
-InitMoreBuffers(STG_NO_ARGS)
-{
- gumPackBuffer
- = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize, "initMoreBuffers");
-}
-
-void
-sendFetch(rga, lga, load)
-globalAddr *rga, *lga;
-int load;
-{
- CostCentre Save_CCC = CCC;
-
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
- CCC->scc_count++;
-
- ASSERT(rga->weight > 0 && lga->weight > 0);
-#ifdef FETCH_DEBUG
- fprintf(stderr, "Sending Fetch (%x, %d, 0), load = %d\n",
- rga->loc.gc.gtid, rga->loc.gc.slot, load);
-#endif
- SendOpV(PP_FETCH, rga->loc.gc.gtid, 6,
- (W_) rga->loc.gc.gtid, (W_) rga->loc.gc.slot,
- (W_) lga->weight, (W_) lga->loc.gc.gtid, (W_) lga->loc.gc.slot, (W_) load);
-
- CCC = Save_CCC;
-}
-\end{code}
-
-@unpackFetch@ unpacks a FETCH message into two Global addresses and a load figure.
-
-\begin{code}
-
-static void
-unpackFetch(globalAddr *lga, globalAddr *rga, int *load)
-{
- long buf[6];
-
- GetArgs(buf, 6);
- lga->weight = 1;
- lga->loc.gc.gtid = (GLOBAL_TASK_ID) buf[0];
- lga->loc.gc.slot = (int) buf[1];
-
- rga->weight = (unsigned) buf[2];
- rga->loc.gc.gtid = (GLOBAL_TASK_ID) buf[3];
- rga->loc.gc.slot = (int) buf[4];
-
- *load = (int) buf[5];
-
- ASSERT(rga->weight > 0);
-}
-\end{code}
-
-@SendResume@ packs the remote blocking queue's GA and data into a message
-and sends it.
-
-\begin{code}
-void
-sendResume(rga, nelem, data)
-globalAddr *rga;
-int nelem;
-P_ data;
-{
- CostCentre Save_CCC = CCC;
-
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
- CCC->scc_count++;
-
-#ifdef RESUME_DEBUG
- PrintPacket(data);
- fprintf(stderr, "Sending Resume for (%x, %d, %x)\n",
- rga->loc.gc.gtid, rga->loc.gc.slot, rga->weight);
-#endif
-
- SendOpNV(PP_RESUME, rga->loc.gc.gtid, nelem, data, 2,
- (W_) rga->weight, (W_) rga->loc.gc.slot);
-
- CCC = Save_CCC;
-}
-\end{code}
-
-@blockFetch@ blocks a @BlockedFetch@ node on some kind of black hole.
-
-\begin{code}
-static void
-blockFetch(P_ bf, P_ bh)
-{
- switch (INFO_TYPE(INFO_PTR(bh))) {
- case INFO_BH_TYPE:
- BF_LINK(bf) = PrelBase_Z91Z93_closure;
- SET_INFO_PTR(bh, BQ_info);
- BQ_ENTRIES(bh) = (W_) bf;
-
-#ifdef GC_MUT_REQUIRED
- /*
- * If we modify a black hole in the old generation, we have to
- * make sure it goes on the mutables list
- */
-
- if (bh <= StorageMgrInfo.OldLim) {
- MUT_LINK(bh) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = bh;
- } else
- MUT_LINK(bh) = MUT_NOT_LINKED;
-#endif
- break;
- case INFO_BQ_TYPE:
- BF_LINK(bf) = (P_) BQ_ENTRIES(bh);
- BQ_ENTRIES(bh) = (W_) bf;
- break;
- case INFO_FMBQ_TYPE:
- BF_LINK(bf) = (P_) FMBQ_ENTRIES(bh);
- FMBQ_ENTRIES(bh) = (W_) bf;
- break;
- case INFO_SPEC_RBH_TYPE:
- BF_LINK(bf) = (P_) SPEC_RBH_BQ(bh);
- SPEC_RBH_BQ(bh) = (W_) bf;
- break;
- case INFO_GEN_RBH_TYPE:
- BF_LINK(bf) = (P_) GEN_RBH_BQ(bh);
- GEN_RBH_BQ(bh) = (W_) bf;
- break;
- default:
- fprintf(stderr, "Panic: thought %#lx was a black hole (IP %#lx)\n",
- (W_) bh, INFO_PTR(bh));
- EXIT(EXIT_FAILURE);
- }
-}
-\end{code}
-
-@processFetches@ constructs and sends resume messages for every
-@BlockedFetch@ which is ready to be awakened.
-
-\begin{code}
-extern P_ PendingFetches;
-
-void
-processFetches()
-{
- P_ bf;
- P_ next;
- P_ closure;
- P_ ip;
- globalAddr rga;
-
- for (bf = PendingFetches; bf != PrelBase_Z91Z93_closure; bf = next) {
- next = BF_LINK(bf);
-
- /*
- * Find the target at the end of the indirection chain, and
- * process it in much the same fashion as the original target
- * of the fetch. Though we hope to find graph here, we could
- * find a black hole (of any flavor) or even a FetchMe.
- */
- closure = BF_NODE(bf);
- while (IS_INDIRECTION(INFO_PTR(closure)))
- closure = (P_) IND_CLOSURE_PTR(closure);
- ip = (P_) INFO_PTR(closure);
-
- if (INFO_TYPE(ip) == INFO_FETCHME_TYPE) {
- /* Forward the Fetch to someone else */
- rga.loc.gc.gtid = (GLOBAL_TASK_ID) BF_GTID(bf);
- rga.loc.gc.slot = (int) BF_SLOT(bf);
- rga.weight = (unsigned) BF_WEIGHT(bf);
-
- sendFetch(FETCHME_GA(closure), &rga, 0 /* load */);
- } else if (IS_BLACK_HOLE(ip)) {
- BF_NODE(bf) = closure;
- blockFetch(bf, closure);
- } else {
- /* We now have some local graph to send back */
- W_ size;
- P_ graph;
-
- if ((graph = PackNearbyGraph(closure, &size)) == NULL) {
- PendingFetches = bf;
- ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
- SAVE_Hp -= PACK_HEAP_REQUIRED;
- bf = PendingFetches;
- next = BF_LINK(bf);
- closure = BF_NODE(bf);
- graph = PackNearbyGraph(closure, &size);
- ASSERT(graph != NULL);
- }
- rga.loc.gc.gtid = (GLOBAL_TASK_ID) BF_GTID(bf);
- rga.loc.gc.slot = (int) BF_SLOT(bf);
- rga.weight = (unsigned) BF_WEIGHT(bf);
-
- sendResume(&rga, size, graph);
- }
- }
- PendingFetches = PrelBase_Z91Z93_closure;
-}
-
-\end{code}
-
-@unpackResume@ unpacks a Resume message into two Global addresses and a data array.
-
-\begin{code}
-
-static void
-unpackResume(globalAddr *lga, int *nelem, W_ *data)
-{
- long buf[3];
-
- GetArgs(buf, 3);
- lga->weight = (unsigned) buf[0];
- lga->loc.gc.gtid = mytid;
- lga->loc.gc.slot = (int) buf[1];
-
- *nelem = (int) buf[2];
- GetArgs(data, *nelem);
-}
-\end{code}
-
-@SendAck@ packs the global address being acknowledged, together with
-an array of global addresses for any closures shipped and sends them.
-\begin{code}
-
-void
-sendAck(task, ngas, gagamap)
-GLOBAL_TASK_ID task;
-int ngas;
-globalAddr *gagamap;
-{
- static long *buffer;
- long *p;
- int i;
- CostCentre Save_CCC = CCC;
-
- buffer = (long *) gumPackBuffer;
-
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
- CCC->scc_count++;
-
- for(i = 0, p = buffer; i < ngas; i++, p += 6) {
- ASSERT(gagamap[1].weight > 0);
- p[0] = (long) gagamap->weight;
- p[1] = (long) gagamap->loc.gc.gtid;
- p[2] = (long) gagamap->loc.gc.slot;
- gagamap++;
- p[3] = (long) gagamap->weight;
- p[4] = (long) gagamap->loc.gc.gtid;
- p[5] = (long) gagamap->loc.gc.slot;
- gagamap++;
- }
-#ifdef ACK_DEBUG
- fprintf(stderr,"Sending Ack (%d pairs) to %x\n", ngas, task);
-#endif
- SendOpN(PP_ACK, task, p - buffer, buffer);
-
- CCC = Save_CCC;
-}
-\end{code}
-
-@unpackAck@ unpacks an Acknowledgement message into a Global address,
-a count of the number of global addresses following and a map of
-Global addresses
-
-\begin{code}
-
-static void
-unpackAck(int *ngas, globalAddr *gagamap)
-{
- long GAarraysize;
- long buf[6];
-
- GetArgs(&GAarraysize, 1);
-
- *ngas = GAarraysize / 6;
-
- while (GAarraysize > 0) {
- GetArgs(buf, 6);
- gagamap->weight = (unsigned) buf[0];
- gagamap->loc.gc.gtid = (GLOBAL_TASK_ID) buf[1];
- gagamap->loc.gc.slot = (int) buf[2];
- gagamap++;
- gagamap->weight = (unsigned) buf[3];
- gagamap->loc.gc.gtid = (GLOBAL_TASK_ID) buf[4];
- gagamap->loc.gc.slot = (int) buf[5];
- ASSERT(gagamap->weight > 0);
- gagamap++;
- GAarraysize -= 6;
- }
-}
-\end{code}
-
-@SendFish@ packs the global address being acknowledged, together with
-an array of global addresses for any closures shipped and sends them.
-\begin{code}
-
-void
-sendFish(destPE, origPE, age, history, hunger)
-GLOBAL_TASK_ID destPE, origPE;
-int age, history, hunger;
-{
- CostCentre Save_CCC = CCC;
-
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
- CCC->scc_count++;
-
-#ifdef FISH_DEBUG
- fprintf(stderr,"Sending Fish to %lx\n", destPE);
-#endif
- SendOpV(PP_FISH, destPE, 4, (W_) origPE, (W_) age, (W_) history, (W_) hunger);
- if (origPE == mytid)
- fishing = rtsTrue;
-
- CCC = Save_CCC;
-}
-\end{code}
-
-@unpackFish@ unpacks a FISH message into the global task id of the
-originating PE and 3 data fields: the age, history and hunger of the
-fish. The history + hunger are not currently used.
-
-\begin{code}
-
-static void
-unpackFish(GLOBAL_TASK_ID *origPE, int *age, int *history, int *hunger)
-{
- long buf[4];
-
- GetArgs(buf, 4);
-
- *origPE = (GLOBAL_TASK_ID) buf[0];
- *age = (int) buf[1];
- *history = (int) buf[2];
- *hunger = (int) buf[3];
-}
-\end{code}
-
-@SendFree@ sends (weight, slot) pairs for GAs that we no longer need references
-to.
-
-\begin{code}
-void
-sendFree(pe, nelem, data)
-GLOBAL_TASK_ID pe;
-int nelem;
-P_ data;
-{
- CostCentre Save_CCC = CCC;
-
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
- CCC->scc_count++;
-
-#ifdef FREE_DEBUG
- fprintf(stderr, "Sending Free (%d GAs) to %x\n", nelem / 2, pe);
-#endif
- SendOpN(PP_FREE, pe, nelem, data);
-
- CCC = Save_CCC;
-}
-
-\end{code}
-
-@unpackFree@ unpacks a FREE message into the amount of data shipped and
-a data block.
-
-\begin{code}
-
-static void
-unpackFree(int *nelem, W_ *data)
-{
- long buf[1];
-
- GetArgs(buf, 1);
- *nelem = (int) buf[0];
- GetArgs(data, *nelem);
-}
-\end{code}
-
-@SendSchedule@ sends a closure to be evaluated in response to a Fish
-message. The message is directed to the PE that originated the Fish
-(origPE), and includes the packed closure (data) along with its size
-(nelem).
-
-\begin{code}
-
-void
-sendSchedule(origPE, nelem, data)
-GLOBAL_TASK_ID origPE;
-int nelem;
-P_ data;
-{
-
- CostCentre Save_CCC = CCC;
-
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
- CCC->scc_count++;
-
-#ifdef SCHEDULE_DEBUG
- PrintPacket(data);
- fprintf(stderr, "Sending Schedule to %x\n", origPE);
-#endif
-
- SendOpN(PP_SCHEDULE, origPE, nelem, data);
-
- CCC = Save_CCC;
-}
-\end{code}
-
-@unpackSchedule@ unpacks a SCHEDULE message into the Global address of
-the closure shipped, the amount of data shipped (nelem) and the data
-block (data).
-
-\begin{code}
-
-static void
-unpackSchedule(int *nelem, W_ *data)
-{
- long buf[1];
-
- GetArgs(buf, 1);
- *nelem = (int) buf[0];
- GetArgs(data, *nelem);
-}
-\end{code}
-
-\section{Message-Processing Functions}
-
-The following routines process incoming GUM messages. Often reissuing
-messages in response.
-
-@processFish@ unpacks a fish message, reissuing it if it's our own,
-sending work if we have it or sending it onwards otherwise.
-
-\begin{code}
-static void
-processFish(STG_NO_ARGS)
-{
- GLOBAL_TASK_ID origPE;
- int age, history, hunger;
-
- unpackFish(&origPE, &age, &history, &hunger);
-
- if (origPE == mytid) {
- fishing = rtsFalse;
- } else {
- P_ spark;
-
- while ((spark = FindLocalSpark(rtsTrue)) != NULL) {
- W_ size;
- P_ graph;
-
- if ((graph = PackNearbyGraph(spark, &size)) == NULL) {
- ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
- SAVE_Hp -= PACK_HEAP_REQUIRED;
- /* Now go back and try again */
- } else {
- sendSchedule(origPE, size, graph);
- DisposeSpark(spark);
- break;
- }
- }
- if (spark == NULL) {
- /* We have no sparks to give */
- if (age < FISH_LIFE_EXPECTANCY)
- sendFish(choosePE(), origPE,
- (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
-
- /* Send it home to die */
- else
- sendFish(origPE, origPE, (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
- }
- }
-} /* processFish */
-\end{code}
-
-@processFetch@ either returns the requested data (if available)
-or blocks the remote blocking queue on a black hole (if not).
-
-\begin{code}
-static void
-processFetch(STG_NO_ARGS)
-{
- globalAddr ga, rga;
- int load;
-
- P_ closure;
- P_ ip;
-
- unpackFetch(&ga, &rga, &load);
-#ifdef FETCH_DEBUG
- fprintf(stderr, "Rcvd Fetch for (%x, %d, 0), Resume (%x, %d, %x) (load %d) \n",
- ga.loc.gc.gtid, ga.loc.gc.slot,
- rga.loc.gc.gtid, rga.loc.gc.slot, rga.weight, load);
-#endif
-
- closure = GALAlookup(&ga);
- ip = (P_) INFO_PTR(closure);
-
- if (INFO_TYPE(ip) == INFO_FETCHME_TYPE) {
- /* Forward the Fetch to someone else */
- sendFetch(FETCHME_GA(closure), &rga, load);
- } else if (rga.loc.gc.gtid == mytid) {
- /* Our own FETCH forwarded back around to us */
- P_ fmbq = GALAlookup(&rga);
-
- /* We may have already discovered that the fetch target is our own. */
- if (fmbq != closure)
- CommonUp(fmbq, closure);
- (void) addWeight(&rga);
- } else if (IS_BLACK_HOLE(ip)) {
- /* This includes RBH's and FMBQ's */
- P_ bf;
-
- if ((bf = AllocateHeap(FIXED_HS + BF_CLOSURE_SIZE(dummy))) == NULL) {
- ReallyPerformThreadGC(FIXED_HS + BF_CLOSURE_SIZE(dummy), rtsFalse);
- closure = GALAlookup(&ga);
- bf = SAVE_Hp - (FIXED_HS + BF_CLOSURE_SIZE(dummy)) + 1;
- }
- ASSERT(GALAlookup(&rga) == NULL);
-
- SET_BF_HDR(bf, BF_info, bogosity);
- BF_NODE(bf) = closure;
- BF_GTID(bf) = (W_) rga.loc.gc.gtid;
- BF_SLOT(bf) = (W_) rga.loc.gc.slot;
- BF_WEIGHT(bf) = (W_) rga.weight;
- blockFetch(bf, closure);
-
-#ifdef FETCH_DEBUG
- fprintf(stderr, "Blocking Fetch (%x, %d, %x) on %#lx\n",
- rga.loc.gc.gtid, rga.loc.gc.slot, rga.weight, closure);
-#endif
-
- } else {
- /* The target of the FetchMe is some local graph */
- W_ size;
- P_ graph;
-
- if ((graph = PackNearbyGraph(closure, &size)) == NULL) {
- ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
- SAVE_Hp -= PACK_HEAP_REQUIRED;
- closure = GALAlookup(&ga);
- graph = PackNearbyGraph(closure, &size);
- ASSERT(graph != NULL);
- }
- sendResume(&rga, size, graph);
- }
-}
-\end{code}
-
-@processFree@ unpacks a FREE message and adds the weights to our GAs.
-
-\begin{code}
-static void
-processFree(STG_NO_ARGS)
-{
- int nelem;
- static W_ *freeBuffer;
- int i;
- globalAddr ga;
-
- freeBuffer = gumPackBuffer;
- unpackFree(&nelem, freeBuffer);
-#ifdef FREE_DEBUG
- fprintf(stderr, "Rcvd Free (%d GAs)\n", nelem / 2);
-#endif
- ga.loc.gc.gtid = mytid;
- for (i = 0; i < nelem;) {
- ga.weight = (unsigned) freeBuffer[i++];
- ga.loc.gc.slot = (int) freeBuffer[i++];
-#ifdef FREE_DEBUG
- fprintf(stderr,"Processing free (%x, %d, %x)\n", ga.loc.gc.gtid,
- ga.loc.gc.slot, ga.weight);
-#endif
- (void) addWeight(&ga);
- }
-}
-\end{code}
-
-@processResume@ unpacks a RESUME message into the graph, filling in
-the LA -> GA, and GA -> LA tables. Threads blocked on the original
-@FetchMe@ (now a blocking queue) are awakened, and the blocking queue
-is converted into an indirection. Finally it sends an ACK in response
-which contains any newly allocated GAs.
-
-\begin{code}
-
-static void
-processResume(GLOBAL_TASK_ID sender)
-{
- int nelem;
- W_ nGAs;
- static W_ *packBuffer;
- P_ newGraph;
- P_ old;
- globalAddr lga;
- globalAddr *gagamap;
-
- packBuffer = gumPackBuffer;
- unpackResume(&lga, &nelem, packBuffer);
-
-#ifdef RESUME_DEBUG
- fprintf(stderr, "Rcvd Resume for (%x, %d, %x)\n",
- lga.loc.gc.gtid, lga.loc.gc.slot, lga.weight);
- PrintPacket(packBuffer);
-#endif
-
- /*
- * We always unpack the incoming graph, even if we've received the
- * requested node in some other data packet (and already awakened
- * the blocking queue).
- */
- if (SAVE_Hp + packBuffer[0] >= SAVE_HpLim) {
- ReallyPerformThreadGC(packBuffer[0], rtsFalse);
- SAVE_Hp -= packBuffer[0];
- }
-
- /* Do this *after* GC; we don't want to release the object early! */
-
- if (lga.weight > 0)
- (void) addWeight(&lga);
-
- old = GALAlookup(&lga);
-
- if (RTSflags.ParFlags.granSimStats) {
- P_ tso = NULL;
-
- if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE) {
- for(tso = (P_) FMBQ_ENTRIES(old);
- TSO_LINK(tso) != PrelBase_Z91Z93_closure;
- tso = TSO_LINK(tso))
- ;
- }
- /* DumpGranEventAndNode(GR_REPLY, tso, old, taskIDtoPE(sender)); */
- DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(sender),GR_REPLY,
- tso,old,0);
- }
-
- newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
- ASSERT(newGraph != NULL);
-
- /*
- * Sometimes, unpacking will common up the resumee with the
- * incoming graph, but if it hasn't, we'd better do so now.
- */
-
- if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE)
- CommonUp(old, newGraph);
-
-#ifdef RESUME_DEBUG
- DebugPrintGAGAMap(gagamap, nGAs);
-#endif
-
- sendAck(sender, nGAs, gagamap);
-}
-\end{code}
-
-@processSchedule@ unpacks a SCHEDULE message into the graph, filling
-in the LA -> GA, and GA -> LA tables. The root of the graph is added to
-the local spark queue. Finally it sends an ACK in response
-which contains any newly allocated GAs.
-
-\begin{code}
-static void
-processSchedule(GLOBAL_TASK_ID sender)
-{
- int nelem;
- int space_required;
- rtsBool success;
- static W_ *packBuffer;
- W_ nGAs;
- P_ newGraph;
- globalAddr *gagamap;
-
- packBuffer = gumPackBuffer; /* HWL */
- unpackSchedule(&nelem, packBuffer);
-
-#ifdef SCHEDULE_DEBUG
- fprintf(stderr, "Rcvd Schedule\n");
- PrintPacket(packBuffer);
-#endif
-
- /*
- * For now, the graph is a closure to be sparked as an advisory
- * spark, but in future it may be a complete spark with
- * required/advisory status, priority etc.
- */
-
- space_required = packBuffer[0];
- if (SAVE_Hp + space_required >= SAVE_HpLim) {
- ReallyPerformThreadGC(space_required, rtsFalse);
- SAVE_Hp -= space_required;
- }
- newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
- ASSERT(newGraph != NULL);
- success = Spark(newGraph, rtsFalse);
- ASSERT(success);
-
-#ifdef SCHEDULE_DEBUG
- DebugPrintGAGAMap(gagamap, nGAs);
-#endif
-
- if (nGAs > 0)
- sendAck(sender, nGAs, gagamap);
-
- fishing = rtsFalse;
-}
-\end{code}
-
-@processAck@ unpacks an ACK, and uses the GAGA map to convert RBH's
-(which represent shared thunks that have been shipped) into fetch-mes
-to remote GAs.
-
-\begin{code}
-static void
-processAck(STG_NO_ARGS)
-{
- int nGAs;
- globalAddr *gaga;
-
- globalAddr gagamap[MAX_GAS * 2];
-
- unpackAck(&nGAs, gagamap);
-
-#ifdef ACK_DEBUG
- fprintf(stderr, "Rcvd Ack (%d pairs)\n", nGAs);
- DebugPrintGAGAMap(gagamap, nGAs);
-#endif
-
- /*
- * For each (oldGA, newGA) pair, set the GA of the corresponding
- * thunk to the newGA, convert the thunk to a FetchMe, and return
- * the weight from the oldGA.
- */
- for (gaga = gagamap; gaga < gagamap + nGAs * 2; gaga += 2) {
- P_ old = GALAlookup(gaga);
- P_ new = GALAlookup(gaga + 1);
-
- if (new == NULL) {
- /* We don't have this closure, so we make a fetchme for it */
- globalAddr *ga = setRemoteGA(old, gaga + 1, rtsTrue);
-
- convertToFetchMe(old, ga);
- } else {
- /*
- * Oops...we've got this one already; update the RBH to
- * point to the object we already know about, whatever it
- * happens to be.
- */
- CommonUp(old, new);
-
- /*
- * Increase the weight of the object by the amount just
- * received in the second part of the ACK pair.
- */
- (void) addWeight(gaga + 1);
- }
- (void) addWeight(gaga);
- }
-}
-\end{code}
-
-\section{GUM Message Processor}
-
-@processMessages@ processes any messages that have arrived, calling
-appropriate routines depending on the message tag
-(opcode). N.B. Unless profiling it assumes that there {\em ARE} messages
-present and performs a blocking receive! During profiling it
-busy-waits in order to record idle time.
-
-\begin{code}
-void
-processMessages(STG_NO_ARGS)
-{
- PACKET packet;
- OPCODE opcode;
- CostCentre Save_CCC;
-
- /* Temporary Test Definitions */
- GLOBAL_TASK_ID task;
-
- Save_CCC = CCC;
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
-
- do {
- if (RTSflags.CcFlags.doCostCentres) {
- CCC = (CostCentre)STATIC_CC_REF(CC_IDLE);
- CCC->scc_count++;
-
- while (!PacketsWaiting())
- /*busy-wait loop*/;
-
- CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
- }
-
- packet = GetPacket(); /* Get next message; block until one available */
- CCC->scc_count++;
-
- get_opcode_and_sender(packet, &opcode, &task);
-
- switch (opcode) {
-
- case PP_FINISH:
- EXIT(EXIT_SUCCESS); /* The computation has been completed by someone
- * else */
- break;
-
- case PP_FETCH:
- processFetch();
- break;
-
- case PP_RESUME:
- processResume(task);
- break;
-
- case PP_ACK:
- processAck();
- break;
-
- case PP_FISH:
- processFish();
- break;
-
- case PP_FREE:
- processFree();
- break;
-
- case PP_SCHEDULE:
- processSchedule(task);
- break;
-
- default:
- /* Anything we're not prepared to deal with. */
- fprintf(stderr, "Task %x: Unexpected opcode %x from %x\n",
- mytid, opcode, task);
-
- EXIT(EXIT_FAILURE);
- } /* switch */
-
- } while (PacketsWaiting()); /* While there are messages: process them */
- CCC = Save_CCC;
-} /* processMessages */
-\end{code}
-
-\section{Exception Handlers}
-
-
-@Comms_Harness_Exception@ is an exception handler that tests out the different
-GUM messages.
-
-\begin{code}
-void
-Comms_Harness_Exception(packet)
-PACKET packet;
-{
- int i, load;
- globalAddr ga,bqga;
-/* GLOBAL_TASK_ID sender = Sender_Task(packet); */
- OPCODE opcode = Opcode(packet);
- GLOBAL_TASK_ID task;
-
-/* fprintf(stderr,"STG_Exception: Received %s (%x), sender %x\n",GetOpName(opcode),opcode,sender); */
-
- switch (opcode) {
-
- case PP_FINISH:
- EXIT(EXIT_SUCCESS);
- break;
-
- case PP_FETCH:
- {
- W_ data[11];
- get_opcode_and_sender(packet,&opcode,&task);
- fprintf(stderr,"Task %x: Got Fetch from %x\n", mytid, task );
- unpackFetch(&ga,&bqga,&load);
- fprintf(stderr,"In PE, Fetch = (%x, %d, %x) (%x, %d, %x) %d \n",
- ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight,
- bqga.loc.gc.gtid, bqga.loc.gc.slot, bqga.weight, load);
- /*Send Resume in Response*/
- for (i=0; i <= 10; ++i) data[i] = i;
- sendResume(&bqga,11,data);
- }
- break;
-
- case PP_ACK:
- {
- int nGAs;
- globalAddr gagamap[MAX_GAS*2];
-
- get_opcode_and_sender(packet,&opcode,&task);
- fprintf(stderr,"Task %x: Got Ack from %x\n", mytid, task );
- unpackAck(&nGAs,gagamap);
-#ifdef DEBUG
- DebugPrintGAGAMap(gagamap,nGAs);
-#endif
- }
- break;
-
- case PP_FISH:
- {
- GLOBAL_TASK_ID origPE;
- int age, history, hunger;
- globalAddr testGA;
- StgWord testData[6];
-
- get_opcode_and_sender(packet,&opcode,&task);
- fprintf(stderr,"Task %x: Got FISH from %x\n", mytid, task );
- unpackFish(&origPE, &age, &history, &hunger);
- fprintf(stderr,"In PE, FISH.origPE = %x age = %d history = %d hunger = %d\n",
- origPE, age, history, hunger);
-
- testGA.loc.gc.gtid = mytid; testGA.loc.gc.slot = 52; testGA.weight = 1024;
- for (i=0; i <= 5; ++i) testData[i] = 40+i;
- sendSchedule(origPE,6,testData);
- }
- break;
-
- case PP_SCHEDULE:
- { /* Test variables */
- int nelem;
- int testData[6];
-
- get_opcode_and_sender(packet,&opcode,&task);
- fprintf(stderr,"Task %x: Got SCHEDULE from %x\n", mytid, task );
- unpackSchedule(&nelem, &testData);
- fprintf(stderr,"In PE, nelem = %d \n", nelem);
- for (i=0; i <= 5; ++i) fprintf(stderr,"tData[%d] = %d ",i,testData[i]);
- fprintf(stderr,"\n");
- }
- break;
-
- /* Anything we're not prepared to deal with. Note that ALL
- * opcodes are discarded during termination -- this helps
- * prevent bizarre race conditions.
- */
- default:
- if (!GlobalStopPending)
- {
- GLOBAL_TASK_ID ErrorTask;
- int opcode;
-
- get_opcode_and_sender(packet,&opcode,&ErrorTask);
- fprintf(stderr,"Task %x: Unexpected opcode %x from %x in Comms Harness\n",
- mytid, opcode, ErrorTask );
-
- PEShutDown();
-
- EXIT(EXIT_FAILURE);
- }
- }
-}
-\end{code}
-
-@STG_Exception@ handles real communication exceptions
-
-\begin{code}
-void
-STG_Exception(packet)
-PACKET packet;
-{
- GLOBAL_TASK_ID sender = Sender_Task(packet);
- OPCODE opcode = Opcode(packet);
-#if 0
- fprintf(stderr,"STG_Exception: Received %s (%x), sender %x\n",GetOpName(opcode),opcode,sender);
-#endif
- switch (opcode) {
-
- case PP_FINISH:
- EXIT(EXIT_SUCCESS);
- break;
-
- /* Anything we're not prepared to deal with. Note that ALL opcodes are discarded
- during termination -- this helps prevent bizarre race conditions.
- */
- default:
- if (!GlobalStopPending)
- {
- GLOBAL_TASK_ID ErrorTask;
- int opcode;
-
- get_opcode_and_sender(packet,&opcode,&ErrorTask);
- fprintf(stderr,"Task %x: Unexpected opcode %x from %x in STG_Exception\n",
- mytid, opcode, ErrorTask );
-
- EXIT(EXIT_FAILURE);
- }
- }
-}
-\end{code}
-
-\section{Miscellaneous Functions}
-
-@ChoosePE@ selects a GlobalTaskId from the array of PEs 'at random'.
-Important properties:
-o it varies during execution, even if the PE is idle
-o it's different for each PE
-o we never send a fish to ourselves
-
-\begin{code}
-extern long lrand48 (STG_NO_ARGS);
-
-GLOBAL_TASK_ID
-choosePE(STG_NO_ARGS)
-{
- long temp;
-
- temp = lrand48() % nPEs;
- if (PEs[temp] == mytid) { /* Never send a FISH to yourself */
- temp = (temp + 1) % nPEs;
- }
- return PEs[temp];
-}
-\end{code}
-
-@WaitForTermination@ enters an infinite loop waiting for the
-termination sequence to be completed.
-
-\begin{code}
-void
-WaitForTermination(STG_NO_ARGS)
-{
- do {
- PACKET p = GetPacket();
- HandleException(p);
- } while (rtsTrue);
-}
-\end{code}
-
-\begin{code}
-#ifdef DEBUG
-void
-DebugPrintGAGAMap(gagamap, nGAs)
-globalAddr *gagamap;
-int nGAs;
-{
- int i;
-
- for (i = 0; i < nGAs; ++i, gagamap += 2)
- fprintf(stderr, "gagamap[%d] = (%x, %d, %x) -> (%x, %d, %x)\n", i,
- gagamap[0].loc.gc.gtid, gagamap[0].loc.gc.slot, gagamap[0].weight,
- gagamap[1].loc.gc.gtid, gagamap[1].loc.gc.slot, gagamap[1].weight);
-}
-#endif
-\end{code}
-
-\begin{code}
-
-static PP_ freeMsgBuffer = NULL;
-static int *freeMsgIndex = NULL;
-
-void
-prepareFreeMsgBuffers(STG_NO_ARGS)
-{
- int i;
-
- /* Allocate the freeMsg buffers just once and then hang onto them. */
-
- if (freeMsgIndex == NULL) {
-
- freeMsgIndex = (int *) stgMallocBytes(nPEs * sizeof(int), "prepareFreeMsgBuffers (Index)");
- freeMsgBuffer = (PP_) stgMallocBytes(nPEs * sizeof(long *), "prepareFreeMsgBuffers (Buffer)");
-
- for(i = 0; i < nPEs; i++) {
- if (i != thisPE) {
- freeMsgBuffer[i] = (P_) stgMallocWords(RTSflags.ParFlags.packBufferSize,
- "prepareFreeMsgBuffers (Buffer #i)");
- }
- }
- }
-
- /* Initialize the freeMsg buffer pointers to point to the start of their buffers */
- for (i = 0; i < nPEs; i++)
- freeMsgIndex[i] = 0;
-}
-
-void
-freeRemoteGA(pe, ga)
-int pe;
-globalAddr *ga;
-{
- int i;
-
- ASSERT(GALAlookup(ga) == NULL);
-
- if ((i = freeMsgIndex[pe]) + 2 >= RTSflags.ParFlags.packBufferSize) {
-#ifdef FREE_DEBUG
- fprintf(stderr, "Filled a free message buffer\n");
-#endif
- sendFree(ga->loc.gc.gtid, i, freeMsgBuffer[pe]);
- i = 0;
- }
- freeMsgBuffer[pe][i++] = (W_) ga->weight;
- freeMsgBuffer[pe][i++] = (W_) ga->loc.gc.slot;
- freeMsgIndex[pe] = i;
-#ifdef DEBUG
- ga->weight = 0x0f0f0f0f;
- ga->loc.gc.gtid = 0x666;
- ga->loc.gc.slot = 0xdeaddead;
-#endif
-}
-
-void
-sendFreeMessages(STG_NO_ARGS)
-{
- int i;
-
- for (i = 0; i < nPEs; i++) {
- if (freeMsgIndex[i] > 0)
- sendFree(PEs[i], freeMsgIndex[i], freeMsgBuffer[i]);
- }
-}
-
-#endif /* PAR -- whole file */
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section[Hash.lc]{Dynamic Hash Tables}
-%* *
-%************************************************************************
-
-Dynamically expanding linear hash tables, as described in
-Per-\AAke Larson, ``Dynamic Hash Tables,'' CACM 31(4), April 1988,
-pp. 446 -- 457.
-
-\begin{code}
-#ifdef PAR /* whole file */
-
-#include "rtsdefs.h"
-
-#define HSEGSIZE 1024 /* Size of a single hash table segment */
- /* Also the minimum size of a hash table */
-#define HDIRSIZE 1024 /* Size of the segment directory */
- /* Maximum hash table size is HSEGSIZE * HDIRSIZE */
-#define HLOAD 5 /* Maximum average load of a single hash bucket */
-
-#define HCHUNK (1024 * sizeof(W_) / sizeof(HashList))
- /* Number of HashList cells to allocate in one go */
-
-\end{code}
-
-Fill in the ADTs.
-
-\begin{code}
-
-/* Linked list of (key, data) pairs for separate chaining */
-struct hashlist {
- StgWord key;
- void *data;
- struct hashlist *next; /* Next cell in bucket chain (same hash value) */
-};
-
-struct hashtable {
- int split; /* Next bucket to split when expanding */
- int max; /* Max bucket of smaller table */
- int mask1; /* Mask for doing the mod of h_1 (smaller table) */
- int mask2; /* Mask for doing the mod of h_2 (larger table) */
- int kcount; /* Number of keys */
- int bcount; /* Number of buckets */
- HashList **dir[HDIRSIZE]; /* Directory of segments */
-};
-
-\end{code}
-
-Hash first using the smaller table. If the bucket is less than the
-next bucket to be split, re-hash using the larger table.
-
-\begin{code}
-
-static int
-hash(HashTable *table, W_ key)
-{
- int bucket;
-
- /* Strip the boring zero bits */
- key /= sizeof(StgWord);
-
- /* Mod the size of the hash table (a power of 2) */
- bucket = key & table->mask1;
-
- if (bucket < table->split) {
- /* Mod the size of the expanded hash table (also a power of 2) */
- bucket = key & table->mask2;
- }
- return bucket;
-}
-
-\end{code}
-
-Allocate a new segment of the dynamically growing hash table.
-
-\begin{code}
-
-static void
-allocSegment(HashTable *table, int segment)
-{
- table->dir[segment] = (HashList **) stgMallocBytes(HSEGSIZE * sizeof(HashList *), "allocSegment");
-}
-
-\end{code}
-
-Expand the larger hash table by one bucket, and split one bucket
-from the smaller table into two parts. Only the bucket referenced
-by @table->split@ is affected by the expansion.
-
-\begin{code}
-
-static void
-expand(HashTable *table)
-{
- int oldsegment;
- int oldindex;
- int newbucket;
- int newsegment;
- int newindex;
- HashList *hl;
- HashList *next;
- HashList *old, *new;
-
- if (table->split + table->max >= HDIRSIZE * HSEGSIZE)
- /* Wow! That's big. Too big, so don't expand. */
- return;
-
- /* Calculate indices of bucket to split */
- oldsegment = table->split / HSEGSIZE;
- oldindex = table->split % HSEGSIZE;
-
- newbucket = table->max + table->split;
-
- /* And the indices of the new bucket */
- newsegment = newbucket / HSEGSIZE;
- newindex = newbucket % HSEGSIZE;
-
- if (newindex == 0)
- allocSegment(table, newsegment);
-
- if (++table->split == table->max) {
- table->split = 0;
- table->max *= 2;
- table->mask1 = table->mask2;
- table->mask2 = table->mask2 << 1 | 1;
- }
- table->bcount++;
-
- /* Split the bucket, paying no attention to the original order */
-
- old = new = NULL;
- for (hl = table->dir[oldsegment][oldindex]; hl != NULL; hl = next) {
- next = hl->next;
- if (hash(table, hl->key) == newbucket) {
- hl->next = new;
- new = hl;
- } else {
- hl->next = old;
- old = hl;
- }
- }
- table->dir[oldsegment][oldindex] = old;
- table->dir[newsegment][newindex] = new;
-
- return;
-}
-
-\end{code}
-
-\begin{code}
-
-void *
-lookupHashTable(table, key)
-HashTable *table;
-StgWord key;
-{
- int bucket;
- int segment;
- int index;
- HashList *hl;
-
- bucket = hash(table, key);
- segment = bucket / HSEGSIZE;
- index = bucket % HSEGSIZE;
-
- for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next)
- if (hl->key == key)
- return hl->data;
-
- /* It's not there */
- return NULL;
-}
-
-\end{code}
-
-We allocate the hashlist cells in large chunks to cut down on malloc
-overhead. Although we keep a free list of hashlist cells, we make
-no effort to actually return the space to the malloc arena.
-
-\begin{code}
-
-static HashList *freeList = NULL;
-
-static HashList *
-allocHashList(STG_NO_ARGS)
-{
- HashList *hl, *p;
-
- if ((hl = freeList) != NULL) {
- freeList = hl->next;
- } else {
- hl = (HashList *) stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList");
-
- freeList = hl + 1;
- for (p = freeList; p < hl + HCHUNK - 1; p++)
- p->next = p + 1;
- p->next = NULL;
- }
- return hl;
-}
-
-static void
-freeHashList(HashList *hl)
-{
- hl->next = freeList;
- freeList = hl;
-}
-
-\end{code}
-
-\begin{code}
-
-void
-insertHashTable(table, key, data)
-HashTable *table;
-StgWord key;
-void *data;
-{
- int bucket;
- int segment;
- int index;
- HashList *hl;
-
-#if 0
- /* We want no duplicates */
- ASSERT(lookupHashTable(table, key) == NULL);
-#endif
-
- /* When the average load gets too high, we expand the table */
- if (++table->kcount >= HLOAD * table->bcount)
- expand(table);
-
- bucket = hash(table, key);
- segment = bucket / HSEGSIZE;
- index = bucket % HSEGSIZE;
-
- hl = allocHashList();
-
- hl->key = key;
- hl->data = data;
- hl->next = table->dir[segment][index];
- table->dir[segment][index] = hl;
-
-}
-
-\end{code}
-
-\begin{code}
-
-void *
-removeHashTable(table, key, data)
-HashTable *table;
-StgWord key;
-void *data;
-{
- int bucket;
- int segment;
- int index;
- HashList *hl;
- HashList *prev = NULL;
-
- bucket = hash(table, key);
- segment = bucket / HSEGSIZE;
- index = bucket % HSEGSIZE;
-
- for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next) {
- if (hl->key == key && (data == NULL || hl->data == data)) {
- if (prev == NULL)
- table->dir[segment][index] = hl->next;
- else
- prev->next = hl->next;
- table->kcount--;
- return hl->data;
- }
- prev = hl;
- }
-
- /* It's not there */
- ASSERT(data == NULL);
- return NULL;
-}
-
-\end{code}
-
-When we free a hash table, we are also good enough to free the
-data part of each (key, data) pair, as long as our caller can tell
-us how to do it.
-
-\begin{code}
-
-void
-freeHashTable(table, freeDataFun)
- HashTable *table;
- void (*freeDataFun) PROTO((void *));
-{
- long segment;
- long index;
- HashList *hl;
- HashList *next;
-
- /* The last bucket with something in it is table->max + table->split - 1 */
- segment = (table->max + table->split - 1) / HSEGSIZE;
- index = (table->max + table->split - 1) % HSEGSIZE;
-
- while (segment >= 0) {
- while (index >= 0) {
- for (hl = table->dir[segment][index]; hl != NULL; hl = next) {
- next = hl->next;
- if (freeDataFun != NULL)
- (*freeDataFun)(hl->data);
- freeHashList(hl);
- }
- index--;
- }
- free(table->dir[segment]);
- segment--;
- index = HSEGSIZE - 1;
- }
- free(table);
-}
-\end{code}
-
-When we initialize a hash table, we set up the first segment as well,
-initializing all of the first segment's hash buckets to NULL.
-
-\begin{code}
-
-HashTable *
-allocHashTable(STG_NO_ARGS)
-{
- HashTable *table;
- HashList **hb;
-
- table = (HashTable *) stgMallocBytes(sizeof(HashTable),"allocHashTable");
-
- allocSegment(table, 0);
-
- for (hb = table->dir[0]; hb < table->dir[0] + HSEGSIZE; hb++)
- *hb = NULL;
-
- table->split = 0;
- table->max = HSEGSIZE;
- table->mask1 = HSEGSIZE - 1;
- table->mask2 = 2 * HSEGSIZE - 1;
- table->kcount = 0;
- table->bcount = HSEGSIZE;
-
- return table;
-}
-
-#endif /* PAR -- whole file */
-\end{code}
+++ /dev/null
-%****************************************************************************
-%
-\section[LLComms.lc]{GUM Low-Level Inter-Task Communication}
-%
-% This module defines PVM Routines for PE-PE communication.
-%
-% (c) The Parade/AQUA Projects, Glasgow University, 1994-1995
-% P. Trinder, December 5th. 1994.
-%
-%****************************************************************************
-
-
-\begin{code}
-#ifdef PAR /* whole file */
-\end{code}
-
-This module defines the routines which communicate between PEs. The
-code is based on Kevin Hammond's GRIP RTS. (@Opcodes.h@ defines
-@PEOp1@ etc. in terms of @SendOp1@ etc.).
-
-\begin{onlylatex}
-\begin{center}
-\end{onlylatex}
-\begin{tabular}{|l|l|} \hline
-Routine & Arguments \\ \hline
- & \\
-@SendOp@ & 0 \\
-@SendOp1@ & 1 \\
-@SendOp2@ & 2 \\
-@SendOpN@ & vector \\
-@SendOpV@ & variable \\
-@SendOpNV@ & variable+ vector \\
-\end{tabular}
-\begin{onlylatex}
-\end{center}
-\end{onlylatex}
-
-First the standard include files.
-
-\begin{code}
-#define NON_POSIX_SOURCE /* so says Solaris */
-
-#include "rtsdefs.h"
-
-#include "LLC.h"
-#ifdef __STDC__
-#include <stdarg.h>
-#else
-#include <varargs.h>
-#endif
-\end{code}
-
-Then some miscellaneous functions.
-@GetOpName@ returns the character-string name of any opcode.
-
-\begin{code}
-char *UserPEOpNames[] = { PEOP_NAMES };
-
-char *
-GetOpName(op)
-unsigned op;
-{
- if (op >= MIN_PEOPS && op <= MAX_PEOPS)
- return (UserPEOpNames[op - MIN_PEOPS]);
-
- else
- return ("Unknown PE Opcode");
-}
-
-void
-NullException(STG_NO_ARGS)
-{
- fprintf(stderr,"Null_Exception: called");
-}
-
-void (*ExceptionHandler)() = NullException;
-\end{code}
-
-@trace_SendOp@ handles the tracing of messages at the OS level. If
-tracing is on (as specified by @PETrace@, @SystemTrace@ and
-@ReplyTrace@), then a message is printed. The opcode and address word
-of the previous PE opcode is recorded in the variables @lastSendOp@ and
-@lastPEaddress@. @PElastop@ is a Boolean which records whether the
-last message sent was for a PE or an IMU.
-
-\begin{code}
-rtsBool PETrace = rtsFalse, IMUTrace = rtsFalse, SystemTrace = rtsFalse, ReplyTrace = rtsFalse;
-
-static void
-trace_SendOp(OPCODE op, GLOBAL_TASK_ID dest, unsigned int data1, unsigned int data2)
-{
- char *OpName;
-
- if (!ReplyTrace && op == REPLY_OK)
- return;
-
- OpName = GetOpName(op);
-/* fprintf(stderr, " %s [%x,%x] sent from %x to %x\n", OpName, data1, data2, mytid, dest);*/
-}
-
-\end{code}
-
-@SendOp@ sends a 0-argument message with opcode {\em op} to
-the global task {\em task}.
-
-\begin{code}
-void
-SendOp(op, task)
-OPCODE op;
-GLOBAL_TASK_ID task;
-{
- trace_SendOp(op, task,0,0);
-
- pvm_initsend(PvmDataRaw);
- pvm_send( task, op );
-}
-\end{code}
-
-@SendOp1@ sends a 1-argument message with opcode {\em op}
-to the global task {\em task}.
-
-\begin{code}
-void
-SendOp1(op, task, arg1)
-OPCODE op;
-GLOBAL_TASK_ID task;
-StgWord arg1;
-{
- trace_SendOp(op, task, arg1,0);
-
- pvm_initsend(PvmDataRaw);
- PutArg1(arg1);
- pvm_send( task, op );
-}
-
-\end{code}
-
-@SendOp2@ is used by the FP code only.
-
-\begin{code}
-void
-SendOp2(op, task, arg1, arg2)
-OPCODE op;
-GLOBAL_TASK_ID task;
-StgWord arg1;
-StgWord arg2;
-{
- trace_SendOp(op, task, arg1, arg2);
-
- pvm_initsend(PvmDataRaw);
- PutArg1(arg1);
- PutArg2(arg2);
- pvm_send( task, op );
-}
-\end{code}
-
-@SendOpV@ takes a variable number of arguments, as specified by {\em n}.
-For example,
-\begin{verbatim}
- SendOpV( PP_STATS, StatsTask, 3, start_time, stop_time, sparkcount);
-\end{verbatim}
-
-\begin{code}
-void
-SendOpV(OPCODE op, GLOBAL_TASK_ID task, int n, ...)
-{
- va_list ap;
- int i;
- StgWord arg;
-
- va_start(ap, n);
-
- trace_SendOp(op, task, 0, 0);
-
- pvm_initsend(PvmDataRaw);
-
- for (i = 0; i < n; ++i) {
- arg = va_arg(ap, StgWord);
- PutArgN(i, arg);
- }
- va_end(ap);
-
- pvm_send(task, op);
-}
-\end{code}
-
-@SendOpNV@ takes a variable-size datablock, as specified by {\em
-nelem} and a variable number of arguments, as specified by {\em
-narg}. N.B. The datablock and the additional arguments are contiguous
-and are copied over together. For example,
-
-\begin{verbatim}
- SendOpNV(PP_RESUME, tsoga.pe, 6, nelem, data,
- (W_) ga.weight, (W_) ga.loc.gc.gtid, (W_) ga.loc.gc.slot,
- (W_) tsoga.weight, (W_) tsoga.loc.gc.gtid, (W_) tsoga.loc.gc.slot);
-\end{verbatim}
-
-Important: The variable arguments must all be StgWords.
-
-\begin{code}
-
-void
-SendOpNV(OPCODE op, GLOBAL_TASK_ID task, int nelem, StgWord *datablock, int narg, ...)
-{
- va_list ap;
- int i;
- StgWord arg;
-
- va_start(ap, narg);
-
- trace_SendOp(op, task, 0, 0);
-/* fprintf(stderr,"SendOpNV: op = %x, task = %x, narg = %d, nelem = %d\n",op,task,narg,nelem); */
-
- pvm_initsend(PvmDataRaw);
-
- for (i = 0; i < narg; ++i) {
- arg = va_arg(ap, StgWord);
-/* fprintf(stderr,"SendOpNV: arg = %d\n",arg); */
- PutArgN(i, arg);
- }
- arg = (StgWord) nelem;
- PutArgN(narg, arg);
-
-/* for (i=0; i < nelem; ++i) fprintf(stderr, "%d ",datablock[i]); */
-/* fprintf(stderr," in SendOpNV\n");*/
-
- PutArgs(datablock, nelem);
- va_end(ap);
-
- pvm_send(task, op);
-}
-\end{code}
-
-
-@SendOpN@ take a variable size array argument, whose size is given by
-{\em n}. For example,
-
-\begin{verbatim}
- SendOpN( PP_STATS, StatsTask, 3, stats_array);
-\end{verbatim}
-
-\begin{code}
-
-void
-SendOpN(op, task, n, args)
-OPCODE op;
-GLOBAL_TASK_ID task;
-int n;
-StgWord *args;
-
-{
- long arg;
-
- trace_SendOp(op, task, 0, 0);
-
- pvm_initsend(PvmDataRaw);
- arg = (long) n;
- PutArgN(0, arg);
- PutArgs(args, n);
- pvm_send(task, op);
-}
-\end{code}
-
-@WaitForPEOp@ waits for a packet from global task {\em who} with the
-opcode {\em op}. Other opcodes are handled by the standard exception handler.
-
-\begin{code}
-PACKET WaitForPEOp(op, who)
-OPCODE op;
-GLOBAL_TASK_ID who;
-{
- PACKET p;
- int nbytes;
- OPCODE opcode;
- GLOBAL_TASK_ID sender_id;
- rtsBool match;
-
- do {
-#if 0
- fprintf(stderr,"WaitForPEOp: op = %x, who = %x\n",op,who);
-#endif
- while((p = pvm_recv(ANY_TASK,ANY_OPCODE)) < 0)
- pvm_perror("WaitForPEOp: Waiting for PEOp");
-
- pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
-#if 0
- fprintf(stderr,"WaitForPEOp: received: opcode = %x, sender_id = %x\n",opcode,sender_id);
-#endif
- match = (op == ANY_OPCODE || op == opcode) && (who == ANY_TASK || who == sender_id);
-
- if(match)
- return(p);
-
- /* Handle the unexpected opcodes */
- HandleException(p);
-
- } while(rtsTrue);
-}
-\end{code}
-
-\begin{code}
-
-OPCODE
-Opcode(p)
-PACKET p;
-{
- int nbytes;
- OPCODE opcode;
- GLOBAL_TASK_ID sender_id;
- pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
- return(opcode);
-}
-
-GLOBAL_TASK_ID
-Sender_Task(p)
-PACKET p;
-{
- int nbytes;
- OPCODE opcode;
- GLOBAL_TASK_ID sender_id;
- pvm_bufinfo( p, &nbytes, &opcode, &sender_id );
- return(sender_id);
-}
-
-void
-get_opcode_and_sender(p,popcode,psender_id)
-PACKET p;
-OPCODE *popcode;
-GLOBAL_TASK_ID *psender_id;
-{
- int nbytes;
- pvm_bufinfo( p, &nbytes, popcode, psender_id );
-}
-
-\end{code}
-
-@PEStartUp@ does the low-level comms specific startup stuff for a
-PE. It initialises the comms system, joins the appropriate groups,
-synchronises with the other PEs. Receives and records in a global
-variable the task-id of SysMan. If this is the main thread (discovered
-in main.lc), identifies itself to SysMan. Finally it receives
-from SysMan an array of the Global Task Ids of each PE, which is
-returned as the value of the function.
-
-\begin{code}
-GLOBAL_TASK_ID *
-PEStartUp(nPEs)
-unsigned nPEs;
-{
- int i;
- PACKET addr;
- long *buffer = (long *) stgMallocBytes(sizeof(long) * nPEs, "PEStartUp (buffer)");
- GLOBAL_TASK_ID *PEs
- = (GLOBAL_TASK_ID *) stgMallocBytes(sizeof(GLOBAL_TASK_ID) * nPEs, "PEStartUp (PEs)");
-
- mytid = _my_gtid; /* Initialise PVM and get task id into global var.*/
-
-/* fprintf(stderr,"PEStartup, Task id = [%x], No. PEs = %d \n", mytid, nPEs); */
- checkComms(pvm_joingroup(PEGROUP), "PEStartup");
-/* fprintf(stderr,"PEStartup, Joined PEGROUP\n"); */
- checkComms(pvm_joingroup(PECTLGROUP), "PEStartup");
-/* fprintf(stderr,"PEStartup, Joined PECTLGROUP\n"); */
- checkComms(pvm_barrier(PECTLGROUP, nPEs+1), "PEStartup");
-/* fprintf(stderr,"PEStartup, Passed PECTLGROUP barrier\n"); */
-
- addr = WaitForPEOp(PP_SYSMAN_TID, ANY_GLOBAL_TASK);
- SysManTask = Sender_Task(addr);
- if (IAmMainThread) { /* Main Thread Identifies itself to SysMan */
- pvm_initsend(PvmDataDefault);
- pvm_send(SysManTask, PP_MAIN_TASK);
- }
- addr = WaitForPEOp(PP_PETIDS, ANY_GLOBAL_TASK);
- GetArgs(buffer, nPEs);
- for (i = 0; i < nPEs; ++i) {
- PEs[i] = (GLOBAL_TASK_ID) buffer[i];
-#if 0
- fprintf(stderr,"PEs[%d] = %x \n", i, PEs[i]);
-#endif
- }
- free(buffer);
- return PEs;
-}
-\end{code}
-
-@PEShutdown@ does the low-level comms-specific shutdown stuff for a
-single PE. It leaves the groups and then exits from pvm.
-
-\begin{code}
-void
-PEShutDown(STG_NO_ARGS)
-{
- checkComms(pvm_lvgroup(PEGROUP),"PEShutDown");
- checkComms(pvm_lvgroup(PECTLGROUP),"PEShutDown");
- checkComms(pvm_exit(),"PEShutDown");
-}
-\end{code}
-
-@heapChkCounter@ tracks the number of heap checks since the last probe.
-Not currently used! We check for messages when a thread is resheduled.
-
-\begin{code}
-int heapChkCounter = 0;
-\end{code}
-
-\begin{code}
-#endif /* PAR -- whole file */
-\end{code}
+++ /dev/null
-%
-% (c) The Parade/AQUA Projects, Glasgow University, 1995
-% Kevin Hammond, February 15th. 1995
-%
-% This is for GUM and for GrAnSim.
-%
-%************************************************************************
-%* *
-\section[Pack.lc]{Packing closures for export to remote processors}
-%* *
-%************************************************************************
-
-This module defines routines for packing closures in the parallel runtime
-system (GUM).
-
-The GrAnSim version of the code defines routines for *simulating* the
-packing of closures in the same way it
-is done in the parallel runtime system. Basically GrAnSim only puts the
-addresses of the closures to be transferred into a buffer. This buffer will
-then be associated with the event of transferring the graph. When this
-event is scheduled, the @UnpackGraph@ routine is called and the buffer
-can be discarded afterwards.
-
-Note that in GrAnSim we need many buffers, not just one per PE.
-
-\begin{code}
-#if defined(PAR) || defined(GRAN) /* whole file */
-
-#include "rtsdefs.h"
-
-/* Which RTS flag should be used to get the size of the pack buffer ? */
-#if defined(PAR)
-#define PACK_BUFFER_SIZE RTSflags.ParFlags.packBufferSize
-#else /* GRAN */
-#define PACK_BUFFER_SIZE RTSflags.GranFlags.packBufferSize
-#endif
-\end{code}
-
-Static data and code declarations.
-
-\begin{code}
-#if defined(GRAN)
-/* To be pedantic: in GrAnSim we're packing *addresses* of closures,
- not the closures themselves.
-*/
-static P_ *PackBuffer = NULL; /* size: can be set via option */
-#else
-static W_ *PackBuffer = NULL; /* size: can be set via option */
-#endif
-
-static W_ packlocn, clqsize, clqpos;
-static W_ unpackedsize;
-static W_ reservedPAsize; /*Space reserved for primitive arrays*/
-static rtsBool RoomInBuffer;
-
-
-static void InitPacking(STG_NO_ARGS), DonePacking(STG_NO_ARGS);
-#if defined(GRAN)
-static rtsBool NotYetPacking PROTO((P_ closure));
-static void Pack PROTO((P_ data));
-#else
-static rtsBool NotYetPacking PROTO((int offset));
-static void Pack PROTO((W_ data));
-#endif
-static rtsBool RoomToPack PROTO((W_ size, W_ ptrs));
-static void AmPacking PROTO((P_ closure));
-
-static void PackClosure PROTO((P_ closure))
-#if !defined(GRAN)
- , PackPLC PROTO((P_ addr))
- , PackOffset PROTO((int offset))
- , GlobaliseAndPackGA PROTO((P_ closure))
-#endif
- ;
-
-static int OffsetFor PROTO((P_ closure));
-\end{code}
-
-Bit of a hack for testing if a closure is the root of the graph. This is
-set in @PackNearbyGraph@ and tested in @PackClosure@.
-
-\begin{code}
-#if defined(GRAN)
-I_ packed_thunks = 0;
-P_ graphroot;
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PackNearbyGraph]{Packing Sections of Nearby Graph}
-%* *
-%************************************************************************
-
-@PackNearbyGraph@ packs a closure and associated graph into a static
-buffer (@PackBuffer@). It returns the address of this buffer and the
-size of the data packed into the buffer (in its second parameter,
-@packbuffersize@). The associated graph is packed in a depth first
-manner, hence it uses an explicit queue of closures to be packed
-rather than simply using a recursive algorithm. Once the packet is
-full, closures (other than primitive arrays) are packed as FetchMes,
-and their children are not queued for packing.
-
-\begin{code}
-# if defined(PAR)
-P_
-PackNearbyGraph(closure, packbuffersize)
-P_ closure;
-W_ *packbuffersize;
-# else /* GRAN */
-P_
-PackNearbyGraph(closure, tso, packbuffersize)
-P_ closure;
-P_ tso;
-W_ *packbuffersize;
-# endif
-{
- /* Ensure enough heap for all possible RBH_Save closures */
-
- ASSERT(PACK_BUFFER_SIZE > 0);
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 )
- fprintf(stderr,"Packing graph with root at 0x%lx (PE %d); demanded by TSO %#lx (%d) (PE %d) ...\n",
- closure, where_is(closure), tso, TSO_ID(tso), where_is(tso) );
-# endif /* GRAN */
-
- if (SAVE_Hp + PACK_HEAP_REQUIRED > SAVE_HpLim)
- return NULL;
-
- InitPacking();
-# if defined(GRAN)
- graphroot = closure;
-# endif
-
- QueueClosure(closure);
- do {
- PackClosure(DeQueueClosure());
- } while (!QueueEmpty());
-
-# if defined(PAR)
- /* Record how much space is needed to unpack the graph */
- PackBuffer[0] = unpackedsize;
-# else /* GRAN */
- /* Record how much space is needed to unpack the graph */
- PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
- PackBuffer[PACK_TSO_LOCN] = tso;
- PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
-# endif
-
- /* Set the size parameter */
-# if defined(PAR)
- ASSERT(packlocn <= RTSflags.ParFlags.packBufferSize);
- *packbuffersize = packlocn;
-# else /* GRAN */
- ASSERT(packlocn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
- /* ToDo: Print an earlier, more meaningful message */
- if (packlocn==PACK_HDR_SIZE) { /* i.e. packet is empty */
- fprintf(stderr,"EMPTY PACKET! Can't transfer closure %#lx at all!!\n",
- closure);
- EXIT(EXIT_FAILURE);
- }
- PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
- *packbuffersize = packlocn;
-# endif
-
-# if !defined(GRAN)
- DonePacking(); /* {GrAnSim}vaD 'ut'Ha' */
-# endif
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- tot_packets++;
- tot_packet_size += packlocn-PACK_HDR_SIZE ;
-
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- PrintPacket((P_)PackBuffer);
- }
-# endif /* GRAN */
-
- return ((P_)PackBuffer);
-}
-
-#if defined(GRAN)
-/* This version is used when the node is already local */
-
-P_
-PackOneNode(closure, tso, packbuffersize)
-P_ closure;
-P_ tso;
-W_ *packbuffersize;
-{
- int i, clpacklocn;
-
- InitPacking();
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- W_ size, ptrs, nonptrs, vhs;
- P_ info;
- char str[80], junk_str[80];
-
- info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
- fprintf(stderr,"PackOneNode: %#lx (%s)(PE %#lx) requested by TSO %#lx (%d) (PE %#lx)\n",
- closure, str, where_is(closure), tso, TSO_ID(tso), where_is(tso));
- }
-# endif
-
- Pack(closure);
-
- /* Record how much space is needed to unpack the graph */
- PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
- PackBuffer[PACK_TSO_LOCN] = tso;
- PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
-
- /* Set the size parameter */
- ASSERT(packlocn <= PACK_BUFFER_SIZE);
- PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
- *packbuffersize = packlocn;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- tot_packets++;
- tot_packet_size += packlocn-PACK_HDR_SIZE ;
-
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- PrintPacket(PackBuffer);
- }
-# endif /* GRAN */
-
- return ((P_)PackBuffer);
-}
-#endif /* GRAN */
-\end{code}
-
-@PackTSO@ and @PackStkO@ are entry points for two special kinds of
-closure which are used in the parallel RTS. Compared with other
-closures they are rather awkward to pack because they don't follow the
-normal closure layout (where all pointers occur before all non-pointers).
-Luckily, they're only needed when migrating threads between processors.
-
-\begin{code}
-#if defined(GRAN)
-P_ *
-#else
-W_ *
-#endif
-PackTSO(tso,packbuffersize)
-P_ tso;
-W_ *packbuffersize;
-{
- *packbuffersize = 0;
- PackBuffer[0] = PackBuffer[1] = 0;
- return(PackBuffer);
-}
-
-#if defined(GRAN)
-P_ *
-#else
-W_ *
-#endif
-PackStkO(stko,packbuffersize)
-P_ stko;
-W_ *packbuffersize;
-{
- *packbuffersize = 0;
- PackBuffer[0] = PackBuffer[1] = 0;
- return(PackBuffer);
-}
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[PackClosure]{Packing Closures}
-%* *
-%************************************************************************
-
-@PackClosure@ is the heart of the normal packing code. It packs a
-single closure into the pack buffer, skipping over any indirections
-and globalising it as necessary, queues any child pointers for further
-packing, and turns it into a @FetchMe@ or revertible black hole
-(@RBH@) locally if it was a thunk. Before the actual closure is
-packed, a suitable global address (GA) is inserted in the pack buffer.
-There is always room to pack a fetch-me to the closure (guaranteed by
-the RoomToPack calculation), and this is packed if there is no room
-for the entire closure.
-
-Space is allocated for any primitive array children of a closure, and
-hence a primitive array can always be packed along with it's parent
-closure.
-
-\begin{code}
-#if defined(PAR)
-
-void
-PackClosure(closure)
-P_ closure;
-{
- W_ size, ptrs, nonptrs, vhs;
- int i, clpacklocn;
- char str[80];
-
- while (IS_INDIRECTION(INFO_PTR(closure))) {
- /* Don't pack indirection closures */
-# ifdef PACK_DEBUG
- fprintf(stderr, "Shorted an indirection at %x", closure);
-# endif
- closure = (P_) IND_CLOSURE_PTR(closure);
- }
-
- clpacklocn = OffsetFor(closure);
-
- /* If the closure's not already being packed */
- if (NotYetPacking(clpacklocn)) {
- P_ info;
-
- /*
- * PLCs reside on all of the PEs already. Just pack the
- * address as a GA (a bit of a kludge, since an address may
- * not fit in *any* of the individual GA fields). Const,
- * charlike and small intlike closures are converted into
- * PLCs.
- */
- switch (INFO_TYPE(INFO_PTR(closure))) {
-
- case INFO_CHARLIKE_TYPE:
-# ifdef PACK_DEBUG
- fprintf(stderr, "Packing a charlike %s\n", CHARLIKE_VALUE(closure));
-# endif
- PackPLC((P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(closure)));
- return;
-
- case INFO_CONST_TYPE:
-# ifdef PACK_DEBUG
- fprintf(stderr, "Packing a const %s\n", CONST_STATIC_CLOSURE(INFO_PTR(closure)));
-# endif
- PackPLC(CONST_STATIC_CLOSURE(INFO_PTR(closure)));
- return;
-
- case INFO_STATIC_TYPE:
- case INFO_CAF_TYPE: /* For now we ship indirections to CAFs: They are
- * evaluated on each PE if needed */
-# ifdef PACK_DEBUG
- fprintf(stderr, "Packing a PLC %x\n", closure);
-# endif
- PackPLC(closure);
- return;
-
- case INFO_INTLIKE_TYPE:
- {
- I_ val = INTLIKE_VALUE(closure);
-
- if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
-# ifdef PACK_DEBUG
- fprintf(stderr, "Packing a small intlike %d as a PLC\n", val);
-# endif
- PackPLC(INTLIKE_CLOSURE(val));
- return;
- } else {
-# ifdef PACK_DEBUG
- fprintf(stderr, "Packing a big intlike %d as a normal closure\n", val);
-# endif
- break;
- }
- }
- default:
-# ifdef PACK_DEBUG
- fprintf(stderr, "Not a PLC: ");
-# endif
- } /* Switch */
-
- /* Otherwise it's not Fixed */
-
- info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
-
- if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
- size = ptrs = nonptrs = vhs = 0;
-
- /*
- * Now peek ahead to see whether the closure has any primitive array
- * children
- */
- for (i = 0; i < ptrs; ++i) {
- P_ childInfo;
- W_ childSize, childPtrs, childNonPtrs, childVhs;
-
- childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
- &childSize, &childPtrs, &childNonPtrs, &childVhs, str);
- if (IS_BIG_MOTHER(childInfo)) {
- reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
- + childPtrs * PACK_FETCHME_SIZE;
- }
- }
-
- /* Record the location of the GA */
- AmPacking(closure);
-
- /* Pack the global address */
- GlobaliseAndPackGA(closure);
-
- /*
- * Pack a fetchme to the closure if it's a black hole, or the buffer is full
- * and it isn't a primitive array. N.B. Primitive arrays are always packed
- * (because their parents index into them directly)
- */
-
- if (IS_BLACK_HOLE(info) ||
- !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
- || IS_BIG_MOTHER(info))) {
-
- ASSERT(packlocn > PACK_HDR_SIZE);
-
- /* Just pack as a FetchMe */
- info = FetchMe_info;
- for (i = 0; i < FIXED_HS; ++i) {
- if (i == INFO_HDR_POSN)
- Pack((W_) FetchMe_info);
- else
- Pack(closure[i]);
- }
-
- unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(dummy);
-
- } else {
- /* At last! A closure we can actually pack! */
-
- if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
- fprintf(stderr, "Warning: Replicated a Mutable closure!\n");
-
- for (i = 0; i < FIXED_HS + vhs; ++i)
- Pack(closure[i]);
-
- for (i = 0; i < ptrs; ++i)
- QueueClosure(((PP_) (closure))[i + FIXED_HS + vhs]);
-
- for (i = 0; i < nonptrs; ++i)
- Pack(closure[i + FIXED_HS + vhs + ptrs]);
-
- unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
-
- /*
- * Record that this is a revertable black hole so that we can fill in
- * its address from the fetch reply. Problem: unshared thunks may cause
- * space leaks this way, their GAs should be deallocated following an
- * ACK.
- */
-
- if (IS_THUNK(info) && IS_UPDATABLE(info)) {
-# ifdef DEBUG
- P_ rbh =
-# else
- (void)
-# endif
- convertToRBH(closure);
-
- ASSERT(rbh != NULL);
- }
- }
- }
- /* Pack an indirection to the original closure! */
- else
- PackOffset(clpacklocn);
-}
-
-#else /* GRAN */
-
-/* Fake the packing of a closure */
-
-void
-PackClosure(closure)
-P_ closure;
-{
- W_ size, ptrs, nonptrs, vhs;
- W_ childSize, childPtrs, junk; /*size, no. ptrs etc. of a child closure*/
- P_ childInfo;
- P_ info;
- int i, clpacklocn;
- W_ PAsize = 0; /*total size + no. ptrs of all child prim arrays*/
- W_ PAptrs = 0;
- char str[80], junk_str[80];
- rtsBool will_be_rbh, no_more_thunks_please;
-
- /* In GranSim we don't pack and unpack closures -- we just simulate */
- /* that by updating the bitmask. So, the graph structure is unchanged */
- /* i.e. we don't short out indirections here. -- HWL */
-
- if (where_is(closure) != where_is(graphroot)) {
- /* GUM would pack a FETCHME here; simulate that by increasing the */
- /* unpacked size accordingly but don't pack anything -- HWL */
- unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(closure);
- return;
- }
- /* clpacklocn = OffsetFor(closure); */
-
- /* If the closure's not already being packed */
- if (NotYetPacking(closure)) {
- switch (INFO_TYPE(INFO_PTR(closure))) {
- case INFO_SPEC_RBH_TYPE:
- case INFO_GEN_RBH_TYPE:
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- fprintf(stderr,"************ Avoid packing RBH @ %#lx!\n", closure);
- }
-# endif
- /* Just ignore RBHs i.e. they stay where they are */
- return;
-
- case INFO_CHARLIKE_TYPE:
- case INFO_CONST_TYPE:
- case INFO_STATIC_TYPE:
- case INFO_CAF_TYPE: /* For now we ship indirections to CAFs:
- * They are evaluated on each PE if needed */
- Pack(closure);
- return;
-
- case INFO_INTLIKE_TYPE:
- {
- I_ val = INTLIKE_VALUE(closure);
- if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
- Pack(closure);
- return;
- } else {
- break;
- }
- }
- default:
- /* Just fall through to the rest of the function */
- } /* Switch */
-
- /* Otherwise it's not Fixed */
-
- info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
- will_be_rbh = IS_THUNK(info) && IS_UPDATABLE(info);
- no_more_thunks_please =
- (RTSflags.GranFlags.ThunksToPack>0) &&
- (packed_thunks>=RTSflags.GranFlags.ThunksToPack);
-
- if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
- size = ptrs = nonptrs = vhs = 0;
-
- /* Now peek ahead to see whether the closure has any primitive */
- /* array children */
- for (i = 0; i < ptrs; ++i) {
- P_ childInfo;
- W_ childSize, childPtrs, childNonPtrs, childVhs;
-
- childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
- &childSize, &childPtrs, &childNonPtrs,
- &childVhs, junk_str);
- if (IS_BIG_MOTHER(childInfo)) {
- reservedPAsize += PACK_GA_SIZE + FIXED_HS +
- childVhs + childNonPtrs +
- childPtrs * PACK_FETCHME_SIZE;
- PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
- PAptrs += childPtrs;
- }
- }
-
- /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
- * is full and it isn't a primitive array. N.B. Primitive arrays are
- * always packed (because their parents index into them directly) */
-
- if (IS_BLACK_HOLE(info) ||
- !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
- || IS_BIG_MOTHER(info)))
- return;
-
- /* At last! A closure we can actually pack! */
-
- if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
- fprintf(stderr,"Warning: Replicated a Mutable closure!");
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if (no_more_thunks_please && will_be_rbh) {
- tot_cuts++;
- if ( RTSflags.GranFlags.debug & 0x100 )
- fprintf(stderr,"PackClosure (w/ RTSflags.GranFlags.ThunksToPack=%d): Cutting tree with root at %#lx\n",
- RTSflags.GranFlags.ThunksToPack, closure);
- } else if (will_be_rbh || (closure==graphroot) ) {
- packed_thunks++;
- tot_thunks++;
- }
-# endif
- if (!(no_more_thunks_please && will_be_rbh)) {
- Pack(closure); /* actual PACKING done here -- HWL */
- for (i = 0; i < ptrs; ++i)
- QueueClosure(((StgPtrPtr) (closure))[i + FIXED_HS + vhs]);
-
- /* Turn thunk into a revertible black hole. */
- if (will_be_rbh)
- {
- P_ rbh;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- fprintf(stderr,"> RBHing the following closure:\n (%#lx) ",
- closure);
- G_PPN(closure); /* see StgDebug */
- }
-# endif
- rbh = convertToRBH(closure);
- ASSERT(rbh != NULL);
- }
- }
- }
- else /* !NotYetPacking(clpacklocn) */
- /* Don't have to do anything in GrAnSim if closure is already */
- /* packed -- HWL */
- {
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 )
- fprintf(stderr,"*** Closure %#lx is already packed and omitted now!\n",
- closure);
-# endif
- }
-}
-#endif /* PAR */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[simple-pack-routines]{Simple Packing Routines}
-%* *
-%************************************************************************
-
-About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
-gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
-words. In the simulated PackBuffer we only keep the addresses of the
-closures that would be packed in the parallel system (see Pack). To decide
-if a packet overflow occurs pack_buffer_size must be compared versus
-unpackedsize (see RoomToPack). Currently, there is no multi packet
-strategy implemented, so in the case of an overflow we just stop adding
-closures to the closure queue. If an overflow of the simulated packet
-occurs, we just realloc some more space for it and carry on as usual.
-% -- HWL
-
-\begin{code}
-#if defined(GRAN)
-static P_ *
-InstantiatePackBuffer () {
-
- PackBuffer =
- /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
- (P_ *) stgMallocWords(RTSflags.GranFlags.packBufferSize_internal+PACK_HDR_SIZE,
- "InstantiatePackBuffer") ;
-
- PackBuffer[PACK_SIZE_LOCN] = (P_)RTSflags.GranFlags.packBufferSize_internal;
-
- return (PackBuffer);
-}
-#endif
-\end{code}
-
-@Pack@ is the basic packing routine. It just writes a word of
-data into the pack buffer and increments the pack location.
-
-\begin{code}
-#if defined(PAR)
-static void
-Pack(data)
- W_ data;
-{
- ASSERT(packlocn < RTSflags.ParFlags.packBufferSize);
- PackBuffer[packlocn++] = data;
-}
-#else /* GRAN */
-static void
-Pack(addr)
-P_ addr;
-{
- W_ size, ptrs, nonptrs, vhs;
- P_ info;
- char str[80];
-
- /* This checks the size of the GrAnSim internal pack buffer. The simulated
- pack buffer is checked via RoomToPack (as in GUM) */
- if (packlocn >= (int)PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE) {
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x8000 ) {
- fprintf(stderr, "Increasing size of PackBuffer %#lx to %d words (PE %u @ %d)\n",
- PackBuffer, PackBuffer[PACK_SIZE_LOCN]+REALLOC_SZ,
- CurrentProc, CurrentTime[CurrentProc]);
- }
-# endif
- PackBuffer = (P_ *) realloc(PackBuffer,
- sizeof(P_)*(REALLOC_SZ +
- (int)PackBuffer[PACK_SIZE_LOCN] +
- PACK_HDR_SIZE)) ;
- if (PackBuffer == NULL) {
- fprintf(stderr,"Failing to realloc %d more words for PackBuffer %#lx (PE %u @ %d)\n",
- REALLOC_SZ, PackBuffer, CurrentProc, CurrentTime[CurrentProc]);
- EXIT(EXIT_FAILURE);
- }
- PackBuffer[PACK_SIZE_LOCN] += REALLOC_SZ;
- }
-
- ASSERT(packlocn < PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
-
- if (addr==NULL)
- fprintf(stderr,"Qagh {Pack}Daq: Trying to pack 0\n");
- PackBuffer[packlocn++] = addr;
- /* ASSERT: Data is a closure in GrAnSim here */
- info = get_closure_info(addr, &size, &ptrs, &nonptrs, &vhs, str);
- unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ?
- MIN_UPD_SIZE :
- size);
-}
-#endif /* PAR */
-\end{code}
-
-If a closure is local, make it global. Then, divide its weight for export.
-The GA is then packed into the pack buffer.
-
-\begin{code}
-#if !defined(GRAN)
-
-static void
-GlobaliseAndPackGA(closure)
-P_ closure;
-{
- globalAddr *ga;
- globalAddr packGA;
-
- if ((ga = LAGAlookup(closure)) == NULL)
- ga = MakeGlobal(closure, rtsTrue);
- splitWeight(&packGA, ga);
- ASSERT(packGA.weight > 0);
-
-#ifdef PACK_DEBUG
- fprintf(stderr, "Packing (%x, %d, %x)\n",
- packGA.loc.gc.gtid, packGA.loc.gc.slot, packGA.weight);
-#endif
- Pack((W_) packGA.weight);
- Pack((W_) packGA.loc.gc.gtid);
- Pack((W_) packGA.loc.gc.slot);
-}
-\end{code}
-
-@PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
-address follows instead of PE, slot.
-
-\begin{code}
-static void
-PackPLC(addr)
-P_ addr;
-{
- Pack(0L); /* weight */
- Pack((W_) addr); /* address */
-}
-\end{code}
-
-@PackOffset@ packs a special GA value that will be interpreted as
-an offset to a closure in the pack buffer. This is used to avoid
-unfolding the graph structure into a tree.
-
-\begin{code}
-static void
-PackOffset(offset)
-int offset;
-{
-#ifdef PACK_DEBUG
- fprintf(stderr,"Packing Offset %d at pack location %u\n",offset,packlocn);
-#endif
- Pack(1L); /* weight */
- Pack(0L); /* pe */
- Pack(offset); /* slot/offset */
-}
-#endif /* !GRAN */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[pack-offsets]{Offsets into the Pack Buffer}
-%* *
-%************************************************************************
-
-The offset hash table is used during packing to record the location in
-the pack buffer of each closure which is packed.
-
-\begin{code}
-#if defined(PAR)
-static HashTable *offsettable;
-\end{code}
-
-@InitPacking@ initialises the packing buffer etc.
-
-\begin{code}
-void
-InitPackBuffer(STG_NO_ARGS)
-{
- if (PackBuffer == NULL) { /* not yet allocated */
-
- PackBuffer = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize+PACK_HDR_SIZE,
- "InitPackBuffer");
-
- InitPendingGABuffer(RTSflags.ParFlags.packBufferSize);
- AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
- }
-}
-#endif /* PAR */
-
-static void
-InitPacking(STG_NO_ARGS)
-{
-#if defined(GRAN)
- PackBuffer = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
- /* NB: free in UnpackGraph */
-#endif
-
- packlocn = PACK_HDR_SIZE;
- unpackedsize = 0;
- reservedPAsize = 0;
- RoomInBuffer = rtsTrue;
- InitClosureQueue();
-#if defined(PAR)
- offsettable = allocHashTable();
-#else
- packed_thunks = 0;
-#endif
-}
-\end{code}
-
-@DonePacking@ is called when we've finished packing. It releases memory
-etc.
-
-\begin{code}
-#if defined(PAR)
-
-static void
-DonePacking(STG_NO_ARGS)
-{
- freeHashTable(offsettable,NULL);
- offsettable = NULL;
-}
-\end{code}
-
-@AmPacking@ records that the closure is being packed. Note the abuse
-of the data field in the hash table -- this saves calling @malloc@!
-
-\begin{code}
-static void
-AmPacking(closure)
-P_ closure;
-{
-#ifdef PACK_DEBUG
- fprintf(stderr, "Packing %#lx (IP %#lx) at %u\n",
- closure, INFO_PTR(closure), packlocn);
-#endif
- insertHashTable(offsettable, (W_) closure, (void *) (W_) packlocn);
-}
-\end{code}
-
-@OffsetFor@ returns an offset for a closure which is already being
-packed.
-
-\begin{code}
-static int
-OffsetFor(P_ closure)
-{
- return (int) (W_) lookupHashTable(offsettable, (W_) closure);
-}
-\end{code}
-
-@NotYetPacking@ determines whether the closure's already being packed.
-Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.
-
-\begin{code}
-static rtsBool
-NotYetPacking(offset)
-int offset;
-{
- return(offset < PACK_HDR_SIZE);
-}
-
-#else /* GRAN */
-
-static rtsBool
-NotYetPacking(closure)
-P_ closure;
-{ int i;
- rtsBool found = rtsFalse;
-
- for (i=PACK_HDR_SIZE; (i<packlocn) && !found; i++)
- found = PackBuffer[i]==closure;
-
- return (!found);
-}
-#endif
-\end{code}
-
-@RoomToPack@ determines whether there's room to pack the closure into
-the pack buffer based on
-
-o how full the buffer is already,
-o the closures' size and number of pointers (which must be packed as GAs),
-o the size and number of pointers held by any primitive arrays that it points to
-
-It has a *side-effect* in assigning RoomInBuffer to False.
-
-\begin{code}
-static rtsBool
-RoomToPack(size, ptrs)
-W_ size, ptrs;
-{
-#if defined(PAR)
- if (RoomInBuffer &&
- (packlocn + reservedPAsize + size +
- ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
- {
-#ifdef PACK_DEBUG
- fprintf(stderr, "Buffer full\n");
-#endif
- RoomInBuffer = rtsFalse;
- }
-#else /* GRAN */
- if (RoomInBuffer &&
- (unpackedsize + reservedPAsize + size +
- ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
- {
-#if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 )
- fprintf(stderr, "Buffer full\n");
-#endif
- RoomInBuffer = rtsFalse;
- }
-#endif
- return (RoomInBuffer);
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[pack-closure-queue]{Closure Queues}
-%* *
-%************************************************************************
-
-These routines manage the closure queue.
-
-\begin{code}
-static W_ clqpos, clqsize;
-
-static P_ *ClosureQueue = NULL; /* HWL: init in main */
-\end{code}
-
-@InitClosureQueue@ initialises the closure queue.
-
-\begin{code}
-void
-AllocClosureQueue(size)
- W_ size;
-{
- ASSERT(ClosureQueue == NULL);
- ClosureQueue = (P_ *) stgMallocWords(size, "AllocClosureQueue");
-}
-
-void
-InitClosureQueue(STG_NO_ARGS)
-{
- clqpos = clqsize = 0;
-
- if ( ClosureQueue == NULL )
- AllocClosureQueue(PACK_BUFFER_SIZE);
-}
-\end{code}
-
-@QueueEmpty@ returns @rtsTrue@ if the closure queue is empty;
-@rtsFalse@ otherwise.
-
-\begin{code}
-rtsBool
-QueueEmpty(STG_NO_ARGS)
-{
- return(clqpos >= clqsize);
-}
-\end{code}
-
-@QueueClosure@ adds its argument to the closure queue.
-
-\begin{code}
-void
-QueueClosure(closure)
-P_ closure;
-{
- if(clqsize < PACK_BUFFER_SIZE )
- ClosureQueue[clqsize++] = closure;
- else
- {
- fprintf(stderr,"Closure Queue Overflow (EnQueueing %lx)\n", (W_)closure);
- EXIT(EXIT_FAILURE);
- }
-}
-\end{code}
-
-@DeQueueClosure@ returns the head of the closure queue.
-
-\begin{code}
-P_
-DeQueueClosure(STG_NO_ARGS)
-{
- if(!QueueEmpty())
- return(ClosureQueue[clqpos++]);
- else
- return(NULL);
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[pack-ga-types]{Types of Global Addresses}
-%* *
-%************************************************************************
-
-These routines determine whether a GA is one of a number of special types
-of GA.
-
-\begin{code}
-#if defined(PAR)
-rtsBool
-isOffset(ga)
-globalAddr *ga;
-{
- return (ga->weight == 1 && ga->loc.gc.gtid == 0);
-}
-
-rtsBool
-isFixed(ga)
-globalAddr *ga;
-{
- return (ga->weight == 0);
-}
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[pack-print-packet]{Printing Packet Contents}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(DEBUG) || defined(GRAN_CHECK)
-
-#if defined(PAR)
-void
-PrintPacket(buffer)
-P_ buffer;
-{
- W_ size, ptrs, nonptrs, vhs;
- char str[80];
-
- globalAddr ga;
-
- W_ bufsize;
- P_ parent;
- W_ pptr = 0, pptrs = 0, pvhs;
-
- W_ unpacklocn = PACK_HDR_SIZE;
- W_ gastart = unpacklocn;
- W_ closurestart = unpacklocn;
-
- P_ info;
-
- int i;
-
- InitClosureQueue();
-
- /* Unpack the header */
- bufsize = buffer[0];
-
- fprintf(stderr, "Packed Packet size %u\n\n--- Begin ---\n", bufsize);
-
- do {
- gastart = unpacklocn;
- ga.weight = buffer[unpacklocn++];
- if (ga.weight > 0) {
- ga.loc.gc.gtid = buffer[unpacklocn++];
- ga.loc.gc.slot = buffer[unpacklocn++];
- } else
- ga.loc.plc = (P_) buffer[unpacklocn++];
- closurestart = unpacklocn;
-
- if (isFixed(&ga)) {
- fprintf(stderr, "[%u]: PLC @ %#lx\n", gastart, ga.loc.plc);
- } else if (isOffset(&ga)) {
- fprintf(stderr, "[%u]: OFFSET TO [%d]\n", gastart, ga.loc.gc.slot);
- }
- /* Print normal closures */
- else {
- fprintf(stderr, "[%u]: (%x, %d, %x) ", gastart,
- ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
-
- info = get_closure_info((P_) (buffer + closurestart), &size,
- &ptrs, &nonptrs, &vhs, str);
-
- if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
- size = ptrs = nonptrs = vhs = 0;
-
- if (IS_THUNK(info)) {
- if (IS_UPDATABLE(info))
- fputs("SHARED ", stderr);
- else
- fputs("UNSHARED ", stderr);
- }
- if (IS_BLACK_HOLE(info)) {
- fputs("BLACK HOLE\n", stderr);
- } else {
- /* Fixed header */
- fprintf(stderr, "FH [%#lx", buffer[unpacklocn++]);
- for (i = 1; i < FIXED_HS; i++)
- fprintf(stderr, " %#lx", buffer[unpacklocn++]);
-
- /* Variable header */
- if (vhs > 0) {
- fprintf(stderr, "] VH [%#lx", buffer[unpacklocn++]);
-
- for (i = 1; i < vhs; i++)
- fprintf(stderr, " %#lx", buffer[unpacklocn++]);
- }
-
- fprintf(stderr, "] PTRS %u", ptrs);
-
- /* Non-pointers */
- if (nonptrs > 0) {
- fprintf(stderr, " NPTRS [%#lx", buffer[unpacklocn++]);
-
- for (i = 1; i < nonptrs; i++)
- fprintf(stderr, " %#lx", buffer[unpacklocn++]);
-
- putc(']', stderr);
- }
- putc('\n', stderr);
- }
-
- /* Add to queue for processing */
- QueueClosure((P_) (buffer + closurestart));
- }
-
- /* Locate next parent pointer */
- pptr++;
- while (pptr + 1 > pptrs) {
- parent = DeQueueClosure();
-
- if (parent == NULL)
- break;
- else {
- (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
- &pvhs, str);
- pptr = 0;
- }
- }
- } while (parent != NULL);
-
- fprintf(stderr, "--- End ---\n\n");
-}
-#else /* GRAN */
-void
-PrintPacket(buffer)
-P_ buffer;
-{
- extern char *info_hdr_type(P_ infoptr); /* defined in Threads.lc */
- extern char *info_type(P_ infoptr); /* defined in Threads.lc */
-
- char str1[80], str2[80], junk_str[80];
-
- W_ size, ptrs, nonptrs, vhs;
-
- /* globalAddr ga; */
-
- W_ bufsize, unpackedsize ;
- P_ parent;
- W_ pptr = 0, pptrs = 0, pvhs;
-
- W_ unpacklocn = PACK_HDR_SIZE;
- W_ gastart = unpacklocn;
- W_ closurestart = unpacklocn;
-
- P_ info, tso;
- P_ closure;
-
- int i;
-
- InitClosureQueue();
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
- fprintf(stderr,"Packet @ 0x%lx hs no flag : 0x%lx\n",
- buffer, buffer[PACK_FLAG_LOCN]);
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- tso = (P_) buffer[PACK_TSO_LOCN];
-
- /* Unpack the header */
- unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
- bufsize = buffer[PACK_SIZE_LOCN];
-
- fprintf(stderr, "Packed Packet %#lx, size %u (unpacked size is %u); demanded by TSO %#lx (%d)(PE %d)\n--- Begin ---\n",
- buffer, bufsize, unpackedsize, tso, TSO_ID(tso), where_is(tso));
-
- do {
- closurestart = unpacklocn;
- closure = (P_) buffer[unpacklocn++];
-
- fprintf(stderr, "[%u]: (%#lx) ", closurestart, closure);
-
- info = get_closure_info((P_) (closure),
- &size, &ptrs, &nonptrs, &vhs,str1);
- strcpy(str2,info_type(info));
- fprintf(stderr, "(%s|%s) ", str1, str2);
-
- if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
- size = ptrs = nonptrs = vhs = 0;
-
- if (IS_THUNK(info)) {
- if (IS_UPDATABLE(info))
- fputs("SHARED ", stderr);
- else
- fputs("UNSHARED ", stderr);
- }
- if (IS_BLACK_HOLE(info)) {
- fputs("BLACK HOLE\n", stderr);
- } else {
- /* Fixed header */
- fprintf(stderr, "FH [%#lx", closure[0]);
- for (i = 1; i < FIXED_HS; i++)
- fprintf(stderr, " %#lx", closure[i]);
-
- /* Variable header */
- if (vhs > 0) {
- fprintf(stderr, "] VH [%#lx", closure[FIXED_HS]);
-
- for (i = 1; i < vhs; i++)
- fprintf(stderr, " %#lx", closure[FIXED_HS+i]);
- }
-
- fprintf(stderr, "] PTRS %u", ptrs);
-
- /* Non-pointers */
- if (nonptrs > 0) {
- fprintf(stderr, " NPTRS [%#lx", closure[FIXED_HS+vhs]);
-
- for (i = 1; i < nonptrs; i++)
- fprintf(stderr, " %#lx", closure[FIXED_HS+vhs+i]);
-
- putc(']', stderr);
- }
- putc('\n', stderr);
- }
- } while (unpacklocn<bufsize) ; /* (parent != NULL); */
-
- fprintf(stderr, "--- End ---\n\n");
-}
-#endif /* PAR */
-#endif /* DEBUG || GRAN_CHECK */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[pack-get-closure-info]{Closure Info}
-%* *
-%************************************************************************
-
-@get_closure_info@ determines the size, number of pointers etc. for this
-type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
-
-[Can someone please keep this function up to date. I keep needing it
- (or something similar) for interpretive code, and it keeps
- bit-rotting. {\em It really belongs somewhere else too}. KH @@ 17/2/95]
-
-\begin{code}
-P_
-get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
-P_ closure;
-W_ *size, *ptrs, *nonptrs, *vhs;
-char *type;
-{
- P_ ip = (P_) INFO_PTR(closure);
-
- if (closure==NULL) {
- fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
- *size = *ptrs = *nonptrs = *vhs = 0;
- strcpy(type,"ERROR in get_closure_info");
- return;
- } else if (closure==PrelBase_Z91Z93_closure) {
- /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
- *size = *ptrs = *nonptrs = *vhs = 0;
- strcpy(type,"PrelBase_Z91Z93_closure");
- return;
- };
-
- ip = (P_) INFO_PTR(closure);
-
- switch (INFO_TYPE(ip)) {
- case INFO_SPEC_U_TYPE:
- case INFO_SPEC_S_TYPE:
- case INFO_SPEC_N_TYPE:
- *size = SPEC_CLOSURE_SIZE(closure);
- *ptrs = SPEC_CLOSURE_NoPTRS(closure);
- *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
- *vhs = 0 /*SPEC_VHS*/;
- strcpy(type,"SPEC");
- break;
-
- case INFO_GEN_U_TYPE:
- case INFO_GEN_S_TYPE:
- case INFO_GEN_N_TYPE:
- *size = GEN_CLOSURE_SIZE(closure);
- *ptrs = GEN_CLOSURE_NoPTRS(closure);
- *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
- *vhs = GEN_VHS;
- strcpy(type,"GEN");
- break;
-
- case INFO_DYN_TYPE:
- *size = DYN_CLOSURE_SIZE(closure);
- *ptrs = DYN_CLOSURE_NoPTRS(closure);
- *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
- *vhs = DYN_VHS;
- strcpy(type,"DYN");
- break;
-
- case INFO_TUPLE_TYPE:
- *size = TUPLE_CLOSURE_SIZE(closure);
- *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
- *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
- *vhs = TUPLE_VHS;
- strcpy(type,"TUPLE");
- break;
-
- case INFO_DATA_TYPE:
- *size = DATA_CLOSURE_SIZE(closure);
- *ptrs = DATA_CLOSURE_NoPTRS(closure);
- *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
- *vhs = DATA_VHS;
- strcpy(type,"DATA");
- break;
-
- case INFO_IMMUTUPLE_TYPE:
- case INFO_MUTUPLE_TYPE:
- *size = MUTUPLE_CLOSURE_SIZE(closure);
- *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
- *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
- *vhs = MUTUPLE_VHS;
- strcpy(type,"(IM)MUTUPLE");
- break;
-
- case INFO_STATIC_TYPE:
- *size = STATIC_CLOSURE_SIZE(closure);
- *ptrs = STATIC_CLOSURE_NoPTRS(closure);
- *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
- *vhs = STATIC_VHS;
- strcpy(type,"STATIC");
- break;
-
- case INFO_CAF_TYPE:
- case INFO_IND_TYPE:
- *size = IND_CLOSURE_SIZE(closure);
- *ptrs = IND_CLOSURE_NoPTRS(closure);
- *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
- *vhs = IND_VHS;
- strcpy(type,"CAF|IND");
- break;
-
- case INFO_CONST_TYPE:
- *size = CONST_CLOSURE_SIZE(closure);
- *ptrs = CONST_CLOSURE_NoPTRS(closure);
- *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
- *vhs = CONST_VHS;
- strcpy(type,"CONST");
- break;
-
- case INFO_SPEC_RBH_TYPE:
- *size = SPEC_RBH_CLOSURE_SIZE(closure);
- *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
- *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
- if (*ptrs <= 2) {
- *nonptrs -= (2 - *ptrs);
- *ptrs = 1;
- } else
- *ptrs -= 1;
- *vhs = SPEC_RBH_VHS;
- strcpy(type,"SPEC_RBH");
- break;
-
- case INFO_GEN_RBH_TYPE:
- *size = GEN_RBH_CLOSURE_SIZE(closure);
- *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
- *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
- if (*ptrs <= 2) {
- *nonptrs -= (2 - *ptrs);
- *ptrs = 1;
- } else
- *ptrs -= 1;
- *vhs = GEN_RBH_VHS;
- strcpy(type,"GEN_RBH");
- break;
-
- case INFO_CHARLIKE_TYPE:
- *size = CHARLIKE_CLOSURE_SIZE(closure);
- *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
- *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
- *vhs = CHARLIKE_VHS;
- strcpy(type,"CHARLIKE");
- break;
-
- case INFO_INTLIKE_TYPE:
- *size = INTLIKE_CLOSURE_SIZE(closure);
- *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
- *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
- *vhs = INTLIKE_VHS;
- strcpy(type,"INTLIKE");
- break;
-
-# if !defined(GRAN)
- case INFO_FETCHME_TYPE:
- *size = FETCHME_CLOSURE_SIZE(closure);
- *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
- *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
- *vhs = FETCHME_VHS;
- strcpy(type,"FETCHME");
- break;
-
- case INFO_FMBQ_TYPE:
- *size = FMBQ_CLOSURE_SIZE(closure);
- *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
- *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
- *vhs = FMBQ_VHS;
- strcpy(type,"FMBQ");
- break;
-# endif
-
- case INFO_BQ_TYPE:
- *size = BQ_CLOSURE_SIZE(closure);
- *ptrs = BQ_CLOSURE_NoPTRS(closure);
- *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
- *vhs = BQ_VHS;
- strcpy(type,"BQ");
- break;
-
- case INFO_BH_TYPE:
- *size = BH_CLOSURE_SIZE(closure);
- *ptrs = BH_CLOSURE_NoPTRS(closure);
- *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
- *vhs = BH_VHS;
- strcpy(type,"BH");
- break;
-
- case INFO_TSO_TYPE:
- *size = 0; /* TSO_CLOSURE_SIZE(closure); */
- *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
- *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
- *vhs = TSO_VHS;
- strcpy(type,"TSO");
- break;
-
- case INFO_STKO_TYPE:
- *size = 0;
- *ptrs = 0;
- *nonptrs = 0;
- *vhs = STKO_VHS;
- strcpy(type,"STKO");
- break;
-
- default:
- fprintf(stderr, "get_closure_info: Unexpected closure type (%lu), closure %lx\n",
- INFO_TYPE(ip), (W_) closure);
- EXIT(EXIT_FAILURE);
- }
-
- return ip;
-}
-\end{code}
-
-@AllocateHeap@ will bump the heap pointer by @size@ words if the space
-is available, but it will not perform garbage collection.
-
-\begin{code}
-P_
-AllocateHeap(size)
-W_ size;
-{
- P_ newClosure;
-
- /* Allocate a new closure */
- if (SAVE_Hp + size > SAVE_HpLim)
- return NULL;
-
- newClosure = SAVE_Hp + 1;
- SAVE_Hp += size;
-
- return newClosure;
-}
-
-#if defined(PAR)
-
-void
-doGlobalGC(STG_NO_ARGS)
-{
- fprintf(stderr,"Splat -- we just hit global GC!\n");
- EXIT(EXIT_FAILURE);
- fishing = rtsFalse;
-}
-
-#endif /* PAR */
-\end{code}
-
-\begin{code}
-#endif /* PAR || GRAN -- whole file */
-\end{code}
+++ /dev/null
-%****************************************************************************
-%
-\section[ParInit.lc]{Initialising the parallel RTS}
-%
-% (c) The Parade/AQUA Projects, Glasgow University, 1995.
-% P. Trinder, January 17th 1995.
-% An extension based on Kevin Hammond's GRAPH for PVM version
-%
-%****************************************************************************
-
-\begin{code}
-#ifdef PAR /* whole file */
-
-#ifndef _AIX
-#define NON_POSIX_SOURCE /* so says Solaris */
-#endif
-
-#include "rtsdefs.h"
-#include <setjmp.h>
-#include "LLC.h"
-#include "HLC.h"
-\end{code}
-
-Global conditions defined here.
-
-\begin{code}
-rtsBool
- OkToGC = rtsFalse, /* Set after initialisation */
- IAmMainThread = rtsFalse, /* Set for the main thread */
- GlobalStopPending = rtsFalse, /* Terminate */
- GlobalGCPending = rtsFalse; /* Start Global GC */
-\end{code}
-
-Task identifiers for various interesting global tasks.
-
-\begin{code}
-GLOBAL_TASK_ID IOTask = 0, /* The IO Task Id */
- SysManTask = 0, /* The System Manager Task Id */
- GCManTask = 0, /* The GC Manager Task Id */
- StatsManTask = 0, /* The Statistics Manager Task Id*/
- mytid = 0; /* This PE's Task Id */
-\end{code}
-
-\begin{code}
-REAL_TIME main_start_time; /* When the program started */
-REAL_TIME main_stop_time; /* When the program finished */
-jmp_buf exit_parallel_system; /* How to abort from the RTS */
-\end{code}
-
-Flag handling.
-
-\begin{code}
-rtsBool TraceSparks = rtsFalse; /* Enable the spark trace mode */
-rtsBool SparkLocally = rtsFalse; /* Use local threads if possible */
-rtsBool DelaySparks = rtsFalse; /* Use delayed sparking */
-rtsBool LocalSparkStrategy = rtsFalse; /* Either delayed threads or local threads */
-rtsBool GlobalSparkStrategy = rtsFalse; /* Export all threads */
-
-rtsBool DeferGlobalUpdates = rtsFalse; /* Defer updating of global nodes */
-rtsBool fishing = rtsFalse; /* We have no fish out in the stream */
-\end{code}
-
-\begin{code}
-void
-RunParallelSystem(program_closure)
-StgPtr program_closure;
-{
-
- /* Return here when exiting the program. */
- if (setjmp(exit_parallel_system) != 0)
- return;
-
- /* Show that we've started */
- if (IAmMainThread && ! RTSflags.ParFlags.outputDisabled)
- fprintf(stderr, "Starting main program...\n");
-
- /* Record the start time for statistics purposes. */
- main_start_time = usertime();
- /* fprintf(stderr, "Start time is %u\n", main_start_time); */
-
- /*
- * Start the main scheduler which will fish for threads on all but the PE with
- * the main thread
- */
-
- ScheduleThreads(program_closure);
- myexit(1);
-}
-\end{code}
-
-@myexit@ defines how to terminate the program. If the exit code is
-non-zero (i.e. an error has occurred), the PE should not halt until
-outstanding error messages have been processed. Otherwise, messages
-might be sent to non-existent Task Ids. The infinite loop will actually
-terminate, since @STG_Exception@ will call @myexit@\tr{(0)} when
-it received a @PP_FINISH@ from the system manager task.
-
-\begin{code}
-void
-myexit(n) /* NB: "EXIT" is set to "myexit" for parallel world */
-I_ n;
-{
- GlobalStopPending = rtsTrue;
- SendOp(PP_FINISH, SysManTask);
- if (n != 0)
- WaitForTermination();
- else
- WaitForPEOp(PP_FINISH, SysManTask);
- PEShutDown();
- fprintf(stderr,"PE %lx shutting down, %ld Threads run, %ld Sparks created, %ld Sparks ignored\n", (W_) mytid, threadId, sparksCreated, sparksIgnored); /* HWL */
-
- /* And actually terminate -- always with code 0 */
- longjmp(exit_parallel_system, 1);
-}
-\end{code}
-
-\begin{code}
-void srand48 PROTO((long));
-time_t time PROTO((time_t *));
-
-void
-initParallelSystem(STG_NO_ARGS)
-{
- /* Don't buffer standard channels... */
- setbuf(stdout,NULL);
- setbuf(stderr,NULL);
-
- srand48(time(NULL) * getpid()); /*Initialise Random-number generator seed*/
-
- OkToGC = rtsFalse; /* Must not GC till we have set up the environment */
- /* because C is hanging onto heap pointers */
- /* maybe bogus for the new RTS? -- KH */
- /* And for the GUM system? PWT */
- InitPackBuffer();
- InitMoreBuffers();
-}
-\end{code}
-
-@SynchroniseSystem@ synchronises the reduction task with the system manager.
-
-\begin{code}
-GLOBAL_TASK_ID *PEs;
-
-void
-SynchroniseSystem(STG_NO_ARGS)
-{
- PACKET addr;
- int i;
-
- _SetMyExceptionHandler(STG_Exception);
-
- PEs = PEStartUp(nPEs);
-
- /* Initialize global address tables */
- initGAtables();
-
- /* Record the shortened the PE identifiers for LAGA etc. tables */
- for (i = 0; i < nPEs; ++i)
- registerTask(PEs[i]);
-
-/* pvm_notify( PvmTaskExit, PP_FAIL, 1, &SysManTask); /? Setup an error handler */
-
- /* Initialise the PE task array? */
-}
-
-#endif /* PAR -- whole file */
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA/Parade Projects, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section[RBH.lc]{Revertible Black Hole Manipulation}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(PAR) || defined(GRAN) /* whole file */
-
-#include "rtsdefs.h"
-\end{code}
-
-Turn a closure into a revertible black hole. After the conversion,
-the first two words of the closure will be a link to the mutables
-list (if appropriate for the garbage collector), and a pointer
-to the blocking queue. The blocking queue is terminated by a 2-word
-SPEC closure which holds the original contents of the first two
-words of the closure.
-
-\begin{code}
-EXTFUN(RBH_Save_0_info);
-EXTFUN(RBH_Save_1_info);
-EXTFUN(RBH_Save_2_info);
-
-P_
-convertToRBH(closure)
-P_ closure;
-{
- P_ infoPtr, newInfoPtr;
- W_ size, ptrs, nonptrs, vhs;
- P_ rbh_save;
- rtsBool isSpec;
- char str[80];
-
- if ((rbh_save = AllocateHeap(SPEC_HS + 2)) == NULL)
- return NULL;
-
- infoPtr = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
- ASSERT(size >= MIN_UPD_SIZE);
-
- switch (BASE_INFO_TYPE(infoPtr)) {
- case INFO_SPEC_TYPE:
- isSpec = rtsTrue;
- break;
- case INFO_GEN_TYPE:
- isSpec = rtsFalse;
- break;
- default:
- fprintf(stderr, "Panic: turn %#lx (IP %#lx) into RBH\n", (W_)closure, (W_)infoPtr);
- EXIT(EXIT_FAILURE);
- }
-
- /* Fill in the RBH_Save closure with the original data */
- rbh_save[SPEC_HS] = closure[isSpec ? SPEC_HS : GEN_HS];
- rbh_save[SPEC_HS + 1] = closure[(isSpec ? SPEC_HS : GEN_HS) + 1];
-
- /*
- * Set the info_ptr for the rbh_Save closure according to the number of pointers
- * in the original
- */
-
- newInfoPtr = (P_) (ptrs == 0 ? RBH_Save_0_info :
- ptrs == 1 ? RBH_Save_1_info :
- RBH_Save_2_info);
- SET_INFO_PTR(rbh_save, newInfoPtr);
-
- /* Do some magic garbage collection mangling on the first word */
-
-#if defined(GCap) || defined(GCgn)
-
- /*
- * If the closure's in the old generation, we have to make sure it goes on the
- * mutables list
- */
-
- if (closure <= StorageMgrInfo.OldLim) {
- MUT_LINK(closure) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = closure;
- } else
- MUT_LINK(closure) = MUT_NOT_LINKED;
-#endif
-
- /*
- * Second word points to the RBH_Save closure with the original data. This may
- * become a blocking queue terminated by the RBH_Save closure.
- */
- if (isSpec)
- SPEC_RBH_BQ(closure) = (W_) rbh_save;
- else
- GEN_RBH_BQ(closure) = (W_) rbh_save;
-
- /* OK, now actually turn it into a RBH (what a great system!) */
- SET_INFO_PTR(closure, RBH_INFOPTR(INFO_PTR(closure)));
-
- return closure;
-}
-
-\end{code}
-
-Converting a closure to a FetchMe is trivial, unless the closure has
-acquired a blocking queue. If that has happened, we first have to
-awaken the blocking queue. What a nuisance! Fortunately,
-@AwakenBlockingQueue@ should now know what to do.
-
-A note on GrAnSim: In GrAnSim we don't have FetchMe closures. However, we
-have to turn a RBH back to its original form when the simulated transfer
-of the closure has been finished. Therefore we need the @convertFromRBH@
-routine below. After converting the RBH back to its original form and
-awakening all TSOs, the first TSO will reenter the closure which is now
-local and carry on merrily reducing it (the other TSO will be less merrily
-blocked on the now local closure; we're costing the difference between
-local and global blocks in the BQ code).
-
-\begin{code}
-#if defined(PAR)
-
-EXTDATA_RO(FetchMe_info);
-
-void
-convertToFetchMe(closure, ga)
-P_ closure;
-globalAddr *ga;
-{
- P_ ip = (P_) INFO_PTR(closure);
- P_ bqe;
-#if defined(GCap) || defined(GCgn)
- rtsBool linked = IS_MUTABLE(ip) && MUT_LINK(closure) != MUT_NOT_LINKED;
-#endif
-
- switch(INFO_TYPE(ip)) {
- case INFO_SPEC_RBH_TYPE:
- bqe = (P_) SPEC_RBH_BQ(closure);
- break;
- case INFO_GEN_RBH_TYPE:
- bqe = (P_) GEN_RBH_BQ(closure);
- break;
- default:
-#ifdef DEBUG
- fprintf(stderr, "Weird...just tried to convert %#lx (IP %#lx) to FetchMe\n",
- closure, ip);
-#endif
- return;
- }
-
- SET_INFO_PTR(closure, FetchMe_info);
-
-#if defined(GCap) || defined(GCgn)
- /* If we modify a fetchme in the old generation,
- we have to make sure it goes on the mutables list */
-
- if(closure <= StorageMgrInfo.OldLim) {
- if (!linked) {
- MUT_LINK(closure) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = closure;
- }
- } else
- MUT_LINK(closure) = MUT_NOT_LINKED;
-#endif
-
- FETCHME_GA(closure) = ga;
- if (IS_MUTABLE(INFO_PTR(bqe)))
- AwakenBlockingQueue(bqe);
-}
-#else /* GRAN */
-/* Prototype */
-void UnlinkFromMUT(P_ closure);
-
-void
-convertFromRBH(closure) /* The corresponding function in GUM is: */
- /* convertToFetchMe */
-P_ closure;
-{
- P_ ip = (P_) INFO_PTR(closure);
- P_ bqe, rbh_save = PrelBase_Z91Z93_closure;
- int isSpec;
-#if defined(GCap) || defined(GCgn)
- rtsBool linked = IS_MUTABLE(ip) && MUT_LINK(closure) != MUT_NOT_LINKED;
- P_ oldLink = MUT_LINK(closure);
-#endif
-
- switch(INFO_TYPE(ip)) {
- case INFO_SPEC_RBH_TYPE:
- bqe = (P_) SPEC_RBH_BQ(closure);
- isSpec = 1;
- break;
- case INFO_GEN_RBH_TYPE:
- bqe = (P_) GEN_RBH_BQ(closure);
- isSpec = 0;
- break;
- default:
-#if 1
- fprintf(stderr, "Weird...just tried to convert %#lx (IP %#lx) to FetchMe\n",
- closure, ip);
-#endif
- return;
- }
-
-# if defined(GCap) || defined(GCgn)
- /* If the RBH is turned back to a SPEC or GEN closure we have to take
- it off the mutables list */
-
- if (linked) {
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x100) {
- fprintf(stderr,"\n**>>>> Unlinking closure %#lx from mutables list on PE %d @ %ld (next mutable=%#lx)\n",
- closure,
- where_is(closure), CurrentTime[where_is(closure)],
- MUT_LINK(closure));
- GN(closure);
- }
-# endif
- UnlinkFromMUT(closure);
- }
-# endif
-
- /* FETCHME_GA(closure) = ga; */
- if (IS_MUTABLE(INFO_PTR(bqe))) {
- PROC old_proc = CurrentProc, /* NB: For AwakenBlockingQueue, */
- new_proc = where_is(closure); /* CurentProc must be where */
- /* closure lives. */
- CurrentProc = new_proc;
-
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x100)
- fprintf(stderr,"===== AwBQ of node 0x%lx (%s) [PE %2u]\n",
- closure, (isSpec ? "SPEC_RBH" : "GEN_RBH"), new_proc);
-# endif
-
- rbh_save = AwakenBlockingQueue(bqe); /* AwakenBlockingQueue(bqe); */
- CurrentProc = old_proc;
- } else {
- rbh_save = bqe;
- }
-
- /* Put data from special RBH save closures back into the closure */
- if ( rbh_save == PrelBase_Z91Z93_closure ) {
- fprintf(stderr,"convertFromRBH: No RBH_Save_? closure found at end of BQ!\n");
- EXIT(EXIT_FAILURE);
- } else {
- closure[isSpec ? SPEC_HS : GEN_HS] = rbh_save[SPEC_HS];
- closure[(isSpec ? SPEC_HS : GEN_HS) + 1] = rbh_save[SPEC_HS + 1];
- }
-
- /* Put back old info pointer (only in GrAnSim) -- HWL */
- SET_INFO_PTR(closure, REVERT_INFOPTR(INFO_PTR(closure)));
-
-# if (defined(GCap) || defined(GCgn))
- /* If we convert from an RBH in the old generation,
- we have to make sure it goes on the mutables list */
-
- if(closure <= StorageMgrInfo.OldLim) {
- if (IS_MUTABLE(INFO_PTR(closure)) && MUT_LINK(closure) == MUT_NOT_LINKED) {
- MUT_LINK(closure) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = closure;
- }
- }
-# endif
-}
-
-/* Remove closure from the mutables list */
-
-void
-UnlinkFromMUT(P_ closure)
-{
- P_ curr = StorageMgrInfo.OldMutables, prev = NULL;
-
- while (curr != NULL && curr != closure) {
- ASSERT(MUT_LINK(curr)!=MUT_NOT_LINKED);
- prev=curr;
- curr=MUT_LINK(curr);
- }
- if (curr==closure) {
- if (prev==NULL)
- StorageMgrInfo.OldMutables = MUT_LINK(curr);
- else
- MUT_LINK(prev) = MUT_LINK(curr);
- MUT_LINK(curr) = MUT_NOT_LINKED;
- }
-
-#if 0 && (defined(GCap) || defined(GCgn))
- {
- closq newclos;
- extern closq ex_RBH_q;
-
- newclos = (closq) stgMallocBytes(sizeof(struct clos), "UnlinkFromMUT");
- CLOS_CLOSURE(newclos) = closure;
- CLOS_PREV(newclos) = NULL;
- CLOS_NEXT(newclos) = ex_RBH_q;
- if (ex_RBH_q!=NULL)
- CLOS_PREV(ex_RBH_q) = newclos;
- ex_RBH_q = newclos;
- }
-#endif
-}
-
-#endif /* PAR */
-
-#endif /* PAR || GRAN -- whole file */
-\end{code}
+++ /dev/null
-/****************************************************************
-* *
-* Spark Management Routines (Sparks.lc) *
-* *
-* Contains the spark-management routines used by GUM *
-* (c) The Parade/AQUA Projects, Glasgow University, 1995 *
-* Kevin Hammond, 27 February 1995 *
-* *
-*****************************************************************/
-
-
-\begin{code}
-#if defined(PAR) || defined(GRAN) /* whole file */
-
-#include "rtsdefs.h"
-\end{code}
-
-This uses GranSim-style sparkqs rather than old-style sparks as used
-in the threaded world. The problem with the latter is that they
-contain insufficient information (we also need to know whether a spark
-is local/global etc.). Problem: at the moment GUMM uses threaded-style
-sparks (presumably). ToDo: Fix this...
-
-\begin{code}
-P_
-FindLocalSpark(forexport)
-rtsBool forexport;
-{
-#ifdef PAR
- P_ spark;
-
- while (PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL]) {
- spark = *PendingSparksHd[REQUIRED_POOL]++;
- if (SHOULD_SPARK(spark))
- return spark;
- }
- while (PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL]) {
- spark = *PendingSparksHd[ADVISORY_POOL]++;
- if (SHOULD_SPARK(spark))
- return spark;
- }
- return NULL;
-
-#else
-
- fprintf(stderr,"FindLocalSpark: under GRAN!\n");
- abort();
-
-# if 0
- sparkq spark, prev, next, thespark;
-
- int pool, poolcount;
-
- thespark = NULL;
-
- for (poolcount = 0, pool = REQUIRED_POOL;
- thespark == NULL && poolcount < 2;
- ++poolcount, pool = ADVISORY_POOL) {
- for (prev = NULL, spark = PendingSparksHd[pool];
- spark != NULL && thespark == NULL; spark = next) {
- next = SPARK_NEXT(spark);
-
- if (SHOULD_SPARK(SPARK_NODE(spark))) {
- /* Don't Steal local sparks */
- if (forexport && !SPARK_GLOBAL(spark)) {
- prev = spark;
- continue;
- }
- SPARK_NEXT(spark) = NULL;
- thespark = spark;
- } else {
- DisposeSpark(spark);
- }
-
- if (spark == PendingSparksHd[pool])
- PendingSparksHd[pool] = next;
-
- if (prev != NULL)
- SPARK_NEXT(prev) = next;
- }
-
- if (PendingSparksHd[pool] == NULL)
- PendingSparksTl[pool] = NULL;
- }
- return (thespark == NULL ? NULL : thespark);
-# endif /* 0 */
-
-#endif
-}
-
-#ifdef PAR
-void
-DisposeSpark(spark)
-P_ spark;
-{
- /* Do nothing */
-}
-
-#else
-# ifndef GRAN
-void
-DisposeSpark(spark)
-sparkq spark;
-{
- if(spark!=NULL)
- free(spark);
-}
-# endif
-#endif
-
-rtsBool
-Spark(closure, required)
-P_ closure;
-rtsBool required;
-{
-#ifdef PAR
- I_ pool = required ? REQUIRED_POOL : ADVISORY_POOL;
-
- if (SHOULD_SPARK(closure) && PendingSparksTl[pool] < PendingSparksLim[pool]) {
- *PendingSparksTl[pool]++ = closure;
- }
-#endif
- return rtsTrue;
-}
-
-#endif /* PAR or GRAN -- whole file */
-\end{code}
+++ /dev/null
-%****************************************************************************
-%
-\section[Sysman.lc]{GUM Sysman Program}
-%
-% (c) The Parade/AQUA Projects, Glasgow University, 1994-1995.
-% P. Trinder, November 30th. 1994.
-%
-%****************************************************************************
-
-The Sysman task currently controls initiation, termination, of a
-parallel Haskell program running under GUM. In the future it may
-control global GC synchronisation and statistics gathering. Based on
-K. Hammond's SysMan.lc in Graph for PVM. SysMan is unusual in that it
-is not part of the executable produced by ghc: it is a free-standing
-program that spawns PVM tasks (logical PEs) to evaluate the
-program. After initialisation it runs in parallel with the PE tasks,
-awaiting messages.
-
-OK children, buckle down for some serious weirdness, it works like this ...
-
-\begin{itemize}
-\item The argument vector (argv) for SysMan has one the following 2 shapes:
-\begin{verbatim}
--------------------------------------------------------------------------------
-| SysMan path | debug flag | pvm-executable path | Num. PEs | Program Args ...|
--------------------------------------------------------------------------------
-
--------------------------------------------------------------------
-| SysMan path | pvm-executable path | Num. PEs | Program Args ... |
--------------------------------------------------------------------
-\end{verbatim}
-The "pvm-executable path" is an absolute path of where PVM stashes the
-code for each PE. The arguments passed on to each PE-executable
-spawned by PVM are:
-\begin{verbatim}
--------------------------------
-| Num. PEs | Program Args ... |
--------------------------------
-\end{verbatim}
-The arguments passed to the Main-thread PE-executable are
-\begin{verbatim}
--------------------------------------------------------------------
-| main flag | pvm-executable path | Num. PEs | Program Args ... |
--------------------------------------------------------------------
-\end{verbatim}
-\item SysMan's algorithm is as follows.
-\begin{itemize}
-\item use PVM to spawn (nPE-1) PVM tasks
-\item fork SysMan to create the main-thread PE. This permits the main-thread to
-read and write to stdin and stdout.
-\item Barrier-synchronise waiting for all of the PE-tasks to start.
-\item Broadcast the SysMan task-id, so that the main thread knows it.
-\item Wait for the Main-thread PE to send it's task-id.
-\item Broadcast an array of the PE task-ids to all of the PE-tasks.
-\item Enter a loop awaiting incoming messages, e.g. failure, Garbage-collection,
-termination.
-\end{itemize}
-
-The forked Main-thread algorithm, in SysMan, is as follows.
-\begin{itemize}
-\item disconnects from PVM.
-\item sets a flag in argv to indicate that it is the main thread.
-\item `exec's a copy of the pvm-executable (i.e. the program being run)
-\end{itemize}
-
-The pvm-executable run by each PE-task, is initialised as follows.
-\begin{itemize}
-\item Registers with PVM, obtaining a task-id.
-\item Joins the barrier synchronisation awaiting the other PEs.
-\item Receives and records the task-id of SysMan, for future use.
-\item If the PE is the main thread it sends its task-id to SysMan.
-\item Receives and records the array of task-ids of the other PEs.
-\item Begins execution.
-\end{itemize}
-
-\end{itemize}
-\begin{code}
-#define NON_POSIX_SOURCE /* so says Solaris */
-
-#include "rtsdefs.h"
-#include "LLC.h"
-\end{code}
-
-The following definitions included so that SysMan can be linked with
-Low Level Communications module (LLComms). They are not used in
-SysMan.
-
-\begin{code}
-GLOBAL_TASK_ID mytid, SysManTask;
-rtsBool IAmMainThread;
-\end{code}
-
-
-\begin{code}
-static GLOBAL_TASK_ID gtids[MAX_PES];
-static long PEbuffer[MAX_PES];
-int nPEs = 0;
-static GLOBAL_TASK_ID sysman_id, sender_id, mainThread_id;
-static unsigned PEsTerminated = 0;
-static rtsBool Finishing = rtsFalse;
-\end{code}
-
-\begin{code}
-#define checkerr(c) do {if((c)<0) { pvm_perror("Sysman"); EXIT(EXIT_FAILURE); }} while(0)
-\end{code}
-
-This Function not yet implemented for GUM
-
-\begin{code}
-static void
-DoGlobalGC(STG_NO_ARGS)
-{}
-/*
-static void
-HandleException(PACKET p)
-{}
-*/
-\end{code}
-
-\begin{code}
-main(int argc, char **argv)
-{
- int rbufid;
- int opcode, nbytes;
- char **pargv;
- int i, cc;
- int spawn_flag = PvmTaskDefault;
- PACKET addr;
-
- char *petask, *pvmExecutable;
-
- setbuf(stdout, NULL);
- setbuf(stderr, NULL);
-
- if (argc > 1) {
- if (*argv[1] == '-') {
- spawn_flag = PvmTaskDebug;
- argv[1] = argv[0];
- argv++; argc--;
- }
- sysman_id = pvm_mytid();/* This must be the first PVM call */
-
- checkerr(sysman_id);
-
- /*
- Get the full path and filename of the pvm executable (stashed in some
- PVM directory.
- */
- pvmExecutable = argv[1];
-
- nPEs = atoi(argv[2]);
-
- if ((petask = getenv(PETASK)) == NULL)
- petask = PETASK;
-
-#if 0
- fprintf(stderr, "nPEs (%s) = %d\n", petask, nPEs);
-#endif
-
- /* Check that we can create the number of PE and IMU tasks requested */
- if (nPEs > MAX_PES) {
- fprintf(stderr, "No more than %d PEs allowed (%d requested)\n", MAX_PES, nPEs);
- EXIT(EXIT_FAILURE);
- }
-
- /*
- Now create the PE Tasks. We spawn (nPEs-1) pvm threads: the Main Thread
- (which starts execution and performs IO) is created by forking SysMan
- */
- nPEs--;
- if (nPEs > 0) {
- /* Initialise the PE task arguments from Sysman's arguments */
- pargv = argv + 2;
-#if 0
- fprintf(stderr, "Spawning %d PEs(%s) ...\n", nPEs, petask);
- fprintf(stderr, " args: ");
- for (i = 0; pargv[i]; ++i)
- fprintf(stderr, "%s, ", pargv[i]);
- fprintf(stderr, "\n");
-#endif
- checkerr(pvm_spawn(petask, pargv, spawn_flag, "", nPEs, gtids));
- /*
- * Stash the task-ids of the PEs away in a buffer, once we know
- * the Main Thread's task-id, we'll broadcast them all.
- */
- for (i = 0; i < nPEs; i++)
- PEbuffer[i+1] = (long) gtids[i];
-#if 0
- fprintf(stderr, "Spawned /* PWT */\n");
-#endif
- }
-
- /*
- Create the MainThread PE by forking SysMan. This arcane coding
- is required to allow MainThread to read stdin and write to stdout.
- PWT 18/1/96
- */
- nPEs++; /* Record that the number of PEs is increasing */
- if (cc = fork()) {
- checkerr(cc); /* Parent continues as SysMan */
-#if 0
- fprintf(stderr, "SysMan Task is [t%x]\n", sysman_id);
-#endif
- /*
- SysMan joins PECTLGROUP, so that it can wait (at the
- barrier sysnchronisation a few instructions later) for the
- other PE-tasks to start.
-
- The manager group (MGRGROUP) is vestigial at the moment. It
- may eventually include a statistics manager, and a (global)
- garbage collector manager.
- */
- checkerr(pvm_joingroup(PECTLGROUP));
-#if 0
- fprintf(stderr, "Joined PECTLGROUP /* PWT */\n");
-#endif
- /* Wait for all the PEs to arrive */
- checkerr(pvm_barrier(PECTLGROUP, nPEs + 1));
-#if 0
- fprintf(stderr, "PECTLGROUP barrier passed /* HWL */\n");
-#endif
- /* Broadcast SysMan's ID, so Main Thread PE knows it */
- pvm_initsend(PvmDataDefault);
- pvm_bcast(PEGROUP, PP_SYSMAN_TID);
-
- /* Wait for Main Thread to identify itself*/
- addr = WaitForPEOp(PP_MAIN_TASK, ANY_GLOBAL_TASK);
- pvm_bufinfo(addr, &nbytes, &opcode, &mainThread_id );
- PEbuffer[0] = mainThread_id;
-#if 0
- fprintf(stderr,"SysMan received Main Task = %x\n",mainThread_id);
-#endif
- /* Now that we have them all, broadcast Global Task Ids of all PEs */
- pvm_initsend(PvmDataDefault);
- PutArgs(PEbuffer, nPEs);
- pvm_bcast(PEGROUP, PP_PETIDS);
-#if 0
- fprintf(stderr, "Sysman successfully initialized!\n");
-#endif
- /* Process incoming messages */
- while (1) {
- if ((rbufid = pvm_recv(ANY_TASK, ANY_OPCODE)) < 0)
- pvm_perror("Sysman: Receiving Message");
- else {
- pvm_bufinfo(rbufid, &nbytes, &opcode, &sender_id);
-#if 0
- fprintf(stderr, "HWL-DBG(SysMan; main loop): rbufid=%x, nbytes = %d, opcode = %x, sender_id = %x\n",
- rbufid, nbytes, opcode, sender_id);
-#endif
- switch (opcode) {
- case PP_GC_INIT:
- /* This Function not yet implemented for GUM */
- fprintf(stderr, "Global GC from %x Not yet implemented for GUM!\n", sender_id);
- sync(PECTLGROUP, PP_FULL_SYSTEM);
- broadcast(PEGROUP, PP_GC_INIT);
- DoGlobalGC();
-/* broadcast(PEGROUP, PP_INIT); */
- break;
-
- case PP_STATS_ON:
- case PP_STATS_OFF:
- /* This Function not yet implemented for GUM */
- break;
-
- case PP_FINISH:
- if (!Finishing) {
- fprintf(stderr, "\nFinish from %x\n", sender_id);
- Finishing = rtsTrue;
- pvm_initsend(PvmDataDefault);
- pvm_bcast(PEGROUP, PP_FINISH);
- } else {
- ++PEsTerminated;
- }
- if (PEsTerminated >= nPEs) {
- broadcast(PEGROUP, PP_FINISH);
- broadcast(MGRGROUP, PP_FINISH);
- pvm_lvgroup(PECTLGROUP);
- pvm_lvgroup(MGRGROUP);
- pvm_exit();
- EXIT(EXIT_SUCCESS);
- }
- break;
-
- case PP_FAIL:
- fprintf(stderr, "Fail from %x\n", sender_id);
- if (!Finishing) {
- Finishing = rtsTrue;
- broadcast(PEGROUP, PP_FAIL);
- }
- break;
-
- default:
- {
-/* char *opname = GetOpName(opcode);
- fprintf(stderr,"Sysman: Unrecognised opcode %s (%x)\n",
- opname,opcode); */
- fprintf(stderr, "Sysman: Unrecognised opcode (%x)\n",
- opcode);
- }
- break;
- } /* switch */
- } /* else */
- } /* while 1 */
- } /* forked Sysman Process */
- else {
- pvmendtask(); /* Disconnect from PVM to avoid confusion: */
- /* executable reconnects */
- *argv[0] = '-'; /* Flag that this is the Main Thread PE */
- execv(pvmExecutable,argv); /* Parent task becomes Main Thread PE */
- }
- } /* argc > 1 */
-} /* main */
-\end{code}
-
-@myexit@ for the system manager.
-
-\begin{code}
-
-void
-myexit(n)
-I_ n;
-{
-#ifdef exit
-#undef exit
-#endif
- exit(n);
-}
-
-\end{code}
+++ /dev/null
-%
-% (c) Parade/AQUA Projects, Glasgow University, 1995
-% Kevin Hammond, February 15th. 1995
-%
-% This is for GUM and GrAnSim.
-%
-%************************************************************************
-%* *
-\section[Unpack.lc]{Unpacking closures which have been exported to remote processors}
-%* *
-%************************************************************************
-
-This module defines routines for unpacking closures in the parallel runtime
-system (GUM).
-
-In the case of GrAnSim, this module defines routines for *simulating* the
-unpacking of closures as it is done in the parallel runtime system.
-
-\begin{code}
-#include "rtsdefs.h"
-
-#if defined(PAR)
-
-EXTDATA_RO(FetchMe_info);
-\end{code}
-
-Local Definitions.
-
-\begin{code}
-static globalAddr *PendingGABuffer; /* HWL; init in main; */
-
-void
-InitPendingGABuffer(size)
-W_ size;
-{
- PendingGABuffer
- = (globalAddr *) stgMallocBytes((size-PACK_HDR_SIZE)*2*sizeof(globalAddr), "InitPendingGABuffer");
-}
-\end{code}
-
-@CommonUp@ commons up two closures which we have discovered to be
-variants of the same object. One is made an indirection to the other.
-
-\begin{code}
-void
-CommonUp(P_ src, P_ dst)
-{
- P_ bqe;
-
- ASSERT(src != dst);
- switch (INFO_TYPE(INFO_PTR(src))) {
- case INFO_SPEC_RBH_TYPE:
- bqe = (P_) SPEC_RBH_BQ(src);
- break;
- case INFO_GEN_RBH_TYPE:
- bqe = (P_) GEN_RBH_BQ(src);
- break;
- case INFO_FETCHME_TYPE:
- bqe = PrelBase_Z91Z93_closure;
- break;
- case INFO_FMBQ_TYPE:
- bqe = (P_) FMBQ_ENTRIES(src);
- break;
- default:
- /* Don't common up anything else */
- return;
-
- }
- /* Note that UPD_IND does *not* awaken the bq */
- UPD_IND(src, dst);
- ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
- if (IS_MUTABLE(INFO_PTR(bqe)))
- AwakenBlockingQueue(bqe);
-}
-
-\end{code}
-
-@UnpackGraph@ unpacks the graph contained in a message buffer. It
-returns a pointer to the new graph. The @gamap@ parameter is set to
-point to an array of (oldGA,newGA) pairs which were created as a
-result of unpacking the buffer; @nGAs@ is set to the number of GA
-pairs which were created.
-
-The format of graph in the pack buffer is as defined in @Pack.lc@.
-
-\begin{code}
-P_
-UnpackGraph(buffer, gamap, nGAs)
-P_ buffer;
-globalAddr **gamap;
-W_ *nGAs;
-{
- W_ size, ptrs, nonptrs, vhs;
-
- P_ bufptr = buffer + PACK_HDR_SIZE;
-
- P_ slotptr;
-
- globalAddr ga;
- P_ closure, existing;
- P_ ip, oldip;
-
- W_ bufsize;
- P_ graphroot, graph, parent;
- W_ pptr = 0, pptrs = 0, pvhs;
- char str[80];
-
- int i;
- globalAddr *gaga;
-
- InitPackBuffer(); /* in case it isn't already init'd */
-
- gaga = PendingGABuffer;
-
- InitClosureQueue();
-
- /* Unpack the header */
- bufsize = buffer[0];
-
- /* allocate heap */
- if (bufsize > 0) {
- graph = AllocateHeap(bufsize);
- ASSERT(graph != NULL);
- }
-
- parent = NULL;
-
- do {
- /* This is where we will ultimately save the closure's address */
- slotptr = bufptr;
-
- /* First, unpack the next GA or PLC */
- ga.weight = *bufptr++;
-
- if (ga.weight > 0) {
- ga.loc.gc.gtid = *bufptr++;
- ga.loc.gc.slot = *bufptr++;
- } else
- ga.loc.plc = (P_) *bufptr++;
-
- /* Now unpack the closure body, if there is one */
- if (isFixed(&ga)) {
- /* No more to unpack; just set closure to local address */
-#ifdef PACK_DEBUG
- fprintf(stderr, "Unpacked PLC at %x \n", ga.loc.plc);
-#endif
- closure = ga.loc.plc;
- } else if (isOffset(&ga)) {
- /* No more to unpack; just set closure to cached address */
- ASSERT(parent != NULL);
- closure = (P_) buffer[ga.loc.gc.slot];
- } else {
-
- /* Now we have to build something. */
-
- ASSERT(bufsize > 0);
-
- /*
- * Close your eyes. You don't want to see where we're looking. You
- * can't get closure info until you've unpacked the variable header,
- * but you don't know how big it is until you've got closure info.
- * So...we trust that the closure in the buffer is organized the
- * same way as they will be in the heap...at least up through the
- * end of the variable header.
- */
- ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs, str);
-
- /* Fill in the fixed header */
- for (i = 0; i < FIXED_HS; i++)
- graph[i] = *bufptr++;
-
- if (INFO_TYPE(ip) == INFO_FETCHME_TYPE)
- size = ptrs = nonptrs = vhs = 0;
-
- /* Fill in the packed variable header */
- for (i = 0; i < vhs; i++)
- graph[FIXED_HS + i] = *bufptr++;
-
- /* Pointers will be filled in later */
-
- /* Fill in the packed non-pointers */
- for (i = 0; i < nonptrs; i++)
- graph[FIXED_HS + i + vhs + ptrs] = *bufptr++;
-
- /* Indirections are never packed */
- ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
-
- /* Add to queue for processing */
- QueueClosure(graph);
-
- /*
- * Common up the new closure with any existing closure having the same
- * GA
- */
-
- if ((existing = GALAlookup(&ga)) == NULL) {
- globalAddr *newGA;
- /* Just keep the new object */
-#ifdef PACK_DEBUG
- fprintf(stderr, "Unpacking new (%x, %d, %x)\n",
- ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
-#endif
- closure = graph;
- newGA = setRemoteGA(graph, &ga, rtsTrue);
- if (INFO_TYPE(ip) == INFO_FETCHME_TYPE)
- FETCHME_GA(closure) = newGA;
- } else {
- /* Two closures, one global name. Someone loses */
- oldip = (P_) INFO_PTR(existing);
-
- if ((INFO_TYPE(oldip) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(oldip)) &&
- INFO_TYPE(ip) != INFO_FETCHME_TYPE) {
-
- /* What we had wasn't worth keeping */
- closure = graph;
- CommonUp(existing, graph);
- } else {
-
- /*
- * Either we already had something worthwhile by this name or
- * the new thing is just another FetchMe. However, the thing we
- * just unpacked has to be left as-is, or the child unpacking
- * code will fail. Remember that the way pointer words are
- * filled in depends on the info pointers of the parents being
- * the same as when they were packed.
- */
-#ifdef PACK_DEBUG
- fprintf(stderr, "Unpacking old (%x, %d, %x), keeping %#lx\n",
- ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight, existing);
-#endif
- closure = existing;
- }
- /* Pool the total weight in the stored ga */
- (void) addWeight(&ga);
- }
-
- /* Sort out the global address mapping */
- if ((IS_THUNK(ip) && IS_UPDATABLE(ip)) ||
- (IS_MUTABLE(ip) && INFO_TYPE(ip) != INFO_FETCHME_TYPE)) {
- /* Make up new GAs for single-copy closures */
- globalAddr *newGA = MakeGlobal(closure, rtsTrue);
-
- ASSERT(closure == graph);
-
- /* Create an old GA to new GA mapping */
- *gaga++ = ga;
- splitWeight(gaga, newGA);
- ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
- gaga++;
- }
- graph += FIXED_HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
- }
-
- /*
- * Set parent pointer to point to chosen closure. If we're at the top of
- * the graph (our parent is NULL), then we want to arrange to return the
- * chosen closure to our caller (possibly in place of the allocated graph
- * root.)
- */
- if (parent == NULL)
- graphroot = closure;
- else
- parent[FIXED_HS + pvhs + pptr] = (W_) closure;
-
- /* Save closure pointer for resolving offsets */
- *slotptr = (W_) closure;
-
- /* Locate next parent pointer */
- pptr++;
- while (pptr + 1 > pptrs) {
- parent = DeQueueClosure();
-
- if (parent == NULL)
- break;
- else {
- (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
- &pvhs, str);
- pptr = 0;
- }
- }
- } while (parent != NULL);
-
- ASSERT(bufsize == 0 || graph - 1 <= SAVE_Hp);
-
- *gamap = PendingGABuffer;
- *nGAs = (gaga - PendingGABuffer) / 2;
-
- /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
- return (graphroot);
-}
-#endif /* PAR */
-\end{code}
-
-For GrAnSim:
-In general no actual unpacking should be necessary. We just have to walk
-over the graph and set the bitmasks appropriately. -- HWL
-
-\begin{code}
-#if defined(GRAN)
-/* This code fakes the unpacking of a somewhat virtual buffer */
-P_
-UnpackGraph(buffer)
-P_ buffer;
-{
- W_ size, ptrs, nonptrs, vhs;
- P_ bufptr, closurestart;
- P_ slotptr;
- P_ closure, existing;
- P_ ip, oldip;
- W_ bufsize, unpackedsize;
- P_ graphroot, graph, parent;
- W_ pptr = 0, pptrs = 0, pvhs;
- char str[80];
- int i;
- P_ tso;
-
- bufptr = buffer + PACK_HDR_SIZE;
- graphroot = *bufptr;
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
- fprintf(stderr,"Qagh: no magic flag at start of packet @ 0x%lx\n",
- buffer);
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- tso = buffer[PACK_TSO_LOCN];
-
- /* Unpack the header */
- unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
- bufsize = buffer[PACK_SIZE_LOCN];
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( RTSflags.GranFlags.debug & 0x100 )
- fprintf(stderr,"\nUnpacking buffer @ 0x%x (root @ 0x%x, PE %d,size
-= %d), demanded by TSO 0x%x (%d)(PE %d)\n",
- buffer,graphroot,where_is(graphroot), bufsize, tso, TSO_ID(tso), where_is(tso));
-# endif
-
- do {
- closurestart = bufptr;
- closure = *bufptr++; /* that's all we need for GrAnSim -- HWL */
-
- /* Actually only ip is needed; rest is useful for TESTING -- HWL */
- ip = get_closure_info(closure,
- &size, &ptrs, &nonptrs, &vhs, str);
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( RTSflags.GranFlags.debug & 0x100 )
- fprintf(stderr,"(0x%x): Bitmask changed [%s]: 0x%x ",
- closure, (IS_NF(INFO_PTR(closure)) ? "NF" : "__"),
- PROCS(closure));
-# endif
-
- if ( (INFO_TYPE(ip) == INFO_SPEC_RBH_TYPE) ||
- (INFO_TYPE(ip) == INFO_GEN_RBH_TYPE) ) {
- PROCS(closure) = PE_NUMBER(CurrentProc); /* Move node */
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- fprintf(stderr," ---> 0x%x\n", PROCS(closure));
- fprintf(stderr,"< Converting RBH @ 0x%x into an updatable
-closure again\n",
- closure);
- }
-# endif
- convertFromRBH(closure); /* In GUM that's done by convertToFetchMe */
- } else if (IS_BLACK_HOLE(ip)) {
- PROCS(closure) |= PE_NUMBER(CurrentProc); /* Copy node */
- } else if ( (PROCS(closure) & PE_NUMBER(CurrentProc)) == 0 ) {
- if (IS_NF(ip)) /* Old: || IS_BQ(node) */
- PROCS(closure) |= PE_NUMBER(CurrentProc); /* Copy node */
- else
- PROCS(closure) = PE_NUMBER(CurrentProc); /* Move node */
- }
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( RTSflags.GranFlags.debug & 0x100 )
- fprintf(stderr," ---> 0x%x\n", PROCS(closure));
-# endif
-
- } while (bufptr<(buffer+bufsize)) ; /* (parent != NULL); */
-
- /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
- free(buffer);
-
- return (graphroot);
-}
-#endif /* GRAN */
-\end{code}
-
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-ErrorHdrHook (StgInt fd)
-{
- const char msg[]="\nFail: ";
- write(fd,msg,sizeof(msg)-1);
-}
-\end{code}
+++ /dev/null
-
-Note: by the time this hook has been called, Haskell land
-will have been shut down completely.
-
-ToDo: feed the hook info on whether we're shutting down as a result
-of termination or run-time error ?
-
-\begin{code}
-#include "rtsdefs.h"
-
-void
-OnExitHook ()
-{
- return;
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-IOErrorHdrHook (StgInt fd)
-{
- const char msg[]="\nI/O error: ";
- write(fd, msg, sizeof(msg)-1);
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-initEachPEHook (void)
-{ /* in a GUM setup this is called on each
- PE immediately before SynchroniseSystem
- it can be used to read in static data
- to each PE which has to be available to
- each PE
-
- This version is the one specialised
- for Lolita, calling the LoadAllData stuff.
- The default version probably should do
- nothing -- HWL
- */
-}
-\end{code}
+++ /dev/null
-
-Hook to invoke when there's nothing left on the runnable threads
-queue {\em and} we've got nothing to wait for. The value
-returned is the exit code to report back.
-
-NOTE: This hook is really CONCURRENT specific, but we include
-it in the way-independent libHSclib.a.
-
-\begin{code}
-#include "rtsdefs.h"
-
-int
-NoRunnableThreadsHook (void)
-{
- fflush(stdout);
- fprintf(stderr, "No runnable threads!\n");
- return(EXIT_FAILURE);
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-OutOfHeapHook (W_ request_size, W_ heap_size) /* both sizes in bytes */
-{
- fprintf(stderr, "Heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse `+RTS -H<size>' to increase the total heap size.\n",
- request_size,
- heap_size);
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-StackOverflowHook (I_ stack_size) /* in bytes */
-{
- fprintf(stderr, "Stack space overflow: current size %ld bytes.\nUse `+RTS -Ksize' to increase it.\n", stack_size);
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-MallocFailHook (I_ request_size /* in bytes */, char *msg)
-{
- fprintf(stderr, "malloc: failed on request for %lu bytes; message: %s\n", request_size, msg);
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-PatErrorHdrHook (StgInt fd)
-{
- const char msg[]="\nFail: ";
- write(fd,msg,sizeof(msg)-1);
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-defaultsHook (void)
-{ /* this is called *after* RTSflags has had
- its defaults set, but *before* we start
- processing the RTS command-line options.
-
- This default version does *nothing*.
- The user may provide a more interesting
- one.
- */
-}
-\end{code}
+++ /dev/null
-\begin{code}
-#include "rtsdefs.h"
-
-void
-PreTraceHook (StgInt fd)
-{
-/* By default, a trace msg doesn't have a header (nor a footer) */
-#if 0
- const char msg[]="Trace On:\n";
- write(fd,msg,sizeof(msg)-1);
-#endif
-}
-
-void
-PostTraceHook (StgInt fd)
-{
-#if 0
- const char msg[]="\nTrace Off.\n";
- write(fd,msg,sizeof(msg)-1);
-#endif
-}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995 - 1996
-% Hans Wolfgang Loidl
-%
-% Time-stamp: <Sun Oct 19 1997 23:39:59 Stardate: [-30]0119.72 hwloidl>
-%
-%************************************************************************
-%* *
-\section[GranSim.lc]{Granularity Simulator Routines}
-%* *
-%************************************************************************
-
-Macros for dealing with the new and improved GA field for simulating
-parallel execution. Based on @CONCURRENT@ package. The GA field now
-contains a mask, where the n-th bit stands for the n-th processor,
-where this data can be found. In case of multiple copies, several bits
-are set. The total number of processors is bounded by @MAX_PROC@,
-which should be <= the length of a word in bits. -- HWL
-
-\begin{code}
-#if defined(GRAN) || defined(PAR)
-
-#ifndef _AIX
-#define NON_POSIX_SOURCE /* gettimeofday */
-#endif
-
-#include "rtsdefs.h"
-
-/* qaStaH nuq Sovpu' ngoqvam ghItlhpu'bogh nuv 'e' vItul */
-# if defined(HAVE_GETCLOCK)
-# if defined(HAVE_SYS_TIMERS_H)
-# define POSIX_4D9 1
-# include <sys/timers.h>
-# endif
-# else
-# if defined(HAVE_GETTIMEOFDAY)
-# if defined(HAVE_SYS_TIME_H)
-# include <sys/time.h>
-# endif
-# else
-# ifdef HAVE_TIME_H
-# include <time.h>
-# endif
-# endif
-# endif
-\end{code}
-
-
-%****************************************************************
-%* *
-\subsection[GranSim-data-types]{Basic data types and set-up variables for GranSim}
-%* *
-%****************************************************************
-
-\begin{code}
-
-/* See GranSim.lh for the definition of the enum gran_event_types */
-char *gran_event_names[] = {
- "START", "START(Q)",
- "STEALING", "STOLEN", "STOLEN(Q)",
- "FETCH", "REPLY", "BLOCK", "RESUME", "RESUME(Q)",
- "SCHEDULE", "DESCHEDULE",
- "END",
- "SPARK", "SPARKAT", "USED", "PRUNED", "EXPORTED", "ACQUIRED",
- "ALLOC",
- "TERMINATE",
- "SYSTEM_START", "SYSTEM_END", /* only for debugging */
- "??"
-};
-
-#if defined(GRAN)
-char *proc_status_names[] = {
- "Idle", "Sparking", "Starting", "Fetching", "Fishing", "Busy",
- "UnknownProcStatus"
-};
-
-#define RAND_MAX 0x7fffffff /* 2^31-1 = 0x80000000 - 1 (see lrand48(3) */
-
-unsigned CurrentProc = 0;
-rtsBool IgnoreEvents = rtsFalse; /* HACK only for testing */
-
-#if 0 && (defined(GCap) || defined(GCgn))
-closq ex_RBH_q = NULL;
-#endif
-#endif /* GRAN */
-\end{code}
-
-The following variables control the behaviour of GrAnSim. In general, there
-is one RTS option for enabling each of these features. In getting the
-desired setup of GranSim the following questions have to be answered:
-\begin{itemize}
-\item {\em Which scheduling algorithm} to use (@RTSflags.GranFlags.DoFairSchedule@)?
- Currently only unfair scheduling is supported.
-\item What to do when remote data is fetched (@RTSflags.GranFlags.DoReScheduleOnFetch@)?
- Either block and wait for the
- data or reschedule and do some other work.
- Thus, if this variable is true, asynchronous communication is
- modelled. Block on fetch mainly makes sense for incremental fetching.
-
- There is also a simplified fetch variant available
- (@RTSflags.GranFlags.SimplifiedFetch@). This variant does not use events to model
- communication. It is faster but the results will be less accurate.
-\item How aggressive to be in getting work after a reschedule on fetch
- (@RTSflags.GranFlags.FetchStrategy@)?
- This is determined by the so-called {\em fetching
- strategy\/}. Currently, there are four possibilities:
- \begin{enumerate}
- \item Only run a runnable thread.
- \item Turn a spark into a thread, if necessary.
- \item Steal a remote spark, if necessary.
- \item Steal a runnable thread from another processor, if necessary.
- \end{itemize}
- The variable @RTSflags.GranFlags.FetchStrategy@ determines how far to go in this list
- when rescheduling on a fetch.
-\item Should sparks or threads be stolen first when looking for work
- (@RTSflags.GranFlags.DoStealThreadsFirst@)?
- The default is to steal sparks first (much cheaper).
-\item Should the RTS use a lazy thread creation scheme
- (@RTSflags.GranFlags.DoAlwaysCreateThreads@)? By default yes i.e.\ sparks are only
- turned into threads when work is needed. Also note, that sparks
- can be discarded by the RTS (this is done in the case of an overflow
- of the spark pool). Setting @RTSflags.GranFlags.DoAlwaysCreateThreads@ to @True@ forces
- the creation of threads at the next possibility (i.e.\ when new work
- is demanded the next time).
-\item Should data be fetched closure-by-closure or in packets
- (@RTSflags.GranFlags.DoGUMMFetching@)? The default strategy is a GRIP-like incremental
- (i.e.\ closure-by-closure) strategy. This makes sense in a
- low-latency setting but is bad in a high-latency system. Setting
- @RTSflags.GranFlags.DoGUMMFetching@ to @True@ enables bulk (packet) fetching. Other
- parameters determine the size of the packets (@pack_buffer_size@) and the number of
- thunks that should be put into one packet (@RTSflags.GranFlags.ThunksToPack@).
-\item If there is no other possibility to find work, should runnable threads
- be moved to an idle processor (@RTSflags.GranFlags.DoThreadMigration@)? In any case, the
- RTS tried to get sparks (either local or remote ones) first. Thread
- migration is very expensive, since a whole TSO has to be transferred
- and probably data locality becomes worse in the process. Note, that
- the closure, which will be evaluated next by that TSO is not
- transferred together with the TSO (that might block another thread).
-\item Should the RTS distinguish between sparks created by local nodes and
- stolen sparks (@RTSflags.GranFlags.PreferSparksOfLocalNodes@)? The idea is to improve
- data locality by preferring sparks of local nodes (it is more likely
- that the data for those sparks is already on the local processor).
- However, such a distinction also imposes an overhead on the spark
- queue management, and typically a large number of sparks are
- generated during execution. By default this variable is set to @False@.
-\item Should the RTS use granularity control mechanisms? The idea of a
- granularity control mechanism is to make use of granularity
- information provided via annotation of the @par@ construct in order
- to prefer bigger threads when either turning a spark into a thread or
- when choosing the next thread to schedule. Currently, three such
- mechanisms are implemented:
- \begin{itemize}
- \item Cut-off: The granularity information is interpreted as a
- priority. If a threshold priority is given to the RTS, then
- only those sparks with a higher priority than the threshold
- are actually created. Other sparks are immediately discarded.
- This is similar to a usual cut-off mechanism often used in
- parallel programs, where parallelism is only created if the
- input data is lage enough. With this option, the choice is
- hidden in the RTS and only the threshold value has to be
- provided as a parameter to the runtime system.
- \item Priority Sparking: This mechanism keeps priorities for sparks
- and chooses the spark with the highest priority when turning
- a spark into a thread. After that the priority information is
- discarded. The overhead of this mechanism comes from
- maintaining a sorted spark queue.
- \item Priority Scheduling: This mechanism keeps the granularity
- information for threads, to. Thus, on each reschedule the
- largest thread is chosen. This mechanism has a higher
- overhead, as the thread queue is sorted, too.
- \end{itemize}
-\end{itemize}
-
-\begin{code}
-#if defined(GRAN)
-
-/* Do we need to reschedule following a fetch? */
-rtsBool NeedToReSchedule = rtsFalse;
-TIME TimeOfNextEvent, EndOfTimeSlice; /* checked from the threaded world! */
-/* I_ avoidedCS=0; */ /* Unused!! ToDo: Remake libraries and nuke this var */
-
-/* For internal use (event statistics) only */
-char *event_names[] =
- { "STARTTHREAD", "CONTINUETHREAD", "RESUMETHREAD",
- "MOVESPARK", "MOVETHREAD", "FINDWORK",
- "FETCHNODE", "FETCHREPLY",
- "GLOBALBLOCK", "UNBLOCKTHREAD"
- };
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
-I_ noOfEvents = 0;
-I_ event_counts[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 };
-
-I_ fetch_misses = 0;
-I_ tot_low_pri_sparks = 0;
-
-I_ rs_sp_count=0, rs_t_count=0, ntimes_total=0, fl_total=0, no_of_steals=0;
-
-/* Variables for gathering packet and queue statistics */
-I_ tot_packets = 0, tot_packet_size = 0, tot_cuts = 0, tot_thunks = 0;
-I_ tot_sq_len = 0, tot_sq_probes = 0, tot_sparks = 0, withered_sparks = 0;
-I_ tot_add_threads = 0, tot_tq_len = 0, non_end_add_threads = 0;
-# endif
-
-# if defined(GRAN_COUNT)
-/* Count the number of updates that are done. Mainly for testing, but
- could be useful for other purposes, too. */
-I_ nUPDs = 0, nUPDs_old = 0, nUPDs_new = 0, nUPDs_BQ = 0, nPAPs = 0,
- BQ_lens = 0;
-# endif
-
-/* Prototypes */
-I_ HandleFetchRequest(P_, PROC, P_);
-/* void HandleFetchRequest(P_, PROC, P_); changed for GUMMFeching */
-static I_ blockFetch(P_ tso, PROC proc, P_ bh);
-
-#endif /* GRAN */
-\end{code}
-
-%****************************************************************
-%* *
-\subsection[global-address-op]{Global Address Operations}
-%* *
-%****************************************************************
-
-These functions perform operations on the global-address (ga) part
-of a closure. The ga is the only new field (1 word) in a closure introduced
-by GrAnSim. It serves as a bitmask, indicating on which processor
-the closure is residing. Since threads are described by Thread State
-Object (TSO), which is nothing but another kind of closure, this
-scheme allows gives placement information about threads.
-
-A ga is just a bitmask, so the operations on them are mainly bitmask
-manipulating functions. Note, that there are important macros like PROCS,
-IS_LOCAL_TO etc. They are defined in @GrAnSim.lh@.
-
-NOTE: In GrAnSim-light we don't maintain placement information. This
-allows to simulate an arbitrary number of processors. The price we have
-to be is the lack of costing any communication properly. In short,
-GrAnSim-light is meant to reveal the maximal parallelism in a program.
-From an implementation point of view the important thing is:
-{\em GrAnSim-light does not maintain global-addresses}.
-
-\begin{code}
-#if defined(GRAN)
-
-/* ga_to_proc returns the first processor marked in the bitmask ga.
- Normally only one bit in ga should be set. But for PLCs all bits
- are set. That shouldn't hurt since we only need IS_LOCAL_TO for PLCs */
-
-PROC
-ga_to_proc(W_ ga)
-{
- PROC i;
- for (i = 0; i < MAX_PROC && !IS_LOCAL_TO(ga, i); i++);
- return (i);
-}
-
-/* NB: This takes a *node* rather than just a ga as input */
-PROC
-where_is(P_ node)
-{ return (ga_to_proc(PROCS(node))); } /* Access the GA field of the node */
-
-rtsBool
-any_idle() {
- I_ i;
- rtsBool any_idle;
- for(i=0, any_idle=rtsFalse;
- !any_idle && i<RTSflags.GranFlags.proc;
- any_idle = any_idle || IS_IDLE(i), i++)
- {} ;
-}
-
-int
-idlers() {
- I_ i, j;
- for(i=0, j=0;
- i<RTSflags.GranFlags.proc;
- j += IS_IDLE(i)?1:0, i++)
- {} ;
- return j;
-}
-#endif /* GRAN */
-\end{code}
-
-%****************************************************************
-%* *
-\subsection[event-queue]{The Global Event Queue}
-%* *
-%****************************************************************
-
-The following routines implement an ADT of an event-queue (FIFO).
-ToDo: Put that in an own file(?)
-
-\begin{code}
-#if defined(GRAN)
-
-/* Pointer to the global event queue; events are currently malloc'ed */
-eventq EventHd = NULL;
-
-eventq
-get_next_event()
-{
- static eventq entry = NULL;
-
- if(EventHd == NULL)
- {
- fprintf(stderr,"No next event. This may be caused by a circular data dependency in the program.\n");
- EXIT(EXIT_FAILURE);
- }
-
- if(entry != NULL)
- free((char *)entry);
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GranFlags.debug & 0x20) { /* count events */
- noOfEvents++;
- event_counts[EVENT_TYPE(EventHd)]++;
- }
-# endif
-
- entry = EventHd;
- EventHd = EVENT_NEXT(EventHd);
- return(entry);
-}
-
-/* When getting the time of the next event we ignore CONTINUETHREAD events:
- we don't want to be interrupted before the end of the current time slice
- unless there is something important to handle.
-*/
-TIME
-get_time_of_next_event()
-{
- eventq event = EventHd;
-
- while (event != NULL && EVENT_TYPE(event)==CONTINUETHREAD) {
- event = EVENT_NEXT(event);
- }
- if(event == NULL)
- return ((TIME) 0);
- else
- return (EVENT_TIME(event));
-}
-
-/* ToDo: replace malloc/free with a free list */
-
-static
-insert_event(newentry)
-eventq newentry;
-{
- EVTTYPE evttype = EVENT_TYPE(newentry);
- eventq event, *prev;
-
- /* if(evttype >= CONTINUETHREAD1) evttype = CONTINUETHREAD; */
-
- /* Search the queue and insert at the right point:
- FINDWORK before everything, CONTINUETHREAD after everything.
-
- This ensures that we find any available work after all threads have
- executed the current cycle. This level of detail would normally be
- irrelevant, but matters for ridiculously low latencies...
- */
-
- /* Changed the ordering: Now FINDWORK comes after everything but
- CONTINUETHREAD. This makes sure that a MOVESPARK comes before a
- FINDWORK. This is important when a GranSimSparkAt happens and
- DoAlwaysCreateThreads is turned on. Also important if a GC occurs
- when trying to build a new thread (see much_spark) -- HWL 02/96 */
-
- if(EventHd == NULL)
- EventHd = newentry;
- else {
- for (event = EventHd, prev=&EventHd;
- event != NULL;
- prev = &(EVENT_NEXT(event)), event = EVENT_NEXT(event)) {
- switch (evttype) {
- case FINDWORK: if ( EVENT_TIME(event) < EVENT_TIME(newentry) ||
- ( (EVENT_TIME(event) == EVENT_TIME(newentry)) &&
- (EVENT_TYPE(event) != CONTINUETHREAD) ) )
- continue;
- else
- break;
- case CONTINUETHREAD: if ( EVENT_TIME(event) <= EVENT_TIME(newentry) )
- continue;
- else
- break;
- default: if ( EVENT_TIME(event) < EVENT_TIME(newentry) ||
- ((EVENT_TIME(event) == EVENT_TIME(newentry)) &&
- (EVENT_TYPE(event) == EVENT_TYPE(newentry))) )
- continue;
- else
- break;
- }
- /* Insert newentry here (i.e. before event) */
- *prev = newentry;
- EVENT_NEXT(newentry) = event;
- break;
- }
- if (event == NULL)
- *prev = newentry;
- }
-}
-
-void
-new_event(proc,creator,time,evttype,tso,node,spark)
-PROC proc, creator;
-TIME time;
-EVTTYPE evttype;
-P_ tso, node;
-sparkq spark;
-{
- eventq newentry = (eventq) stgMallocBytes(sizeof(struct event), "new_event");
-
- EVENT_PROC(newentry) = proc;
- EVENT_CREATOR(newentry) = creator;
- EVENT_TIME(newentry) = time;
- EVENT_TYPE(newentry) = evttype;
- EVENT_TSO(newentry) = tso;
- EVENT_NODE(newentry) = node;
- EVENT_SPARK(newentry) = spark;
- EVENT_GC_INFO(newentry) = 0;
- EVENT_NEXT(newentry) = NULL;
-
- insert_event(newentry);
-}
-
-void
-prepend_event(eventq event) /* put event at beginning of EventQueue */
-{ /* only used for GC! */
- EVENT_NEXT(event) = EventHd;
- EventHd = event;
-}
-
-eventq
-grab_event() /* undo prepend_event i.e. get the event */
-{ /* at the head of EventQ but don't free anything */
- eventq event = EventHd;
-
- if(EventHd == NULL) {
- fprintf(stderr,"No next event (in grab_event). This may be caused by a circular data dependency in the program.\n");
- EXIT(EXIT_FAILURE);
- }
-
- EventHd = EVENT_NEXT(EventHd);
- return (event);
-}
-
-void
-traverse_eventq_for_gc()
-{
- eventq event = EventHd;
- W_ bufsize;
- P_ closure, tso, buffer, bufptr;
- PROC proc, creator;
-
- /* Traverse eventq and replace every FETCHREPLY by a FETCHNODE for the
- orig closure (root of packed graph). This means that a graph, which is
- between processors at the time of GC is fetched again at the time when
- it would have arrived, had there been no GC. Slightly inaccurate but
- safe for GC.
- This is only needed for GUM style fetchng. */
- if (!RTSflags.GranFlags.DoGUMMFetching)
- return;
-
- for(event = EventHd; event!=NULL; event=EVENT_NEXT(event)) {
- if (EVENT_TYPE(event)==FETCHREPLY) {
- buffer = EVENT_NODE(event);
- ASSERT(buffer[PACK_FLAG_LOCN]==MAGIC_PACK_FLAG); /* It's a pack buffer */
- bufsize = buffer[PACK_SIZE_LOCN];
- closure= (P_)buffer[PACK_HDR_SIZE];
- tso = (P_)buffer[PACK_TSO_LOCN];
- proc = EVENT_PROC(event);
- creator = EVENT_CREATOR(event); /* similar to unpacking */
- for (bufptr=buffer+PACK_HDR_SIZE; bufptr<(buffer+bufsize);
- bufptr++) {
- if ( (INFO_TYPE(INFO_PTR(*bufptr)) == INFO_SPEC_RBH_TYPE) ||
- (INFO_TYPE(INFO_PTR(*bufptr)) == INFO_GEN_RBH_TYPE) ) {
- convertFromRBH((P_)*bufptr);
- }
- }
- free(buffer);
- EVENT_TYPE(event) = FETCHNODE;
- EVENT_PROC(event) = creator;
- EVENT_CREATOR(event) = proc;
- EVENT_NODE(event) = closure;
- EVENT_TSO(event) = tso;
- EVENT_GC_INFO(event) = 0;
- }
- }
-}
-
-void
-print_event(event)
-eventq event;
-{
-
- char str_tso[16], str_node[16];
-
- sprintf(str_tso,((EVENT_TSO(event)==PrelBase_Z91Z93_closure) ? "______" : "%#6lx"),
- EVENT_TSO(event));
- sprintf(str_node,((EVENT_NODE(event)==PrelBase_Z91Z93_closure) ? "______" : "%#6lx"),
- EVENT_NODE(event));
-
- if (event==NULL)
- fprintf(stderr,"Evt: NIL\n");
- else
- fprintf(stderr,"Evt: %s (%u), PE %u [%u], Time %lu, TSO %s (%x), node %s\n",
- event_names[EVENT_TYPE(event)],EVENT_TYPE(event),
- EVENT_PROC(event), EVENT_CREATOR(event), EVENT_TIME(event),
- str_tso, TSO_ID(EVENT_TSO(event)), str_node
- /*, EVENT_SPARK(event), EVENT_NEXT(event)*/ );
-
-}
-
-void
-print_eventq(hd)
-eventq hd;
-{
- eventq x;
-
- fprintf(stderr,"Event Queue with root at %x:\n",hd);
- for (x=hd; x!=NULL; x=EVENT_NEXT(x)) {
- print_event(x);
- }
-}
-
-void
-print_spark(spark)
- sparkq spark;
-{
- char str[16];
-
- sprintf(str,((SPARK_NODE(spark)==PrelBase_Z91Z93_closure) ? "______" : "%#6lx"),
- (W_) SPARK_NODE(spark));
-
- if (spark==NULL)
- fprintf(stderr,"Spark: NIL\n");
- else
- fprintf(stderr,"Spark: Node %8s, Name %#6lx, Exported %5s, Prev %#6x, Next %#6x\n",
- str, SPARK_NAME(spark),
- ((SPARK_EXPORTED(spark))?"True":"False"),
- SPARK_PREV(spark), SPARK_NEXT(spark) );
-}
-
-void
-print_sparkq(hd)
-sparkq hd;
-{
- sparkq x;
-
- fprintf(stderr,"Spark Queue with root at %x:\n",hd);
- for (x=hd; x!=NULL; x=SPARK_NEXT(x)) {
- print_spark(x);
- }
-}
-
-
-#endif /* GRAN */
-\end{code}
-
-%****************************************************************************
-%
-\subsection[entry-points]{Routines directly called from Haskell world}
-%
-%****************************************************************************
-
-The @GranSim...@ routines in here are directly called via macros from the
-threaded world.
-
-First some auxiliary routines.
-
-\begin{code}
-#if defined(GRAN)
-/* Take the current thread off the thread queue and thereby activate the */
-/* next thread. It's assumed that the next ReSchedule after this uses */
-/* NEW_THREAD as param. */
-/* This fct is called from GranSimBlock and GranSimFetch */
-
-void
-ActivateNextThread (PROC proc)
-{
- ASSERT(RunnableThreadsHd[proc]!=PrelBase_Z91Z93_closure);
-
- RunnableThreadsHd[proc] = TSO_LINK(RunnableThreadsHd[proc]);
- if(RunnableThreadsHd[proc]==PrelBase_Z91Z93_closure) {
- MAKE_IDLE(proc);
- RunnableThreadsTl[proc] = PrelBase_Z91Z93_closure;
- } else {
- CurrentTime[proc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
- if (RTSflags.GranFlags.granSimStats &&
- (!RTSflags.GranFlags.Light || (RTSflags.GranFlags.debug & 0x20000)))
- DumpRawGranEvent(proc,0,GR_SCHEDULE,RunnableThreadsHd[proc],
- PrelBase_Z91Z93_closure,0);
- }
-}
-\end{code}
-
-Now the main stg-called routines:
-
-\begin{code}
-/* ------------------------------------------------------------------------ */
-/* The following GranSim... fcts are stg-called from the threaded world. */
-/* ------------------------------------------------------------------------ */
-
-/* Called from HEAP_CHK -- NB: node and liveness are junk here now.
- They are left temporarily to avoid complete recompilation.
- KH
-*/
-void
-GranSimAllocate(n,node,liveness)
-I_ n;
-P_ node;
-W_ liveness;
-{
- TSO_ALLOCS(CurrentTSO) += n;
- ++TSO_BASICBLOCKS(CurrentTSO);
-
- if (RTSflags.GranFlags.granSimStats_Heap) {
- DumpRawGranEvent(CurrentProc,0,GR_ALLOC,CurrentTSO,
- PrelBase_Z91Z93_closure,n);
- }
-
- TSO_EXECTIME(CurrentTSO) += RTSflags.GranFlags.gran_heapalloc_cost;
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_heapalloc_cost;
-}
-
-/*
- Subtract the values added above, if a heap check fails and
- so has to be redone.
-*/
-void
-GranSimUnallocate(n,node,liveness)
-W_ n;
-P_ node;
-W_ liveness;
-{
- TSO_ALLOCS(CurrentTSO) -= n;
- --TSO_BASICBLOCKS(CurrentTSO);
-
- TSO_EXECTIME(CurrentTSO) -= RTSflags.GranFlags.gran_heapalloc_cost;
- CurrentTime[CurrentProc] -= RTSflags.GranFlags.gran_heapalloc_cost;
-}
-
-/* NB: We now inline this code via GRAN_EXEC rather than calling this fct */
-void
-GranSimExec(ariths,branches,loads,stores,floats)
-W_ ariths,branches,loads,stores,floats;
-{
- W_ cost = RTSflags.GranFlags.gran_arith_cost*ariths +
- RTSflags.GranFlags.gran_branch_cost*branches +
- RTSflags.GranFlags.gran_load_cost * loads +
- RTSflags.GranFlags.gran_store_cost*stores +
- RTSflags.GranFlags.gran_float_cost*floats;
-
- TSO_EXECTIME(CurrentTSO) += cost;
- CurrentTime[CurrentProc] += cost;
-}
-
-
-/*
- Fetch the node if it isn't local
- -- result indicates whether fetch has been done.
-
- This is GRIP-style single item fetching.
-*/
-
-/* This function in Threads.lc is only needed for SimplifiedFetch */
-FetchNode PROTO((P_ node,PROC CurrentProc));
-
-I_
-GranSimFetch(node /* , liveness_mask */ )
-P_ node;
-/* I_ liveness_mask; */
-{
- if (RTSflags.GranFlags.Light) {
- /* Always reschedule in GrAnSim-Light to prevent one TSO from
- running off too far
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,CurrentTSO,node,NULL);
- */
- NeedToReSchedule = rtsFalse;
- return(0);
- }
-
- /* Note: once a node has been fetched, this test will be passed */
- if(!IS_LOCAL_TO(PROCS(node),CurrentProc))
- {
- /* Add mpacktime to the remote PE for the reply */
- {
- PROC p = where_is(node);
- TIME fetchtime;
-
-# ifdef GRAN_CHECK
- if ( ( RTSflags.GranFlags.debug & 0x40 ) &&
- p == CurrentProc )
- fprintf(stderr,"GranSimFetch: Trying to fetch from own processor%u\n", p);
-# endif /* GRAN_CHECK */
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
- /* NB: Fetch is counted on arrival (FETCHREPLY) */
-
- if (RTSflags.GranFlags.SimplifiedFetch)
- {
- FetchNode(node,CurrentProc);
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime+
- RTSflags.GranFlags.gran_fetchtime+
- RTSflags.GranFlags.gran_munpacktime;
- return(1);
- }
-
- fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p]) +
- RTSflags.GranFlags.gran_latency;
-
- new_event(p,CurrentProc,fetchtime,FETCHNODE,CurrentTSO,node,NULL);
- if (!RTSflags.GranFlags.DoReScheduleOnFetch)
- MAKE_FETCHING(CurrentProc);
- ++OutstandingFetches[CurrentProc];
-
- if (fetchtime<TimeOfNextEvent)
- TimeOfNextEvent = fetchtime;
-
- /* About to block */
- TSO_BLOCKEDAT(CurrentTSO) = CurrentTime[CurrentProc];
-
- if (RTSflags.GranFlags.DoReScheduleOnFetch)
- {
- /* Remove CurrentTSO from the queue
- -- assumes head of queue == CurrentTSO */
- if(!RTSflags.GranFlags.DoFairSchedule)
- {
- if(RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,
- node,0);
-
- ActivateNextThread(CurrentProc);
-
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x10) {
- if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
- fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
- CurrentTSO,CurrentTime[CurrentProc]);
- EXIT(EXIT_FAILURE);
- } else {
- TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
- }
- }
-# endif
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;
- /* CurrentTSO = PrelBase_Z91Z93_closure; */
-
- /* ThreadQueueHd is now the next TSO to schedule or NULL */
- /* CurrentTSO is pointed to by the FETCHNODE event */
- }
- else /* fair scheduling currently not supported -- HWL */
- {
- fprintf(stderr,"Reschedule-on-fetch is not yet compatible with fair scheduling\n");
- EXIT(EXIT_FAILURE);
- }
- }
- else /* !RTSflags.GranFlags.DoReScheduleOnFetch */
- {
- /* Note: CurrentProc is still busy as it's blocked on fetch */
- if(RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,node,0);
-
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x04)
- BlockedOnFetch[CurrentProc] = CurrentTSO; /*- rtsTrue; -*/
- if (RTSflags.GranFlags.debug & 0x10) {
- if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
- fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
- CurrentTSO,CurrentTime[CurrentProc]);
- EXIT(EXIT_FAILURE);
- } else {
- TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
- }
- CurrentTSO = PrelBase_Z91Z93_closure;
- }
-# endif
- }
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
-
- /* Rescheduling is necessary */
- NeedToReSchedule = rtsTrue;
-
- return(1);
- }
- }
- return(0);
-}
-
-void
-GranSimSpark(local,node)
-W_ local;
-P_ node;
-{
- /* ++SparksAvail; Nope; do that in add_to_spark_queue */
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(CurrentProc,(PROC)0,SP_SPARK,PrelBase_Z91Z93_closure,node,
- spark_queue_len(CurrentProc,ADVISORY_POOL)-1);
-
- /* Force the PE to take notice of the spark */
- if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
- if (CurrentTime[CurrentProc]<TimeOfNextEvent)
- TimeOfNextEvent = CurrentTime[CurrentProc];
- }
-
- if(local)
- ++TSO_LOCALSPARKS(CurrentTSO);
- else
- ++TSO_GLOBALSPARKS(CurrentTSO);
-}
-
-void
-GranSimSparkAt(spark,where,identifier)
-sparkq spark;
-P_ where; /* This should be a node; alternatively could be a GA */
-I_ identifier;
-{
- PROC p = where_is(where);
- GranSimSparkAtAbs(spark,p,identifier);
-}
-
-void
-GranSimSparkAtAbs(spark,proc,identifier)
-sparkq spark;
-PROC proc;
-I_ identifier;
-{
- TIME exporttime;
-
- if ( spark == (sparkq)NULL) /* Note: Granularity control might have */
- return; /* turned a spark into a NULL. */
-
- /* ++SparksAvail; Nope; do that in add_to_spark_queue */
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(proc,0,SP_SPARKAT,PrelBase_Z91Z93_closure,SPARK_NODE(spark),
- spark_queue_len(proc,ADVISORY_POOL));
-
- if (proc!=CurrentProc) {
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
- exporttime = (CurrentTime[proc] > CurrentTime[CurrentProc]?
- CurrentTime[proc]: CurrentTime[CurrentProc])
- + RTSflags.GranFlags.gran_latency;
- } else {
- exporttime = CurrentTime[CurrentProc];
- }
-
- if ( RTSflags.GranFlags.Light )
- /* Need CurrentTSO in event field to associate costs with creating
- spark even in a GrAnSim Light setup */
- new_event(proc,CurrentProc,exporttime,
- MOVESPARK,CurrentTSO,PrelBase_Z91Z93_closure,spark);
- else
- new_event(proc,CurrentProc,exporttime,
- MOVESPARK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,spark);
- /* Bit of a hack to treat placed sparks the same as stolen sparks */
- ++OutstandingFishes[proc];
-
- /* Force the PE to take notice of the spark (FINDWORK is put after a
- MOVESPARK into the sparkq!) */
- if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
- new_event(CurrentProc,CurrentProc,exporttime+1,
- FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
- }
-
- if (exporttime<TimeOfNextEvent)
- TimeOfNextEvent = exporttime;
-
- if (proc!=CurrentProc) {
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
- ++TSO_GLOBALSPARKS(CurrentTSO);
- } else {
- ++TSO_LOCALSPARKS(CurrentTSO);
- }
-}
-
-/* This function handles local and global blocking */
-/* It's called either from threaded code (RBH_entry, BH_entry etc) or */
-/* from blockFetch when trying to fetch an BH or RBH */
-
-void
-GranSimBlock(P_ tso, PROC proc, P_ node)
-{
- PROC node_proc = where_is(node);
-
- ASSERT(tso==RunnableThreadsHd[proc]);
-
- if(RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(proc,node_proc,GR_BLOCK,tso,node,0);
-
- ++TSO_BLOCKCOUNT(tso);
- /* Distinction between local and global block is made in blockFetch */
- TSO_BLOCKEDAT(tso) = CurrentTime[proc];
-
- CurrentTime[proc] += RTSflags.GranFlags.gran_threadqueuetime;
- ActivateNextThread(proc);
- TSO_LINK(tso) = PrelBase_Z91Z93_closure; /* not really necessary; only for testing */
-}
-
-#endif /* GRAN */
-
-\end{code}
-
-%****************************************************************************
-%
-\subsection[GrAnSim-profile]{Writing profiling info for GrAnSim}
-%
-%****************************************************************************
-
-Event dumping routines.
-
-\begin{code}
-
-/*
- * If you're not using GNUC and you're on a 32-bit machine, you're
- * probably out of luck here. However, since CONCURRENT currently
- * requires GNUC, I'm not too worried about it. --JSM
- */
-
-#if !defined(GRAN)
-
-static ullong startTime = 0;
-
-ullong
-msTime(STG_NO_ARGS)
-{
-# ifdef HAVE_GETCLOCK
- struct timespec tv;
-
- if (getclock(TIMEOFDAY, &tv) != 0) {
- fflush(stdout);
- fprintf(stderr, "Clock failed\n");
- EXIT(EXIT_FAILURE);
- }
- return tv.tv_sec * LL(1000) + tv.tv_nsec / LL(1000000) - startTime;
-# else
-# ifdef HAVE_GETTIMEOFDAY
- struct timeval tv;
-
- if (gettimeofday(&tv, NULL) != 0) {
- fflush(stdout);
- fprintf(stderr, "Clock failed\n");
- EXIT(EXIT_FAILURE);
- }
- return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime;
-# else
- time_t t;
- if ((t = time(NULL)) == (time_t) -1) {
- fflush(stdout);
- fprintf(stderr, "Clock failed\n");
- EXIT(EXIT_FAILURE);
- }
- return t * LL(1000);
-# endif
-# endif
-}
-
-#endif /* !GRAN */
-
-#if defined(GRAN) || defined(PAR)
-
-void
-DumpGranEvent(name, tso)
-enum gran_event_types name;
-P_ tso;
-{
- DumpRawGranEvent(CURRENT_PROC, (PROC)0, name, tso, PrelBase_Z91Z93_closure, 0);
-}
-
-void
-DumpRawGranEvent(proc, p, name, tso, node, len)
-PROC proc, p; /* proc ... where it happens; p ... where node lives */
-enum gran_event_types name;
-P_ tso, node;
-I_ len;
-{
- W_ id;
- char time_string[500], node_str[16]; /*ToDo: kill magic constants */
- ullong_format_string(TIME_ON_PROC(proc), time_string, rtsFalse/*no commas!*/);
-#if defined(GRAN)
- if (RTSflags.GranFlags.granSimStats_suppressed)
- return;
-#endif
-
- id = tso == NULL ? -1 : TSO_ID(tso);
- if (node==PrelBase_Z91Z93_closure)
- strcpy(node_str,"________"); /* "PrelBase_Z91Z93_closure"); */
- else
- sprintf(node_str,"0x%-6lx",node);
-
- if (name > GR_EVENT_MAX)
- name = GR_EVENT_MAX;
-
- if(GRANSIMSTATS_BINARY)
- /* ToDo: fix code for writing binary GrAnSim statistics */
- switch (name) {
- case GR_START:
- case GR_STARTQ:
- grputw(name);
- grputw(proc);
- abort(); /* die please: a single word */
- /* doesn't represent long long times */
- grputw(TIME_ON_PROC(proc));
- grputw((W_)node);
- break;
- case GR_FETCH:
- case GR_REPLY:
- case GR_BLOCK:
- grputw(name);
- grputw(proc);
- abort(); /* die please: a single word */
- /* doesn't represent long long times */
- grputw(TIME_ON_PROC(proc)); /* this line is bound to */
- grputw(id); /* do the wrong thing */
- break;
- default:
- grputw(name);
- grputw(proc);
- abort(); /* die please: a single word */
- /* doesn't represent long long times */
- grputw(TIME_ON_PROC(proc));
- grputw((W_)node);
- }
- else
- switch (name) {
- case GR_START:
- case GR_STARTQ:
- /* fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n", */
- /* using spark queue length as optional argument ^^^^^^^^^ */
- fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[SN %u]\n",
- /* using spark name as optional argument ^^^^^^ */
- proc,time_string,gran_event_names[name],
- id,node_str,len);
- break;
- case GR_FETCH:
- case GR_REPLY:
- case GR_BLOCK:
- case GR_STOLEN:
- case GR_STOLENQ:
- fprintf(gr_file, "PE %2u [%s]: %-9s\t%lx \t%s\t(from %2u)\n",
- proc, time_string, gran_event_names[name],
- id,node_str,p);
- break;
- case GR_RESUME:
- case GR_RESUMEQ:
- case GR_SCHEDULE:
- case GR_DESCHEDULE:
- fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx \n",
- proc,time_string,gran_event_names[name],id);
- break;
- case GR_STEALING:
- fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t \t(by %2u)\n",
- proc,time_string,gran_event_names[name],id,p);
- break;
- case GR_ALLOC:
- fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t \tallocating %u words\n",
- proc,time_string,gran_event_names[name],id,len);
- break;
- default:
- fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n",
- proc,time_string,gran_event_names[name],id,node_str,len);
- }
-}
-
-
-#if defined(GRAN)
-/* Only needed for special dynamic spark labelling support */
-void
-DumpStartEventAt(time, proc, p, name, tso, node, len)
-TIME time;
-PROC proc, p; /* proc ... where it happens; p ... where node lives */
-enum gran_event_types name;
-P_ tso, node;
-I_ len;
-{
- W_ id;
- char time_string[500], node_str[16]; /*ToDo: kill magic constants */
- ullong_format_string(time, time_string, rtsFalse/*no commas!*/);
- /* ^^^^ only important change to DumpRawGranEvent */
- if (RTSflags.GranFlags.granSimStats_suppressed)
- return;
-
- id = tso == NULL ? -1 : TSO_ID(tso);
- if (node==PrelBase_Z91Z93_closure)
- strcpy(node_str,"________"); /* "Z91Z93_closure"); */
- else
- sprintf(node_str,"0x%-6lx",node);
-
- if (name > GR_EVENT_MAX)
- name = GR_EVENT_MAX;
-
- if(GRANSIMSTATS_BINARY)
- /* ToDo: fix code for writing binary GrAnSim statistics */
- switch (name) {
- case GR_START:
- case GR_STARTQ:
- grputw(name);
- grputw(proc);
- abort(); /* die please: a single word */
- /* doesn't represent long long times */
- grputw(TIME_ON_PROC(proc));
- grputw((W_)node);
- break;
- default:
- fprintf(stderr,"Error in DumpStartEventAt: event %s is not a START event\n",
- gran_event_names[name]);
- }
- else
- switch (name) {
- case GR_START:
- case GR_STARTQ:
- /* fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n", */
- /* using spark queue length as optional argument ^^^^^^^^^ */
- fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[SN %u]\n",
- /* using spark name as optional argument ^^^^^^ */
- proc,time_string,gran_event_names[name],
- id,node_str,len);
- break;
- default:
- fprintf(stderr,"Error in DumpStartEventAt: event %s is not a START event\n",
- gran_event_names[name]);
- }
-}
-#endif /* GRAN */
-
-void
-DumpGranInfo(proc, tso, mandatory_thread)
-PROC proc;
-P_ tso;
-rtsBool mandatory_thread;
-{
- char time_string[500]; /* ToDo: kill magic constant */
- ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
-
-#if defined(GRAN)
- if (RTSflags.GranFlags.granSimStats_suppressed)
- return;
-#endif
-
- if (GRANSIMSTATS_BINARY) {
- grputw(GR_END);
- grputw(proc);
- abort(); /* die please: a single word doesn't represent long long times */
- grputw(CURRENT_TIME); /* this line is bound to fail */
- grputw(TSO_ID(tso));
-#ifdef PAR
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
- grputw(0);
-#else
- grputw(TSO_SPARKNAME(tso));
- grputw(TSO_STARTEDAT(tso));
- grputw(TSO_EXPORTED(tso));
- grputw(TSO_BASICBLOCKS(tso));
- grputw(TSO_ALLOCS(tso));
- grputw(TSO_EXECTIME(tso));
- grputw(TSO_BLOCKTIME(tso));
- grputw(TSO_BLOCKCOUNT(tso));
- grputw(TSO_FETCHTIME(tso));
- grputw(TSO_FETCHCOUNT(tso));
- grputw(TSO_LOCALSPARKS(tso));
- grputw(TSO_GLOBALSPARKS(tso));
-#endif
- grputw(mandatory_thread);
- } else {
-
- /*
- * NB: DumpGranEvent cannot be used because PE may be wrong
- * (as well as the extra info)
- */
- fprintf(gr_file, "PE %2u [%s]: END %lx, SN %lu, ST %lu, EXP %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu), LS %lu, GS %lu, MY %c\n"
- ,proc
- ,time_string
- ,TSO_ID(tso)
- ,TSO_SPARKNAME(tso)
- ,TSO_STARTEDAT(tso)
- ,TSO_EXPORTED(tso) ? 'T' : 'F'
- ,TSO_BASICBLOCKS(tso)
- ,TSO_ALLOCS(tso)
- ,TSO_EXECTIME(tso)
- ,TSO_BLOCKTIME(tso)
- ,TSO_BLOCKCOUNT(tso)
- ,TSO_FETCHTIME(tso)
- ,TSO_FETCHCOUNT(tso)
- ,TSO_LOCALSPARKS(tso)
- ,TSO_GLOBALSPARKS(tso)
- ,mandatory_thread ? 'T' : 'F'
- );
- }
-}
-
-void
-DumpTSO(tso)
-P_ tso;
-{
- fprintf(stderr,"TSO 0x%lx, NAME 0x%lx, ID %lu, LINK 0x%lx, TYPE %s\n"
- ,tso
- ,TSO_NAME(tso)
- ,TSO_ID(tso)
- ,TSO_LINK(tso)
- ,TSO_TYPE(tso)==T_MAIN?"MAIN":
- TSO_TYPE(tso)==T_FAIL?"FAIL":
- TSO_TYPE(tso)==T_REQUIRED?"REQUIRED":
- TSO_TYPE(tso)==T_ADVISORY?"ADVISORY":
- "???"
- );
-
- fprintf(stderr,"PC (0x%lx,0x%lx), ARG (0x%lx), SWITCH %lx0x\n"
- ,TSO_PC1(tso)
- ,TSO_PC2(tso)
- ,TSO_ARG1(tso)
- /* ,TSO_ARG2(tso) */
- ,TSO_SWITCH(tso)
- );
-
- fprintf(gr_file,"TSO %lx: SN %lu, ST %lu, GBL %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu) LS %lu, GS %lu\n"
- ,TSO_ID(tso)
- ,TSO_SPARKNAME(tso)
- ,TSO_STARTEDAT(tso)
- ,TSO_EXPORTED(tso)?'T':'F'
- ,TSO_BASICBLOCKS(tso)
- ,TSO_ALLOCS(tso)
- ,TSO_EXECTIME(tso)
- ,TSO_BLOCKTIME(tso)
- ,TSO_BLOCKCOUNT(tso)
- ,TSO_FETCHTIME(tso)
- ,TSO_FETCHCOUNT(tso)
- ,TSO_LOCALSPARKS(tso)
- ,TSO_GLOBALSPARKS(tso)
- );
-}
-
-/*
- Output a terminate event and an 8-byte time.
-*/
-
-void
-grterminate(v)
-TIME v;
-{
-#if defined(GRAN)
- if (RTSflags.GranFlags.granSimStats_suppressed)
- return;
-#endif
-
- DumpGranEvent(GR_TERMINATE, PrelBase_Z91Z93_closure);
-
- if (sizeof(TIME) == 4) {
- putc('\0', gr_file);
- putc('\0', gr_file);
- putc('\0', gr_file);
- putc('\0', gr_file);
- } else {
- putc(v >> 56l, gr_file);
- putc((v >> 48l) & 0xffl, gr_file);
- putc((v >> 40l) & 0xffl, gr_file);
- putc((v >> 32l) & 0xffl, gr_file);
- }
- putc((v >> 24l) & 0xffl, gr_file);
- putc((v >> 16l) & 0xffl, gr_file);
- putc((v >> 8l) & 0xffl, gr_file);
- putc(v & 0xffl, gr_file);
-}
-
-/*
- Length-coded output: first 3 bits contain length coding
-
- 00x 1 byte
- 01x 2 bytes
- 10x 4 bytes
- 110 8 bytes
- 111 5 or 9 bytes
-*/
-
-void
-grputw(v)
-TIME v;
-{
-#if defined(GRAN)
- if (RTSflags.GranFlags.granSimStats_suppressed)
- return;
-#endif
-
- if (v <= 0x3fl) { /* length v = 1 byte */
- fputc(v & 0x3f, gr_file);
- } else if (v <= 0x3fffl) { /* length v = 2 byte */
- fputc((v >> 8l) | 0x40l, gr_file);
- fputc(v & 0xffl, gr_file);
- } else if (v <= 0x3fffffffl) { /* length v = 4 byte */
- fputc((v >> 24l) | 0x80l, gr_file);
- fputc((v >> 16l) & 0xffl, gr_file);
- fputc((v >> 8l) & 0xffl, gr_file);
- fputc(v & 0xffl, gr_file);
- } else if (sizeof(TIME) == 4) {
- fputc(0x70, gr_file);
- fputc((v >> 24l) & 0xffl, gr_file);
- fputc((v >> 16l) & 0xffl, gr_file);
- fputc((v >> 8l) & 0xffl, gr_file);
- fputc(v & 0xffl, gr_file);
- } else {
- if (v <= 0x3fffffffffffffl)
- putc((v >> 56l) | 0x60l, gr_file);
- else {
- putc(0x70, gr_file);
- putc((v >> 56l) & 0xffl, gr_file);
- }
-
- putc((v >> 48l) & 0xffl, gr_file);
- putc((v >> 40l) & 0xffl, gr_file);
- putc((v >> 32l) & 0xffl, gr_file);
- putc((v >> 24l) & 0xffl, gr_file);
- putc((v >> 16l) & 0xffl, gr_file);
- putc((v >> 8l) & 0xffl, gr_file);
- putc(v & 0xffl, gr_file);
- }
-}
-
-#endif /* GRAN || PAR */
-\end{code}
-
-%****************************************************************************
-%
-\subsection[gr-simulation]{Granularity Simulation}
-%
-%****************************************************************************
-
-General routines for GranSim. Mainly, startup and shutdown routines, called
-from @main.lc@.
-
-\begin{code}
-#if defined(GRAN)
-FILE *gr_file = NULL;
-char gr_filename[STATS_FILENAME_MAXLEN];
-/* I_ do_gr_sim = 0; */ /* In GrAnSim setup always do simulation */
-
-int
-init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv)
-char *prog_argv[], *rts_argv[];
-int prog_argc, rts_argc;
-{
- I_ i;
-
- char *extension = RTSflags.GranFlags.granSimStats_Binary ? "gb" : "gr";
-
- if (RTSflags.GranFlags.granSimStats_suppressed)
- return;
-
- sprintf(gr_filename, GR_FILENAME_FMT, prog_argv[0], extension);
-
- if ((gr_file = fopen(gr_filename, "w")) == NULL) {
- fprintf(stderr, "Can't open granularity simulation report file %s\n", gr_filename);
- EXIT(EXIT_FAILURE);
- }
-# if 0 /* that's obsolete now, I think -- HWL */
- if (RTSflags.GranFlags.DoReScheduleOnFetch)
- setbuf(gr_file, NULL);
-# endif
-
- fputs("Granularity Simulation for ", gr_file);
- for (i = 0; i < prog_argc; ++i) {
- fputs(prog_argv[i], gr_file);
- fputc(' ', gr_file);
- }
-
- if (rts_argc > 0) {
- fputs("+RTS ", gr_file);
-
- for (i = 0; i < rts_argc; ++i) {
- fputs(rts_argv[i], gr_file);
- fputc(' ', gr_file);
- }
- }
-
- fputs("\nStart time: ", gr_file);
- fputs(time_str(), gr_file); /* defined in main.lc */
- fputc('\n', gr_file);
-
- fputs("\n\n--------------------\n\n", gr_file);
-
- fputs("General Parameters:\n\n", gr_file);
-
- if (RTSflags.GranFlags.Light)
- fprintf(gr_file, "GrAnSim-Light\nPEs infinite, %s Scheduler, %sMigrate Threads %s, %s\n",
- RTSflags.GranFlags.DoFairSchedule?"Fair":"Unfair",
- RTSflags.GranFlags.DoThreadMigration?"":"Don't ",
- RTSflags.GranFlags.DoThreadMigration && RTSflags.GranFlags.DoStealThreadsFirst?" Before Sparks":"",
- RTSflags.GranFlags.SimplifiedFetch ? "Simplified Fetch" :
- RTSflags.GranFlags.DoReScheduleOnFetch ? "Reschedule on Fetch" :
- "Block on Fetch");
- else
- fprintf(gr_file, "PEs %u, %s Scheduler, %sMigrate Threads %s, %s\n",
- RTSflags.GranFlags.proc,RTSflags.GranFlags.DoFairSchedule?"Fair":"Unfair",
- RTSflags.GranFlags.DoThreadMigration?"":"Don't ",
- RTSflags.GranFlags.DoThreadMigration && RTSflags.GranFlags.DoStealThreadsFirst?" Before Sparks":"",
- RTSflags.GranFlags.SimplifiedFetch ? "Simplified Fetch" :
- RTSflags.GranFlags.DoReScheduleOnFetch ? "Reschedule on Fetch" :
- "Block on Fetch");
-
- if (RTSflags.GranFlags.DoGUMMFetching)
- if (RTSflags.GranFlags.ThunksToPack)
- fprintf(gr_file, "Bulk Fetching: Fetch %d Thunks in Each Packet (Packet Size = %d closures)\n",
- RTSflags.GranFlags.ThunksToPack,
- RTSflags.GranFlags.packBufferSize);
- else
- fprintf(gr_file, "Bulk Fetching: Fetch as many closures as possible (Packet Size = %d closures)\n",
- RTSflags.GranFlags.packBufferSize);
- else
- fprintf(gr_file, "Incremental Fetching: Fetch Exactly One Closure in Each Packet\n");
-
- fprintf(gr_file, "Fetch Strategy(%u):If outstanding fetches %s\n",
- RTSflags.GranFlags.FetchStrategy,
- RTSflags.GranFlags.FetchStrategy==0 ?
- " block (block-on-fetch)":
- RTSflags.GranFlags.FetchStrategy==1 ?
- "only run runnable threads":
- RTSflags.GranFlags.FetchStrategy==2 ?
- "create threads only from local sparks":
- RTSflags.GranFlags.FetchStrategy==3 ?
- "create threads from local or global sparks":
- RTSflags.GranFlags.FetchStrategy==4 ?
- "create sparks and steal threads if necessary":
- "unknown");
-
- if (RTSflags.GranFlags.DoPrioritySparking)
- fprintf(gr_file, "Priority Sparking (i.e. keep sparks ordered by priority)\n");
-
- if (RTSflags.GranFlags.DoPriorityScheduling)
- fprintf(gr_file, "Priority Scheduling (i.e. keep threads ordered by priority)\n");
-
- fprintf(gr_file, "Thread Creation Time %lu, Thread Queue Time %lu\n",
- RTSflags.GranFlags.gran_threadcreatetime,
- RTSflags.GranFlags.gran_threadqueuetime);
- fprintf(gr_file, "Thread DeSchedule Time %lu, Thread Schedule Time %lu\n",
- RTSflags.GranFlags.gran_threaddescheduletime,
- RTSflags.GranFlags.gran_threadscheduletime);
- fprintf(gr_file, "Thread Context-Switch Time %lu\n",
- RTSflags.GranFlags.gran_threadcontextswitchtime);
- fputs("\n\n--------------------\n\n", gr_file);
-
- fputs("Communication Metrics:\n\n", gr_file);
- fprintf(gr_file,
- "Latency %lu (1st) %lu (rest), Fetch %lu, Notify %lu (Global) %lu (Local)\n",
- RTSflags.GranFlags.gran_latency,
- RTSflags.GranFlags.gran_additional_latency,
- RTSflags.GranFlags.gran_fetchtime,
- RTSflags.GranFlags.gran_gunblocktime,
- RTSflags.GranFlags.gran_lunblocktime);
- fprintf(gr_file,
- "Message Creation %lu (+ %lu after send), Message Read %lu\n",
- RTSflags.GranFlags.gran_mpacktime,
- RTSflags.GranFlags.gran_mtidytime,
- RTSflags.GranFlags.gran_munpacktime);
- fputs("\n\n--------------------\n\n", gr_file);
-
- fputs("Instruction Metrics:\n\n", gr_file);
- fprintf(gr_file, "Arith %lu, Branch %lu, Load %lu, Store %lu, Float %lu, Alloc %lu\n",
- RTSflags.GranFlags.gran_arith_cost,
- RTSflags.GranFlags.gran_branch_cost,
- RTSflags.GranFlags.gran_load_cost,
- RTSflags.GranFlags.gran_store_cost,
- RTSflags.GranFlags.gran_float_cost,
- RTSflags.GranFlags.gran_heapalloc_cost);
- fputs("\n\n++++++++++++++++++++\n\n", gr_file);
-
- if (RTSflags.GranFlags.granSimStats_Binary)
- grputw(sizeof(TIME));
-
- return (0);
-}
-
-void
-end_gr_simulation(STG_NO_ARGS)
-{
- char time_string[500]; /* ToDo: kill magic constant */
- ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
-
- if (RTSflags.GranFlags.granSimStats_suppressed)
- return;
-
-#if defined(GRAN_CHECK) && defined(GRAN)
- /* Print event stats */
- if (RTSflags.GranFlags.debug & 0x20) {
- int i;
-
- fprintf(stderr,"Event statistics (number of events: %d):\n",
- noOfEvents);
- for (i=0; i<=MAX_EVENT; i++) {
- fprintf(stderr," %s (%d): \t%ld \t%f%%\t%f%%\n",
- event_names[i],i,event_counts[i],
- (float)(100*event_counts[i])/(float)(noOfEvents),
- (i==CONTINUETHREAD ? 0.0 :
- (float)(100*(event_counts[i])/(float)(noOfEvents-event_counts[CONTINUETHREAD])) ));
- }
- fprintf(stderr,"Randomized steals: %u sparks, %u threads \n \t(Sparks: #%u (avg ntimes=%f; avg fl=%f) \n",
- rs_sp_count, rs_t_count, no_of_steals,
- (float)ntimes_total/(float)STG_MAX(no_of_steals,1),
- (float)fl_total/(float)STG_MAX(no_of_steals,1));
- fprintf(stderr,"Moved sparks: %d Withered sparks: %d (%.2f %%)\n",
- tot_sparks,withered_sparks,
- ( tot_sparks == 0 ? 0 :
- (float)(100*withered_sparks)/(float)(tot_sparks)) );
- /* Print statistics about priority sparking */
- if (RTSflags.GranFlags.DoPrioritySparking) {
- fprintf(stderr,"About Priority Sparking:\n");
- fprintf(stderr," Total no. NewThreads: %d Avg. spark queue len: %.2f \n", tot_sq_probes, (float)tot_sq_len/(float)tot_sq_probes);
- }
- /* Print statistics about priority sparking */
- if (RTSflags.GranFlags.DoPriorityScheduling) {
- fprintf(stderr,"About Priority Scheduling:\n");
- fprintf(stderr," Total no. of StartThreads: %d (non-end: %d) Avg. thread queue len: %.2f\n",
- tot_add_threads, non_end_add_threads,
- (float)tot_tq_len/(float)tot_add_threads);
- }
- /* Print packet statistics if GUMM fetching is turned on */
- if (RTSflags.GranFlags.DoGUMMFetching) {
- fprintf(stderr,"Packet statistcs:\n");
- fprintf(stderr," Total no. of packets: %d Avg. packet size: %.2f \n", tot_packets, (float)tot_packet_size/(float)tot_packets);
- fprintf(stderr," Total no. of thunks: %d Avg. thunks/packet: %.2f \n", tot_thunks, (float)tot_thunks/(float)tot_packets);
- fprintf(stderr," Total no. of cuts: %d Avg. cuts/packet: %.2f\n", tot_cuts, (float)tot_cuts/(float)tot_packets);
- /*
- if (closure_queue_overflows>0)
- fprintf(stderr," Number of closure queue overflows: %u\n",
- closure_queue_overflows);
- */
- }
- }
-
- if (RTSflags.GranFlags.PrintFetchMisses)
- fprintf(stderr,"Number of fetch misses: %d\n",fetch_misses);
-
-# if defined(GRAN_COUNT)
- fprintf(stderr,"Update count statistics:\n");
- fprintf(stderr," Total number of updates: %u\n",nUPDs);
- fprintf(stderr," Needed to awaken BQ: %u with avg BQ len of: %f\n",
- nUPDs_BQ,(float)BQ_lens/(float)nUPDs_BQ);
- fprintf(stderr," Number of PAPs: %u\n",nPAPs);
-# endif
-
-#endif /* GRAN_CHECK */
-
- fprintf(stderr, "Simulation finished after @ %s @ cycles. Look at %s for details.\n",
- time_string,gr_filename);
- if (RTSflags.GranFlags.granSimStats)
- fclose(gr_file);
-}
-#elif defined(PAR)
-FILE *gr_file = NULL;
-char gr_filename[STATS_FILENAME_MAXLEN];
-
-/* I_ do_sp_profile = 0; */
-
-void
-init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv)
- char *prog_argv[], *rts_argv[];
- int prog_argc, rts_argc;
-{
- int i;
-
- char *extension = RTSflags.ParFlags.granSimStats_Binary ? "gb" : "gr";
-
- sprintf(gr_filename, GR_FILENAME_FMT_GUM, prog_argv[0], thisPE, extension);
-
- if ((gr_file = fopen(gr_filename, "w")) == NULL) {
- fprintf(stderr, "Can't open activity report file %s\n", gr_filename);
- EXIT(EXIT_FAILURE);
- }
-
- for (i = 0; i < prog_argc; ++i) {
- fputs(prog_argv[i], gr_file);
- fputc(' ', gr_file);
- }
-
- if (rts_argc > 0) {
- fputs("+RTS ", gr_file);
-
- for (i = 0; i < rts_argc; ++i) {
- fputs(rts_argv[i], gr_file);
- fputc(' ', gr_file);
- }
- }
- fputc('\n', gr_file);
-
- fputs("Start-Time: ", gr_file);
- fputs(time_str(), gr_file); /* defined in main.lc */
- fputc('\n', gr_file);
-
- startTime = CURRENT_TIME;
-
- if (startTime > LL(1000000000)) {
- /* This shouldn't overflow twice */
- fprintf(gr_file, "PE %2u [%lu%lu]: TIME\n", thisPE,
- (TIME) (startTime / LL(1000000000)),
- (TIME) (startTime % LL(1000000000)));
- } else {
- fprintf(gr_file, "PE %2u [%lu]: TIME\n", thisPE, (TIME) startTime);
- }
-
- if (RTSflags.ParFlags.granSimStats_Binary)
- grputw(sizeof(TIME));
-}
-#endif /* PAR */
-
-#endif /* GRAN || PAR */
-\end{code}
-
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section[Itimer.lc]{Interval Timer}
-%* *
-%************************************************************************
-
-The interval timer is used for profiling and for context switching in the
-threaded build. Though POSIX 1003.1b includes a standard interface for
-such things, no one really seems to be implementing them yet. Even
-Solaris 2.3 only seems to provide support for @CLOCK_REAL@, whereas we're
-keen on getting access to @CLOCK_VIRTUAL@.
-
-Hence, we use the old-fashioned @setitimer@ that just about everyone seems
-to support. So much for standards.
-
-\begin{code}
-
-#if defined(PROFILING) || defined(CONCURRENT)
-
-/* OLD: # include "platform.h" */
-
-# include "config.h"
-
-#if !defined(_AIX)
-# define NON_POSIX_SOURCE
-#endif
-
-# include "rtsdefs.h"
-
-/* As recommended in the autoconf manual */
-# ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-# else
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-# endif
-\end{code}
-
-Handling timer events under cygwin32 is not done with signal/setitimer.
-Instead of the two steps of first registering a signal handler to handle
-\tr{SIGVTALRM} and then start generating them via @setitimer()@, we use
-the Multimedia API (MM) and its @timeSetEvent@. (Internally, the MM API
-creates a separate thread that will notify the main thread of timer
-expiry). -- SOF 7/96
-
-\begin{code}
-#if defined(cygwin32_TARGET_OS)
-
-#include <windows.h> /* OK, bring it all in... */
-
-/*
- vtalrm_handler is assigned and set up in
- main/Signals.lc.
-
- vtalrm_id (defined in main/Signals.lc) holds
- the system id for the current timer (used to
- later block/kill the timer)
-*/
-extern I_ vtalrm_id;
-extern TIMECALLBACK *vtalrm_cback;
-
-int
-initialize_virtual_timer(ms)
-int ms;
-{
- /* VTALRM is currently not supported by cygwin32,
- so we use the Timer support provided by the
- MultiMedia API that is part of Win32. The
- parameters to timeSetEvent may require some tweaking.
- */
- unsigned int delay,vtalrm_id;
-
- delay = timeBeginPeriod(1);
- if (delay == TIMERR_NOCANDO) { /* error of some sort. */
- return delay;
- }
- vtalrm_id =
- timeSetEvent(ms, /* event every `delay' milliseconds. */
- 1, /* precision is within 5 millisecs. */
- (LPTIMECALLBACK)vtalrm_cback,
- 0,
- TIME_PERIODIC);
- return 0;
-}
-
-#else
-
-int
-initialize_virtual_timer(ms)
-int ms;
-{
-# ifndef HAVE_SETITIMER
- fprintf(stderr, "No virtual timer on this system\n");
- return -1;
-# else
- struct itimerval it;
-
- it.it_value.tv_sec = ms / 1000;
- it.it_value.tv_usec = 1000 * (ms - (1000 * it.it_value.tv_sec));
- it.it_interval = it.it_value;
- return (setitimer(ITIMER_VIRTUAL, &it, NULL));
-# endif
-}
-
-#endif /* !cygwin32_TARGET_OS */
-
-# if 0
-/* This is a potential POSIX version */
-int
-initialize_virtual_timer(ms)
-int ms;
-{
- struct sigevent se;
- struct itimerspec it;
- timer_t tid;
-
- se.sigev_notify = SIGEV_SIGNAL;
- se.sigev_signo = SIGVTALRM;
- se.sigev_value.sival_int = SIGVTALRM;
- if (timer_create(CLOCK_VIRTUAL, &se, &tid)) {
- fprintf(stderr, "Can't create virtual timer.\n");
- EXIT(EXIT_FAILURE);
- }
- it.it_value.tv_sec = ms / 1000;
- it.it_value.tv_nsec = 1000000 * (ms - 1000 * it.it_value.tv_sec);
- it.it_interval = it.it_value;
- timer_settime(tid, TIMER_RELTIME, &it, NULL);
-}
-# endif
-
-#endif /* PROFILING || CONCURRENT */
-
-\end{code}
+++ /dev/null
-%---------------------------------------------------------------*
-%
-\section{Wrappers around malloc}
-%
-%---------------------------------------------------------------*
-
-Routines that deal with memory allocation:
-
-A LONG-AGO WISH: All dynamic allocation must be done before the stacks
-and heap are allocated. This allows us to use the lower level sbrk
-routines if required.
-
-ANOTHER ONE: Should allow use of valloc to align on page boundary.
-
-\begin{code}
-#include "rtsdefs.h"
-
-char *
-stgMallocBytes(n, msg)
- I_ n;
- char *msg;
-{
- char *space;
-
- if ((space = (char *) malloc((size_t) n)) == NULL) {
- fflush(stdout);
- MallocFailHook((W_) n, msg); /*msg*/
- EXIT(EXIT_FAILURE);
- }
- return space;
-}
-
-char *
-stgMallocWords(n, msg)
- I_ n;
- char *msg;
-{
- return(stgMallocBytes(n * sizeof(W_), msg));
-}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section{Runtime-system runtime flags}
-
-Everything to do with RTS runtime flags, including RTS parameters
-that can be set by them, either directly or indirectly.
-
-@rtsFlags.lh@ defines the data structure that holds all of them.
-
-\begin{code}
-#include "rtsdefs.h"
-
-struct RTS_FLAGS RTSflags; /* actually declare the data structure */
-struct ALL_FLAGS AllFlags;
-
-/* some fwd decls */
-static I_ decode(const char *);
-static void bad_option(const char *);
-static FILE * open_stats_file (I_ arg,
- int argc, char *argv[], int rts_argc, char *rts_argv[],
- const char *FILENAME_FMT);
-#ifdef GRAN
-static void process_gran_option(int arg,
- int *rts_argc, char *rts_argv[], rtsBool *error);
-#endif
-
-/* extern decls */
-long strtol PROTO((const char *, char **, int));
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Initial default values for @RTSFlags@}
-%* *
-%************************************************************************
-
-\begin{code}
-void
-initRtsFlagsDefaults (STG_NO_ARGS)
-{
- RTSflags.GcFlags.statsFile = NULL;
- RTSflags.GcFlags.giveStats = NO_GC_STATS;
-
- RTSflags.GcFlags.stksSize = 0x10002; /* 2^16 = 16Kwords = 64Kbytes */
- RTSflags.GcFlags.heapSize = 0x100002; /* 2^20 = 1Mwords = 4Mbytes */
- RTSflags.GcFlags.allocAreaSize = 0x4002; /* 2^14 = 16Kwords = 64Kbytes;
- plus 2 cache-friendly words */
- RTSflags.GcFlags.allocAreaSizeGiven = rtsFalse;
- RTSflags.GcFlags.specifiedOldGenSize= 0; /* means: use all heap available */
- RTSflags.GcFlags.pcFreeHeap = 3; /* 3% */
- /* minAllocAreaSize is derived; set in initSM,
- after we know pcFreeHeap and heapSize */
-
- RTSflags.GcFlags.force2s = rtsFalse;
- RTSflags.GcFlags.forceGC = rtsFalse;
- RTSflags.GcFlags.forcingInterval = 5000000; /* 5MB (or words?) */
- RTSflags.GcFlags.ringBell = rtsFalse;
- RTSflags.GcFlags.trace = 0; /* not turned on */
-
- RTSflags.GcFlags.lazyBlackHoling = rtsTrue;
- RTSflags.GcFlags.doSelectorsAtGC = rtsTrue;
- RTSflags.GcFlags.squeezeUpdFrames = rtsTrue;
-
-#if defined(PROFILING) || defined(PAR)
- RTSflags.CcFlags.doCostCentres = 0;
- RTSflags.CcFlags.sortBy = SORTCC_TIME;
-
- /* "ctxtSwitchTicks", "profilerTicks", & "msecsPerTick" are
- derived info, so they are set after ctxtSwitchTime has been
- determined.
- */
-#endif /* PROFILING or PAR */
-
-#ifdef PROFILING
- RTSflags.ProfFlags.doHeapProfile = rtsFalse;
-
- RTSflags.ProfFlags.ccSelector = NULL;
- RTSflags.ProfFlags.modSelector = NULL;
- RTSflags.ProfFlags.grpSelector = NULL;
- RTSflags.ProfFlags.descrSelector = NULL;
- RTSflags.ProfFlags.typeSelector = NULL;
- RTSflags.ProfFlags.kindSelector = NULL;
-#endif /* PROFILING */
-/* there really shouldn't be a threads limit for concurrent mandatory threads.
- For now, unlimitied means less than 64k (there's a storage overhead) -- SOF
-*/
-#if defined(CONCURRENT) && !defined(GRAN)
- RTSflags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
- RTSflags.ConcFlags.maxThreads = 65536;
- RTSflags.ConcFlags.stkChunkSize = 1024;
- RTSflags.ConcFlags.maxLocalSparks = 65536;
-#endif /* CONCURRENT only */
-
-#ifdef GRAN
- RTSflags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
- RTSflags.ConcFlags.maxThreads = 32;
- RTSflags.ConcFlags.stkChunkSize = 1024;
- RTSflags.ConcFlags.maxLocalSparks = 500;
-#endif /* GRAN */
-
-#ifdef PAR
- RTSflags.ParFlags.parallelStats = rtsFalse;
- RTSflags.ParFlags.granSimStats = rtsFalse;
- RTSflags.ParFlags.granSimStats_Binary = rtsFalse;
-
- RTSflags.ParFlags.outputDisabled = rtsFalse;
-
- RTSflags.ParFlags.packBufferSize = 1024;
-#endif /* PAR */
-
-#ifdef GRAN
- RTSflags.GranFlags.granSimStats = rtsFalse;
- RTSflags.GranFlags.granSimStats_suppressed = rtsFalse;
- RTSflags.GranFlags.granSimStats_Binary = rtsFalse;
- RTSflags.GranFlags.granSimStats_Sparks = rtsFalse;
- RTSflags.GranFlags.granSimStats_Heap = rtsFalse;
- RTSflags.GranFlags.labelling = rtsFalse;
- RTSflags.GranFlags.packBufferSize = 1024;
- RTSflags.GranFlags.packBufferSize_internal = GRANSIM_DEFAULT_PACK_BUFFER_SIZE;
-
- RTSflags.GranFlags.proc = MAX_PROC;
- RTSflags.GranFlags.max_fishes = MAX_FISHES;
- RTSflags.GranFlags.time_slice = GRAN_TIME_SLICE;
- RTSflags.GranFlags.Light = rtsFalse;
-
- RTSflags.GranFlags.gran_latency = LATENCY;
- RTSflags.GranFlags.gran_additional_latency = ADDITIONAL_LATENCY;
- RTSflags.GranFlags.gran_fetchtime = FETCHTIME;
- RTSflags.GranFlags.gran_lunblocktime = LOCALUNBLOCKTIME;
- RTSflags.GranFlags.gran_gunblocktime = GLOBALUNBLOCKTIME;
- RTSflags.GranFlags.gran_mpacktime = MSGPACKTIME;
- RTSflags.GranFlags.gran_munpacktime = MSGUNPACKTIME;
- RTSflags.GranFlags.gran_mtidytime = MSGTIDYTIME;
-
- RTSflags.GranFlags.gran_threadcreatetime = THREADCREATETIME;
- RTSflags.GranFlags.gran_threadqueuetime = THREADQUEUETIME;
- RTSflags.GranFlags.gran_threaddescheduletime = THREADDESCHEDULETIME;
- RTSflags.GranFlags.gran_threadscheduletime = THREADSCHEDULETIME;
- RTSflags.GranFlags.gran_threadcontextswitchtime = THREADCONTEXTSWITCHTIME;
-
- RTSflags.GranFlags.gran_arith_cost = ARITH_COST;
- RTSflags.GranFlags.gran_branch_cost = BRANCH_COST;
- RTSflags.GranFlags.gran_load_cost = LOAD_COST;
- RTSflags.GranFlags.gran_store_cost = STORE_COST;
- RTSflags.GranFlags.gran_float_cost = FLOAT_COST;
-
- RTSflags.GranFlags.gran_heapalloc_cost = HEAPALLOC_COST;
-
- RTSflags.GranFlags.gran_pri_spark_overhead = PRI_SPARK_OVERHEAD;
- RTSflags.GranFlags.gran_pri_sched_overhead = PRI_SCHED_OVERHEAD;
-
- RTSflags.GranFlags.DoFairSchedule = rtsFalse;
- RTSflags.GranFlags.DoReScheduleOnFetch = rtsFalse;
- RTSflags.GranFlags.DoStealThreadsFirst = rtsFalse;
- RTSflags.GranFlags.SimplifiedFetch = rtsFalse;
- RTSflags.GranFlags.DoAlwaysCreateThreads = rtsFalse;
- RTSflags.GranFlags.DoGUMMFetching = rtsFalse;
- RTSflags.GranFlags.DoThreadMigration = rtsFalse;
- RTSflags.GranFlags.FetchStrategy = 2;
- RTSflags.GranFlags.PreferSparksOfLocalNodes = rtsFalse;
- RTSflags.GranFlags.DoPrioritySparking = rtsFalse;
- RTSflags.GranFlags.DoPriorityScheduling = rtsFalse;
- RTSflags.GranFlags.SparkPriority = 0;
- RTSflags.GranFlags.SparkPriority2 = 0;
- RTSflags.GranFlags.RandomPriorities = rtsFalse;
- RTSflags.GranFlags.InversePriorities = rtsFalse;
- RTSflags.GranFlags.IgnorePriorities = rtsFalse;
- RTSflags.GranFlags.ThunksToPack = 0;
- RTSflags.GranFlags.RandomSteal = rtsTrue;
- RTSflags.GranFlags.NoForward = rtsFalse;
- RTSflags.GranFlags.PrintFetchMisses = rtsFalse;
-
- RTSflags.GranFlags.debug = 0x0;
- RTSflags.GranFlags.event_trace = rtsFalse;
- RTSflags.GranFlags.event_trace_all = rtsFalse;
-#endif
-
-#ifdef TICKY_TICKY
- RTSflags.TickyFlags.showTickyStats = rtsFalse;
- RTSflags.TickyFlags.tickyFile = NULL;
-
- AllFlags.doUpdEntryCounts = rtsTrue; /*ToDo:move? */
-#endif
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Usage message for runtime-system (RTS) flags}
-%* *
-%************************************************************************
-
-\begin{code}
-static const char *
-usage_text[] = {
-"",
-"Usage: <prog> <args> [+RTS <rtsopts> | -RTS <args>] ... --RTS <args>",
-"",
-" +RTS Indicates run time system options follow",
-" -RTS Indicates program arguments follow",
-" --RTS Indicates that ALL subsequent arguments will be given to the",
-" program (including any of these RTS flags)",
-"",
-"The following run time system options are available:",
-"",
-" -? -f Prints this message and exits; the program is not executed",
-"",
-" -K<size> Sets the stack size (default 64k) Egs: -K32k -K512k",
-" -H<size> Sets the heap size (default 4M) -H512k -H16M",
-" -s<file> Summary GC statistics (default file: <program>.stat)",
-" -S<file> Detailed GC statistics (with -Sstderr going to stderr)",
-"",
-#if defined(GCap)
-" -M<n>% Sets minimum size of alloc area as % of heap (default 3%)",
-" -A<size> Fixes size of alloc area, overriding any minimum (-A gives 64k)",
-" -G<size> Fixes size of major generation (default is dynamic threshold)",
-" -F2s Forces program compiled for Appel gc to use 2s collection",
-#else
-# if defined(GCgn)
-" -A<size> Specifies size of alloc area (default 64k)",
-" -G<size> Fixes size of major generation (default is available heap)",
-" -F2s Forces program compiled for Gen gc to use 2s collection",
-# else
-" -M<n>% Minimum % of heap which must be available (default 3%)",
-" -A<size> Fixes size of heap area allocated between GCs (-A gives 64k)",
-# endif
-#endif
-" -j<size> Forces major GC at every <size> bytes allocated",
-#if defined(GCdu)
-" -u<percent> Fixes residency threshold at which mode switches (range 0.0..0.95)",
-#endif
-"",
-" -N No black-holing during GC (for use when a signal handler is present)",
-" -Z Don't squeeze out update frames on stack overflow",
-" -B Sound the bell at the start of each (major) garbage collection",
-#if defined(PROFILING) || defined(PAR)
-"",
-" -p<sort> Produce cost centre time profile (output file <program>.prof)",
-" sort: T = time (default), A = alloc, C = cost centre label",
-" -P<sort> Produce serial time profile (output file <program>.time)",
-" and a -p profile with detailed tick/alloc info",
-# if defined(PROFILING)
-"",
-" -h<break-down> Heap residency profile (output file <program>.hp)",
-" break-down: C = cost centre (default), M = module, G = group",
-" D = closure description, Y = type description",
-" T<ints>,<start> = time closure created",
-" ints: no. of interval bands plotted (default 18)",
-" start: seconds after which intervals start (default 0.0)",
-" A subset of closures may be selected by the attached cost centre using:",
-" -c{mod:lab,mod:lab...}, specific module:label cost centre(s)",
-" -m{mod,mod...} all cost centres from the specified modules(s)",
-" -g{grp,grp...} all cost centres from the specified group(s)",
-" Selections can also be made by description, type, kind and age:",
-" -d{des,des...} closures with specified closure descriptions",
-" -y{typ,typ...} closures with specified type descriptions",
-" -k{knd,knd...} closures of the specified kinds",
-" -a<age> closures which survived <age> complete intervals",
-" The selection logic used is summarised as follows:",
-" ([-c] or [-m] or [-g]) and ([-d] or [-y] or [-k]) and [-a]",
-" where an option is true if not specified",
-# endif
-"",
-" -z<tbl><size> set hash table <size> for <tbl> (C, M, G, D or Y)",
-"",
-" -i<secs> Number of seconds in a profiling interval (default 1.0):",
-" heap profile (-h) and/or serial time profile (-P) frequency",
-#endif /* PROFILING or PAR */
-"",
-#if defined(TICKY_TICKY)
-" -r<file> Produce reduction profiling statistics (with -rstderr for stderr)",
-"",
-#endif
-" -T<level> Trace garbage collection execution (debugging)",
-#ifdef CONCURRENT
-"",
-# ifdef PAR
-" -N<n> Use <n> PVMish processors in parallel (default: 2)",
-/* NB: the -N<n> is implemented by the driver!! */
-# endif
-" -C<secs> Context-switch interval in seconds",
-" (0 or no argument means switch as often as possible)",
-" the default is .01 sec; resolution is .01 sec",
-" -e<size> Size of spark pools (default 100)",
-# ifdef PAR
-" -q Enable activity profile (output files in ~/<program>*.gr)",
-" -qb Enable binary activity profile (output file /tmp/<program>.gb)",
-" -Q<size> Set pack-buffer size (default: 1024)",
-# else
-" -q[v] Enable quasi-parallel profile (output file <program>.qp)",
-# endif
-" -t<num> Set maximum number of advisory threads per PE (default 32)",
-" -o<num> Set stack chunk size (default 1024)",
-# ifdef PAR
-" -d Turn on PVM-ish debugging",
-" -O Disable output for performance measurement",
-# endif /* PAR */
-# ifdef GRAN /* ToDo: fill in decent Docu here */
-" -b... All GranSim options start with -b; see GranSim User's Guide for details",
-# endif
-#endif /* CONCURRENT */
-"",
-"Other RTS options may be available for programs compiled a different way.",
-"The GHC User's Guide has full details.",
-"",
-0
-};
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Processing command-line arguments to set @RTSFlags@}
-%* *
-%************************************************************************
-
-\begin{code}
-#define RTS 1
-#define PGM 0
-
-#ifndef atof
-extern double atof();
-/* no proto because some machines use const and some do not */
-#endif
-
-static __inline__ rtsBool
-strequal(const char *a, const char * b)
-{
- return(strcmp(a, b) == 0);
-}
-
-void
-setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
-{
- rtsBool error = rtsFalse;
- I_ mode;
- I_ arg, total_arg;
- char *last_slash;
-
- /* Remove directory from argv[0] -- default files in current directory */
-
- if ((last_slash = (char *) strrchr(argv[0], '/')) != NULL)
- strcpy(argv[0], last_slash+1);
-
- /* Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts */
- /* argv[0] must be PGM argument -- leave in argv */
-
- total_arg = *argc;
- arg = 1;
-
- *argc = 1;
- *rts_argc = 0;
-
- for (mode = PGM; arg < total_arg && ! strequal("--RTS", argv[arg]); arg++) {
- if (strequal("+RTS", argv[arg])) {
- mode = RTS;
- }
- else if (strequal("-RTS", argv[arg])) {
- mode = PGM;
- }
- else if (mode == RTS && *rts_argc < MAX_RTS_ARGS-1) {
- rts_argv[(*rts_argc)++] = argv[arg];
- }
- else if (mode == PGM) {
- argv[(*argc)++] = argv[arg];
- }
- else {
- fflush(stdout);
- fprintf(stderr, "setupRtsFlags: Too many RTS arguments (max %d)\n",
- MAX_RTS_ARGS-1);
- EXIT(EXIT_FAILURE);
- }
- }
- if (arg < total_arg) {
- /* arg must be --RTS; process remaining program arguments */
- while (++arg < total_arg) {
- argv[(*argc)++] = argv[arg];
- }
- }
- argv[*argc] = (char *) 0;
- rts_argv[*rts_argc] = (char *) 0;
-
- /* Process RTS (rts_argv) part: mainly to determine statsfile */
-
- for (arg = 0; arg < *rts_argc; arg++) {
- if (rts_argv[arg][0] != '-') {
- fflush(stdout);
- fprintf(stderr, "setupRtsFlags: Unexpected RTS argument: %s\n",
- rts_argv[arg]);
- error = rtsTrue;
-
- } else {
- switch(rts_argv[arg][1]) {
-
- /* process: general args, then PROFILING-only ones,
- then CONCURRENT-only, PARallel-only, GRAN-only,
- TICKY-only (same order as defined in RtsFlags.lh);
- within those groups, mostly in case-insensitive
- alphabetical order.
- */
-
-#ifdef TICKY_TICKY
-# define TICKY_BUILD_ONLY(x) x
-#else
-# define TICKY_BUILD_ONLY(x) \
-fprintf(stderr, "setupRtsFlags: GHC not built for: ticky-ticky stats\n"); \
-error = rtsTrue;
-#endif
-
-#if (defined(PROFILING) || defined(PAR))
-# define COST_CENTRE_USING_BUILD_ONLY(x) x
-#else
-# define COST_CENTRE_USING_BUILD_ONLY(x) \
-fprintf(stderr, "setupRtsFlags: GHC not built for: -prof or -parallel\n"); \
-error = rtsTrue;
-#endif
-
-#ifdef PROFILING
-# define PROFILING_BUILD_ONLY(x) x
-#else
-# define PROFILING_BUILD_ONLY(x) \
-fprintf(stderr, "setupRtsFlags: GHC not built for: -prof\n"); \
-error = rtsTrue;
-#endif
-
-#ifdef CONCURRENT
-# define CONCURRENT_BUILD_ONLY(x) x
-#else
-# define CONCURRENT_BUILD_ONLY(x) \
-fprintf(stderr, "setupRtsFlags: GHC not built for: -concurrent\n"); \
-error = rtsTrue;
-#endif
-
-#ifdef PAR
-# define PAR_BUILD_ONLY(x) x
-#else
-# define PAR_BUILD_ONLY(x) \
-fprintf(stderr, "setupRtsFlags: GHC not built for: -parallel\n"); \
-error = rtsTrue;
-#endif
-
-#ifdef GRAN
-# define GRAN_BUILD_ONLY(x) x
-#else
-# define GRAN_BUILD_ONLY(x) \
-fprintf(stderr, "setupRtsFlags: GHC not built for: -gransim\n"); \
-error = rtsTrue;
-#endif
-
- /* =========== GENERAL ========================== */
- case '?':
- case 'f':
- error = rtsTrue;
- break;
-
- case 'A':
- RTSflags.GcFlags.allocAreaSize
- = decode(rts_argv[arg]+2) / sizeof(W_);
- RTSflags.GcFlags.allocAreaSizeGiven = rtsTrue;
- break;
-
- case 'B':
- RTSflags.GcFlags.ringBell = rtsTrue;
- break;
-
- case 'F':
- if (strequal(rts_argv[arg]+2, "2s")) {
- RTSflags.GcFlags.force2s = rtsTrue;
- } else {
- bad_option( rts_argv[arg] );
- }
- break;
-
- case 'G':
- RTSflags.GcFlags.specifiedOldGenSize
- = decode(rts_argv[arg]+2) / sizeof(W_);
- break;
-
- case 'K':
- RTSflags.GcFlags.stksSize = decode(rts_argv[arg]+2) / sizeof(W_);
-
- if (RTSflags.GcFlags.stksSize == 0) bad_option( rts_argv[arg] );
- break;
-
- case 'H':
- RTSflags.GcFlags.heapSize = decode(rts_argv[arg]+2) / sizeof(W_);
- /* user give size in *bytes* but "heapSize" is in *words* */
-
- if (RTSflags.GcFlags.heapSize <= 0) bad_option(rts_argv[arg]);
- break;
-
- case 'j': /* force GC option */
- RTSflags.GcFlags.forceGC = rtsTrue;
- if (rts_argv[arg][2]) {
- RTSflags.GcFlags.forcingInterval
- = decode(rts_argv[arg]+2) / sizeof(W_);
- }
- break;
-
- case 'M':
- RTSflags.GcFlags.pcFreeHeap = atof(rts_argv[arg]+2);
-
- if (RTSflags.GcFlags.pcFreeHeap < 0 || RTSflags.GcFlags.pcFreeHeap > 100)
- bad_option( rts_argv[arg] );
- break;
-
- case 'N':
- RTSflags.GcFlags.lazyBlackHoling = rtsFalse;
- break;
-
- case 'n':
- RTSflags.GcFlags.doSelectorsAtGC = rtsFalse;
- break;
-
- case 'S': /* NB: no difference at present ! */
- case 's':
- RTSflags.GcFlags.giveStats ++; /* will be VERBOSE_GC_STATS */
-#ifdef PAR
- /* Opening all those files would almost certainly fail... */
- RTSflags.ParFlags.parallelStats = rtsTrue;
- RTSflags.GcFlags.statsFile = stderr; /* temporary; ToDo: rm */
-#else
- RTSflags.GcFlags.statsFile
- = open_stats_file(arg, *argc, argv,
- *rts_argc, rts_argv, STAT_FILENAME_FMT);
-
- if (RTSflags.GcFlags.statsFile == NULL) error = rtsTrue;
-#endif
- break;
-
- case 'T':
- if (rts_argv[arg][2] != '\0')
- RTSflags.GcFlags.trace
- = (W_) strtol(rts_argv[arg]+2, (char **)NULL, 0);
- else
- RTSflags.GcFlags.trace = 1; /* slightly weird; why, really? */
- break;
-
- case 'Z':
- RTSflags.GcFlags.squeezeUpdFrames = rtsFalse;
- break;
-
- /* =========== PROFILING ========================== */
-
- case 'P': /* detailed cost centre profiling (time/alloc) */
- COST_CENTRE_USING_BUILD_ONLY(
- RTSflags.CcFlags.doCostCentres++;
- )
- case 'p': /* cost centre profiling (time/alloc) */
- COST_CENTRE_USING_BUILD_ONLY(
- RTSflags.CcFlags.doCostCentres++;
-
- switch (rts_argv[arg][2]) {
- case SORTCC_LABEL:
- case SORTCC_TIME:
- case SORTCC_ALLOC:
- RTSflags.CcFlags.sortBy = rts_argv[arg][2];
- break;
- default:
- RTSflags.CcFlags.sortBy = SORTCC_TIME;
- break;
- }
- ) break;
-
- case 'i': /* serial profiling -- initial timer interval */
- COST_CENTRE_USING_BUILD_ONLY(
- interval_ticks = (I_) ((atof(rts_argv[arg]+2) * TICK_FREQUENCY));
- if (interval_ticks <= 0)
- interval_ticks = 1;
- ) break;
-
- case 'h': /* serial heap profile */
- PROFILING_BUILD_ONLY(
- switch (rts_argv[arg][2]) {
- case '\0':
- case CCchar:
- RTSflags.ProfFlags.doHeapProfile = HEAP_BY_CC;
- break;
- case MODchar:
- RTSflags.ProfFlags.doHeapProfile = HEAP_BY_MOD;
- break;
- case GRPchar:
- RTSflags.ProfFlags.doHeapProfile = HEAP_BY_GRP;
- break;
- case DESCRchar:
- RTSflags.ProfFlags.doHeapProfile = HEAP_BY_DESCR;
- break;
- case TYPEchar:
- RTSflags.ProfFlags.doHeapProfile = HEAP_BY_TYPE;
- break;
- case TIMEchar:
- RTSflags.ProfFlags.doHeapProfile = HEAP_BY_TIME;
- if (rts_argv[arg][3]) {
- char *start_str = strchr(rts_argv[arg]+3, ',');
- I_ intervals;
- if (start_str) *start_str = '\0';
-
- if ((intervals = decode(rts_argv[arg]+3)) != 0) {
- time_intervals = (hash_t) intervals;
- /* ToDo: and what if it *is* zero intervals??? */
- }
- if (start_str) {
- earlier_ticks = (I_)((atof(start_str + 1) * TICK_FREQUENCY));
- }
- }
- break;
- default:
- fprintf(stderr, "Invalid heap profile option: %s\n",
- rts_argv[arg]);
- error = rtsTrue;
- }
- ) break;
-
- case 'z': /* size of index tables */
- PROFILING_BUILD_ONLY(
- switch (rts_argv[arg][2]) {
- case CCchar:
- max_cc_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_cc_no == 0) {
- fprintf(stderr, "Bad number of cost centres %s\n", rts_argv[arg]);
- error = rtsTrue;
- }
- break;
- case MODchar:
- max_mod_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_mod_no == 0) {
- fprintf(stderr, "Bad number of modules %s\n", rts_argv[arg]);
- error = rtsTrue;
- }
- break;
- case GRPchar:
- max_grp_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_grp_no == 0) {
- fprintf(stderr, "Bad number of groups %s\n", rts_argv[arg]);
- error = rtsTrue;
- }
- break;
- case DESCRchar:
- max_descr_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_descr_no == 0) {
- fprintf(stderr, "Bad number of closure descriptions %s\n", rts_argv[arg]);
- error = rtsTrue;
- }
- break;
- case TYPEchar:
- max_type_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_type_no == 0) {
- fprintf(stderr, "Bad number of type descriptions %s\n", rts_argv[arg]);
- error = rtsTrue;
- }
- break;
- default:
- fprintf(stderr, "Invalid index table size option: %s\n",
- rts_argv[arg]);
- error = rtsTrue;
- }
- ) break;
-
- case 'c': /* cost centre label select */
- case 'm': /* cost centre module select */
- case 'g': /* cost centre group select */
- case 'd': /* closure descr select */
- case 'y': /* closure type select */
- case 'k': /* closure kind select */
- PROFILING_BUILD_ONLY(
- {char *left = strchr(rts_argv[arg], '{');
- char *right = strrchr(rts_argv[arg], '}');
-
- if (! left || ! right ||
- strrchr(rts_argv[arg], '{') != left ||
- strchr(rts_argv[arg], '}') != right) {
- fprintf(stderr, "Invalid heap profiling selection bracketing\n %s\n", rts_argv[arg]);
- error = rtsTrue;
- } else {
- *right = '\0';
- switch (rts_argv[arg][1]) {
- case 'c': /* cost centre label select */
- RTSflags.ProfFlags.ccSelector = left + 1;
- break;
- case 'm': /* cost centre module select */
- RTSflags.ProfFlags.modSelector = left + 1;
- break;
- case 'g': /* cost centre group select */
- RTSflags.ProfFlags.grpSelector = left + 1;
- break;
- case 'd': /* closure descr select */
- RTSflags.ProfFlags.descrSelector = left + 1;
- break;
- case 'y': /* closure type select */
- RTSflags.ProfFlags.typeSelector = left + 1;
- break;
- case 'k': /* closure kind select */
- RTSflags.ProfFlags.kindSelector = left + 1;
- break;
- }
- }}
- ) break;
-
- /* =========== CONCURRENT ========================= */
- case 'C': /* context switch interval */
- CONCURRENT_BUILD_ONLY (
- if (rts_argv[arg][2] == '\0')
- RTSflags.ConcFlags.ctxtSwitchTime = 0;
- else {
- I_ cst; /* tmp */
-
- /* Convert to milliseconds */
- cst = (I_) ((atof(rts_argv[arg]+2) * 1000));
- cst = (cst / CS_MIN_MILLISECS) * CS_MIN_MILLISECS;
- if (cst < CS_MIN_MILLISECS)
- cst = CS_MIN_MILLISECS;
-
- RTSflags.ConcFlags.ctxtSwitchTime = cst;
- }
- ) break;
-
- case 't':
- CONCURRENT_BUILD_ONLY(
- if (rts_argv[arg][2] != '\0') {
- RTSflags.ConcFlags.maxThreads
- = strtol(rts_argv[arg]+2, (char **) NULL, 10);
- } else {
- fprintf(stderr, "setupRtsFlags: missing size for -t\n");
- error = rtsTrue;
- }
- ) break;
-
- case 'o':
- CONCURRENT_BUILD_ONLY (
- if (rts_argv[arg][2] != '\0') {
- I_ size = decode(rts_argv[arg]+2);
-
- if (size < MIN_STKO_CHUNK_SIZE)
- size = MIN_STKO_CHUNK_SIZE;
-
- RTSflags.ConcFlags.stkChunkSize = size;
- } else {
- fprintf(stderr, "setupRtsFlags: missing size for -o\n");
- error = rtsTrue;
- }
- ) break;
-
- /* =========== PARALLEL =========================== */
- case 'e':
- CONCURRENT_BUILD_ONLY(
- if (rts_argv[arg][2] != '\0') { /* otherwise, stick w/ the default */
-
- RTSflags.ConcFlags.maxLocalSparks
- = strtol(rts_argv[arg]+2, (char **) NULL, 10);
-
- if (RTSflags.ConcFlags.maxLocalSparks <= 0) {
- fprintf(stderr, "setupRtsFlags: bad value for -e\n");
- error = rtsTrue;
- }
- }
- ) break;
-
- case 'O':
- PAR_BUILD_ONLY(
- RTSflags.ParFlags.outputDisabled = rtsTrue;
- ) break;
-
- case 'q': /* activity profile option */
- PAR_BUILD_ONLY(
- if (rts_argv[arg][2] == 'b')
- RTSflags.ParFlags.granSimStats_Binary = rtsTrue;
- else
- RTSflags.ParFlags.granSimStats = rtsTrue;
- ) break;
-
-#if 0 /* or??? */
- case 'q': /* quasi-parallel profile option */
- GRAN_BUILD_ONLY (
- if (rts_argv[arg][2] == 'v')
- do_qp_prof = 2;
- else
- do_qp_prof++;
- ) break;
-#endif /* 0??? */
-
- case 'Q': /* Set pack buffer size */
- PAR_BUILD_ONLY(
- if (rts_argv[arg][2] != '\0') {
- RTSflags.ParFlags.packBufferSize = decode(rts_argv[arg]+2);
- } else {
- fprintf(stderr, "setupRtsFlags: missing size of PackBuffer (for -Q)\n");
- error = rtsTrue;
- }
- ) break;
-
- /* =========== GRAN =============================== */
-
- case 'b':
- GRAN_BUILD_ONLY(
- process_gran_option(arg, rts_argc, rts_argv, &error);
- ) break;
-
- /* =========== TICKY ============================== */
-
- case 'r': /* Basic profiling stats */
- TICKY_BUILD_ONLY(
-
- RTSflags.TickyFlags.showTickyStats = rtsTrue;
- RTSflags.TickyFlags.tickyFile
- = open_stats_file(arg, *argc, argv,
- *rts_argc, rts_argv, TICKY_FILENAME_FMT);
-
- if (RTSflags.TickyFlags.tickyFile == NULL) error = rtsTrue;
- ) break;
-
- /* =========== OH DEAR ============================ */
- default:
- fprintf(stderr, "setupRtsFlags: Unknown RTS option: %s\n",rts_argv[arg]);
- error = rtsTrue;
- break;
- }
- }
- }
- if (error) {
- const char **p;
-
- fflush(stdout);
- for (p = usage_text; *p; p++)
- fprintf(stderr, "%s\n", *p);
- EXIT(EXIT_FAILURE);
- }
-
-}
-
-#if defined(GRAN)
-void
-enable_GrAnSimLight() {
-
- fprintf(stderr,"GrAnSim Light enabled (infinite number of processors; 0 communication costs)\n");
- RTSflags.GranFlags.Light=rtsTrue;
- RTSflags.GranFlags.gran_latency =
- RTSflags.GranFlags.gran_fetchtime =
- RTSflags.GranFlags.gran_additional_latency =
- RTSflags.GranFlags.gran_gunblocktime =
- RTSflags.GranFlags.gran_lunblocktime =
- RTSflags.GranFlags.gran_threadcreatetime =
- RTSflags.GranFlags.gran_threadqueuetime =
- RTSflags.GranFlags.gran_threadscheduletime =
- RTSflags.GranFlags.gran_threaddescheduletime =
- RTSflags.GranFlags.gran_threadcontextswitchtime = 0;
-
- RTSflags.GranFlags.gran_mpacktime =
- RTSflags.GranFlags.gran_munpacktime = 0;
-
- RTSflags.GranFlags.DoFairSchedule = rtsTrue;
- RTSflags.GranFlags.DoReScheduleOnFetch = rtsFalse;
- RTSflags.GranFlags.DoAlwaysCreateThreads = rtsTrue;
- /* FetchStrategy is irrelevant in GrAnSim-Light */
-
- /* GrAnSim Light often creates an abundance of parallel threads,
- each with its own stack etc. Therefore, it's in general a good
- idea to use small stack chunks (use the -o<size> option to
- increase it again).
- */
- RTSflags.ConcFlags.stkChunkSize = 100;
-
- RTSflags.GranFlags.proc = 1;
-}
-
-static void
-process_gran_option(int arg, int *rts_argc, char *rts_argv[], rtsBool *error)
-{
- if (rts_argv[arg][1] != 'b') /* All GranSim options start with -b */
- return;
-
- /* Should we emulate hbcpp */
- if(strcmp((rts_argv[arg]+2),"roken")==0) {
- RTSflags.GranFlags.DoAlwaysCreateThreads=rtsTrue;
- strcpy(rts_argv[arg]+2,"oring");
- }
-
- /* or a ridiculously idealised simulator */
- if(strcmp((rts_argv[arg]+2),"oring")==0) {
- RTSflags.GranFlags.gran_latency =
- RTSflags.GranFlags.gran_fetchtime =
- RTSflags.GranFlags.gran_additional_latency =
- RTSflags.GranFlags.gran_gunblocktime =
- RTSflags.GranFlags.gran_lunblocktime =
- RTSflags.GranFlags.gran_threadcreatetime =
- RTSflags.GranFlags.gran_threadqueuetime =
- RTSflags.GranFlags.gran_threadscheduletime =
- RTSflags.GranFlags.gran_threaddescheduletime =
- RTSflags.GranFlags.gran_threadcontextswitchtime = 0;
-
- RTSflags.GranFlags.gran_mpacktime =
- RTSflags.GranFlags.gran_munpacktime = 0;
-
- RTSflags.GranFlags.gran_arith_cost =
- RTSflags.GranFlags.gran_float_cost =
- RTSflags.GranFlags.gran_load_cost =
- RTSflags.GranFlags.gran_store_cost =
- RTSflags.GranFlags.gran_branch_cost = 0;
-
- RTSflags.GranFlags.gran_heapalloc_cost = 1;
-
- /* ++RTSflags.GranFlags.DoFairSchedule; */
- RTSflags.GranFlags.DoStealThreadsFirst = rtsTrue; /* -bZ */
- RTSflags.GranFlags.DoThreadMigration = rtsTrue; /* -bM */
- RTSflags.GranFlags.granSimStats = rtsTrue; /* -bP */
- return;
- }
-
- /* or a somewhat idealised simulator */
- if(strcmp((rts_argv[arg]+2),"onzo")==0) {
- RTSflags.GranFlags.gran_latency =
- RTSflags.GranFlags.gran_fetchtime =
- RTSflags.GranFlags.gran_additional_latency =
- RTSflags.GranFlags.gran_gunblocktime =
- RTSflags.GranFlags.gran_lunblocktime =
- RTSflags.GranFlags.gran_threadcreatetime =
- RTSflags.GranFlags.gran_threadqueuetime =
- RTSflags.GranFlags.gran_threadscheduletime =
- RTSflags.GranFlags.gran_threaddescheduletime =
- RTSflags.GranFlags.gran_threadcontextswitchtime = 0;
-
- RTSflags.GranFlags.gran_mpacktime =
- RTSflags.GranFlags.gran_munpacktime = 0;
-
- RTSflags.GranFlags.gran_heapalloc_cost = 1;
-
- /* RTSflags.GranFlags.DoFairSchedule = rtsTrue; */ /* -b-R */
- /* RTSflags.GranFlags.DoStealThreadsFirst = rtsTrue; */ /* -b-T */
- RTSflags.GranFlags.DoReScheduleOnFetch = rtsTrue; /* -bZ */
- RTSflags.GranFlags.DoThreadMigration = rtsTrue; /* -bM */
- RTSflags.GranFlags.granSimStats = rtsTrue; /* -bP */
-# if defined(GRAN_CHECK) && defined(GRAN)
- RTSflags.GranFlags.debug = 0x20; /* print event statistics */
-# endif
- return;
- }
-
- /* Communication and task creation cost parameters */
- switch(rts_argv[arg][2]) {
- case ':':
- enable_GrAnSimLight(); /* set flags for GrAnSim-Light mode */
- break;
-
- case 'l':
- if (rts_argv[arg][3] != '\0')
- {
- RTSflags.GranFlags.gran_gunblocktime =
- RTSflags.GranFlags.gran_latency = decode(rts_argv[arg]+3);
- RTSflags.GranFlags.gran_fetchtime = 2*RTSflags.GranFlags.gran_latency;
- }
- else
- RTSflags.GranFlags.gran_latency = LATENCY;
- break;
-
- case 'a':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_additional_latency = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_additional_latency = ADDITIONAL_LATENCY;
- break;
-
- case 'm':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_mpacktime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_mpacktime = MSGPACKTIME;
- break;
-
- case 'x':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_mtidytime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_mtidytime = 0;
- break;
-
- case 'r':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_munpacktime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_munpacktime = MSGUNPACKTIME;
- break;
-
- case 'g':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_fetchtime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_fetchtime = FETCHTIME;
- break;
-
- case 'n':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_gunblocktime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_gunblocktime = GLOBALUNBLOCKTIME;
- break;
-
- case 'u':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_lunblocktime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_lunblocktime = LOCALUNBLOCKTIME;
- break;
-
- /* Thread-related metrics */
- case 't':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_threadcreatetime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_threadcreatetime = THREADCREATETIME;
- break;
-
- case 'q':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_threadqueuetime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_threadqueuetime = THREADQUEUETIME;
- break;
-
- case 'c':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_threadscheduletime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_threadscheduletime = THREADSCHEDULETIME;
-
- RTSflags.GranFlags.gran_threadcontextswitchtime = RTSflags.GranFlags.gran_threadscheduletime
- + RTSflags.GranFlags.gran_threaddescheduletime;
- break;
-
- case 'd':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_threaddescheduletime = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_threaddescheduletime = THREADDESCHEDULETIME;
-
- RTSflags.GranFlags.gran_threadcontextswitchtime = RTSflags.GranFlags.gran_threadscheduletime
- + RTSflags.GranFlags.gran_threaddescheduletime;
- break;
-
- /* Instruction Cost Metrics */
- case 'A':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_arith_cost = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_arith_cost = ARITH_COST;
- break;
-
- case 'F':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_float_cost = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_float_cost = FLOAT_COST;
- break;
-
- case 'B':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_branch_cost = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_branch_cost = BRANCH_COST;
- break;
-
- case 'L':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_load_cost = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_load_cost = LOAD_COST;
- break;
-
- case 'S':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_store_cost = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_store_cost = STORE_COST;
- break;
-
- case 'H':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_heapalloc_cost = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_heapalloc_cost = 0;
- break;
-
- case 'y':
- RTSflags.GranFlags.DoReScheduleOnFetch = rtsTrue;
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.FetchStrategy = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.FetchStrategy = 2;
- if (RTSflags.GranFlags.FetchStrategy == 0)
- RTSflags.GranFlags.DoReScheduleOnFetch = rtsFalse;
- break;
-
- case 'K': /* sort overhead (per elem in spark list) */
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_pri_spark_overhead = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_pri_spark_overhead = PRI_SPARK_OVERHEAD;
- fprintf(stderr,"Overhead for pri spark: %d (per elem).\n",
- RTSflags.GranFlags.gran_pri_spark_overhead);
- break;
-
- case 'O': /* sort overhead (per elem in spark list) */
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.gran_pri_sched_overhead = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.gran_pri_sched_overhead = PRI_SCHED_OVERHEAD;
- fprintf(stderr,"Overhead for pri sched: %d (per elem).\n",
- RTSflags.GranFlags.gran_pri_sched_overhead);
- break;
-
- /* General Parameters */
- case 'p':
- if (rts_argv[arg][3] != '\0')
- {
- RTSflags.GranFlags.proc = decode(rts_argv[arg]+3);
- if (RTSflags.GranFlags.proc==0) {
- enable_GrAnSimLight(); /* set flags for GrAnSim-Light mode */
- } else if (RTSflags.GranFlags.proc > MAX_PROC ||
- RTSflags.GranFlags.proc < 1)
- {
- fprintf(stderr,"setupRtsFlags: no more than %u processors
-allowed\n",
- MAX_PROC);
- *error = rtsTrue;
- }
- }
- else
- RTSflags.GranFlags.proc = MAX_PROC;
- break;
-
- case 'f':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.max_fishes = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.max_fishes = MAX_FISHES;
- break;
-
- case 'w':
- if (rts_argv[arg][3] != '\0')
- RTSflags.GranFlags.time_slice = decode(rts_argv[arg]+3);
- else
- RTSflags.GranFlags.time_slice = GRAN_TIME_SLICE;
- break;
-
- case 'C':
- RTSflags.GranFlags.DoAlwaysCreateThreads=rtsTrue;
- RTSflags.GranFlags.DoThreadMigration=rtsTrue;
- break;
-
- case 'G':
- fprintf(stderr,"Bulk fetching enabled.\n");
- RTSflags.GranFlags.DoGUMMFetching=rtsTrue;
- break;
-
- case 'M':
- fprintf(stderr,"Thread migration enabled.\n");
- RTSflags.GranFlags.DoThreadMigration=rtsTrue;
- break;
-
- case 'R':
- fprintf(stderr,"Fair Scheduling enabled.\n");
- RTSflags.GranFlags.DoFairSchedule=rtsTrue;
- break;
-
- case 'I':
- fprintf(stderr,"Priority Scheduling enabled.\n");
- RTSflags.GranFlags.DoPriorityScheduling=rtsTrue;
- break;
-
- case 'T':
- RTSflags.GranFlags.DoStealThreadsFirst=rtsTrue;
- RTSflags.GranFlags.DoThreadMigration=rtsTrue;
- break;
-
- case 'Z':
- RTSflags.GranFlags.DoReScheduleOnFetch=rtsTrue;
- break;
-
- case 'z':
- RTSflags.GranFlags.SimplifiedFetch=rtsTrue;
- break;
-
- case 'N':
- RTSflags.GranFlags.PreferSparksOfLocalNodes=rtsTrue;
- break;
-
- case 'b':
- RTSflags.GranFlags.granSimStats_Binary=rtsTrue;
- break;
-
- case 'P':
- RTSflags.GranFlags.granSimStats=rtsTrue;
- break;
-
- case 's':
- RTSflags.GranFlags.granSimStats_Sparks=rtsTrue;
- break;
-
- case 'h':
- RTSflags.GranFlags.granSimStats_Heap=rtsTrue;
- break;
-
- case 'U':
- RTSflags.GranFlags.labelling=rtsTrue;
- break;
-
- case 'Y': /* syntax: -bY<n>[,<n>] n ... pos int */
- if (rts_argv[arg][3] != '\0') {
- char *arg0, *tmp;
-
- arg0 = rts_argv[arg]+3;
- if ((tmp = strstr(arg0,","))==NULL) {
- RTSflags.GranFlags.SparkPriority = decode(arg0);
- fprintf(stderr,"SparkPriority: %u.\n",RTSflags.GranFlags.SparkPriority);
- } else {
- *(tmp++) = '\0';
- RTSflags.GranFlags.SparkPriority = decode(arg0);
- RTSflags.GranFlags.SparkPriority2 = decode(tmp);
- fprintf(stderr,"SparkPriority: %u.\n",
- RTSflags.GranFlags.SparkPriority);
- fprintf(stderr,"SparkPriority2:%u.\n",
- RTSflags.GranFlags.SparkPriority2);
- if (RTSflags.GranFlags.SparkPriority2 <
- RTSflags.GranFlags.SparkPriority) {
- fprintf(stderr,"WARNING: 2nd pri < main pri (%u<%u); 2nd pri has no effect\n",
- RTSflags.GranFlags.SparkPriority2,
- RTSflags.GranFlags.SparkPriority);
- }
- }
- } else {
- /* plain pri spark is now invoked with -bX
- RTSflags.GranFlags.DoPrioritySparking = 1;
- fprintf(stderr,"PrioritySparking.\n");
- */
- }
- break;
-
- case 'Q':
- if (rts_argv[arg][3] != '\0') {
- RTSflags.GranFlags.ThunksToPack = decode(rts_argv[arg]+3);
- } else {
- RTSflags.GranFlags.ThunksToPack = 1;
- }
- fprintf(stderr,"Thunks To Pack in one packet: %u.\n",
- RTSflags.GranFlags.ThunksToPack);
- break;
-
- case 'e':
- RTSflags.GranFlags.RandomSteal = rtsFalse;
- fprintf(stderr,"Deterministic mode (no random stealing)\n");
- break;
-
- /* The following class of options contains eXperimental */
- /* features in connection with exploiting granularity */
- /* information. I.e. if -bY is chosen these options */
- /* tell the RTS what to do with the supplied info --HWL */
-
- case 'W':
- if (rts_argv[arg][3] != '\0') {
- RTSflags.GranFlags.packBufferSize_internal = decode(rts_argv[arg]+3);
- } else {
- RTSflags.GranFlags.packBufferSize_internal = GRANSIM_DEFAULT_PACK_BUFFER_SIZE;
- }
- fprintf(stderr,"Size of GranSim internal pack buffer: %u.\n",
- RTSflags.GranFlags.packBufferSize_internal);
- break;
-
- case 'X':
- switch(rts_argv[arg][3]) {
-
- case '\0':
- RTSflags.GranFlags.DoPrioritySparking = 1;
- fprintf(stderr,"Priority Sparking with Normal Priorities.\n");
- RTSflags.GranFlags.InversePriorities = rtsFalse;
- RTSflags.GranFlags.RandomPriorities = rtsFalse;
- RTSflags.GranFlags.IgnorePriorities = rtsFalse;
- break;
-
- case 'I':
- RTSflags.GranFlags.DoPrioritySparking = 1;
- fprintf(stderr,"Priority Sparking with Inverse Priorities.\n");
- RTSflags.GranFlags.InversePriorities++;
- break;
-
- case 'R':
- RTSflags.GranFlags.DoPrioritySparking = 1;
- fprintf(stderr,"Priority Sparking with Random Priorities.\n");
- RTSflags.GranFlags.RandomPriorities++;
- break;
-
- case 'N':
- RTSflags.GranFlags.DoPrioritySparking = 1;
- fprintf(stderr,"Priority Sparking with No Priorities.\n");
- RTSflags.GranFlags.IgnorePriorities++;
- break;
-
- default:
- bad_option( rts_argv[arg] );
- break;
- }
- break;
-
- case '-':
- switch(rts_argv[arg][3]) {
-
- case 'C':
- RTSflags.GranFlags.DoAlwaysCreateThreads=rtsFalse;
- RTSflags.GranFlags.DoThreadMigration=rtsFalse;
- break;
-
- case 'G':
- RTSflags.GranFlags.DoGUMMFetching=rtsFalse;
- break;
-
- case 'M':
- RTSflags.GranFlags.DoThreadMigration=rtsFalse;
- break;
-
- case 'R':
- RTSflags.GranFlags.DoFairSchedule=rtsFalse;
- break;
-
- case 'T':
- RTSflags.GranFlags.DoStealThreadsFirst=rtsFalse;
- RTSflags.GranFlags.DoThreadMigration=rtsFalse;
- break;
-
- case 'Z':
- RTSflags.GranFlags.DoReScheduleOnFetch=rtsFalse;
- break;
-
- case 'N':
- RTSflags.GranFlags.PreferSparksOfLocalNodes=rtsFalse;
- break;
-
- case 'P':
- RTSflags.GranFlags.granSimStats_suppressed=rtsTrue;
- break;
-
- case 's':
- RTSflags.GranFlags.granSimStats_Sparks=rtsFalse;
- break;
-
- case 'h':
- RTSflags.GranFlags.granSimStats_Heap=rtsFalse;
- break;
-
- case 'b':
- RTSflags.GranFlags.granSimStats_Binary=rtsFalse;
- break;
-
- case 'X':
- RTSflags.GranFlags.DoPrioritySparking = rtsFalse;
- break;
-
- case 'Y':
- RTSflags.GranFlags.DoPrioritySparking = rtsFalse;
- RTSflags.GranFlags.SparkPriority = rtsFalse;
- break;
-
- case 'I':
- RTSflags.GranFlags.DoPriorityScheduling = rtsFalse;
- break;
-
- case 'e':
- RTSflags.GranFlags.RandomSteal = rtsFalse;
- break;
-
- default:
- bad_option( rts_argv[arg] );
- break;
- }
- break;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- case 'D':
- switch(rts_argv[arg][3]) {
- case 'Q': /* Set pack buffer size (same as 'Q' in GUM) */
- if (rts_argv[arg][4] != '\0') {
- RTSflags.GranFlags.packBufferSize = decode(rts_argv[arg]+4);
- fprintf(stderr,"Pack buffer size: %d\n",
- RTSflags.GranFlags.packBufferSize);
- } else {
- fprintf(stderr, "setupRtsFlags: missing size of PackBuffer (for -Q)\n");
- error = rtsTrue;
- }
- break;
-
- case 'e': /* event trace */
- fprintf(stderr,"Printing event trace.\n");
- RTSflags.GranFlags.event_trace=rtsTrue;
- break;
-
- case 'f':
- fprintf(stderr,"Printing forwarding of FETCHNODES.\n");
- RTSflags.GranFlags.debug |= 0x2; /* print fwd messages */
- break;
-
- case 'z':
- fprintf(stderr,"Check for blocked on fetch.\n");
- RTSflags.GranFlags.debug |= 0x4; /* debug non-reschedule-on-fetch */
- break;
-
- case 't':
- fprintf(stderr,"Check for TSO asleep on fetch.\n");
- RTSflags.GranFlags.debug |= 0x10; /* debug TSO asleep for fetch */
- break;
-
- case 'E':
- fprintf(stderr,"Printing event statistics.\n");
- RTSflags.GranFlags.debug |= 0x20; /* print event statistics */
- break;
-
- case 'F':
- fprintf(stderr,"Prohibiting forward.\n");
- RTSflags.GranFlags.NoForward = rtsTrue; /* prohibit forwarding */
- break;
-
- case 'm':
- fprintf(stderr,"Printing fetch misses.\n");
- RTSflags.GranFlags.PrintFetchMisses = rtsTrue; /* prohibit forwarding */
- break;
-
- case 'd':
- fprintf(stderr,"Debug mode.\n");
- RTSflags.GranFlags.debug |= 0x40;
- break;
-
- case 'D':
- fprintf(stderr,"Severe debug mode.\n");
- RTSflags.GranFlags.debug |= 0x80;
- break;
-
- case 'q':
- fprintf(stderr,"FULL event trace.\n");
- RTSflags.GranFlags.event_trace_all =rtsTrue;
- break;
-
- case 'G':
- fprintf(stderr,"Debugging packet fetching.\n");
- RTSflags.GranFlags.debug |= 0x100;
- break;
-
- case 'n':
- fprintf(stderr,"Ignore events till end of time slice\n");
- RTSflags.GranFlags.debug |= 0x200;
- IgnoreEvents = rtsTrue;
- break;
-
- case 'S':
- fprintf(stderr,"Check that spark queues are sorted.\n");
- RTSflags.GranFlags.debug |= 0x400;
- break;
-
- case 'H':
- fprintf(stderr,"Print heap allocation messages (RBH).\n");
- RTSflags.GranFlags.debug |= 0x800;
- break;
-
- case 'p':
- fprintf(stderr,"Debug breadth-first pruning.\n");
- RTSflags.GranFlags.debug |= 0x1000;
- break;
-
- case 'r':
- fprintf(stderr,"Debug random stealing.\n");
- RTSflags.GranFlags.debug |= 0x2000;
- break;
-
- case 'B':
- fprintf(stderr,"Debug busyness.\n");
- RTSflags.GranFlags.debug |= 0x4000;
- break;
-
- case 'P':
- fprintf(stderr,"Debug pack buffer handling.\n");
- RTSflags.GranFlags.debug |= 0x8000;
- break;
-
- case 's':
- fprintf(stderr,"Debug spark-queue manipulations.\n");
- RTSflags.GranFlags.debug |= 0x10000;
- break;
-
- case ':':
- fprintf(stderr,"Debug GrAnSim Light.\n");
- RTSflags.GranFlags.debug |= 0x20000;
- break;
-
- case '\0':
- RTSflags.GranFlags.debug = 1;
- break;
-
- default:
- bad_option( rts_argv[arg] );
- break;
- }
- break;
-# endif /* GRAN_CHECK */
- default:
- bad_option( rts_argv[arg] );
- break;
- }
-}
-#endif /* GRAN */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Profiling RTS Arguments}
-%* *
-%************************************************************************
-
-\begin{code}
-I_ MaxResidency = 0; /* in words; for stats only */
-I_ ResidencySamples = 0; /* for stats only */
-
-void
-initSM(void)
-{
- RTSflags.GcFlags.minAllocAreaSize
- = (I_) (RTSflags.GcFlags.heapSize * RTSflags.GcFlags.pcFreeHeap / 100);
- /*
- This needs to be here, in case the user changed some of these
- values with a "hook".
- */
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Utility bits}
-%* *
-%************************************************************************
-
-\begin{code}
-static FILE * /* return NULL on error */
-open_stats_file (
- I_ arg,
- int argc, char *argv[],
- int rts_argc, char *rts_argv[],
- const char *FILENAME_FMT)
-{
- FILE *f = NULL;
-
- if (strequal(rts_argv[arg]+2, "stderr")) /* use real stderr */
- f = stderr;
- else if (rts_argv[arg][2] != '\0') /* stats file specified */
- f = fopen(rts_argv[arg]+2,"w");
- else {
- char stats_filename[STATS_FILENAME_MAXLEN]; /* default <program>.<ext> */
- sprintf(stats_filename, FILENAME_FMT, argv[0]);
- f = fopen(stats_filename,"w");
- }
- if (f == NULL) {
- fprintf(stderr, "Can't open stats file %s\n", rts_argv[arg]+2);
- } else {
- /* Write argv and rtsv into start of stats file */
- I_ count;
- for(count = 0; count < argc; count++)
- fprintf(f, "%s ", argv[count]);
- fprintf(f, "+RTS ");
- for(count = 0; count < rts_argc; count++)
- fprintf(f, "%s ", rts_argv[count]);
- fprintf(f, "\n");
- }
-
- return(f);
-}
-
-static I_
-decode(const char *s)
-{
- I_ c;
- StgDouble m;
-
- if (!*s)
- return 0;
-
- m = atof(s);
- c = s[strlen(s)-1];
-
- if (c == 'g' || c == 'G')
- m *= 1000*1000*1000; /* UNchecked! */
- else if (c == 'm' || c == 'M')
- m *= 1000*1000; /* We do not use powers of 2 (1024) */
- else if (c == 'k' || c == 'K') /* to avoid possible bad effects on */
- m *= 1000; /* a direct-mapped cache. */
- else if (c == 'w' || c == 'W')
- m *= sizeof(W_);
-
- return (I_)m;
-}
-
-static void
-bad_option(const char *s)
-{
- fflush(stdout);
- fprintf(stderr, "initSM: Bad RTS option: %s\n", s);
- EXIT(EXIT_FAILURE);
-}
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994
-%
-
-% Guilty party: BOS
-
-%************************************************************************
-%* *
-\section[Rep.lc]{Global rep tables}
-%* *
-%************************************************************************
-
-These are the single, global static instances of each rep table type.
-
-\begin{code}
-#define COMPILING_REP_LC
-
-#include "rtsdefs.h"
-#include "../storage/SMinternal.h"
-
-#ifdef aix_TARGET_OS /* AIX gives link errors with consts in this file (RO assembler section) */
-#define const /* */
-#endif
-
-EXTFUN(_PRIn_0);
-EXTFUN(_PRIn_1);
-EXTFUN(_PRIn_2);
-EXTFUN(_PRIn_3);
-EXTFUN(_PRIn_4);
-EXTFUN(_PRIn_5);
-EXTFUN(_PRIn_6);
-EXTFUN(_PRIn_7);
-EXTFUN(_PRIn_8);
-EXTFUN(_PRIn_9);
-EXTFUN(_PRIn_10);
-EXTFUN(_PRIn_11);
-EXTFUN(_PRIn_12);
-
-/* SPEC_x_RTBL(size,ptrs) */
-
-SPEC_N_RTBL(1,0);
-SPEC_N_RTBL(1,1);
-SPEC_N_RTBL(2,0);
-SPEC_N_RTBL(2,1);
-SPEC_N_RTBL(2,2);
-SPEC_N_RTBL(3,0);
-SPEC_N_RTBL(3,1);
-SPEC_N_RTBL(3,2);
-SPEC_N_RTBL(3,3);
-SPEC_N_RTBL(4,0);
-SPEC_N_RTBL(4,4);
-SPEC_N_RTBL(5,0);
-SPEC_N_RTBL(5,5);
-SPEC_N_RTBL(6,6);
-SPEC_N_RTBL(7,7);
-SPEC_N_RTBL(8,8);
-SPEC_N_RTBL(9,9);
-SPEC_N_RTBL(10,10);
-SPEC_N_RTBL(11,11);
-SPEC_N_RTBL(12,12);
-
-SPEC_S_RTBL(1,0);
-SPEC_S_RTBL(1,1);
-SPEC_S_RTBL(2,0);
-SPEC_S_RTBL(2,1);
-SPEC_S_RTBL(2,2);
-SPEC_S_RTBL(3,0);
-SPEC_S_RTBL(3,1);
-SPEC_S_RTBL(3,2);
-SPEC_S_RTBL(3,3);
-SPEC_S_RTBL(4,0);
-SPEC_S_RTBL(4,4);
-SPEC_S_RTBL(5,0);
-SPEC_S_RTBL(5,5);
-SPEC_S_RTBL(6,6);
-SPEC_S_RTBL(7,7);
-SPEC_S_RTBL(8,8);
-SPEC_S_RTBL(9,9);
-SPEC_S_RTBL(10,10);
-SPEC_S_RTBL(11,11);
-SPEC_S_RTBL(12,12);
-
-SPEC_U_RTBL(1,0);
-SPEC_U_RTBL(1,1);
-SPEC_U_RTBL(2,0);
-SPEC_U_RTBL(2,1);
-SPEC_U_RTBL(2,2);
-SPEC_U_RTBL(3,0);
-SPEC_U_RTBL(3,1);
-SPEC_U_RTBL(3,2);
-SPEC_U_RTBL(3,3);
-SPEC_U_RTBL(4,0);
-SPEC_U_RTBL(4,4);
-SPEC_U_RTBL(5,0);
-SPEC_U_RTBL(5,5);
-SPEC_U_RTBL(6,6);
-SPEC_U_RTBL(7,7);
-SPEC_U_RTBL(8,8);
-SPEC_U_RTBL(9,9);
-SPEC_U_RTBL(10,10);
-SPEC_U_RTBL(11,11);
-SPEC_U_RTBL(12,12);
-
-/* SELECT_RTBL(size,ptrs,select_word_i) */
-
-SELECT_RTBL(2,1,0);
-SELECT_RTBL(2,1,1);
-SELECT_RTBL(2,1,2);
-SELECT_RTBL(2,1,3);
-SELECT_RTBL(2,1,4);
-SELECT_RTBL(2,1,5);
-SELECT_RTBL(2,1,6);
-SELECT_RTBL(2,1,7);
-SELECT_RTBL(2,1,8);
-SELECT_RTBL(2,1,9);
-SELECT_RTBL(2,1,10);
-SELECT_RTBL(2,1,11);
-SELECT_RTBL(2,1,12);
-
-GEN_N_RTBL();
-GEN_S_RTBL();
-GEN_U_RTBL();
-DYN_RTBL();
-TUPLE_RTBL();
-DATA_RTBL();
-MUTUPLE_RTBL();
-IMMUTUPLE_RTBL();
-STATIC_RTBL();
-
-#if !defined(PAR) /* && !defined(GRAN) */
-ForeignObj_RTBL();
-#endif
-
-BH_RTBL(N);
-BH_RTBL(U);
-
-IND_RTBL();
-PERM_IND_RTBL();
-CAF_RTBL();
-CONST_RTBL();
-CHARLIKE_RTBL();
-INTLIKE_RTBL();
-
-CAF_EVAC_UPD_RTBL();
-
-#ifdef GCgn
-FORWARDREF_RTBL(_Evacuate_Old_Forward_Ref);
-FORWARDREF_RTBL(_Evacuate_New_Forward_Ref);
-FORWARDREF_RTBL(_Evacuate_OldRoot_Forward);
-#endif
-FORWARDREF_RTBL(_Evacuate_Forward_Ref);
-
-#ifdef _INFO_MARKING
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextRoot,_Dummy_PRReturn_entry);
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextCAF,_Dummy_PRReturn_entry);
-# ifdef CONCURRENT
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextSpark,_Dummy_PRReturn_entry);
-# endif
-# if defined(GRAN)
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextEvent,_Dummy_PRReturn_entry);
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextClosureInFetchBuffer,_Dummy_PRReturn_entry);
-# endif
-# ifdef PAR
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextGA,_Dummy_PRReturn_entry);
-# else
-# if 1 /* !defined(CONCURRENT) */ /* HWL */
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextAStack,_Dummy_PRReturn_entry);
-DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextBStack,_Dummy_PRReturn_entry);
-# endif
-# endif
-#endif
-
-#ifdef GCgn
-OLDROOT_RTBL();
-#endif
-
-#ifdef CONCURRENT
-TSO_RTBL();
-STKO_RTBL();
-BQ_RTBL();
-# ifndef PAR
-STKO_STATIC_RTBL();
-# else
-FETCHME_RTBL();
-FMBQ_RTBL();
-BF_RTBL();
-# endif
-#endif
-
-#if defined(PAR) || defined(GRAN)
-SPEC_RBH_RTBL(2,0);
-SPEC_RBH_RTBL(2,1);
-SPEC_RBH_RTBL(2,2);
-SPEC_RBH_RTBL(3,0);
-SPEC_RBH_RTBL(3,1);
-SPEC_RBH_RTBL(3,2);
-SPEC_RBH_RTBL(3,3);
-SPEC_RBH_RTBL(4,0);
-SPEC_RBH_RTBL(4,4);
-SPEC_RBH_RTBL(5,0);
-SPEC_RBH_RTBL(5,5);
-SPEC_RBH_RTBL(6,6);
-SPEC_RBH_RTBL(7,7);
-SPEC_RBH_RTBL(8,8);
-SPEC_RBH_RTBL(9,9);
-SPEC_RBH_RTBL(10,10);
-SPEC_RBH_RTBL(11,11);
-SPEC_RBH_RTBL(12,12);
-
-GEN_RBH_RTBL();
-#endif
-
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section[Select.lc]{Select Available File Descriptors}
-%* *
-%************************************************************************
-
-Handling of select() of read&write on file descriptors or timer expiry.
-
-\begin{code}
-
-#ifdef CONCURRENT
-
-/* #define STK_CHK_DEBUG */
-
-#define NULL_REG_MAP
-
-#if !defined(_AIX)
-#define NON_POSIX_SOURCE
-#endif
-/* Should there be a POSIX alternative based on poll()? */
-
-#include "rtsdefs.h"
-
-# if defined(HAVE_SYS_TYPES_H)
-# include <sys/types.h>
-# endif
-
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# endif
-
-/* Counter holding the number of timer ticks seen during GC */
-I_ delayTicks = 0;
-
-/*
- handleTimerExpiry is used to temporarily delay the handling of
- timer ticks for threads delayed waiting for timeout. Disable
- during GC, counting up the ticks , before updating the waiting
- threads queue when finished GCing.
-
- */
-
-void
-handleTimerExpiry(enable)
-rtsBool enable;
-{
- /*
- If we enable the handling of timer expiry, update the WaitingThreads
- queue with the number of ticks we have accumulated since the handling
- was disabled.
- */
- if (!enable)
- delayTicks = 1;
- else {
- if (delayTicks > 1) {
- delayTicks = 0;
- AwaitEvent((delayTicks-1) * RTSflags.ConcFlags.ctxtSwitchTime);
- }
- }
-}
-
-void
-AwaitEvent(I_ delta)
-{
- P_ tso, prev, next;
- rtsBool ready;
- fd_set rfd,wfd;
- I_ us;
- I_ min, numFound;
- I_ maxfd=0;
-
- struct timeval tv,tv_before,tv_after;
-
- min = delta == 0 ? 0x7fffffff : 0;
-
- /*
- * Collect all of the fd's that we're interested in, and capture
- * the minimum waiting time (in microseconds) for the delayed threads.
- *
- * (I_)TSO_EVENT(tso) < 0 => thread waiting on read on fd (-(I_)TSO_EVENT(tso))
- *
- * (I_)TSO_EVENT(tso) < -FD_SETSIZE => thread waiting on write on fd
- * (FD_SETSIZE-(I_)TSO_EVENT(tso))
- */
- FD_ZERO(&rfd);
- FD_ZERO(&wfd);
- for(tso = WaitingThreadsHd; tso != PrelBase_Z91Z93_closure; tso = TSO_LINK(tso)) {
- us = (I_) TSO_EVENT(tso);
- if (us > 0) {
- /* Looking at a delay event */
- if (us < min)
- min = us;
- } else if ( us <= (-(I_)FD_SETSIZE)) {
- /* Looking at a waitWrite event */
- us += (I_)FD_SETSIZE;
- maxfd = ((1-us)> maxfd) ? (1-us) : maxfd;
- FD_SET((-us), &wfd);
- } else {
- /* Looking at a waitRead event */
- maxfd = ((1-us)> maxfd) ? (1-us) : maxfd;
- FD_SET((-us), &rfd);
- }
- }
-
- /* Check for any interesting events */
-
- tv.tv_sec = min / 1000000;
- tv.tv_usec = min % 1000000;
-
- gettimeofday(&tv_before, (struct timezone *) NULL);
-
- while ((numFound = select(maxfd, &rfd, &wfd, NULL, &tv)) < 0) {
- if (errno != EINTR) {
- fflush(stdout);
- fprintf(stderr, "AwaitEvent: select failed\n");
- EXIT(EXIT_FAILURE);
- }
- }
-
- if (numFound != 0) {
- /*
- File descriptors ready, but we have don't know how much time was spent
- in the select(). To interpolate, we compare the time before and after the
- select().
- */
-
- gettimeofday(&tv_after, (struct timezone *) NULL);
- delta = (tv_after.tv_sec - tv_before.tv_sec) * 1000000 +
- tv_after.tv_usec - tv_before.tv_usec;
-
- }
-
- if (delta == 0)
- delta=min;
-
- /*
- Step through the waiting queue, unblocking every thread that now has
- a file descriptor in a ready state.
-
- For the delayed threads, decrement the number of microsecs
- we've been blocked for. Unblock the threads that have thusly expired.
- */
-
- prev = NULL;
- for(tso = WaitingThreadsHd; tso != PrelBase_Z91Z93_closure; tso = next) {
- next = TSO_LINK(tso);
- us = (I_) TSO_EVENT(tso);
- if (us > 0) {
- /* Looking at a delay event */
- us -= delta;
- ready = (us <= 0);
- if (!ready)
- TSO_EVENT(tso) = (W_) us;
- } else if ( us <= (-(I_)FD_SETSIZE)) {
- /* Looking at a waitWrite event */
- ready = FD_ISSET(((I_)FD_SETSIZE-us), &wfd);
- } else {
- /* Looking at a waitRead event */
- ready = FD_ISSET((-us), &rfd);
- }
- if (ready) {
-
-#if defined(GRAN)
- if (ThreadQueueTl == PrelBase_Z91Z93_closure)
- ThreadQueueHd = tso;
- else
- TSO_LINK(ThreadQueueTl) = tso;
- ThreadQueueTl = tso;
- TSO_LINK(tso) = PrelBase_Z91Z93_closure;
-#else
- if (RunnableThreadsTl == PrelBase_Z91Z93_closure)
- RunnableThreadsHd = tso;
- else
- TSO_LINK(RunnableThreadsTl) = tso;
- RunnableThreadsTl = tso;
- TSO_LINK(tso) = PrelBase_Z91Z93_closure;
-#endif
- } else {
- if (prev == NULL)
- WaitingThreadsHd = tso;
- else
- TSO_LINK(prev) = tso;
- prev = tso;
- }
- }
- if (prev == NULL)
- WaitingThreadsHd = WaitingThreadsTl = PrelBase_Z91Z93_closure;
- else {
- TSO_LINK(prev) = PrelBase_Z91Z93_closure;
- WaitingThreadsTl = prev;
- }
-}
-
-#endif /* CONCURRENT */
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section[Signals.lc]{Signal Handlers}
-%* *
-%************************************************************************
-
-There are two particular signals that we find interesting in the RTS:
-segmentation faults (for cheap stack overflow checks) and virtual
-timer alarms (for profiling and thread context switching). POSIX
-compliance is supposed to make this kind of thing easy, but it
-doesn't. Expect every new target platform to require gory hacks to
-get this stuff to work.
-
-Then, there are the user-specified signal handlers to cope with.
-Since they're pretty rudimentary, they shouldn't actually cause as
-much pain.
-
-\begin{code}
-#include "config.h"
-
-/* Treat nexttep3 and sunos4 alike. CaS */
-#if defined(nextstep3_TARGET_OS)
-# define NON_POSIX_SOURCE
-#endif
-
-#if defined(sunos4_TARGET_OS)
- /* The sigaction in SunOS 4.1.X does not grok SA_SIGINFO */
-# define NON_POSIX_SOURCE
-#endif
-
-#if defined(freebsd_TARGET_OS)
-# define NON_POSIX_SOURCE
-#endif
-
-#if defined(osf3_TARGET_OS) || defined(osf1_TARGET_OS)
- /* The include files for OSF1 do not normally define SA_SIGINFO */
-# define _OSF_SOURCE 1
-#endif
-
-#if irix_TARGET_OS
-/* SIGVTALRM not avail w/ POSIX_SOURCE, but worse things happen without */
-/* SIGH: triple SIGH (WDP 95/07) */
-# define SIGVTALRM 28
-#endif
-
-#include "rtsdefs.h"
-
-#if defined(HAVE_SYS_TYPES_H)
-# include <sys/types.h>
-#endif
-
- /* This is useful with the particular set of header files on my NeXT.
- * CaS
- */
-#if defined(HAVE_SYS_SIGNAL_H)
-# include <sys/signal.h>
-#endif
-
-#if defined(HAVE_SIGNAL_H)
-# include <signal.h>
-#endif
-
-#if defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS)
-/* to look *inside* sigcontext...
-
- sigcontext has moved and been protected from the General Public,
- in later versions (>2), the sigcontext decl is protected by
- a __KERNEL__ #ifdef. As ever, we workaround by trying to
- be version savvy - the version numbers are currently just a guess!
- (ToDo: determine at what version no. the sigcontext move
- was made).
-*/
-# ifndef LINUX_VERSION_CODE
-# include <linux/version.h>
-# endif
-/* Snaffled from drivers/scsi/eata.c in 2.0.30 sources */
-#define LinuxVersionCode(v, p, s) (((v)<<16)+((p)<<8)+(s))
-# if ( LINUX_VERSION_CODE < LinuxVersionCode(2,0,0) )
-# include <asm/signal.h>
-# else
-# include <asm/sigcontext.h>
-# endif
-
-#endif
-
-#if defined(HAVE_SIGINFO_H)
- /* DEC OSF1 seems to need this explicitly. Maybe others do as well? */
-# include <siginfo.h>
-#endif
-
-#if defined(cygwin32_TARGET_OS)
-# include <windows.h>
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Stack-check by protected-memory-faulting}
-%* *
-%************************************************************************
-
-If we are checking stack overflow by page faulting, then we need to be
-able to install a @SIGSEGV@ handler, preferably one which can
-determine where the fault occurred, so that we can satisfy ourselves
-that it really was a stack overflow and not some random segmentation
-fault.
-
-\begin{code}
-#if STACK_CHECK_BY_PAGE_FAULT
- /* NB: At the moment, this is always false on nextstep3. CaS. */
-
-extern P_ stks_space; /* Where the stacks live, from SMstacks.lc */
-\end{code}
-
-SunOS 4.x is too old to have @SA_SIGINFO@ as a flag to @sigaction@, so
-we use the older @signal@ call instead. This means that we also have
-to set up the handler to expect a different collection of arguments.
-Fun, eh?
-
-\begin{code}
-# if defined(sunos4_TARGET_OS) || defined(freebsd_TARGET_OS) \
- || defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS) \
- || defined(aix_TARGET_OS)
-
-static void
-segv_handler(int sig,
- /* NB: all except first argument are "implementation defined" */
-# if defined(sunos4_TARGET_OS) || defined(freebsd_TARGET_OS)
- int code, struct sigcontext *scp, caddr_t addr)
-# else /* linux || aix */
-# if defined(aix_TARGET_OS)
- int code, struct sigcontext *scp)
-# else /* linux */
- /* sigcontext_struct has been renamed to sigcontext. If
- compiling this code elicits a bunch of warnings about
- "struct sigcontext_struct" being undeclared, check to
- see whether you've got "struct sigcontext" in <asm/sigcontext.h>.
- or not.
-
- If you do, lower the version number below to fit the version
- you're running (and pass us a note saying that you had to - thx!)
- */
-# if LINUX_VERSION_CODE >= LinuxVersionCode(2,1,51)
- /* sigcontext_struct has been renamed to sigcontext */
- struct sigcontext scp)
-# else
- struct sigcontext_struct scp)
-# endif
-# endif
-# endif
-{
- extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
-
-# if defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS)
- unsigned long addr = scp.cr2;
- /* Magic info from Tommy Thorn! */
-# endif
-# if defined(aix_TARGET_OS)
- caddr_t addr = scp->sc_jmpbuf.jmp_context.o_vaddr;
- /* Magic guess by andre */
-# endif
- if ( (char *)addr >= (char *)stks_space
- && (char *)addr < (char *)(stks_space + RTSflags.GcFlags.stksSize))
- StackOverflow();
-
- fflush(stdout);
- fprintf(stderr, "Segmentation fault caught, address = %lx\n", (W_) addr);
- abort();
-}
-
-int
-install_segv_handler(void)
-{
-#if freebsd_TARGET_OS
- /* FreeBSD seems to generate SIGBUS for stack overflows */
- if (signal(SIGBUS, segv_handler) == SIG_ERR)
- return -1;
- if (signal(SIGSEGV, segv_handler) == SIG_ERR)
- return -1;
- return 0;
-#else
- return ((int) signal(SIGSEGV, segv_handler) == SIG_ERR);
- /* I think the "== SIG_ERR" is saying "there was no
- handler for SIGSEGV before this one". WDP 95/12
- */
-#endif
-}
-
-# elif defined(irix6_TARGET_OS)
-
-static void
-segv_handler(int sig, siginfo_t *sip, void *dummy)
-{
- fflush(stdout);
- if (sip == NULL) {
- fprintf(stderr, "Segmentation fault caught, address unknown\n");
- } else {
- if (sip->si_addr >= (void *) stks_space
- && sip->si_addr < (void *) (stks_space + RTSflags.GcFlags.stksSize))
- StackOverflow();
- fprintf(stderr, "Segmentation fault caught, address = %08lx\n", (W_) sip->si_addr);
- }
- abort();
-}
-
-int
-install_segv_handler(STG_NO_ARGS)
-{
- struct sigaction action;
-
- action.sa_sigaction = segv_handler;
- sigemptyset(&action.sa_mask);
- action.sa_flags = SA_SIGINFO;
-
- return sigaction(SIGSEGV, &action, NULL);
-}
-
-# elif defined(cygwin32_TARGET_OS)
-
-/*
- The signal handlers in cygwin32 are only passed the signal
- number, no sigcontext/siginfo is passed as event data..sigh. For
- SIGSEGV, to get at the violating address, we need to use the Win32's
- GetThreadContext() to get at the faulting address.
-*/
-static void
-segv_handler(sig)
- int sig;
-{
- CONTEXT context;
- HANDLE hThread;
- BOOL t;
-
- context.ContextFlags = CONTEXT_CONTROL;
- hThread = GetCurrentThread(); /* cannot fail */
- t = GetThreadContext(hThread,&context);
-
- fflush(stdout);
- if (t == FALSE) {
- fprintf(stderr, "Segmentation fault caught, address unknown\n");
- } else {
- void *si_addr = context.Eip; /* magic */
- if (si_addr >= (void *) stks_space
- && si_addr < (void *) (stks_space + RTSflags.GcFlags.stksSize))
- StackOverflow();
-
- fprintf(stderr, "Segmentation fault caught, address = %08lx\n", (W_)si_addr);
- }
- abort();
-}
-
-int
-install_segv_handler()
-{
- return (int) signal(SIGSEGV, segv_handler) == -1;
-}
-
-# else /* ! (cygwin32|irix6|sunos4|linux*|*bsd|aix) */
-
-# if defined(irix_TARGET_OS)
- /* certainly BOGUS (WDP 94/05) -- copied from /usr/include/sys/siginfo.h */
-# define si_addr _data._fault._addr
-# endif
-
-static void
-segv_handler(int sig, siginfo_t *sip)
- /* NB: the second "siginfo_t" argument is not really standard */
-{
- fflush(stdout);
- if (sip == NULL) {
- fprintf(stderr, "Segmentation fault caught, address unknown\n");
- } else {
- if (sip->si_addr >= (caddr_t) stks_space
- && sip->si_addr < (caddr_t) (stks_space + RTSflags.GcFlags.stksSize))
- StackOverflow();
-
- fprintf(stderr, "Segmentation fault caught, address = %08lx\n", (W_) sip->si_addr);
- }
- abort();
-}
-
-int
-install_segv_handler(STG_NO_ARGS)
-{
- struct sigaction action;
-
- action.sa_handler = segv_handler;
- sigemptyset(&action.sa_mask);
- action.sa_flags = SA_SIGINFO;
-
- return sigaction(SIGSEGV, &action, NULL);
-}
-
-# endif /* ! (cygwin32|irix6|sunos4|linux*|*bsd|aix) */
-
-#endif /* STACK_CHECK_BY_PAGE_FAULT */
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Virtual-timer alarm (for profiling, etc.)}
-%* *
-%************************************************************************
-
-The timer interrupt is somewhat simpler, and we could probably use
-sigaction across the board, but since we have committed ourselves to
-the non-POSIX signal under SunOS 4.1.X, we adopt the same approach
-here.
-
-\begin{code}
-#if defined(PROFILING) || defined(CONCURRENT) /* && !defined(GRAN) */
-
-# ifdef CONCURRENT
-
-extern I_ delayTicks;
-
-# ifdef PAR
-extern P_ CurrentTSO;
-# endif
-
-/*
- cygwin32 does not support VTALRM (sigh) - to do anything
- sensible here we use the underlying Win32 calls.
- (will this work??)
-*/
-# if defined(cygwin32_TARGET_OS)
-/* windows.h already included */
-static VOID CALLBACK
-vtalrm_handler(uID,uMsg,dwUser,dw1,dw2)
-int uID;
-unsigned int uMsg;
-unsigned int dwUser;
-unsigned int dw1;
-unsigned int dw2;
-# else
-static void
-vtalrm_handler(int sig)
-# endif
-{
-/*
- For the parallel world, currentTSO is set if there is any work
- on the current PE. In this case we DO want to context switch,
- in case other PEs have sent us messages which must be processed.
-*/
-
-# if defined(PROFILING) || defined(PAR)
- static I_ csTicks = 0, pTicks = 0;
-
- if (time_profiling) {
- if (++pTicks % RTSflags.CcFlags.profilerTicks == 0) {
-# if ! defined(PROFILING)
- handle_tick_serial();
-# else
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
- || RTSflags.ProfFlags.doHeapProfile)
- handle_tick_serial();
- else
- handle_tick_noserial();
-# endif
- }
- if (++csTicks % RTSflags.CcFlags.ctxtSwitchTicks != 0)
- return;
- }
-# endif
-
- /*
- Handling a tick for threads blocked waiting for file
- descriptor I/O or time.
-
- This requires some care since virtual time alarm ticks
- can occur when we are in the GC. If that is the case,
- we just increment a delayed timer tick counter, but do
- not check to see if any TSOs have been made runnable
- as a result. (Do a bulk update of their status once
- the GC has completed).
-
- If the vtalrm does not occur within GC, we try to promote
- any of the waiting threads to the runnable list (see awaitEvent)
-
- 4/96 SOF
- */
-
- if (delayTicks != 0) /* delayTicks>0 => don't handle timer expiry (in GC) */
- delayTicks++;
- else if (WaitingThreadsHd != PrelBase_Z91Z93_closure)
- AwaitEvent(RTSflags.ConcFlags.ctxtSwitchTime);
-
-# ifdef PAR
- if (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL] ||
- PendingSparksTl[ADVISORY_POOL] == PendingSparksLim[ADVISORY_POOL]) {
- PruneSparks();
- if (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL])
- PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL] +
- SparkLimit[REQUIRED_POOL] / 2;
- if (PendingSparksTl[ADVISORY_POOL] == PendingSparksLim[ADVISORY_POOL]) {
- PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL] +
- SparkLimit[ADVISORY_POOL] / 2;
- sparksIgnored += SparkLimit[REQUIRED_POOL] / 2;
- }
- }
-
- if (CurrentTSO != NULL ||
-# else
- if (RunnableThreadsHd != PrelBase_Z91Z93_closure ||
-# endif
- PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL] ||
- PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL]) {
- /* ToDo: anything else for GRAN? WDP */
- context_switch = 1;
- }
-}
-
-# endif
-
-
-#if defined(cygwin32_TARGET_OS) /* really just Win32 */
-/* windows.h already included for the segv_handling above */
-
-I_ vtalrm_id;
-TIMECALLBACK *vtalrm_cback;
-
-#ifndef CONCURRENT
-void (*tick_handle)(STG_NO_ARGS);
-
-static VOID CALLBACK
-tick_handler(uID,uMsg,dwUser,dw1,dw2)
-int uID;
-unsigned int uMsg;
-unsigned int dwUser;
-unsigned int dw1;
-unsigned int dw2;
-{
- (*tick_handle)();
-}
-#endif
-
-int install_vtalrm_handler()
-{
-# ifdef CONCURRENT
- vtalrm_cback = vtalrm_handler;
-# else
- /*
- Only turn on ticking
- */
- vtalrm_cback = tick_handler;
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
- || RTSflags.ProfFlags.doHeapProfile)
- tick_handle = handle_tick_serial;
- else
- tick_handle = handle_tick_noserial;
-# endif
- return (int)0;
-}
-
-void
-blockVtAlrmSignal(STG_NO_ARGS)
-{
- timeKillEvent(vtalrm_id);
-}
-
-void
-unblockVtAlrmSignal(STG_NO_ARGS)
-{
-#ifdef CONCURRENT
- timeSetEvent(RTSflags.ConcFlags.ctxtSwitchTime,5,vtalrm_cback,NULL,TIME_PERIODIC);
-#else
- timeSetEvent(RTSflags.CcFlags.msecsPerTick,5,vtalrm_cback,NULL,TIME_PERIODIC);
-#endif
-}
-
-#elif defined(sunos4_TARGET_OS)
-
-int
-install_vtalrm_handler(void)
-{
- void (*old)();
-
-# ifdef CONCURRENT
- old = signal(SIGVTALRM, vtalrm_handler);
-# else
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
- || RTSflags.ProfFlags.doHeapProfile)
- old = signal(SIGVTALRM, handle_tick_serial);
- else
- old = signal(SIGVTALRM, handle_tick_noserial);
-# endif
- return ((int) old == SIG_ERR);
-}
-
-static int vtalrm_mask;
-
-void
-blockVtAlrmSignal(STG_NO_ARGS)
-{
- vtalrm_mask = sigblock(sigmask(SIGVTALRM));
-}
-
-void
-unblockVtAlrmSignal(STG_NO_ARGS)
-{
- (void) sigsetmask(vtalrm_mask);
-}
-
-# else /* Not SunOS 4 */
-
-int
-install_vtalrm_handler(STG_NO_ARGS)
-{
- struct sigaction action;
-
-# ifdef CONCURRENT
- action.sa_handler = vtalrm_handler;
-# else
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
- || RTSflags.ProfFlags.doHeapProfile)
- action.sa_handler = handle_tick_serial;
- else
- action.sa_handler = handle_tick_noserial;
-# endif
-
- sigemptyset(&action.sa_mask);
- action.sa_flags = 0;
-
- return sigaction(SIGVTALRM, &action, NULL);
-}
-
-void
-blockVtAlrmSignal(STG_NO_ARGS)
-{
- sigset_t signals;
-
- sigemptyset(&signals);
- sigaddset(&signals, SIGVTALRM);
-
- (void) sigprocmask(SIG_BLOCK, &signals, NULL);
-}
-
-void
-unblockVtAlrmSignal(STG_NO_ARGS)
-{
- sigset_t signals;
-
- sigemptyset(&signals);
- sigaddset(&signals, SIGVTALRM);
-
- (void) sigprocmask(SIG_UNBLOCK, &signals, NULL);
-}
-
-# endif /* ! SunOS 4 */
-
-#endif /* PROFILING || CONCURRENT (but not GRAN) */
-
-\end{code}
-
-Signal handling support for user-specified signal handlers. Since we
-need stable pointers to do this properly, we just refuse to try in the
-parallel world. Sorry.
-
-\begin{code}
-
-#if defined(PAR) /* || defined(GRAN) */
-
-void
-blockUserSignals(void)
-{
- return;
-}
-
-void
-unblockUserSignals(void)
-{
- return;
-}
-
-I_
-# ifdef _POSIX_SOURCE
-sig_install(sig, spi, mask)
- sigset_t *mask;
-# else
- sig_install(sig, spi)
-# endif
- I_ sig;
- I_ spi;
-{
- fflush(stdout);
- fprintf(stderr,"No signal handling support in a parallel implementation.\n");
- EXIT(EXIT_FAILURE);
-}
-
-#else /* !PAR */
-
-# include <setjmp.h>
-
-extern StgPtr deRefStablePointer PROTO((StgStablePtr));
-extern void freeStablePointer PROTO((I_));
-extern jmp_buf restart_main;
-
-static I_ *handlers = NULL; /* Dynamically grown array of signal handlers */
-static I_ nHandlers = 0; /* Size of handlers array */
-
-static void
-more_handlers(I_ sig)
-{
- I_ i;
-
- if (sig < nHandlers)
- return;
-
- if (handlers == NULL)
- handlers = (I_ *) malloc((sig + 1) * sizeof(I_));
- else
- handlers = (I_ *) realloc(handlers, (sig + 1) * sizeof(I_));
-
- if (handlers == NULL) {
- fflush(stdout);
- fprintf(stderr, "VM exhausted (in more_handlers)\n");
- EXIT(EXIT_FAILURE);
- }
- for(i = nHandlers; i <= sig; i++)
- /* Fill in the new slots with default actions */
- handlers[i] = STG_SIG_DFL;
-
- nHandlers = sig + 1;
-}
-
-I_ nocldstop = 0;
-
-# ifdef _POSIX_SOURCE
-
-static void
-generic_handler(int sig)
-{
- sigset_t signals;
-
- SAVE_Hp = SAVE_HpLim; /* Just to be safe */
- if (! initStacks(&StorageMgrInfo)) {
- fflush(stdout);
- fprintf(stderr, "initStacks failed!\n");
- EXIT(EXIT_FAILURE);
- }
- TopClosure = deRefStablePointer(handlers[sig]);
- sigemptyset(&signals);
- sigaddset(&signals, sig);
- sigprocmask(SIG_UNBLOCK, &signals, NULL);
- longjmp(restart_main, sig);
-}
-
-static sigset_t userSignals;
-static sigset_t savedSignals;
-
-void
-initUserSignals(void)
-{
- sigemptyset(&userSignals);
-}
-
-void
-blockUserSignals(void)
-{
- sigprocmask(SIG_SETMASK, &userSignals, &savedSignals);
-}
-
-void
-unblockUserSignals(void)
-{
- sigprocmask(SIG_SETMASK, &savedSignals, NULL);
-}
-
-
-I_
-sig_install(sig, spi, mask)
- I_ sig;
- I_ spi;
- sigset_t *mask;
-{
- sigset_t signals;
- struct sigaction action;
- I_ previous_spi;
-
- /* Block the signal until we figure out what to do */
- /* Count on this to fail if the signal number is invalid */
- if(sig < 0 || sigemptyset(&signals) || sigaddset(&signals, sig) ||
- sigprocmask(SIG_BLOCK, &signals, NULL))
- return STG_SIG_ERR;
-
- more_handlers(sig);
-
- previous_spi = handlers[sig];
-
- switch(spi) {
- case STG_SIG_IGN:
- handlers[sig] = STG_SIG_IGN;
- sigdelset(&userSignals, sig);
- action.sa_handler = SIG_IGN;
- break;
-
- case STG_SIG_DFL:
- handlers[sig] = STG_SIG_DFL;
- sigdelset(&userSignals, sig);
- action.sa_handler = SIG_DFL;
- break;
- default:
- handlers[sig] = spi;
- sigaddset(&userSignals, sig);
- action.sa_handler = generic_handler;
- break;
- }
-
- if (mask != NULL)
- action.sa_mask = *mask;
- else
- sigemptyset(&action.sa_mask);
-
- action.sa_flags = sig == SIGCHLD && nocldstop ? SA_NOCLDSTOP : 0;
-
- if (sigaction(sig, &action, NULL) || sigprocmask(SIG_UNBLOCK, &signals, NULL)) {
- if (previous_spi)
- freeStablePointer(handlers[sig]);
- return STG_SIG_ERR;
- }
-
- return previous_spi;
-}
-
-# else /* !POSIX */
-
-static void
-generic_handler(sig)
-{
- SAVE_Hp = SAVE_HpLim; /* Just to be safe */
- if (! initStacks(&StorageMgrInfo)) {
- fflush(stdout);
- fprintf(stderr, "initStacks failed!\n");
- EXIT(EXIT_FAILURE);
- }
- TopClosure = deRefStablePointer(handlers[sig]);
- sigsetmask(0);
- longjmp(restart_main, sig);
-}
-
-static int userSignals;
-static int savedSignals;
-
-void
-initUserSignals(void)
-{
- userSignals = 0;
-}
-
-void
-blockUserSignals(void)
-{
- savedSignals = sigsetmask(userSignals);
-}
-
-void
-unblockUserSignals(void)
-{
- sigsetmask(savedSignals);
-}
-
-I_
-sig_install(sig, spi)
- I_ sig;
- I_ spi;
-{
- I_ previous_spi;
- int mask;
- void (*handler)(int);
-
- /* Block the signal until we figure out what to do */
- /* Count on this to fail if the signal number is invalid */
- if(sig < 0 || (mask = sigmask(sig)) == 0)
- return STG_SIG_ERR;
-
- mask = sigblock(mask);
-
- more_handlers(sig);
-
- previous_spi = handlers[sig];
-
- switch(spi) {
- case STG_SIG_IGN:
- handlers[sig] = STG_SIG_IGN;
- userSignals &= ~sigmask(sig);
- handler = SIG_IGN;
- break;
-
- case STG_SIG_DFL:
- handlers[sig] = STG_SIG_DFL;
- userSignals &= ~sigmask(sig);
- handler = SIG_DFL;
- break;
- default:
- handlers[sig] = spi;
- userSignals |= sigmask(sig);
- handler = generic_handler;
- break;
- }
-
- if (signal(sig, handler) < 0) {
- if (previous_spi)
- freeStablePointer(handlers[sig]);
- sigsetmask(mask);
- return STG_SIG_ERR;
- }
-
- sigsetmask(mask);
- return previous_spi;
-}
-
-# endif /* !POSIX */
-
-#endif /* PAR */
-
-\end{code}
+++ /dev/null
-\section[stk-overflow]{Stack overflow routine}
-
-%************************************************************************
-%* *
-\subsection[arity-error]{Arity error has nothing to do with stack overflow}
-%* *
-%************************************************************************
-
-\begin{code}
-
-#include "rtsdefs.h"
-
-void PrintTickyInfo(STG_NO_ARGS);
-
-#ifdef __DO_ARITY_CHKS__
-I_ ExpectedArity;
-
-void
-ArityError(n)
- I_ n;
-{
- fflush(stdout);
- fprintf(stderr, "Arity error: called with %ld args, should have been %ld\n",
- ExpectedArity, n);
-
-#if defined(TICKY_TICKY)
- if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
-#endif
-
- EXIT(EXIT_FAILURE);
-}
-
-#endif /* __DO_ARITY_CHECKS__ */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[stk-oflow-seq]{Boring sequential stack overflow}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifndef CONCURRENT
-
-void
-StackOverflow(STG_NO_ARGS)
-{
- fflush(stdout);
- StackOverflowHook(RTSflags.GcFlags.stksSize * sizeof(W_)); /*msg*/
-
-#if defined(TICKY_TICKY)
- if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
-#endif
-
- EXIT(EXIT_FAILURE);
-}
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[stk-squeeze]{Code for squeezing out update frames}
-%* *
-%************************************************************************
-
-Code for squeezing out vacuous update frames. Updatees of squeezed frames
-are turned into indirections to the common black hole (or blocking queue).
-
-\begin{code}
-I_
-SqueezeUpdateFrames(bottom, top, frame)
-P_ bottom;
-P_ top;
-P_ frame;
-{
- I_ displacement = 0;
- P_ next_frame = NULL; /* Temporally next */
- P_ prev_frame; /* Temporally previous */
-
- /*
- * If we have no update frames, there is nothing to do.
- */
-
- if (frame <= bottom)
- return 0;
-
- if ((prev_frame = GRAB_SuB(frame)) <= bottom) {
-#if !defined(CONCURRENT)
- if ( RTSflags.GcFlags.lazyBlackHoling )
- UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
-#endif
- return 0;
- }
-
- /*
- * Walk down the stack, reversing the SuB pointers so that we can walk back up
- * as we squeeze from the bottom. Note that next_frame and prev_frame refer to
- * next and previous as they were added to the stack, rather than the way we see
- * them in this walk. (It makes the next loop less confusing.)
- */
-
- while (prev_frame > bottom) {
- PUSH_SuB(frame, next_frame);
- next_frame = frame;
- frame = prev_frame;
- prev_frame = GRAB_SuB(frame);
- }
-
- /*
- * Now, we're at the bottom. Frame points to the lowest update
- * frame on the stack, and its saved SuB actually points to the
- * frame above. We have to walk back up the stack, squeezing out
- * empty update frames and turning the pointers back around on the
- * way back up.
- */
-
- /*
- * The bottom-most frame has not been altered, and we never want
- * to eliminate it anyway. Just black hole the updatee and walk
- * one step up before starting to squeeze. When you get to the
- * topmost frame, remember that there are still some words above
- * it that might have to be moved.
- */
-
-#if !defined(CONCURRENT)
- if ( RTSflags.GcFlags.lazyBlackHoling )
- UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
-#endif
- prev_frame = frame;
- frame = next_frame;
-
- /*
- * Loop through all of the middle frames (everything except the
- * very bottom and the very top).
- */
- while ((next_frame = GRAB_SuB(frame)) != NULL) {
- P_ sp;
- P_ frame_bottom = frame + BREL(STD_UF_SIZE);
-
- /* Check to see if the current frame is empty (both A and B) */
- if (prev_frame == frame_bottom + BREL(displacement) &&
- GRAB_SuA(next_frame) == GRAB_SuA(frame)) {
-
- /* Now squeeze out the current frame */
- P_ updatee_keep = GRAB_UPDATEE(prev_frame);
- P_ updatee_bypass = GRAB_UPDATEE(frame);
-
- /*
- fprintf(stderr, "squeezing frame at %lx, ret %lx\n", frame,
- GRAB_RET(frame));
- */
-
-#ifdef CONCURRENT
- /* Check for a blocking queue on the node that's going away */
- if (INFO_PTR(updatee_bypass) == (W_) BQ_info) {
- /* Sigh. It has one. Don't lose those threads! */
- if (INFO_PTR(updatee_keep) == (W_) BQ_info) {
- /* Urgh. Two queues. Merge them. */
- P_ tso = (P_) BQ_ENTRIES(updatee_keep);
-
- while (TSO_LINK(tso) != PrelBase_Z91Z93_closure)
- tso = TSO_LINK(tso);
-
- TSO_LINK(tso) = (P_) BQ_ENTRIES(updatee_bypass);
- } else {
- /* For simplicity, just swap the BQ for the BH */
- P_ temp = updatee_keep;
-
- updatee_keep = updatee_bypass;
- updatee_bypass = temp;
-
- /* Record the swap in the kept frame (below) */
- PUSH_UPDATEE(prev_frame, updatee_keep);
- }
- }
-#endif
-
- UPD_SQUEEZED(); /* ticky stuff (NB: nothing for spat-profiling) */
- UPD_IND(updatee_bypass, updatee_keep);
-
- sp = frame - BREL(1); /* Toss the current frame */
- displacement += STD_UF_SIZE;
-
- } else {
-#if !defined(CONCURRENT)
- if ( RTSflags.GcFlags.lazyBlackHoling )
- UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
-#endif
-
- /* No squeeze for this frame */
- sp = frame_bottom - BREL(1); /* Keep the current frame */
-
- /* Fix the SuB in the current frame (should point to the frame below) */
- PUSH_SuB(frame, prev_frame);
- }
-
- /* Now slide all words from sp up to the next frame */
-
- if (displacement > 0) {
- P_ next_frame_bottom = next_frame + BREL(STD_UF_SIZE);
-
- /*
- fprintf(stderr, "sliding [%lx, %lx] by %d\n", sp, next_frame_bottom,
- displacement);
- */
-
- while (sp <= next_frame_bottom) {
- sp[BREL(displacement)] = *sp;
- sp -= BREL(1);
- }
- }
- prev_frame = frame + BREL(displacement);
- frame = next_frame;
- }
-
- /*
- * Now handle the topmost frame. Patch SuB, black hole the
- * updatee, and slide down.
- */
-
- PUSH_SuB(frame, prev_frame);
-
-#if !defined(CONCURRENT)
- if ( RTSflags.GcFlags.lazyBlackHoling )
- UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
-#endif
-
- if (displacement > 0) {
- P_ sp = frame + BREL(STD_UF_SIZE) - BREL(1);
-
- /*
- fprintf(stderr, "sliding [%lx, %lx] by %d\n", sp, top, displacement);
- */
-
- while (sp <= top) {
- sp[BREL(displacement)] = *sp;
- sp -= BREL(1);
- }
- }
- return displacement;
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[stk-ouflow-par]{Rather exciting parallel stack overflow and underflow}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef CONCURRENT
-\end{code}
-
-StackOverflow: called inside a nice ``callwrapper'' when stack
-overflow occurs. The state is already saved in the TSO, and the stack
-is in a tidy saved state.
-
-\begin{code}
-EXTDATA_RO(StkO_info); /* boring extern decl */
-EXTFUN(EnterNodeCode); /* For reentering node after potential GC */
-
-#ifdef PAR
-EXTDATA_RO(FetchMe_info);
-#endif
-
-I_
-StackOverflow(args1, args2)
-W_ args1;
-W_ args2;
-{
- I_ i;
- P_ old_stko, new_stko;
- W_ headroom = STACK_OVERFLOW_HEADROOM(args1, args2);
- I_ cts_size;
-
-#ifdef PAR
- W_ is_prim_return = STACK_OVERFLOW_PRIM_RETURN(args1, args2);
-#endif
- W_ reenter = STACK_OVERFLOW_REENTER(args1, args2);
- W_ words_of_a = STACK_OVERFLOW_AWORDS(args1, args2);
- W_ words_of_b = STACK_OVERFLOW_BWORDS(args1, args2);
- W_ liveness = STACK_OVERFLOW_LIVENESS(args1, args2);
- I_ really_reenter_node = 0;
-
- SET_TASK_ACTIVITY(ST_OVERHEAD);
-
-
- /*?
- if (RTSflags.GcFlags.giveStats) {
- fprintf(stderr,"StackOverflow:liveness=%lx,a=%lx,b=%lx\n",
- liveness,words_of_a,words_of_b);
- }
- ?*/
-
- old_stko = SAVE_StkO;
-
- /*?
- if (RTSflags.GcFlags.giveStats) {
- fprintf(stderr, "stko: %lx SpA %lx SuA %lx SpB %lx SuB %lx\n",
- old_stko, STKO_SpA(old_stko),
- STKO_SuA(old_stko), STKO_SpB(old_stko), STKO_SuB(old_stko));
- }
- ?*/
-
- if (RTSflags.GcFlags.squeezeUpdFrames) {
-
- i = SqueezeUpdateFrames(STKO_BSTK_BOT(old_stko), STKO_SpB(old_stko),
- STKO_SuB(old_stko));
-
- STKO_SuB(old_stko) += BREL(i);
- STKO_SpB(old_stko) += BREL(i);
-
- /*?
- if (RTSflags.GcFlags.giveStats)
- fprintf(stderr, "Just squeezed; now: SpB %lx SuB %lx retval %d\n", STKO_SpB(old_stko), STKO_SuB(old_stko), i); ?*/
-
- if ((P_) STKO_SpA(old_stko) - AREL(headroom) > STKO_SpB(old_stko)) {
-
- /*?
- if (RTSflags.GcFlags.giveStats) {
- fprintf(stderr, "Squeezed; now: SpA %lx SpB %lx headroom %d\n", STKO_SpA(old_stko),
- STKO_SpB(old_stko), headroom);
- }
- ?*/
-
- /* We saved enough space to continue on the old StkO */
- return 0;
- }
- }
- SAVE_Liveness = liveness;
-
- ASSERT(sanityChk_StkO(old_stko));
-
- /* Double the stack chunk size each time we grow the stack */
- /*?
- if (RTSflags.GcFlags.giveStats) {
- fprintf(stderr, "Stko %lx: about to double stk-chk size from %d...\n", old_stko, STKO_CLOSURE_CTS_SIZE(old_stko)); } ?*/
- cts_size = STKO_CLOSURE_CTS_SIZE(old_stko) * 2;
-
- if (SAVE_Hp + STKO_HS + cts_size > SAVE_HpLim) {
- if (reenter) {
- /*
- * Even in the uniprocessor world, we may have to reenter node in case
- * node is a selector shorted out by GC.
- */
- ASSERT(liveness & LIVENESS_R1);
- TSO_PC2(CurrentTSO) = EnterNodeCode;
- really_reenter_node = 1;
- }
- /*?
- if (RTSflags.GcFlags.giveStats) {
- fprintf(stderr, "StkO %lx: stk-chk GC: size %d...\n",
- old_stko, STKO_HS + cts_size);
- } ?*/
- ReallyPerformThreadGC(STKO_HS + cts_size, rtsFalse);
- /*
- now, GC semantics promise to have left SAVE_Hp with
- the requested space *behind* it; as we will bump
- SAVE_Hp just below, we had better first put it back.
- (PS: Finding this was a two-day bug-hunting trip...)
- Will & Phil 95/10
- */
- SAVE_Hp -= STKO_HS + cts_size;
-
- old_stko = SAVE_StkO;
- }
- ALLOC_STK(STKO_HS, cts_size, 0);
- new_stko = SAVE_Hp + 1;
- SAVE_Hp += STKO_HS + cts_size;
- SET_STKO_HDR(new_stko, StkO_info, CCC);
-
- /*? if (RTSflags.GcFlags.giveStats) fprintf(stderr, "New StkO now %lx...\n", new_stko); ?*/
-
- /* Initialize the StkO, as in NewThread */
- STKO_SIZE(new_stko) = cts_size + STKO_VHS;
- STKO_SpB(new_stko) = STKO_SuB(new_stko) = STKO_BSTK_BOT(new_stko) + BREL(1);
- STKO_SpA(new_stko) = STKO_SuA(new_stko) = STKO_ASTK_BOT(new_stko) + AREL(1);
- STKO_LINK(new_stko) = old_stko;
-
- /*? if (RTSflags.GcFlags.giveStats) fprintf(stderr, "New StkO SpA = %lx...\n", STKO_SpA(new_stko) ); ?*/
-
- STKO_RETURN(new_stko) = SAVE_Ret;
-
-#ifdef PAR
-
- /*
- * When we fall off of the top stack segment, we will either be
- * returning an algebraic data type, in which case R2 holds a
- * valid info ptr, or we will be returning a primitive
- * (e.g. Int#), in which case R2 is garbage. If we need to perform
- * GC to pull in the lower stack segment (this should only happen
- * because of task migration), then we need to know the register
- * liveness for the algebraic returns. We get the liveness out of
- * the info table. Now, we could set up the primitive returns
- * with a bogus infoptr, which has a NO_LIVENESS field in the info
- * table, but that would involve a lot more overhead than the
- * current approach. At present, we set up RetReg to point to
- * *either* a polymorphic algebraic return point, or a primitive
- * return point.
- */
-
- SAVE_Ret = is_prim_return ? (P_) PrimUnderflow : (P_) vtbl_Underflow;
-#else
- SAVE_Ret = (P_) vtbl_Underflow;
-#endif
-
- STKO_SpA(old_stko) += AREL(words_of_a);
- STKO_SpB(old_stko) += BREL(words_of_b);
-
-#ifdef TICKY_TICKY
- /* Record the stack depths in chunks below the new stack object */
-
- STKO_ADEP(new_stko) = STKO_ADEP(old_stko) +
- AREL((I_) STKO_ASTK_BOT(old_stko) - (I_) STKO_SpA(old_stko));
- STKO_BDEP(new_stko) = STKO_BDEP(old_stko) +
- BREL((I_) STKO_BSTK_BOT(old_stko) - (I_) STKO_SpB(old_stko));
-#endif
-
- if (STKO_SpB(old_stko) < STKO_BSTK_BOT(old_stko)) {
- /*
- * This _should_ only happen if PAP_entry fails a stack check
- * and there is no update frame on the current stack. We can
- * deal with this by storing a function's argument
- * requirements in its info table, peering into the PAP (it
- * had better be in R1) for the function pointer and taking
- * only the necessary number of arguments, but this would be
- * hard, so we haven't done it.
- */
- fflush(stdout);
- fprintf(stderr, "StackOverflow too deep (SpB=%lx, Bstk bot=%lx). Probably a PAP with no update frame.\n", STKO_SpB(old_stko), STKO_BSTK_BOT(old_stko));
- abort(); /* an 'abort' may be overkill WDP 95/04 */
- }
- /* Move A stack words from old StkO to new StkO */
- for (i = 1; i <= words_of_a; i++) {
- STKO_SpA(new_stko)[-AREL(i)] = STKO_SpA(old_stko)[-AREL(i)];
- }
- STKO_SpA(new_stko) -= AREL(words_of_a);
-
- /* Move B stack words from old StkO to new StkO */
- for (i = 1; i <= words_of_b; i++) {
- STKO_SpB(new_stko)[-BREL(i)] = STKO_SpB(old_stko)[-BREL(i)];
- }
- STKO_SpB(new_stko) -= BREL(words_of_b);
-
- /* Now, handle movement of a single update frame */
- /* ToDo: Make this more efficient. (JSM) */
- if (STKO_SpB(old_stko) < STKO_SuB(old_stko)) {
- /* Yikes! PAP_entry stole an update frame. Fix the world! */
- P_ frame = STKO_SuB(new_stko) - BREL(STD_UF_SIZE);
-
- /*
- fprintf(stderr, "Stolen update frame: (old %lx, new %lx) SuA %lx, SuB
- %lx, return %lx\n", old_stko, new_stko, GRAB_SuA(frame), GRAB_SuB(frame),
- GRAB_RET(frame));
- */
-
- STKO_SuA(old_stko) = GRAB_SuA(frame);
- STKO_SuB(old_stko) = GRAB_SuB(frame);
-
- SAVE_Ret = STKO_RETURN(new_stko);
- STKO_RETURN(new_stko) = GRAB_RET(frame);
-
- PUSH_SuA(frame, STKO_SuA(new_stko));
- PUSH_SuB(frame, STKO_SuB(new_stko));
- PUSH_RET(frame, vtbl_Underflow);
-
- STKO_SuB(new_stko) = frame;
- }
-
- ASSERT(sanityChk_StkO(new_stko));
-
- SAVE_StkO = new_stko;
-
- return really_reenter_node;
-}
-\end{code}
-
-Underflow things are all done in the threaded world. The code is in
-main/StgThreads.lhc.
-
-\begin{code}
-#endif /* parallel */
-\end{code}
+++ /dev/null
-%/****************************************************************
-%* *
-%* Basic Continuations required by the STG Machine runtime *
-%* *
-%****************************************************************/
-
-
-First continuation called by the mini-interpreter is
-evaluateTopClosure. It has to set up return and jump to the user's
-@main@ closure. If @errorIO@ is called, we will be back here, doing
-the same thing for the specified continuation.
-
-\begin{code}
-#define MAIN_REG_MAP /* STG world */
-#include "rtsdefs.h"
-
-#if 0
-#ifdef PAR
-#include "Statistics.h"
-#endif
-#endif
-
-/* ptr to the user's "main" closure (or "errorIO" arg closure),
- to which we hope to be linked
-*/
-extern P_ TopClosure;
-
-EXTFUN(stopThreadDirectReturn);
-UNVECTBL(,vtbl_stopStgWorld,stopThreadDirectReturn)
-
-/* Well, we have to put the ArrayOfData and ArrayOfPtrs info tables
- somewhere...
-*/
-
-/* Array of data -- mutable */
-STATICFUN(ArrayOfData_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered a primitive array (of data)---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-DATA_ITBL(ArrayOfData_info,ArrayOfData_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"DATA-ARRAY","ARRAY");
-/* ToDo: could put a useful tag in there!!! */
-
-/* Array of pointers -- mutable */
-STATICFUN(ArrayOfPtrs_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered a primitive array (of pointers)---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-MUTUPLE_ITBL(ArrayOfPtrs_info,ArrayOfPtrs_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"PTR-ARRAY(mut)","ARRAY");
-/* ToDo: could put a useful tag in there!!! */
-
-STATICFUN(FullSVar_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered a full SVar---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-MUTUPLE_ITBL(FullSVar_info,FullSVar_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"FullSVar","ARRAY");
-/* ToDo: could put a useful tag in there!!! */
-
-STATICFUN(EmptySVar_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered an empty SVar---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-MUTUPLE_ITBL(EmptySVar_info,EmptySVar_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"EmptySVar","ARRAY");
-/* ToDo: could put a useful tag in there!!! */
-
-/* Array of pointers -- immutable */
-STATICFUN(ImMutArrayOfPtrs_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered a primitive array (immutable, pointers)---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-IMMUTUPLE_ITBL(ImMutArrayOfPtrs_info,ImMutArrayOfPtrs_entry,UpdErr,0,INFO_OTHER_TAG,,,const,IF_,ARR_K,"PTR-ARRAY(immut)","ARRAY");
-/* ToDo: could put a useful tag in there!!! */
-
-/* (end of Array whatnot) */
-
-/* Question for Will: There seem to be a lot of these static things
-now - worth putting them in a file by themselves?? [ADR] */
-
-
-#if !defined(PAR) /* && !defined(GRAN) */
-
-/* Ditto for Foreign Object entry point and info tables. [ADR]
-
- BTW Will, I copied most of this blindly from above - what's with
- this TAG stuff? And what kind of description/ type is wanted here?
-*/
-
-STATICFUN(ForeignObj_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Compiler bug: Entered a ForeignObj---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-ForeignObj_ITBL(ForeignObj_info,ForeignObj_entry,UpdErr,0,INFO_OTHER_TAG,,,const,EF_,ForeignObj_K,"FOREIGN_OBJ","ForeignObj");
-
-/* End of ForeignObj stuff */
-
-/* Ditto for the unused Stable Pointer info table. [ADR]
-*/
-
-void raiseError PROTO((StgStablePtr));
-extern StgStablePtr errorHandler; /* NB: prone to magic-value-ery (WDP 95/12) */
-
-/* Unused Stable Pointer (ie unused slot in a stable pointer table) */
-STATICFUN(UnusedSP_entry)
-{
- FB_
- (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout);
- (void) SAFESTGCALL2(I_,(void *, FILE *, char *),fprintf,stderr, "Entered an unused Stable Pointer---this shouldn't happen!\n(This could be program error (using stable pointer after freeing) or compiler bug.)\n");
-
- (void) STGCALL1(void,(void *, StgStablePtr), raiseError, errorHandler);
- FE_
-}
-
-STATIC_ITBL(UnusedSP_info,UnusedSP_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,CON_K,"UNUSED_STABLE_PTR","USP");
-
-SET_STATIC_HDR(UnusedSP_closure,UnusedSP_info,CC_SUBSUMED,,ED_RO_)
-};
-
-/* Entry point and Info table for Stable Pointer Table. */
-
-STATICFUN(EmptyStablePointerTable_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered *empty* stable pointer table---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-STATICFUN(StablePointerTable_entry)
-{
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered the stable pointer table---this shouldn't happen!\n");
- abort();
- FE_
-}
-
-STATIC_ITBL(EmptyStablePointerTable_info,EmptyStablePointerTable_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,SPT_K,"SP_TABLE","SP_TABLE");
-/* ToDo: could put a useful tag in there!!! */
-
-DYN_ITBL(StablePointerTable_info,StablePointerTable_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,SPT_K,"SP_TABLE","SP_TABLE");
-/* ToDo: could put a useful tag in there!!! */
-
-
-/* To ease initialisation of the heap, we start with an empty stable
- pointer table. When we try to create the first stable pointer, the
- overflow will trigger creation of a table of useful size.
-*/
-
-SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_info,CC_SUBSUMED,,ED_RO_)
-, (W_) DYN_VHS + 0 + 1 + 0 /* size = DYN_VHS + n + 1 + n with n = 0 */
-, (W_) 0 /* number of ptrs */
-, (W_) 0 /* top of stack */
-};
-
-/* End of SP stuff */
-#endif /* !PAR */
-
-/* Not a natural home for these, but
- the following symbols may be referenced in
- an object file, but never entered
-*/
-P_ PrelGHC_void_closure = (P_) 0xbadbadbaL;
-P_ PrelGHC_ZcCCallable_static_info = (P_) 0xbadbadbaL;
-P_ PrelGHC_ZcCReturnable_static_info = (P_) 0xbadbadbaL;
-
-/* the IoWorld token to start the whole thing off */
-/* Question: this is just an amusing hex code isn't it
- -- or does it mean something? ADR */
-P_ realWorldZh_closure = (P_)0xbadbadbaL;
-
-#ifndef CONCURRENT
-
-STGFUN(startStgWorld)
-{
- FB_
- /* At this point we are in the threaded-code world.
-
- TopClosure points to a closure of type PrimIO (), which should be
- performed (by applying it to the state of the world).
-
- The smInfo storage-management info block is assumed to be
- up to date, and is used to load the STG registers.
- */
-
- RestoreAllStgRegs(); /* inline! */
-
- /* ------- STG registers are now valid! -------------------------*/
-
- /* Put a suitable return address on the B stack */
- RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
-
- /* Put an IoWorld token on the A stack */
- SpB -= BREL(1);
- (P_)*SpB = (P_) realWorldZh_closure;
-
- Node = (P_) TopClosure; /* Point to the closure for main/errorIO-arg */
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FE_
-}
-#endif /* ! CONCURRENT */
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[thread-return]{Polymorphic end-of-thread code}
-%* *
-%************************************************************************
-
-\begin{code}
-
-/*
- Here's the polymorphic return for the end of a thread.
-
- NB: For direct returns to work properly, the name of the routine must be
- the same as the name of the vector table with vtbl_ removed and DirectReturn
- appended. This is all the mangler understands.
-*/
-
-const W_
-vtbl_stopThread[] = {
- /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
- (W_) stopThreadDirectReturn,
- (W_) stopThreadDirectReturn,
- (W_) stopThreadDirectReturn,
- (W_) stopThreadDirectReturn,
- (W_) stopThreadDirectReturn,
- (W_) stopThreadDirectReturn,
- (W_) stopThreadDirectReturn,
- (W_) stopThreadDirectReturn
-};
-
-STGFUN(stopThreadDirectReturn)
-{
- FB_
- /* The final exit.
-
- The top-top-level closures (e.g., "main") are of type "IO ()".
- When entered, they perform an IO action and return a () --
- essentially, TagReg is set to 1. Here, we don't need to do
- anything with that.
-
- We just tidy up the register stuff (real regs in *_SAVE, then
- *_SAVE -> smInfo locs).
- */
-
-#ifdef CONCURRENT
- SET_TASK_ACTIVITY(ST_OVERHEAD);
-#endif
-
- SaveAllStgRegs(); /* inline! */
-
-#ifdef CONCURRENT
- EndThread();
-#else
- RESUME_(miniInterpretEnd);
-#endif
- FE_
-}
-
-\end{code}
-
-\begin{code}
-I_ ErrorIO_call_count = 0;
-
-#ifdef CONCURRENT
-EXTFUN(EnterNodeCode);
-
-STGFUN(ErrorIO_innards)
- /* Assumes that "TopClosure" has been set already */
-{
- FB_
- fflush(stdout);
- fflush(stderr);
- if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "too many nested calls to `error'\n");
- EXIT(EXIT_FAILURE);
- }
- ErrorIO_call_count++; /* NB: undo later if decide to let someone else handle it */
-
- /* Unlock all global closures held by this thread! (ToDo) --JSM */
-
- switch(TSO_TYPE(CurrentTSO)) {
- case T_MAIN:
- /* Re-initialize stack pointers (cf. NewThread) */
-#ifdef PAR
- SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
- SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
-#else
- SuA = stackInfo.botA + AREL(1);
- SuB = stackInfo.botB + BREL(1);
- /* HWL */
- /*
- SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
- SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
- */
-
-#endif
- break;
-
- case T_REQUIRED:
- /* Re-initialize stack pointers (cf. NewThread) */
- SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
- SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
- break;
-
- case T_ADVISORY:
- ErrorIO_call_count--; /* undo the damage, as someone else will deal with it */
- /* Let the main thread eventually handle it */
- JMP_(stopThreadDirectReturn);
-
- case T_FAIL:
- EXIT(EXIT_FAILURE);
-
- default:
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr,"ErrorIO: %lx unknown\n", TSO_TYPE(CurrentTSO));
- EXIT(EXIT_FAILURE);
- }
-
- /* Finish stack setup as if for a top-level task and enter the error node */
-
- /* Put an IoWorld token on the B stack */
- SpB -= BREL(1);
- *SpB = (P_) realWorldZh_closure;
-/*
- SpA = SuA - AREL(1);
- *SpA = (P_) realWorldZh_closure;
-*/
- STKO_LINK(StkOReg) = PrelBase_Z91Z93_closure;
- STKO_RETURN(StkOReg) = NULL;
-
-#ifdef TICKY_TICKY
- STKO_ADEP(StkOReg) = STKO_BDEP(StkOReg) = 0;
-#endif
-
- /* Go! */
- Node = (P_) TopClosure;
- RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
- JMP_(EnterNodeCode);
-
- FE_
-}
-\end{code}
-
-We cannot afford to call @error@ too many times
-(e.g., \tr{error x where x = error x}), so we keep count.
-
-\begin{code}
-#else /* !CONCURRENT */
-
-StgFunPtr
-ErrorIO_innards(STG_NO_ARGS)
- /* Assumes that "TopClosure" has been set already */
-{
- FB_
- fflush(stdout);
- fflush(stderr);
- if (ErrorIO_call_count >= 16 /* MAGIC CONSTANT */ ) {
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "too many nested calls to `error'\n");
- EXIT(EXIT_FAILURE);
- }
- ErrorIO_call_count++;
-
- /* Copy the heap-related registers into smInfo. (Other registers get
- saved in this process, but we aren't interested in them.)
-
- Get a new stack (which re-initialises the smInfo stack stuff),
- and start the world again.
- */
- /* ToDo: chk this has been handled in parallel world */
-
- SaveAllStgRegs(); /* inline! */
-
- if (! initStacks( &StorageMgrInfo )) {
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "initStacks failed!\n");
- EXIT(EXIT_FAILURE);
- }
-
- JMP_( startStgWorld );
- FE_
-}
-
-#endif /* !CONCURRENT */
-\end{code}
-
-\begin{code}
-#if defined(PAR) || defined(GRAN)
-
-STATICFUN(RBH_Save_0_entry)
-{
- FB_
- fprintf(stderr,"Oops, entered an RBH save\n");
- EXIT(EXIT_FAILURE);
- FE_
-}
-
-STATICFUN(RBH_Save_1_entry)
-{
- FB_
- fprintf(stderr,"Oops, entered an RBH save\n");
- EXIT(EXIT_FAILURE);
- FE_
-}
-
-STATICFUN(RBH_Save_2_entry)
-{
- FB_
- fprintf(stderr,"Oops, entered an RBH save\n");
- EXIT(EXIT_FAILURE);
- FE_
-}
-
-SPEC_N_ITBL(RBH_Save_0_info,RBH_Save_0_entry,UpdErr,0,INFO_OTHER_TAG,2,0,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_0");
-SPEC_N_ITBL(RBH_Save_1_info,RBH_Save_1_entry,UpdErr,0,INFO_OTHER_TAG,2,1,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_1");
-SPEC_N_ITBL(RBH_Save_2_info,RBH_Save_2_entry,UpdErr,0,INFO_OTHER_TAG,2,2,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_2");
-
-#endif /* PAR || GRAN */
-\end{code}
-
-
-%/****************************************************************
-%* *
-%* Other Bits and Pieces *
-%* *
-%****************************************************************/
-
-\begin{code}
-/* If we don't need the slow entry code for a closure, we put in a
- pointer to this in the closure's slow entry code pointer instead.
- */
-
-STGFUN(__std_entry_error__) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Called non-existent slow-entry code!!!\n");
- abort();
- JMP_(0);
- FE_
-}
-
-/* entry code */
-STGFUN(STK_STUB_entry) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered from a stubbed stack slot!\n");
- abort();
- JMP_(0);
- FE_
-}
-
-/* info table */
-STATIC_ITBL(STK_STUB_info,STK_STUB_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,INTERNAL_KIND,"STK_STUB","STK_STUB");
-
-/* closure */
-SET_STATIC_HDR(STK_STUB_closure,STK_STUB_info,CC_SUBSUMED,,EXTDATA_RO)
- , (W_)0, (W_)0
-};
-
-
-ED_RO_(vtbl_seq);
-
-/*
-STGFUN(seqZhCode)
-{
- FB_
- __label__ cont;
- SpB[BREL(0)] = (W_) RetReg;
- SpB[BREL(1)] = (W_) &&cont;
- RetReg = (StgRetAddr) vtbl_seq;
- ENT_VIA_NODE();
- InfoPtr = (D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
-cont:
- FE_
-}
-*/
-
-\end{code}
-
-%/****************************************************************
-%* *
-%* Some GC info tables *
-%* *
-%****************************************************************/
-
-These have to be in a .lhc file, so they will be reversed correctly.
-
-\begin{code}
-#include "../storage/SMinternal.h"
-
-#if defined(_INFO_COPYING)
-
-STGFUN(Caf_Evac_Upd_entry) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr,"Entered Caf_Evac_Upd %lx: Should never occur!\n", (W_) Node);
- abort();
- FE_
-}
-
-CAF_EVAC_UPD_ITBL(Caf_Evac_Upd_info,Caf_Evac_Upd_entry,const/*not static*/);
-
-#if defined(GCgn)
-
-STGFUN(Forward_Ref_New_entry) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr,"Entered Forward_Ref_New %lx: Should never occur!\n", (W_) Node);
- EXIT(EXIT_FAILURE); /* abort(); */
- FE_
-}
-FORWARDREF_ITBL(Forward_Ref_New_info,Forward_Ref_New_entry,const/*not static*/,_Evacuate_Old_Forward_Ref);
-
-STGFUN(Forward_Ref_Old_entry) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr,"Entered Forward_Ref_Old %lx: Should never occur!\n", (W_) Node);
- EXIT(EXIT_FAILURE); /* abort(); */
- FE_
-}
-FORWARDREF_ITBL(Forward_Ref_Old_info,Forward_Ref_Old_entry,const/*not static*/,_Evacuate_New_Forward_Ref);
-
-STGFUN(OldRoot_Forward_Ref_entry) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr,"Entered OldRoot_Forward_Ref %lx: Should never occur!\n", (W_) Node);
- EXIT(EXIT_FAILURE); /* abort(); */
- FE_
-}
-FORWARDREF_ITBL(OldRoot_Forward_Ref_info,OldRoot_Forward_Ref_entry,const/*not static*/,_Evacuate_OldRoot_Forward);
-#else /* ! GCgn */
-
-STGFUN(Forward_Ref_entry) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr,"Entered Forward_Ref %lx: Should never occur!\n", (W_) Node);
- EXIT(EXIT_FAILURE); /* abort(); */
- FE_
-}
-FORWARDREF_ITBL(Forward_Ref_info,Forward_Ref_entry,const/*not static*/,_Evacuate_Forward_Ref);
-#endif /* ! GCgn */
-
-#endif /* _INFO_COPYING */
-
-#if defined(GCgn)
-OLDROOT_ITBL(OldRoot_info,Ind_Entry,const,EF_);
-#endif /* GCgn */
-\end{code}
-
-
-%/***************************************************************
-%* *
-%* Cost Centre stuff ... *
-%* *
-%****************************************************************/
-
-For cost centres we need prelude cost centres and register routine.
-
-N.B. ALL prelude cost centres should be declared here as none will
- be declared when the prelude is compiled.
-
-ToDo: Explicit cost centres in prelude for Input and Output costs.
-
-\begin{code}
-#if defined(PROFILING)
-
-STGFUN(startCcRegisteringWorld)
-{
- FB_
- /*
- * We used to push miniInterpretEnd on the register stack, but
- * miniInterpretEnd must only be entered with the RESUME_ macro,
- * whereas the other addresses on the register stack must only be
- * entered with the JMP_ macro. Now, we push NULL and test for
- * it explicitly at each pop.
- */
- PUSH_REGISTER_STACK(NULL);
- JMP_(_regMain);
- FE_
-}
-
-CC_DECLARE(CC_CAFs, "CAFs_in_...", "PRELUDE", "PRELUDE", CC_IS_CAF,/*not static*/);
-CC_DECLARE(CC_DICTs, "DICTs_in_...", "PRELUDE", "PRELUDE", CC_IS_DICT,/*not static*/);
-
-START_REGISTER_PRELUDE(_regPrel);
-REGISTER_CC(CC_CAFs);
-REGISTER_CC(CC_DICTs);
-END_REGISTER_CCS()
-
-\end{code}
-
-We also need cost centre declarations and registering routines for other
-built-in prelude-like modules.
-
-ToDo: What built-in prelude-like modules exist ?
-
-\begin{code}
-START_REGISTER_PRELUDE(_regByteOps); /* used in Glasgow tests only? */
-END_REGISTER_CCS()
-
-/* _regPrelude is above */
-
-START_REGISTER_PRELUDE(_regPrelGHC);
-END_REGISTER_CCS()
-
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994
-%
-%************************************************************************
-%* *
-\section[StgThreads.lhc]{Threaded Threads Support}
-%* *
-%************************************************************************
-
-Some of the threads support is done in threaded code. How's that for ambiguous
-overloading?
-
-\begin{code}
-
-#ifdef CONCURRENT
-
-#define MAIN_REG_MAP /* STG world */
-#include "rtsdefs.h"
-
-#if 0
-#ifdef PAR
-#include "Statistics.h"
-#endif
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[thread-objects]{Special objects for thread support}
-%* *
-%************************************************************************
-
-TSO's are Thread State Objects, where the thread context is stored when the
-thread is sleeping, and where we have slots for STG registers that don't
-live in real machine registers.
-
-\begin{code}
-
-TSO_ITBL();
-
-STGFUN(TSO_entry)
-{
- FB_
- fflush(stdout);
- fprintf(stderr, "TSO Entry: panic");
- abort();
- FE_
-}
-
-\end{code}
-
-Stack objects are chunks of stack words allocated out of the heap and
-linked together in a chain.
-
-\begin{code}
-
-STKO_ITBL();
-
-STGFUN(StkO_entry)
-{
- FB_
- fflush(stdout);
- fprintf(stderr, "StkO Entry: panic");
- abort();
- FE_
-
-}
-
-#ifndef PAR
-
-STKO_STATIC_ITBL();
-
-STGFUN(StkO_static_entry)
-{
- FB_
- fflush(stdout);
- fprintf(stderr, "StkO_static Entry: panic");
- abort();
- FE_
-
-}
-
-#endif
-
-\end{code}
-
-Blocking queues are essentially black holes with threads attached. These
-are the threads to be awakened when the closure is updated.
-
-\begin{code}
-
-EXTFUN(EnterNodeCode);
-
-STGFUN(BQ_entry)
-{
- FB_
-
-#if defined(GRAN)
- /* Before overwriting TSO_LINK */
- STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);
-#endif
-
- TSO_LINK(CurrentTSO) = (P_) BQ_ENTRIES(Node);
- BQ_ENTRIES(Node) = (W_) CurrentTSO;
-
- LivenessReg = LIVENESS_R1;
- SaveAllStgRegs();
- TSO_PC1(CurrentTSO) = EnterNodeCode;
-
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
-#ifdef PAR
- if(RTSflags.ParFlags.granSimStats) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- TIME now = CURRENT_TIME;
- TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
- TSO_BLOCKCOUNT(CurrentTSO)++;
- TSO_QUEUE(CurrentTSO) = Q_BLOCKED;
- TSO_BLOCKEDAT(CurrentTSO) = now;
- DumpGranEvent(GR_BLOCK, CurrentTSO);
- }
-#endif
-#if defined(GRAN)
- ReSchedule(SAME_THREAD); /* NB: GranSimBlock activated next thread */
-#else
- ReSchedule(0);
-#endif
- FE_
-}
-
-BQ_ITBL();
-
-\end{code}
-
-Revertible black holes are needed in the parallel world, to handle
-negative acknowledgements of messages containing updatable closures.
-The idea is that when the original message is transmitted, the closure
-is turned into a revertible black hole...an object which acts like a
-black hole when local threads try to enter it, but which can be
-reverted back to the original closure if necessary.
-
-It's actually a lot like a blocking queue (BQ) entry, because
-revertible black holes are initially set up with an empty blocking
-queue.
-
-The combination of GrAnSim with revertible black holes has not been
-checked, yet. -- HWL
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-
-STGFUN(RBH_entry)
-{
- FB_
-
-# if defined(GRAN)
- /* Before overwriting TSO_LINK */
- STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);
-# endif
-
- /* In GranSim and GUM on 2.04 the InfoPtr seems to be invalid when entering
- this routine (exact reason is unknown). This change does the safe
- thing instead. -- HWL */
-
- switch (INFO_TYPE(INFO_PTR(Node))) { /* HWL orig: INFO_TYPE(InfoPtr) */
- case INFO_SPEC_RBH_TYPE:
- TSO_LINK(CurrentTSO) = (P_) SPEC_RBH_BQ(Node);
- SPEC_RBH_BQ(Node) = (W_) CurrentTSO;
- break;
- case INFO_GEN_RBH_TYPE:
- TSO_LINK(CurrentTSO) = (P_) GEN_RBH_BQ(Node);
- GEN_RBH_BQ(Node) = (W_) CurrentTSO;
- break;
- default:
- fflush(stdout);
- fprintf(stderr, "Panic: non-{SPEC,GEN} RBH %#lx (IP %#lx)\n", Node, InfoPtr);
- EXIT(EXIT_FAILURE);
- }
-
- LivenessReg = LIVENESS_R1;
- SaveAllStgRegs();
- TSO_PC1(CurrentTSO) = EnterNodeCode;
-
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
-
-# ifdef PAR
- if(RTSflags.ParFlags.granSimStats) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- TIME now = CURRENT_TIME;
- TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
- TSO_BLOCKCOUNT(CurrentTSO)++;
- TSO_QUEUE(CurrentTSO) = Q_BLOCKED;
- TSO_BLOCKEDAT(CurrentTSO) = now;
- DumpGranEvent(GR_BLOCK, CurrentTSO);
- }
-# endif
-# if defined(GRAN)
- ReSchedule(SAME_THREAD); /* NB: GranSimBlock activated next thread */
-# else
- ReSchedule(0);
-# endif
-
- FE_
-}
-
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[thread-entrypoints]{Scheduler-Thread Interfaces}
-%* *
-%************************************************************************
-
-The normal way of entering a thread is through \tr{resumeThread},
-which short-circuits any indirections to the TSO and StkO, sets up STG
-registers, and jumps to the saved PC.
-
-\begin{code}
-STGFUN(resumeThread)
-{
- FB_
-
- while(IS_INDIRECTION(INFO_PTR(CurrentTSO))) {
- CurrentTSO = (P_) IND_CLOSURE_PTR(CurrentTSO);
- }
-
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- TSO_QUEUE(CurrentTSO) = Q_RUNNING;
- /* Note that CURRENT_TIME may perform an unsafe call */
- TSO_BLOCKEDAT(CurrentTSO) = CURRENT_TIME;
- }
-#endif
-
- CurrentRegTable = TSO_INTERNAL_PTR(CurrentTSO);
-
- while(IS_INDIRECTION(INFO_PTR(SAVE_StkO))) {
- SAVE_StkO = (P_) IND_CLOSURE_PTR(SAVE_StkO);
- }
- RestoreAllStgRegs();
-
- SET_TASK_ACTIVITY(ST_REDUCING);
- RESTORE_CCC(TSO_CCC(CurrentTSO));
- JMP_(TSO_PC1(CurrentTSO));
- FE_
-}
-\end{code}
-
-Since we normally context switch during a heap check, it is possible
-that we will return to a previously suspended thread without
-sufficient heap for the thread to continue. However, we have cleverly
-stashed away the heap requirements in @TSO_ARG1@ so that we can decide
-whether or not to perform a garbage collection before resuming the
-thread. The actual thread resumption address (either @EnterNodeCode@
-or elsewhere) is stashed in @TSO_PC2@.
-
-\begin{code}
-STGFUN(CheckHeapCode)
-{
- FB_
-
- ALLOC_HEAP(TSO_ARG1(CurrentTSO)); /* ticky profiling */
- if ((Hp += TSO_ARG1(CurrentTSO)) > HpLim) {
- ReallyPerformThreadGC(TSO_ARG1(CurrentTSO), rtsFalse);
- JMP_(resumeThread);
- }
- SET_TASK_ACTIVITY(ST_REDUCING);
- RESUME_(TSO_PC2(CurrentTSO));
- FE_
-}
-\end{code}
-
-Often, a thread starts (or rather, resumes) by entering the closure
-that Node points to. Here's a tiny code fragment to do just that.
-The saved PC in the TSO can be set to @EnterNodeCode@ whenever we
-want this to happen upon resumption of the thread.
-
-\begin{code}
-STGFUN(EnterNodeCode)
-{
- FB_
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FE_
-}
-\end{code}
-
-Then, there are the occasions when we just want to pick up where we
-left off. We use \tr{RESUME_} here instead of \tr{JMP_}, because when
-we return to a call site, the Alpha is going to try to load \tr{%gp}
-from \tr{%ra} rather than \tr{%pv}, and \tr{JMP_} only sets \tr{%pv}.
-Resuming to the start of a function is currently okay, but an
-extremely bad practice. As we add support for more architectures, we
-can expect the difference between \tr{RESUME_} and \tr{JMP_} to become
-more acute.
-
-\begin{code}
-STGFUN(Continue)
-{
- FB_
-
- SET_TASK_ACTIVITY(ST_REDUCING);
- RESUME_(TSO_PC2(CurrentTSO));
- FE_
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[stack-chunk-underflow-code]{Underflow code for stack chunks}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifndef PAR
-\end{code}
-
-On a uniprocessor, stack underflow causes us no great headaches. The
-old value of RetReg is squirreled away at the base of the top stack
-object (the one that's about to get blown away). We just yank it
-outta there and perform the same kind of return that got us here in
-the first place.
-
-This simplicity is due to the fact that we never have to fetch a stack
-object on underflow.
-
-\begin{code}
-
-#define DO_RETURN_TEMPLATE(label, cont) \
- STGFUN(label) \
- { \
- P_ temp; \
- FB_ \
- temp = STKO_LINK(StkOReg); \
- RetReg = STKO_RETURN(StkOReg); \
- StkOReg = temp; \
- RestoreStackStgRegs(); \
- JMP_(cont); \
- FE_ \
- }
-
-DO_RETURN_TEMPLATE(UnderflowDirectReturn, DIRECT(((P_)RetReg)))
-DO_RETURN_TEMPLATE(UnderflowVect0, ((P_)RetReg)[RVREL(0)])
-DO_RETURN_TEMPLATE(UnderflowVect1, ((P_)RetReg)[RVREL(1)])
-DO_RETURN_TEMPLATE(UnderflowVect2, ((P_)RetReg)[RVREL(2)])
-DO_RETURN_TEMPLATE(UnderflowVect3, ((P_)RetReg)[RVREL(3)])
-DO_RETURN_TEMPLATE(UnderflowVect4, ((P_)RetReg)[RVREL(4)])
-
-DO_RETURN_TEMPLATE(UnderflowVect5, ((P_)RetReg)[RVREL(5)])
-DO_RETURN_TEMPLATE(UnderflowVect6, ((P_)RetReg)[RVREL(6)])
-DO_RETURN_TEMPLATE(UnderflowVect7, ((P_)RetReg)[RVREL(7)])
-
-DO_RETURN_TEMPLATE(StackUnderflowEnterNode, EnterNodeCode)
-
-#else /* PAR */
-
-\end{code}
-
-In the parallel world, we may have to fetch the StkO from a remote
-location before we can load up the stack registers and perform the
-return. Our convention is that we load RetReg up with the exact
-continuation address (after a vector table lookup, if necessary),
-and tail-call the code to fetch the stack object. (Of course, if
-the stack object is already local, we then just jump to the
-continuation address.)
-
-\begin{code}
-
-STGFUN(CommonUnderflow)
-{
- P_ temp;
-
- FB_
- temp = STKO_LINK(StkOReg);
-
- /* fprintf(stderr,"Stk Underflow from: %lx to: %lx size abandoned: %d\n",StkOReg,temp,STKO_CLOSURE_CTS_SIZE(StkOReg)); */
-
- /* change the guy we are abandoning into something
- that will not be "interesting" on the mutables
- list. (As long as it is there, it will be
- scavenged in GC, and we cannot guarantee that
- it is still a "sane" StkO object). (And, besides,
- why continue to keep it [and all it pts to] alive?)
- Will & Phil 95/10
- */
- FREEZE_MUT_HDR(StkOReg, ImMutArrayOfPtrs_info);
- MUTUPLE_CLOSURE_SIZE(StkOReg) = MUTUPLE_VHS;
-
- StkOReg = temp;
- /* ToDo: Fetch the remote stack object here! */
- RestoreStackStgRegs();
- JMP_(RetReg);
- FE_
-}
-
-#define DO_RETURN_TEMPLATE(label, cont) \
- STGFUN(label) \
- { \
- FB_ \
- RetReg = STKO_RETURN(StkOReg); \
- RetReg = (StgRetAddr)(cont); \
- LivenessReg = INFO_LIVENESS(InfoPtr); \
- JMP_(CommonUnderflow); \
- FE_ \
- }
-
-DO_RETURN_TEMPLATE(UnderflowDirectReturn, DIRECT(((P_)RetReg)))
-DO_RETURN_TEMPLATE(UnderflowVect0, ((P_)RetReg)[RVREL(0)])
-DO_RETURN_TEMPLATE(UnderflowVect1, ((P_)RetReg)[RVREL(1)])
-DO_RETURN_TEMPLATE(UnderflowVect2, ((P_)RetReg)[RVREL(2)])
-DO_RETURN_TEMPLATE(UnderflowVect3, ((P_)RetReg)[RVREL(3)])
-DO_RETURN_TEMPLATE(UnderflowVect4, ((P_)RetReg)[RVREL(4)])
-DO_RETURN_TEMPLATE(UnderflowVect5, ((P_)RetReg)[RVREL(5)])
-DO_RETURN_TEMPLATE(UnderflowVect6, ((P_)RetReg)[RVREL(6)])
-DO_RETURN_TEMPLATE(UnderflowVect7, ((P_)RetReg)[RVREL(7)])
-
-STGFUN(PrimUnderflow)
-{
- FB_
- RetReg = STKO_RETURN(StkOReg);
- RetReg = (StgRetAddr)DIRECT(((P_)RetReg));
- LivenessReg = NO_LIVENESS;
- JMP_(CommonUnderflow);
- FE_
-}
-
-/*
- * This one is similar, but isn't part of the return vector. It's only used
- * when we fall off of a stack chunk and want to enter Node rather than
- * returning through RetReg. (This occurs during UpdatePAP, when the updatee
- * isn't on the current stack chunk.) It can't be done with the template,
- * because R2 is dead, and R1 points to a PAP. Only R1 is live.
- */
-
-#if 0
-
-/* old version of the code */
-STGFUN(StackUnderflowEnterNode)
-{
- FB_
- RetReg = (StgRetAddr)(EnterNodeCode);
- LivenessReg = LIVENESS_R1;
- JMP_(CommonUnderflow);
- FE_
-}
-
-#else
-
-/*
- We've inlined CommonUnderFlow because setting RetReg would zap
- the return vector that the node needs.
- We pick up the RetReg from the STkO header instead.
- KH/HWL 14/2/97
-*/
-
-STGFUN(StackUnderflowEnterNode)
-{
- P_ temp;
- FB_
- RetReg = STKO_RETURN(StkOReg); /* pick up return code from the StkO hdr
- needed because we come from UpdatePAP */
- LivenessReg = LIVENESS_R1;
-
- temp = STKO_LINK(StkOReg);
-
- /*? fprintf(stderr,"Stk Underflow from: %lx to: %lx size abandoned: %d\n",StkOReg,temp,STKO_CLOSURE_CTS_SIZE(StkOReg)); ?*/
-
- /* change the guy we are abandoning into something
- that will not be "interesting" on the mutables
- list. (As long as it is there, it will be
- scavenged in GC, and we cannot guarantee that
- it is still a "sane" StkO object). (And, besides,
- why continue to keep it [and all it pts to] alive?)
- Will & Phil 95/10
- */
- FREEZE_MUT_HDR(StkOReg, ImMutArrayOfPtrs_info);
- MUTUPLE_CLOSURE_SIZE(StkOReg) = MUTUPLE_VHS;
-
- StkOReg = temp;
- /* ToDo: Fetch the remote stack object here! */
- RestoreStackStgRegs();
- JMP_(EnterNodeCode); /* this will enter a PAP containing the old stkos
- A and B stacks */
- FE_
-}
-#endif
-
-
-#endif /* !PAR */
-
-const W_
-vtbl_Underflow[] = {
- /* "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
- (W_) UnderflowVect0,
- (W_) UnderflowVect1,
- (W_) UnderflowVect2,
- (W_) UnderflowVect3,
- (W_) UnderflowVect4,
- (W_) UnderflowVect5,
- (W_) UnderflowVect6,
- (W_) UnderflowVect7
-};
-
-#endif /* CONCURRENT */
-\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\section[update-code]{Code required for update abstraction}
-%* *
-%************************************************************************
-
-This code is required by the update interface which sits on top of the
-storage manager interface (See \tr{SMupdate.lh}).
-
-\begin{itemize}
-\item Indirection entry code and info table.
-\item Black Hole entry code and info table.
-\item Update frame code and return vectors.
-\item PAP update code.
-\item PAP entry code and info table.
-\end{itemize}
-
-System-wide constants need to be included:
-\begin{code}
-#define MAIN_REG_MAP /* STG world */
-
-#include "rtsdefs.h"
-#include "SMupdate.h"
-#if 0
-#ifdef PAR
-# include "Statistics.h"
-#endif
-#endif
-
-EXTDATA(PrelBase_Z91Z93_closure);
-
-#if defined(TICKY_TICKY)
-void PrintTickyInfo(STG_NO_ARGS);
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[indirection-code]{Indirection code}
-%* *
-%************************************************************************
-
-The entry code for indirections and the indirection info-table.
-\begin{code}
-STGFUN(Ind_entry)
-{
- FB_
- ENT_IND(Node); /* Ticky-ticky profiling info */
-
- Node = (P_) IND_CLOSURE_PTR((P_) Node);
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FE_
-}
-
-IND_ITBL(Ind_info,Ind_entry,const,EF_);
-\end{code}
-
-We also need a special @CAF@ indirection info table which is used to
-indirect @CAF@s to evaluated results in the heap.
-\begin{code}
-STGFUN(Caf_entry) /* same as Ind_entry */
-{
- FB_
- ENT_IND(Node);
-
- Node = (P_) IND_CLOSURE_PTR((P_) Node);
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FE_
-}
-
-CAF_ITBL(Caf_info,Caf_entry,const,EF_);
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[black-hole-code]{Black Hole code}
-%* *
-%************************************************************************
-
-The entry code for black holes abort indicating a cyclic data dependency.
-It is used to overwrite closures currently being evaluated.
-
-In the concurrent world, black holes are synchronization points, and they
-are turned into blocking queues when there are threads waiting for the
-evaluation of the closure to finish.
-
-\begin{code}
-#ifdef CONCURRENT
-EXTFUN(EnterNodeCode);
-EXTFUN(StackUnderflowEnterNode);
-EXTDATA_RO(BQ_info);
-#else
-void raiseError PROTO((StgStablePtr));
-extern StgStablePtr errorHandler; /* NB: prone to magic-value-ery (WDP 95/12) */
-#endif
-
-STGFUN(BH_UPD_entry)
-{
-#ifndef CONCURRENT
- FB_
- (void) STGCALL1(int,(void *, FILE *),fflush,stdout);
- (void) STGCALL2(int,(),fprintf,stderr,"Entered a `black hole': the program has a cyclic data dependency.\n");
-
-# if defined(PROFILING)
- {
- CostCentre cc = (CostCentre) CC_HDR(Node);
- (void) STGCALL5(int,(),fprintf,stderr,"Cost Centre: %s Module: %s Group %s\n",cc->label, cc->module, cc->group);
- }
-# endif
-
-# if defined(TICKY_TICKY)
- if (RTSflags.TickyFlags.showTickyStats) {
- (void) STGCALL0(void,(),PrintTickyInfo);
- }
-# endif
-
- (void) STGCALL1(void,(void *, StgStablePtr), raiseError, errorHandler);
- FE_
-
-#else /* threads! */
-
- FB_
-
-# if 0
- if ( RTSflags.GranFlags.debug & 0x80 )
- (void) STGCALL4(int,(),fprintf,stderr,"GRAN_CHECK in BH_UPD_entry: Entered a `black hole' @ 0x%x (CurrentTSO @ 0x%x\n ",Node,CurrentTSO);
-# endif
-
-# if defined(GRAN)
- /* Do this before losing its TSO_LINK */
- STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);
-# endif
-
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;
- SET_INFO_PTR(Node, BQ_info);
- BQ_ENTRIES(Node) = (W_) CurrentTSO;
-
-# if defined(GCap) || defined(GCgn)
- /* If we modify a black hole in the old generation,
- we have to make sure it goes on the mutables list */
-
- if(Node <= StorageMgrInfo.OldLim) {
- MUT_LINK(Node) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = Node;
- } else
- MUT_LINK(Node) = MUT_NOT_LINKED;
-# endif
-
- LivenessReg = LIVENESS_R1;
- SaveAllStgRegs();
- TSO_PC1(CurrentTSO) = EnterNodeCode;
-
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
-
-# ifdef PAR
- if(RTSflags.ParFlags.granSimStats) {
- TIME now = CURRENT_TIME;
- TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
- TSO_BLOCKCOUNT(CurrentTSO)++;
- TSO_QUEUE(CurrentTSO) = Q_BLOCKED;
- TSO_BLOCKEDAT(CurrentTSO) = now;
- DumpGranEvent(GR_BLOCK, CurrentTSO);
- }
-# endif
-
-# if defined(GRAN)
- /* CurrentTSO = PrelBase_Z91Z93_closure; */
- ReSchedule(SAME_THREAD);
-# else
- ReSchedule(0);
-# endif
-
- FE_
-
-#endif /* threads */
-}
-
-/* made external so that debugger can get at it more effectively */
-STGFUN(BH_SINGLE_entry)
-{
- FB_
-
- (void) STGCALL1(int,(void *, FILE *),fflush,stdout);
- (void) STGCALL2(int,(),fprintf,stderr,"Entered a single-entry `black hole' --\n");
- (void) STGCALL2(int,(),fprintf,stderr,"either the compiler made a mistake on single-entryness,\n");
- (void) STGCALL2(int,(),fprintf,stderr,"or the program has a cyclic data dependency.\n");
-
-#if defined(PROFILING)
- {
- CostCentre cc = (CostCentre) CC_HDR(Node);
- (void) STGCALL5(int,(),fprintf,stderr, "Cost Centre: %s Module: %s Group %s\n",cc->label, cc->module, cc->group);
- }
-#endif
-
-# if defined(TICKY_TICKY)
- if (RTSflags.TickyFlags.showTickyStats) {
- (void) STGCALL0(void,(),PrintTickyInfo);
- }
-# endif
-
-#ifndef CONCURRENT
- (void) STGCALL1(void,(void *, StgStablePtr), raiseError, errorHandler);
-#else
- EXIT(EXIT_FAILURE);
-#endif
-
- FE_
-}
-\end{code}
-
-Updatable closures are overwritten with a black hole of a fixed size,
-@MIN_UPD_SIZE@.
-
-\begin{code}
-CAT_DECLARE(BH,BH_K,"BH","BH") /* just one, shared */
-
-BH_ITBL(BH_UPD_info,BH_UPD_entry,U,const,EF_);
-\end{code}
-
-Single-Entry closures, which are not updated, are also overwritten
-with a black hole. They have size @MIN_NONUPD_SIZE@.
-
-\begin{code}
-BH_ITBL(BH_SINGLE_info,BH_SINGLE_entry,N,const,EF_);
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[static-update-code]{Static update code in update frames}
-%* *
-%************************************************************************
-
-This code is pointed to from update frames. It has to cope with
-any kind of algebraic return: vectored or unvectored.
-
-See \tr{SMupdate.lh} for a description of the various update frames
-and the macros defining their layout.
-
-On entry to this code:
-\begin{itemize}
-\item @R1@ points to a recently created heap object (return in heap) or
-is dead (return in regs).
-\item @R2@ points to the info table for the constructor.
-\item When returning in regs, any of the return-regs (@R3@...) may be live,
-but aren't used by this code. They must be preserved.
-\item @SpB@ points to the topmost word of the update frame.
-\end{itemize}
-
-NEW update mechanism (Jan '94):
-
-When returning to an update frame, we want to jump directly to the
-update code for the constructor in hand. Because of the various
-possible return conventions (all of which must be handled by the
-generic update frame), we actually end up with a somewhat indirect
-jump.
-
-\begin{code}
-
-STGFUN(StdUpdFrameDirectReturn)
-{
- FB_
- JMP_(UPDATE_CODE(InfoPtr));
- FE_
-}
-
-/*
- NB: For direct returns to work properly, the name of the routine must be
- the same as the name of the vector table with vtbl_ removed and DirectReturn
- appended. This is all the mangler understands.
-*/
-
-const
-W_
-vtbl_StdUpdFrame[] = {
- /* at least "MAX_VECTORED_RTN" elements (see GhcConstants.lh) */
- (W_) StdUpdFrameDirectReturn/*0*/,
- (W_) StdUpdFrameDirectReturn/*1*/,
- (W_) StdUpdFrameDirectReturn/*2*/,
- (W_) StdUpdFrameDirectReturn/*3*/,
- (W_) StdUpdFrameDirectReturn/*4*/,
- (W_) StdUpdFrameDirectReturn/*5*/,
- (W_) StdUpdFrameDirectReturn/*6*/,
- (W_) StdUpdFrameDirectReturn/*7*/
-};
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[seq-update-code]{Update code for seq}
-%* *
-%************************************************************************
-
-
-\begin{code}
-
-IFN_(seqDirectReturn) {
- void *cont;
-
- FB_
- RetReg = (StgRetAddr) SpB[BREL(0)];
- cont = (void *) SpB[BREL(1)];
- /* SpB += BREL(2); */
- JMP_(cont);
- FE_
-}
-
-/*
- NB: For direct returns to work properly, the name of the routine must be
- the same as the name of the vector table with vtbl_ removed and DirectReturn
- appended. This is all the mangler understands.
- */
-
-const W_
-vtbl_seq[] = {
- (W_) seqDirectReturn,
- (W_) seqDirectReturn,
- (W_) seqDirectReturn,
- (W_) seqDirectReturn,
- (W_) seqDirectReturn,
- (W_) seqDirectReturn,
- (W_) seqDirectReturn,
- (W_) seqDirectReturn
-};
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[existing-con-update-code]{Update code for existing constructors}
-%* *
-%************************************************************************
-
-Here is the standard update code for objects that are returned in the
-heap (or those which are initially returned in registers, but have
-already been allocated in the heap earlier in the update chain). In
-either case, @Node@ points to the heap object. The update code grabs
-the address of the updatee out of the partial update frame (the return
-address has already been popped), makes the updatee an indirection to
-@Node@, and returns according to the convention for the constructor.
-
-\begin{code}
-#define IND_UPD_TEMPLATE(label, retvector) \
- STGFUN(label) \
- { \
- FB_ \
- UPD_EXISTING(); /* Ticky-ticky profiling info */ \
- /* Update thing off stk with an indirection to Node */ \
- UPD_IND(GRAB_UPDATEE(SpB), Node); \
- /* Pop the standard update frame */ \
- POP_STD_UPD_FRAME() \
- \
- JMP_(retvector); \
- FE_ \
- }
-
-IND_UPD_TEMPLATE(IndUpdRetDir, DIRECT(((P_)RetReg)))
-IND_UPD_TEMPLATE(IndUpdRetV0, ((P_)RetReg)[RVREL(0)])
-IND_UPD_TEMPLATE(IndUpdRetV1, ((P_)RetReg)[RVREL(1)])
-IND_UPD_TEMPLATE(IndUpdRetV2, ((P_)RetReg)[RVREL(2)])
-IND_UPD_TEMPLATE(IndUpdRetV3, ((P_)RetReg)[RVREL(3)])
-IND_UPD_TEMPLATE(IndUpdRetV4, ((P_)RetReg)[RVREL(4)])
-IND_UPD_TEMPLATE(IndUpdRetV5, ((P_)RetReg)[RVREL(5)])
-IND_UPD_TEMPLATE(IndUpdRetV6, ((P_)RetReg)[RVREL(6)])
-IND_UPD_TEMPLATE(IndUpdRetV7, ((P_)RetReg)[RVREL(7)])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[no-update-code]{Code for Erroneous Updates}
-%* *
-%************************************************************************
-
-\begin{code}
-
-STGFUN(UpdErr)
-{
- FB_
-
- fflush(stdout);
- fprintf(stderr, "Update error: not a constructor!\n");
- abort();
-
- FE_
-}
-
-STGFUN(StdErrorCode)
-{
- FB_
-
- fflush(stdout);
- fprintf(stderr, "Standard error: should never happen!\n");
- abort();
-
- FE_
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[permanent-indirections]{Lexical Scoping Updates}
-%* *
-%************************************************************************
-
-A function entered without any arguments is updated with an
-indirection. For lexically scoped profiling we still need to set the
-cost centre if we enter the PAP. As the indirection is removed by the
-garbage collector this would not be possible.
-
-To solve this problem we introduce a permanent indirection which sets
-the cost centre when entered. The heap profiler ignores the space
-occupied by it as it would not reside in the heap during normal
-execution.
-
-In ticky-land: If we are trying to collect update-entry counts
-(controlled by an RTS flag), then we must use permanent indirections
-(the shorting-out of regular indirections loses the counts).
-
-\begin{code}
-#if defined(PROFILING) || defined(TICKY_TICKY)
-
-STGFUN(Perm_Ind_entry)
-{
- FB_
-
- /* Don't add INDs to granularity cost */
-
- /* Dont: ENT_IND(Node); for ticky-ticky; this ind is here only to help profiling */
-
- /* Enter PAP cost centre -- lexical scoping only */
- ENTER_CC_PAP_CL(Node);
-
- Node = (P_) IND_CLOSURE_PTR((P_) Node);
-
- /* Dont: ENT_VIA_NODE(); for ticky-ticky; as above */
-
- InfoPtr=(D_)(INFO_PTR(Node));
-
- JMP_(ENTRY_CODE(InfoPtr));
- FE_
-}
-
-PERM_IND_ITBL(Perm_Ind_info,Perm_Ind_entry,const,EF_);
-
-#endif /* PROFILING or TICKY */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[partial-application-updates]{Partial applications}
-%* *
-%************************************************************************
-
-See STG paper implementation section of Partial application updates.
-
-We jump here when the current function fails an argument satisfaction
-check. There can be two reasons for this. In the usual case, there
-is an update frame blocking our access to anything deeper on the
-stack. We then update the updatee in the frame with a partial
-application node and squeeze out the update frame. The other
-possibility is that we are running threaded code, and we are sitting
-on the bottom of a stack chunk. In this case, we still build the
-partial application, but we have nothing in our hands to update, so we
-underflow the stack (awakening the previous chunk) and enter the
-partial application node just built.
-
-On entry to @UpdatePAP@, we assume the following:
-\begin{itemize}
-\item SuB points to topmost word of an update frame or to the bottom of a
-stack chunk.
-\item SpA and SpB point to the topmost words of their respective stacks.
-\item Node points to the closure which needs more arguments than are there.
-\end{itemize}
-
-\begin{code}
-STGFUN(UpdatePAP)
-{
- /*
- * Use STG registers for these locals which must survive the HEAP_CHK.
- * Don't squash Node (R1), because it's an implicit argument.
- */
-
-#define NNonPtrWords (R2.i)
-#define NPtrWords (R3.i)
-#define NArgWords (R4.i)
-#define PapSize (R5.i)
-#if defined(PROFILING)
-# define CC_pap ((CostCentre)(R7.p))
-#endif
-
- /* These other locals do not have to survive a HEAP_CHK */
-
- P_ PapClosure;
- P_ Updatee;
- P_ p;
- I_ i;
-
- FB_
-
-#if defined(GRAN_COUNT)
- ++nPAPs;
-#endif
-
- NPtrWords = AREL(SuA - SpA);
- NNonPtrWords = BREL(SuB - SpB);
-
- ASSERT(NPtrWords >= 0);
- ASSERT(NNonPtrWords >= 0);
-
- NArgWords = NPtrWords + NNonPtrWords + 1; /* +1 for Node */
-
-#if defined(PROFILING)
- /* set "CC_pap" to go in the updatee (see Sansom thesis, p 183) */
-
- CC_pap /*really cc_enter*/ = (CostCentre) CC_HDR(Node);
- if (IS_CAF_OR_DICT_OR_SUB_CC(CC_pap) /*really cc_enter*/)
- CC_pap = CCC;
-#endif
-
- if (NArgWords == 1) {
-
- /*
- * No arguments, only Node. Skip building the PAP and
- * just plan to update with an indirection.
- */
-
- PapClosure = Node;
-
- } else {
-
- /* Build the PAP. A generic PAP closure is laid out thus:
- * code ptr, size, no of words of ptrs, Node, ptrs, non-ptrs
- * (i.e. a DYN closure)
- * ToDo: add stuff for special cases, to omit size and no. of ptrs
- * (Still ToDo? (JSM))
- */
-
- PapSize = NArgWords + DYN_HS;
-
- ALLOC_UPD_PAP(DYN_HS, NArgWords, 0, PapSize);
- CC_ALLOC(CC_pap, PapSize, PAP_K);
-
- /* Allocate PapClosure -- Only Node (R1) is live */
- HEAP_CHK(LIVENESS_R1, PapSize, 0);
-
- PapClosure = Hp + 1 - PapSize; /* The new PapClosure */
-
- SET_DYN_HDR(PapClosure, PAP_info, CC_pap, NArgWords + DYN_VHS, NPtrWords + 1);
-
- /* Now fill in the closure fields */
-
- p = Hp;
- for (i = NNonPtrWords - 1; i >= 0; i--) *p-- = (W_) SpB[BREL(i)];
- for (i = NPtrWords - 1; i >= 0; i--) *p-- = (W_) SpA[AREL(i)];
- *p = (W_) Node;
- }
-
- /*
- * Finished constructing PAP closure; now update the updatee. But
- * wait! What if there is no updatee? Then we fall off the
- * stack.
- */
-
-#ifdef CONCURRENT
- if (SuB < STKO_BSTK_BOT(StkOReg)) {
- Node = PapClosure;
-# ifdef PAR
- LivenessReg = LIVENESS_R1;
-# endif
- JMP_(StackUnderflowEnterNode);
- }
-#endif
-
- /*
- * Now we have a standard update frame, so we update the updatee with
- * either the new PAP or Node.
- *
- * Supposedly, it is not possible to get a constructor update frame,
- * (Why not? (JSM))
- * (Because they have *never* been implemented. (WDP))
- */
-
- Updatee = GRAB_UPDATEE(SuB);
- UPD_IND(Updatee, PapClosure); /* Indirect Updatee to PapClosure */
-
- if (NArgWords != 1) {
- UPD_PAP_IN_NEW(NArgWords);
-
- } else {
- UPD_PAP_IN_PLACE();
-
-#if defined(PROFILING)
- /*
- * Lexical scoping requires a *permanent* indirection, and we
- * also have to set the cost centre for the indirection.
- */
- INFO_PTR(Updatee) = (W_) Perm_Ind_info;
- SET_CC_HDR(Updatee, CC_pap);
-
-#endif /* PROFILING */
- }
-
-#if defined(PROFILING)
- /*
- * Restore the Cost Centre too (if required); again see Sansom thesis p 183.
- * Take the CC out of the update frame if a CAF/DICT.
- */
-
- CCC = (IS_CAF_OR_DICT_OR_SUB_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;
-
-#endif /* PROFILING */
-
- /* Restore SuA, SuB, RetReg */
- RetReg = GRAB_RET(SuB);
- SuA = GRAB_SuA(SuB);
- SuB = GRAB_SuB(SuB);
-
- /*
- * Squeeze out update frame from B stack. Note that despite our best
- * efforts with [AB]REL and friends, the loop order depends on the B
- * stack growing up.
- */
- for (i = NNonPtrWords - 1; i >= 0; i--)
- SpB[BREL(i+STD_UF_SIZE)] = SpB[BREL(i)];
-
- SpB += BREL(STD_UF_SIZE);
-
- /*
- * All done! Restart by re-entering Node
- * Don't count this entry for ticky-ticky profiling.
- */
-
-#if 0 /* defined(GRAN) */
- GRAN_EXEC(16,4,7,4,0);
-#endif
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FE_
-
-#undef NNonPtrWords
-#undef NPtrWords
-#undef NArgWords
-#undef PapSize
-#ifdef PROFILING
-# undef CC_pap
-#endif
-}
-\end{code}
-
-The entry code for a generic PAP. @Node@ points to the PAP closure.
-Reload the stacks from the PAP, and enter the closure stored in the
-PAP. PAPs are in HNF so no update frame is needed.
-
-\begin{code}
-STGFUN(PAP_entry)
-{
- /* Use STG registers for these locals which must survive the STK_CHK */
-#define NPtrWords (R2.i)
-#define NNonPtrWords (R3.i)
-#if defined(PROFILING)
-# define CC_pap ((CostCentre)(R7.p))
-#endif
-
- /* These locals don't have to survive the STK_CHK */
- P_ Updatee;
- P_ p;
- I_ i;
- I_ aWords, bWords;
-
- FB_
-
- /* Concurrent World:
- If we come from StackUnderflowEnterNode the old StkO has been
- nuked and the PAP carries over data from the old StkO.
- The underflow code must restore RetReg to the right value
- because it is not grabbed from the update frame if there is data
- on one of the two stacks.
- -- HWL
- */
- while (AREL(SuA - SpA) == 0 && BREL(SuB - SpB) == 0) {
-#ifdef CONCURRENT
- if (SuB < STKO_BSTK_BOT(StkOReg)) {
-# ifdef PAR
- LivenessReg = LIVENESS_R1;
-# endif
- JMP_(StackUnderflowEnterNode);
- }
-#endif
-
- /* We're sitting on top of an update frame, so let's do the business */
-
- Updatee = GRAB_UPDATEE(SuB);
- UPD_IND(Updatee, Node);
-
-#if defined(PROFILING)
- /*
- * Restore the Cost Centre too (if required); again see Sansom
- * thesis p 183. Take the CC out of the update frame if a
- * CAF/DICT.
- */
-
- CC_pap = (CostCentre) CC_HDR(Node);
- CCC = (IS_CAF_OR_DICT_OR_SUB_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;
-
-#endif /* PROFILING */
-
- RetReg = GRAB_RET(SuB);
- SuA = GRAB_SuA(SuB);
- SuB = GRAB_SuB(SuB);
- SpB += BREL(STD_UF_SIZE);
- }
-
- NPtrWords = DYN_CLOSURE_NoPTRS(Node) - 1; /* The saved Node counts as one */
- NNonPtrWords = DYN_CLOSURE_NoNONPTRS(Node);
-
- /* Ticky-ticky profiling info */
- ENT_PAP(Node);
-
- /* Enter PAP cost centre -- lexical scoping only */
- ENTER_CC_PAP_CL(Node);
-
- /*
- * Check for stack overflow. Ask to take all of the current frame with
- * us to the new world. If there is no update frame on the current stack,
- * bWords will exceed the size of the B stack, but StackOverflow will deal
- * with it.
- */
-
- aWords = AREL(SuA - SpA);
- bWords = BREL(SuB - SpB) + STD_UF_SIZE;
-
- STK_CHK(LIVENESS_R1, NPtrWords, NNonPtrWords, aWords, bWords, 0, 0);
-
- SpA -= AREL(NPtrWords);
- SpB -= BREL(NNonPtrWords);
-
- /* Reload Node */
- p = Node + DYN_HS; /* Point to first pointer word */
- Node = (P_) *p++;
-
- /* Reload the stacks */
-
- for (i=0; i<NPtrWords; i++) SpA[AREL(i)] = (P_) *p++;
- for (i=0; i<NNonPtrWords; i++) SpB[BREL(i)] = *p++;
-
- /* Off we go! */
- ENT_VIA_NODE();
- InfoPtr=(D_)(INFO_PTR(Node));
- JMP_(ENTRY_CODE(InfoPtr));
- FE_
-
-#undef NPtrWords
-#undef NNonPtrWords
-#ifdef PROFILING
-# undef CC_pap
-#endif
-}
-\end{code}
-
-The info table for a generic PAP:
-\begin{code}
-DYN_ITBL(PAP_info,PAP_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,PAP_K,"PAP","->");
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%* *
-\section[Threads.lc]{Thread Control Routines}
-%* *
-%************************************************************************
-
-%************************************************************************
-%
-\subsection[thread-overview]{Overview of the Thread Management System}
-%
-%************************************************************************
-
-%************************************************************************
-%
-\subsection[thread-decls]{Thread Declarations}
-%
-%************************************************************************
-
-% I haven't checked if GRAN can work with QP profiling. But as we use our
-% own profiling (GR profiling) that should be irrelevant. -- HWL
-
-NOTE: There's currently a couple of x86 only pieces in here. The reason
-for this is the need for an expedient hack to make Concurrent Haskell
-and stable pointers work sufficiently for Win32 applications.
-(the changes in here are not x86 specific, but other parts of this patch are
-(see PerformIO.lhc))
-
-ToDo: generalise to all platforms
-
-\begin{code}
-
-#if defined(CONCURRENT) /* the whole module! */
-
-#if !defined(_AIX)
-# define NON_POSIX_SOURCE /* so says Solaris */
-#endif
-
-# include "rtsdefs.h"
-# include <setjmp.h>
-
-#include "LLC.h"
-#include "HLC.h"
-
-static void init_qp_profiling(STG_NO_ARGS); /* forward decl */
-\end{code}
-
-@AvailableStack@ is used to determine whether an existing stack can be
-reused without new allocation, so reducing garbage collection, and
-stack setup time. At present, it is only used for the first stack
-chunk of a thread, the one that's got
-@RTSflags.ConcFlags.stkChunkSize@ words.
-
-\begin{code}
-P_ AvailableStack = PrelBase_Z91Z93_closure;
-P_ AvailableTSO = PrelBase_Z91Z93_closure;
-\end{code}
-
-Macros for dealing with the new and improved GA field for simulating
-parallel execution. Based on @CONCURRENT@ package. The GA field now
-contains a mask, where the n-th bit stands for the n-th processor,
-on which this data can be found. In case of multiple copies, several bits
-are set. The total number of processors is bounded by @MAX_PROC@,
-which should be <= the length of a word in bits. -- HWL
-
-{{GranSim.lc}Daq ngoq' roQlu'ta'}
-(Code has been moved to GranSim.lc).
-
-%****************************************************************
-%* *
-\subsection[thread-getthread]{The Thread Scheduler}
-%* *
-%****************************************************************
-
-This is the heart of the thread scheduling code.
-
-Most of the changes for GranSim are in this part of the RTS.
-Especially the @ReSchedule@ routine has been blown up quite a lot
-It now contains the top-level event-handling loop.
-
-Parts of the code that are not necessary for GranSim, but convenient to
-have when developing it are marked with a @GRAN_CHECK@ variable.
-
-\begin{code}
-STGRegisterTable *CurrentRegTable = NULL;
-P_ CurrentTSO = NULL;
-
-#if defined(GRAN)
-
-/* Only needed for GranSim Light; costs of operations during rescheduling
- are associated to the virtual processor on which ActiveTSO is living */
-P_ ActiveTSO = NULL;
-rtsBool resched = rtsFalse; /* debugging only !!*/
-
-/* Pointers to the head and tail of the runnable queues for each PE */
-/* In GranSim Light only the thread/spark-queues of proc 0 are used */
-P_ RunnableThreadsHd[MAX_PROC];
-P_ RunnableThreadsTl[MAX_PROC];
-
-P_ WaitThreadsHd[MAX_PROC];
-P_ WaitThreadsTl[MAX_PROC];
-
-sparkq PendingSparksHd[MAX_PROC][SPARK_POOLS];
-sparkq PendingSparksTl[MAX_PROC][SPARK_POOLS];
-
-/* One clock for each PE */
-W_ CurrentTime[MAX_PROC];
-
-/* Useful to restrict communication; cf fishing model in GUM */
-I_ OutstandingFetches[MAX_PROC], OutstandingFishes[MAX_PROC];
-
-/* Status of each PE (new since but independent of GranSim Light) */
-enum proc_status procStatus[MAX_PROC];
-
-#if defined(GRAN) && defined(GRAN_CHECK)
-/* To check if the RTS ever tries to run a thread that should be blocked
- because of fetching remote data */
-P_ BlockedOnFetch[MAX_PROC];
-#endif
-
-W_ SparksAvail = 0; /* How many sparks are available */
-W_ SurplusThreads = 0; /* How many excess threads are there */
-
-TIME SparkStealTime();
-
-# else /* !GRAN */
-
-P_ RunnableThreadsHd = PrelBase_Z91Z93_closure;
-P_ RunnableThreadsTl = PrelBase_Z91Z93_closure;
-
-P_ WaitingThreadsHd = PrelBase_Z91Z93_closure;
-P_ WaitingThreadsTl = PrelBase_Z91Z93_closure;
-
-TYPE_OF_SPARK PendingSparksBase[SPARK_POOLS];
-TYPE_OF_SPARK PendingSparksLim[SPARK_POOLS];
-
-TYPE_OF_SPARK PendingSparksHd[SPARK_POOLS];
-TYPE_OF_SPARK PendingSparksTl[SPARK_POOLS];
-
-#endif /* GRAN ; HWL */
-
-static jmp_buf scheduler_loop;
-#if defined(i386_TARGET_ARCH)
-void SchedLoop(int ret);
-extern StgInt entersFromC;
-static jmp_buf finish_sched;
-#endif
-
-I_ required_thread_count = 0;
-I_ advisory_thread_count = 0;
-
-EXTFUN(resumeThread);
-
-/* Misc prototypes */
-#if defined(GRAN)
-P_ NewThread PROTO((P_, W_, I_));
-I_ blockFetch PROTO((P_, PROC, P_));
-I_ HandleFetchRequest PROTO((P_, PROC, P_));
-rtsBool InsertThread PROTO((P_ tso));
-sparkq delete_from_spark_queue PROTO((sparkq, sparkq));
-sparkq prev, spark;
-#else
-P_ NewThread PROTO((P_, W_));
-#endif
-
-I_ context_switch = 0;
-I_ contextSwitchTime = 10000;
-
-I_ threadId = 0;
-
-/* NB: GRAN and GUM use different representations of spark pools.
- GRAN sparks are more flexible (containing e.g. granularity info)
- but slower than GUM sparks. There is no fixed upper bound on the
- number of GRAN sparks either. -- HWL
-*/
-#if defined(PAR)
-
-I_ sparksIgnored =0, sparksCreated = 0;
-
-#endif
-
-#if defined(CONCURRENT) && !defined(GRAN)
-I_ SparkLimit[SPARK_POOLS];
-
-rtsBool
-initThreadPools(STG_NO_ARGS)
-{
- I_ i, size = RTSflags.ConcFlags.maxLocalSparks;
-
- SparkLimit[ADVISORY_POOL] = SparkLimit[REQUIRED_POOL] = size;
-
- if ((PendingSparksBase[ADVISORY_POOL] = (TYPE_OF_SPARK) malloc(size * SIZE_OF_SPARK)) == NULL)
- return rtsFalse;
-
- if ((PendingSparksBase[REQUIRED_POOL] = (TYPE_OF_SPARK) malloc(size * SIZE_OF_SPARK)) == NULL)
- return rtsFalse;
- PendingSparksLim[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL] + size;
- PendingSparksLim[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL] + size;
- return rtsTrue;
-
-}
-#endif
-
-#ifdef PAR
-rtsBool sameThread;
-#endif
-
-void
-ScheduleThreads(topClosure)
-P_ topClosure;
-{
-#ifdef GRAN
- I_ i;
-#endif
- P_ tso;
-
-#if defined(PROFILING) || defined(PAR)
- if (time_profiling || RTSflags.ConcFlags.ctxtSwitchTime > 0) {
- if (initialize_virtual_timer(RTSflags.CcFlags.msecsPerTick)) {
-#else
- if (RTSflags.ConcFlags.ctxtSwitchTime > 0) {
- if (initialize_virtual_timer(RTSflags.ConcFlags.ctxtSwitchTime)) {
-#endif
- fflush(stdout);
- fprintf(stderr, "Can't initialize virtual timer.\n");
- EXIT(EXIT_FAILURE);
- }
- } else
- context_switch = 0 /* 1 HWL */;
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* HWL */
- if ( RTSflags.GranFlags.Light && RTSflags.GranFlags.proc!=1 ) {
- fprintf(stderr,"Qagh: In GrAnSim Light setup .proc must be 1\n");
- EXIT(EXIT_FAILURE);
- }
-
- if ( RTSflags.GranFlags.debug & 0x40 ) {
- fprintf(stderr,"Doing init in ScheduleThreads now ...\n");
- }
-# endif
-
-#if defined(GRAN) /* KH */
- /* Init thread and spark queues on all processors */
- for (i=0; i<RTSflags.GranFlags.proc; i++)
- {
- /* Init of RunnableThreads{Hd,Tl} etc now in main */
- OutstandingFetches[i] = OutstandingFishes[i] = 0;
- procStatus[i] = Idle;
-# if defined(GRAN_CHECK) && defined(GRAN) /* HWL */
- BlockedOnFetch[i] = NULL;
-# endif
- }
-
- CurrentProc = MainProc;
-#endif /* GRAN */
-
- if (DO_QP_PROF)
- init_qp_profiling();
- /*
- * We perform GC so that a signal handler can install a new
- * TopClosure and start a new main thread.
- */
-#ifdef PAR
- if (IAmMainThread) {
-#endif
-#if defined(GRAN)
- if ((tso = NewThread(topClosure, T_MAIN, MAIN_PRI)) == NULL) {
-#else
- if ((tso = NewThread(topClosure, T_MAIN)) == NULL) {
-#endif
- /* kludge to save the top closure as a root */
- CurrentTSO = topClosure;
- ReallyPerformThreadGC(0, rtsTrue);
- topClosure = CurrentTSO;
-#if defined(GRAN)
- if ((tso = NewThread(topClosure, T_MAIN, MAIN_PRI)) == NULL) {
-#else
- if ((tso = NewThread(topClosure, T_MAIN)) == NULL) {
-#endif
- fflush(stdout);
- fprintf(stderr, "Not enough heap for main thread\n");
- EXIT(EXIT_FAILURE);
- }
- }
-#if !defined(GRAN)
- RunnableThreadsHd = RunnableThreadsTl = tso;
-#else
- /* NB: CurrentProc must have been set to MainProc before that! -- HWL */
- ThreadQueueHd = ThreadQueueTl = tso;
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x40 ) {
- fprintf(stderr,"MainTSO has been initialized (0x%x)\n", tso);
- }
-# endif
-#endif /* GRAN */
-
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- DumpGranEvent(GR_START, tso);
- sameThread = rtsTrue;
- }
-#elif defined(GRAN)
- if (RTSflags.GranFlags.granSimStats && !RTSflags.GranFlags.labelling)
- DumpRawGranEvent(CurrentProc,(PROC)0,GR_START,
- tso,topClosure,0);
-#endif
-
-#if defined(GRAN)
- MAKE_BUSY(MainProc); /* Everything except the main PE is idle */
- if (RTSflags.GranFlags.Light)
- ActiveTSO = tso;
-#endif
-
- required_thread_count = 1;
- advisory_thread_count = 0;
-#ifdef PAR
- } /*if IAmMainThread ...*/
-#endif
-#if defined(i386_TARGET_ARCH)
- if (setjmp(finish_sched) < 0) {
- return;
- }
- SchedLoop(0);
-}
- /* ----------------------------------------------------------------- */
- /* This part is the MAIN SCHEDULER LOOP; jumped at from ReSchedule */
- /* ----------------------------------------------------------------- */
-
-void
-SchedLoop(ret)
-int ret;
-{
- P_ tso;
-
- if ( (ret <0) || ( (setjmp(scheduler_loop) < 0) )) {
- longjmp(finish_sched,-1);
- }
-#else
- if( (setjmp(scheduler_loop) < 0) ) {
- return;
- }
-#endif
-
-#if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x80 ) {
- fprintf(stderr,"MAIN Schedule Loop; ThreadQueueHd is ");
- G_TSO(ThreadQueueHd,1);
- /* if (ThreadQueueHd == MainTSO) {
- fprintf(stderr,"D> Event Queue is now:\n");
- GEQ();
- } */
- }
-#endif
-
-#ifdef PAR
- if (PendingFetches != PrelBase_Z91Z93_closure) {
- processFetches();
- }
-
-#elif defined(GRAN)
- if (ThreadQueueHd == PrelBase_Z91Z93_closure) {
- fprintf(stderr, "Qu'vatlh! No runnable threads!\n");
- EXIT(EXIT_FAILURE);
- }
- if (DO_QP_PROF > 1 && CurrentTSO != ThreadQueueHd) {
- QP_Event1("AG", ThreadQueueHd);
- }
-#else
- while (RunnableThreadsHd == PrelBase_Z91Z93_closure) {
- /* If we've no work */
- if (WaitingThreadsHd == PrelBase_Z91Z93_closure) {
- int exitc;
-
- exitc = NoRunnableThreadsHook();
- shutdownHaskell();
- EXIT(exitc);
- }
- /* Block indef. waiting for I/O and timer expire */
- AwaitEvent(0);
- }
-#endif
-
-#ifdef PAR
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure) {
- if (advisory_thread_count < RTSflags.ConcFlags.maxThreads &&
- (PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL] ||
- PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL])) {
- /*
- * If we're here (no runnable threads) and we have pending
- * sparks, we must have a space problem. Get enough space
- * to turn one of those pending sparks into a
- * thread... ReallyPerformGC doesn't return until the
- * space is available, so it may force global GC. ToDo:
- * Is this unnecessary here? Duplicated in ReSchedule()?
- * --JSM
- */
- ReallyPerformThreadGC(THREAD_SPACE_REQUIRED, rtsTrue);
- SAVE_Hp -= THREAD_SPACE_REQUIRED;
- } else {
- /*
- * We really have absolutely no work. Send out a fish
- * (there may be some out there already), and wait for
- * something to arrive. We clearly can't run any threads
- * until a SCHEDULE or RESUME arrives, and so that's what
- * we're hoping to see. (Of course, we still have to
- * respond to other types of messages.)
- */
- if (!fishing)
- sendFish(choosePE(), mytid, NEW_FISH_AGE, NEW_FISH_HISTORY,
- NEW_FISH_HUNGER);
-
- processMessages();
- }
- ReSchedule(0);
- } else if (PacketsWaiting()) { /* Look for incoming messages */
- processMessages();
- }
-#endif /* PAR */
-
-#if !defined(GRAN)
- if (DO_QP_PROF > 1 && CurrentTSO != RunnableThreadsHd) {
- QP_Event1("AG", RunnableThreadsHd);
-}
-#endif
-
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats && !sameThread)
- DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);
-#endif
-
-#if defined(GRAN)
- TimeOfNextEvent = get_time_of_next_event();
- CurrentTSO = ThreadQueueHd;
- if (RTSflags.GranFlags.Light) {
- /* Save time of `virt. proc' which was active since last getevent and
- restore time of `virt. proc' where CurrentTSO is living on. */
- if(RTSflags.GranFlags.DoFairSchedule)
- {
- if (RTSflags.GranFlags.granSimStats &&
- RTSflags.GranFlags.debug & 0x20000)
- DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
- }
- TSO_CLOCK(ActiveTSO) = CurrentTime[CurrentProc];
- ActiveTSO = NULL;
- CurrentTime[CurrentProc] = TSO_CLOCK(CurrentTSO);
- if(RTSflags.GranFlags.DoFairSchedule && resched )
- {
- resched = rtsFalse;
- if (RTSflags.GranFlags.granSimStats &&
- RTSflags.GranFlags.debug & 0x20000)
- DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
- }
- /*
- if (TSO_LINK(ThreadQueueHd)!=PrelBase_Z91Z93_closure &&
- (TimeOfNextEvent == 0 ||
- TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000<TimeOfNextEvent)) {
- new_event(CurrentProc,CurrentProc,TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000,
- CONTINUETHREAD,TSO_LINK(ThreadQueueHd),PrelBase_Z91Z93_closure,NULL);
- TimeOfNextEvent = get_time_of_next_event();
- }
- */
- }
- EndOfTimeSlice = CurrentTime[CurrentProc]+RTSflags.GranFlags.time_slice;
-#else /* !GRAN */
- CurrentTSO = RunnableThreadsHd;
- RunnableThreadsHd = TSO_LINK(RunnableThreadsHd);
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;
-
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure)
- RunnableThreadsTl = PrelBase_Z91Z93_closure;
-#endif
-
- /* If we're not running a timer, just leave the flag on */
- if (RTSflags.ConcFlags.ctxtSwitchTime > 0)
- context_switch = 0;
-
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (CurrentTSO == PrelBase_Z91Z93_closure) {
- fprintf(stderr,"Qagh: Trying to execute PrelBase_Z91Z93_closure on proc %d (@ %d)\n",
- CurrentProc,CurrentTime[CurrentProc]);
- EXIT(EXIT_FAILURE);
- }
-
- if (RTSflags.GranFlags.debug & 0x04) {
- if (BlockedOnFetch[CurrentProc]) {
- fprintf(stderr,"Qagh: Trying to execute TSO 0x%x on proc %d (@ %d) which is blocked-on-fetch by TSO 0x%x\n",
- CurrentTSO,CurrentProc,CurrentTime[CurrentProc],BlockedOnFetch[CurrentProc]);
- EXIT(EXIT_FAILURE);
- }
- }
-
- if ( (RTSflags.GranFlags.debug & 0x10) &&
- (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) ) {
- fprintf(stderr,"Qagh: Trying to execute TSO 0x%x on proc %d (@ %d) which should be asleep!\n",
- CurrentTSO,CurrentProc,CurrentTime[CurrentProc]);
- EXIT(EXIT_FAILURE);
- }
-#endif
-
-#if 0 && defined(i386_TARGET_ARCH)
- fprintf(stderr, "ScheduleThreads: About to resume thread:%#x %d\n",
- CurrentTSO, entersFromC);
-#endif
- miniInterpret((StgFunPtr)resumeThread);
-}
-\end{code}
-
-% Some remarks on GrAnSim -- HWL
-
-The ReSchedule fct is the heart of GrAnSim. Based on its parameter it issues
-a CONTINUETRHEAD to carry on executing the current thread in due course or it watches out for new work (e.g. called from EndThread).
-
-Then it picks the next event (get_next_event) and handles it appropriately
-(see switch construct). Note that a continue in the switch causes the next
-event to be handled and a break causes a jmp to the scheduler_loop where
-the TSO at the head of the current processor's runnable queue is executed.
-
-ReSchedule is mostly entered from HpOverflow.lc:PerformReSchedule which is
-itself called via the GRAN_RESCHEDULE macro in the compiler generated code.
-
-\begin{code}
-/*
- GrAnSim rules here! Others stay out or you will be crashed.
- Concurrent and parallel guys: please use the next door (a few pages down;
- turn left at the !GRAN sign).
-*/
-
-#if defined(GRAN)
-
-/* Prototypes of event handling functions. Only needed in ReSchedule */
-void do_the_globalblock PROTO((eventq event));
-void do_the_unblock PROTO((eventq event));
-void do_the_fetchnode PROTO((eventq event));
-void do_the_fetchreply PROTO((eventq event));
-void do_the_movethread PROTO((eventq event));
-void do_the_movespark PROTO((eventq event));
-void gimme_spark PROTO((rtsBool *found_res, sparkq *prev_res, sparkq *spark_res));
-void munch_spark PROTO((rtsBool found, sparkq prev, sparkq spark));
-
-void
-ReSchedule(what_next)
-int what_next; /* Run the current thread again? */
-{
- sparkq spark, nextspark;
- P_ tso;
- P_ node, closure;
- eventq event;
- int rc;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x80 ) {
- fprintf(stderr,"Entering ReSchedule with mode %u; tso is\n",what_next);
- G_TSO(ThreadQueueHd,1);
- }
-# endif
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( (RTSflags.GranFlags.debug & 0x80) || (RTSflags.GranFlags.debug & 0x40 ) )
- if (what_next<FIND_THREAD || what_next>END_OF_WORLD)
- fprintf(stderr,"Qagh {ReSchedule}Daq: illegal parameter %u for what_next\n",
- what_next);
-# endif
-
- if (RTSflags.GranFlags.Light) {
- /* Save current time; GranSim Light only */
- TSO_CLOCK(CurrentTSO) = CurrentTime[CurrentProc];
- }
-
- /* Run the current thread again (if there is one) */
- if(what_next==SAME_THREAD && ThreadQueueHd != PrelBase_Z91Z93_closure)
- {
- /* A bit of a hassle if the event queue is empty, but ... */
- CurrentTSO = ThreadQueueHd;
-
- resched = rtsFalse;
- if (RTSflags.GranFlags.Light &&
- TSO_LINK(ThreadQueueHd)!=PrelBase_Z91Z93_closure &&
- TSO_CLOCK(ThreadQueueHd)>TSO_CLOCK(TSO_LINK(ThreadQueueHd))) {
- if(RTSflags.GranFlags.granSimStats &&
- RTSflags.GranFlags.debug & 0x20000 )
- DumpGranEvent(GR_DESCHEDULE,ThreadQueueHd);
- resched = rtsTrue;
- ThreadQueueHd = TSO_LINK(CurrentTSO);
- if (ThreadQueueHd==PrelBase_Z91Z93_closure)
- ThreadQueueTl=PrelBase_Z91Z93_closure;
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;
- InsertThread(CurrentTSO);
- }
-
- /* This code does round-Robin, if preferred. */
- if(!RTSflags.GranFlags.Light &&
- RTSflags.GranFlags.DoFairSchedule &&
- TSO_LINK(CurrentTSO) != PrelBase_Z91Z93_closure &&
- CurrentTime[CurrentProc]>=EndOfTimeSlice)
- {
- ThreadQueueHd = TSO_LINK(CurrentTSO);
- TSO_LINK(ThreadQueueTl) = CurrentTSO;
- ThreadQueueTl = CurrentTSO;
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
- if ( RTSflags.GranFlags.granSimStats )
- DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
- CurrentTSO = ThreadQueueHd;
- }
-
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,CurrentTSO,PrelBase_Z91Z93_closure,NULL);
- }
- /* Schedule `next thread' which is at ThreadQueueHd now i.e. thread queue */
- /* has been updated before that already. */
- else if(what_next==NEW_THREAD && ThreadQueueHd != PrelBase_Z91Z93_closure)
- {
-# if defined(GRAN_CHECK) && defined(GRAN)
- fprintf(stderr,"Qagh: ReSchedule(NEW_THREAD) shouldn't be used with DoReScheduleOnFetch!!\n");
- EXIT(EXIT_FAILURE);
-
-# endif
-
- if(RTSflags.GranFlags.granSimStats &&
- (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
- DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
-
- CurrentTSO = ThreadQueueHd;
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,CurrentTSO,PrelBase_Z91Z93_closure,NULL);
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
- }
-
- /* We go in here if the current thread is blocked on fetch => don'd CONT */
- else if(what_next==CHANGE_THREAD)
- {
- /* just fall into event handling loop for next event */
- }
-
- /* We go in here if we have no runnable threads or what_next==0 */
- else
- {
- procStatus[CurrentProc] = Idle;
- /* That's now done in HandleIdlePEs!
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
- */
- CurrentTSO = PrelBase_Z91Z93_closure;
- }
-
- /* ----------------------------------------------------------------- */
- /* This part is the EVENT HANDLING LOOP */
- /* ----------------------------------------------------------------- */
-
- do {
- /* Choose the processor with the next event */
- event = get_next_event();
- CurrentProc = EVENT_PROC(event);
- CurrentTSO = EVENT_TSO(event);
- if (RTSflags.GranFlags.Light) {
- P_ tso;
- W_ tmp;
- /* Restore local clock of the virtual processor attached to CurrentTSO.
- All costs will be associated to the `virt. proc' on which the tso
- is living. */
- if (ActiveTSO != NULL) { /* already in system area */
- TSO_CLOCK(ActiveTSO) = CurrentTime[CurrentProc];
- if (RTSflags.GranFlags.DoFairSchedule)
- {
- if (RTSflags.GranFlags.granSimStats &&
- RTSflags.GranFlags.debug & 0x20000)
- DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
- }
- }
- switch (EVENT_TYPE(event))
- {
- case CONTINUETHREAD:
- case FINDWORK: /* inaccurate this way */
- ActiveTSO = ThreadQueueHd;
- break;
- case RESUMETHREAD:
- case STARTTHREAD:
- case MOVESPARK: /* has tso of virt proc in tso field of event */
- ActiveTSO = EVENT_TSO(event);
- break;
- default: fprintf(stderr,"Illegal event type %s (%d) in GrAnSim Light setup\n",
- event_names[EVENT_TYPE(event)],EVENT_TYPE(event));
- EXIT(EXIT_FAILURE);
- }
- CurrentTime[CurrentProc] = TSO_CLOCK(ActiveTSO);
- if(RTSflags.GranFlags.DoFairSchedule)
- {
- if (RTSflags.GranFlags.granSimStats &&
- RTSflags.GranFlags.debug & 0x20000)
- DumpGranEvent(GR_SYSTEM_START,ActiveTSO);
- }
- }
-
- if(EVENT_TIME(event) > CurrentTime[CurrentProc] &&
- EVENT_TYPE(event)!=CONTINUETHREAD)
- CurrentTime[CurrentProc] = EVENT_TIME(event);
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* HWL */
- if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
- fprintf(stderr,"Qagh {ReSchedule}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
- /* MAKE_BUSY(CurrentProc); don't think that's right in all cases now */
- /* -- HWL */
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GranFlags.debug & 0x80)
- fprintf(stderr,"After get_next_event, before HandleIdlePEs\n");
-# endif
-
- /* Deal with the idlers */
- if ( !RTSflags.GranFlags.Light )
- HandleIdlePEs();
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.event_trace_all ||
- ( RTSflags.GranFlags.event_trace && EVENT_TYPE(event) != CONTINUETHREAD) ||
- (RTSflags.GranFlags.debug & 0x80) )
- print_event(event);
-# endif
-
- switch (EVENT_TYPE(event))
- {
- /* Should just be continuing execution */
- case CONTINUETHREAD:
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( (RTSflags.GranFlags.debug & 0x100) &&
- (EVENT_TSO(event)!=RunnableThreadsHd[EVENT_PROC(event)]) ) {
- fprintf(stderr,"Warning: Wrong TSO in CONTINUETHREAD: %#lx (%x) (PE: %d Hd: 0x%lx)\n",
- EVENT_TSO(event), TSO_ID(EVENT_TSO(event)),
- EVENT_PROC(event),
- RunnableThreadsHd[EVENT_PROC(event)]);
- }
- if ( (RTSflags.GranFlags.debug & 0x04) &&
- BlockedOnFetch[CurrentProc]) {
- fprintf(stderr,"Warning: Discarding CONTINUETHREAD on blocked proc %u @ %u\n",
- CurrentProc,CurrentTime[CurrentProc]);
- print_event(event);
- continue;
- }
-# endif
- if(ThreadQueueHd==PrelBase_Z91Z93_closure)
- {
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
- continue; /* Catches superfluous CONTINUEs -- should be unnecessary */
- }
- else
- break; /* fall into scheduler loop */
-
- case FETCHNODE:
- do_the_fetchnode(event);
- continue; /* handle next event in event queue */
-
- case GLOBALBLOCK:
- do_the_globalblock(event);
- continue; /* handle next event in event queue */
-
- case FETCHREPLY:
- do_the_fetchreply(event);
- continue; /* handle next event in event queue */
-
- case UNBLOCKTHREAD: /* Move from the blocked queue to the tail of */
- do_the_unblock(event);
- continue; /* handle next event in event queue */
-
- case RESUMETHREAD: /* Move from the blocked queue to the tail of */
- /* the runnable queue ( i.e. Qu' SImqa'lu') */
- TSO_BLOCKTIME(EVENT_TSO(event)) += CurrentTime[CurrentProc] -
- TSO_BLOCKEDAT(EVENT_TSO(event));
- StartThread(event,GR_RESUME);
- continue;
-
- case STARTTHREAD:
- StartThread(event,GR_START);
- continue;
-
- case MOVETHREAD:
- do_the_movethread(event);
- continue; /* handle next event in event queue */
-
- case MOVESPARK:
- do_the_movespark(event);
- continue; /* handle next event in event queue */
-
- case FINDWORK:
- { /* Make sure that we have enough heap for creating a new
- thread. This is a conservative estimate of the required heap.
- This eliminates special checks for GC around NewThread within
- munch_spark. */
-
- I_ req_heap = TSO_HS + TSO_CTS_SIZE + STKO_HS +
- RTSflags.ConcFlags.stkChunkSize;
-
- if (SAVE_Hp + req_heap >= SAVE_HpLim ) {
- ReallyPerformThreadGC(req_heap, rtsFalse);
- SAVE_Hp -= req_heap;
- if (IS_SPARKING(CurrentProc))
- MAKE_IDLE(CurrentProc);
- continue;
- }
- }
-
- if( RTSflags.GranFlags.DoAlwaysCreateThreads ||
- (ThreadQueueHd == PrelBase_Z91Z93_closure &&
- (RTSflags.GranFlags.FetchStrategy >= 2 ||
- OutstandingFetches[CurrentProc] == 0)) )
- {
- rtsBool found;
- sparkq prev, spark;
-
- /* ToDo: check */
- ASSERT(procStatus[CurrentProc]==Sparking ||
- RTSflags.GranFlags.DoAlwaysCreateThreads);
-
- /* SImmoHwI' yInej! Search spark queue! */
- gimme_spark (&found, &prev, &spark);
-
- /* DaH chu' Qu' yIchen! Now create new work! */
- munch_spark (found, prev, spark);
-
- /* ToDo: check ; not valid if GC occurs in munch_spark
- ASSERT(procStatus[CurrentProc]==Starting ||
- procStatus[CurrentProc]==Idle ||
- RTSflags.GranFlags.DoAlwaysCreateThreads); */
- }
- continue; /* to the next event */
-
- default:
- fprintf(stderr,"Illegal event type %u\n",EVENT_TYPE(event));
- continue;
- } /* switch */
-#if defined(i386_TARGET_ARCH)
-
- if (entersFromC) {
- /* more than one thread has entered the Haskell world
- via C (and stable pointers) - don't squeeze the C stack. */
- SchedLoop(1);
- } else {
- /* Squeeze C stack */
- longjmp(scheduler_loop, 1);
- }
-#else
- longjmp(scheduler_loop, 1);
-#endif
- } while(1);
-}
-
-/* ----------------------------------------------------------------- */
-/* The main event handling functions; called from ReSchedule (switch) */
-/* ----------------------------------------------------------------- */
-
-void
-do_the_globalblock(eventq event)
-{
- PROC proc = EVENT_PROC(event); /* proc that requested node */
- P_ tso = EVENT_TSO(event), /* tso that requested node */
- node = EVENT_NODE(event); /* requested, remote node */
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh: There should be no GLOBALBLOCKs in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-
- if (!RTSflags.GranFlags.DoGUMMFetching) {
- fprintf(stderr,"Qagh: GLOBALBLOCK events only valid with GUMM fetching\n");
- EXIT(EXIT_FAILURE);
- }
-
- if ( (RTSflags.GranFlags.debug & 0x100) &&
- IS_LOCAL_TO(PROCS(node),proc) ) {
- fprintf(stderr,"Qagh: GLOBALBLOCK: Blocking on LOCAL node 0x %x (PE %d).\n",
- node,proc);
- }
-# endif
- /* CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime; */
- if ( blockFetch(tso,proc,node) != 0 )
- return; /* node has become local by now */
-
- if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* head of queue is next thread */
- P_ tso = RunnableThreadsHd[proc]; /* awaken next thread */
- if(tso != PrelBase_Z91Z93_closure) {
- new_event(proc,proc,CurrentTime[proc],
- CONTINUETHREAD,tso,PrelBase_Z91Z93_closure,NULL);
- CurrentTime[proc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
- if(RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(proc,CurrentProc,GR_SCHEDULE,tso,
- PrelBase_Z91Z93_closure,0);
- MAKE_BUSY(proc); /* might have been fetching */
- } else {
- MAKE_IDLE(proc); /* no work on proc now */
- }
- } else { /* RTSflags.GranFlags.DoReScheduleOnFetch i.e. block-on-fetch */
- /* other thread is already running */
- /* 'oH 'utbe' 'e' vIHar ; I think that's not needed -- HWL
- new_event(proc,proc,CurrentTime[proc],
- CONTINUETHREAD,EVENT_TSO(event),
- (RTSflags.GranFlags.DoGUMMFetching ? closure :
- EVENT_NODE(event)),NULL);
- */
- }
-}
-
-void
-do_the_unblock(eventq event)
-{
- PROC proc = EVENT_PROC(event), /* proc that requested node */
- creator = EVENT_CREATOR(event); /* proc that requested node */
- P_ tso = EVENT_TSO(event), /* tso that requested node */
- node = EVENT_NODE(event); /* requested, remote node */
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh: There should be no UNBLOCKs in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* block-on-fetch */
- /* We count block-on-fetch as normal block time */
- TSO_BLOCKTIME(tso) += CurrentTime[proc] - TSO_BLOCKEDAT(tso);
- /* No costs for contextswitch or thread queueing in this case */
- if(RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(proc,CurrentProc,GR_RESUME,tso, PrelBase_Z91Z93_closure,0);
- new_event(proc,proc,CurrentTime[proc],CONTINUETHREAD,tso,node,NULL);
- } else {
- /* Reschedule on fetch causes additional costs here: */
- /* Bring the TSO from the blocked queue into the threadq */
- new_event(proc,proc,CurrentTime[proc]+RTSflags.GranFlags.gran_threadqueuetime,
- RESUMETHREAD,tso,node,NULL);
- }
-}
-
-void
-do_the_fetchnode(eventq event)
-{
- I_ rc;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh: There should be no FETCHNODEs in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-
- if (RTSflags.GranFlags.SimplifiedFetch) {
- fprintf(stderr,"Qagh: FETCHNODE events not valid with simplified fetch\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
- do {
- rc = HandleFetchRequest(EVENT_NODE(event),
- EVENT_CREATOR(event),
- EVENT_TSO(event));
- if (rc == 4) { /* trigger GC */
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GcFlags.giveStats)
- fprintf(RTSflags.GcFlags.statsFile,"***** veQ boSwI' PackNearbyGraph(node %#lx, tso %#lx (%x))\n",
- EVENT_NODE(event), EVENT_TSO(event), TSO_ID(EVENT_TSO(event)));
-# endif
- prepend_event(event);
- ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GcFlags.giveStats) {
- fprintf(RTSflags.GcFlags.statsFile,"***** SAVE_Hp=%#lx, SAVE_HpLim=%#lx, PACK_HEAP_REQUIRED=%#lx\n",
- SAVE_Hp, SAVE_HpLim, PACK_HEAP_REQUIRED);
- fprintf(stderr,"***** No. of packets so far: %d (total size: %d)\n",
- tot_packets,tot_packet_size);
- }
-# endif
- event = grab_event();
- SAVE_Hp -= PACK_HEAP_REQUIRED;
-
- /* GC knows that events are special and follows the pointer i.e. */
- /* events are valid even if they moved. An EXIT is triggered */
- /* if there is not enough heap after GC. */
- }
- } while (rc == 4);
-}
-
-void
-do_the_fetchreply(eventq event)
-{
- P_ tso, closure;
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh: There should be no FETCHREPLYs in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-
- if (RTSflags.GranFlags.SimplifiedFetch) {
- fprintf(stderr,"Qagh: FETCHREPLY events not valid with simplified fetch\n");
- EXIT(EXIT_FAILURE);
- }
-
- if (RTSflags.GranFlags.debug & 0x10) {
- if (TSO_TYPE(EVENT_TSO(event)) & FETCH_MASK_TSO) {
- TSO_TYPE(EVENT_TSO(event)) &= ~FETCH_MASK_TSO;
- } else {
- fprintf(stderr,"Qagh: FETCHREPLY: TSO %#x (%x) has fetch mask not set @ %d\n",
- CurrentTSO,TSO_ID(CurrentTSO),CurrentTime[CurrentProc]);
- EXIT(EXIT_FAILURE);
- }
- }
-
- if (RTSflags.GranFlags.debug & 0x04) {
- if (BlockedOnFetch[CurrentProc]!=ThreadQueueHd) {
- fprintf(stderr,"Qagh: FETCHREPLY: Proc %d (with TSO %#x (%x)) not blocked-on-fetch by TSO %#lx (%x)\n",
- CurrentProc,CurrentTSO,TSO_ID(CurrentTSO),
- BlockedOnFetch[CurrentProc], TSO_ID(BlockedOnFetch[CurrentProc]));
- EXIT(EXIT_FAILURE);
- } else {
- BlockedOnFetch[CurrentProc] = 0; /*- rtsFalse; -*/
- }
- }
-# endif
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
-
- if (RTSflags.GranFlags.DoGUMMFetching) { /* bulk (packet) fetching */
- P_ buffer = EVENT_NODE(event);
- PROC p = EVENT_PROC(event);
- I_ size = buffer[PACK_SIZE_LOCN];
-
- tso = EVENT_TSO(event);
-
- /* NB: Fetch misses can't occur with GUMM fetching, as */
- /* updatable closure are turned into RBHs and therefore locked */
- /* for other processors that try to grab them. */
-
- closure = UnpackGraph(buffer);
- CurrentTime[CurrentProc] += size * RTSflags.GranFlags.gran_munpacktime;
- } else
- /* Copy or move node to CurrentProc */
- if (FetchNode(EVENT_NODE(event),
- EVENT_CREATOR(event),
- EVENT_PROC(event)) ) {
- /* Fetch has failed i.e. node has been grabbed by another PE */
- P_ node = EVENT_NODE(event), tso = EVENT_TSO(event);
- PROC p = where_is(node);
- TIME fetchtime;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GranFlags.PrintFetchMisses) {
- fprintf(stderr,"Fetch miss @ %lu: node %#lx is at proc %u (rather than proc %u)\n",
- CurrentTime[CurrentProc],node,p,EVENT_CREATOR(event));
- fetch_misses++;
- }
-# endif /* GRAN_CHECK */
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
-
- /* Count fetch again !? */
- ++TSO_FETCHCOUNT(tso);
- TSO_FETCHTIME(tso) += RTSflags.GranFlags.gran_fetchtime;
-
- fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p]) +
- RTSflags.GranFlags.gran_latency;
-
- /* Chase the grabbed node */
- new_event(p,CurrentProc,fetchtime,FETCHNODE,tso,node,NULL);
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (RTSflags.GranFlags.debug & 0x04)
- BlockedOnFetch[CurrentProc] = tso; /*-rtsTrue;-*/
-
- if (RTSflags.GranFlags.debug & 0x10)
- TSO_TYPE(tso) |= FETCH_MASK_TSO;
-# endif
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
-
- return; /* NB: no REPLy has been processed; tso still sleeping */
- }
-
- /* -- Qapla'! Fetch has been successful; node is here, now */
- ++TSO_FETCHCOUNT(EVENT_TSO(event));
- TSO_FETCHTIME(EVENT_TSO(event)) += RTSflags.GranFlags.gran_fetchtime;
-
- if (RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(CurrentProc,EVENT_CREATOR(event),GR_REPLY,
- EVENT_TSO(event),
- (RTSflags.GranFlags.DoGUMMFetching ?
- closure :
- EVENT_NODE(event)),
- 0);
-
- --OutstandingFetches[CurrentProc];
- ASSERT(OutstandingFetches[CurrentProc] >= 0);
-# if 0 && defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (OutstandingFetches[CurrentProc] < 0) {
- fprintf(stderr,"Qagh: OutstandingFetches of proc %u has become negative\n",CurrentProc);
- EXIT(EXIT_FAILURE);
- }
-# endif
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- UNBLOCKTHREAD,EVENT_TSO(event),
- (RTSflags.GranFlags.DoGUMMFetching ?
- closure :
- EVENT_NODE(event)),
- NULL);
-}
-
-void
-do_the_movethread(eventq event) {
- P_ tso = EVENT_TSO(event);
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( RTSflags.GranFlags.Light && CurrentProc!=1 ) {
- fprintf(stderr,"Qagh: There should be no MOVETHREADs in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
- if (!RTSflags.GranFlags.DoThreadMigration) {
- fprintf(stderr,"Qagh: MOVETHREAD events should never occur without -bM\n");
- EXIT(EXIT_FAILURE);
- }
- if (PROCS(tso)!=0) {
- fprintf(stderr,"Qagh: Moved thread has a bitmask of 0%o (proc %d); should be 0\n",
- PROCS(tso), where_is(tso));
- EXIT(EXIT_FAILURE);
- }
-# endif
- --OutstandingFishes[CurrentProc];
- ASSERT(OutstandingFishes[CurrentProc]>=0);
- SET_PROCS(tso,ThisPE);
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
- StartThread(event,GR_STOLEN);
-}
-
-void
-do_the_movespark(eventq event){
- sparkq spark = EVENT_SPARK(event);
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
-
- if (RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(CurrentProc,(PROC)0,SP_ACQUIRED,PrelBase_Z91Z93_closure,
- SPARK_NODE(spark),
- spark_queue_len(CurrentProc,ADVISORY_POOL));
-
-#if defined(GRAN) && defined(GRAN_CHECK)
- if (!SHOULD_SPARK(SPARK_NODE(spark)))
- withered_sparks++;
- /* Not adding the spark to the spark queue would be the right */
- /* thing here, but it also would be cheating, as this info can't be */
- /* available in a real system. -- HWL */
-#endif
- --OutstandingFishes[CurrentProc];
- ASSERT(OutstandingFishes[CurrentProc]>=0);
-
- add_to_spark_queue(spark);
-
- if (procStatus[CurrentProc]==Fishing)
- procStatus[CurrentProc] = Idle;
-
- /* add_to_spark_queue will increase the time of the current proc. */
- /* Just falling into FINDWORK is wrong as we might have other */
- /* events that are happening before that. Therefore, just create */
- /* a FINDWORK event and go back to main event handling loop. */
-
- /* Should we treat stolen sparks specially? Currently, we don't. */
-#if 0
- /* Now FINDWORK is created in HandleIdlePEs */
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
- sparking[CurrentProc]=rtsTrue;
-#endif
-}
-
-/* Search the spark queue of the CurrentProc for a spark that's worth
- turning into a thread */
-void
-gimme_spark (rtsBool *found_res, sparkq *prev_res, sparkq *spark_res)
-{
- P_ node;
- rtsBool found;
- sparkq spark_of_non_local_node = NULL, spark_of_non_local_node_prev = NULL,
- low_priority_spark = NULL, low_priority_spark_prev = NULL,
- spark = NULL, prev = NULL, tmp = NULL;
-
- /* Choose a spark from the local spark queue */
- spark = SparkQueueHd;
- found = rtsFalse;
-
- while (spark != NULL && !found)
- {
- node = SPARK_NODE(spark);
- if (!SHOULD_SPARK(node))
- {
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(CurrentProc,(PROC)0,SP_PRUNED,PrelBase_Z91Z93_closure,
- SPARK_NODE(spark),
- spark_queue_len(CurrentProc,ADVISORY_POOL));
-
- ASSERT(spark != NULL);
-
- --SparksAvail;
- spark = delete_from_spark_queue (prev,spark);
- }
- /* -- node should eventually be sparked */
- else if (RTSflags.GranFlags.PreferSparksOfLocalNodes &&
- !IS_LOCAL_TO(PROCS(node),CurrentProc))
- {
- /* Remember first low priority spark */
- if (spark_of_non_local_node==NULL) {
- spark_of_non_local_node_prev = prev;
- spark_of_non_local_node = spark;
- }
-
- if (SPARK_NEXT(spark)==NULL) {
- ASSERT(spark==SparkQueueTl); /* just for testing */
- prev = spark_of_non_local_node_prev;
- spark = spark_of_non_local_node;
- found = rtsTrue;
- break;
- }
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- /* Should never happen; just for testing */
- if (spark==SparkQueueTl) {
- fprintf(stderr,"ReSchedule: Last spark != SparkQueueTl\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
- prev = spark;
- spark = SPARK_NEXT(spark);
- --SparksAvail;
- }
- else if ( RTSflags.GranFlags.DoPrioritySparking ||
- (SPARK_GRAN_INFO(spark)>=RTSflags.GranFlags.SparkPriority2) )
- {
- found = rtsTrue;
- }
- else /* only used if SparkPriority2 is defined */
- {
- /* Remember first low priority spark */
- if (low_priority_spark==NULL) {
- low_priority_spark_prev = prev;
- low_priority_spark = spark;
- }
-
- if (SPARK_NEXT(spark)==NULL) {
- ASSERT(spark==SparkQueueTl); /* just for testing */
- prev = low_priority_spark_prev;
- spark = low_priority_spark;
- found = rtsTrue; /* take low pri spark => rc is 2 */
- break;
- }
-
- /* Should never happen; just for testing */
- if (spark==SparkQueueTl) {
- fprintf(stderr,"ReSchedule: Last spark != SparkQueueTl\n");
- EXIT(EXIT_FAILURE);
- break;
- }
- prev = spark;
- spark = SPARK_NEXT(spark);
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x40 ) {
- fprintf(stderr,"Ignoring spark of priority %u (SparkPriority=%u); node=0x%lx; name=%u\n",
- SPARK_GRAN_INFO(spark), RTSflags.GranFlags.SparkPriority,
- SPARK_NODE(spark), SPARK_NAME(spark));
- }
-# endif /* GRAN_CHECK */
- }
- } /* while (spark!=NULL && !found) */
-
- *spark_res = spark;
- *prev_res = prev;
- *found_res = found;
-}
-
-void
-munch_spark (rtsBool found, sparkq prev, sparkq spark)
-{
- P_ tso, node;
-
- /* We've found a node; now, create thread (DaH Qu' yIchen) */
- if (found)
- {
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( SPARK_GRAN_INFO(spark) < RTSflags.GranFlags.SparkPriority2 ) {
- tot_low_pri_sparks++;
- if ( RTSflags.GranFlags.debug & 0x40 ) {
- fprintf(stderr,"GRAN_TNG: No high priority spark available; low priority (%u) spark chosen: node=0x%lx; name=%u\n",
- SPARK_GRAN_INFO(spark),
- SPARK_NODE(spark), SPARK_NAME(spark));
- }
- }
-# endif
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcreatetime;
-
- node = SPARK_NODE(spark);
- if((tso = NewThread(node, T_REQUIRED, SPARK_GRAN_INFO(spark)))==NULL)
- {
- /* Some kind of backoff needed here in case there's too little heap */
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (RTSflags.GcFlags.giveStats)
- fprintf(RTSflags.GcFlags.statsFile,"***** vIS Qu' chen veQ boSwI'; spark=%#x, node=%#x; name=%u\n",
- /* (found==2 ? "no hi pri spark" : "hi pri spark"), */
- spark, node,SPARK_NAME(spark));
-# endif
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc]+1,
- FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
- ReallyPerformThreadGC(TSO_HS+TSO_CTS_SIZE,rtsFalse);
- SAVE_Hp -= TSO_HS+TSO_CTS_SIZE;
- spark = NULL;
- return; /* was: continue; */ /* to the next event, eventually */
- }
-
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(CurrentProc,(PROC)0,SP_USED,PrelBase_Z91Z93_closure,
- SPARK_NODE(spark),
- spark_queue_len(CurrentProc,ADVISORY_POOL));
-
- TSO_EXPORTED(tso) = SPARK_EXPORTED(spark);
- TSO_LOCKED(tso) = !SPARK_GLOBAL(spark);
- TSO_SPARKNAME(tso) = SPARK_NAME(spark);
-
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- STARTTHREAD,tso,node,NULL);
-
- procStatus[CurrentProc] = Starting;
-
- ASSERT(spark != NULL);
-
- spark = delete_from_spark_queue (prev, spark);
- }
- else /* !found */
- /* Make the PE idle if nothing sparked and we have no threads. */
- {
- if(ThreadQueueHd == PrelBase_Z91Z93_closure)
- {
- MAKE_IDLE(CurrentProc);
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( (RTSflags.GranFlags.debug & 0x80) )
- fprintf(stderr,"Warning in FINDWORK handling: No work found for PROC %u\n",CurrentProc);
-# endif /* GRAN_CHECK */
- }
-#if 0
- else
- /* ut'lu'Qo' ; Don't think that's necessary any more -- HWL
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,ThreadQueueHd,PrelBase_Z91Z93_closure,NULL);
- */
-#endif
- }
-
-}
-\end{code}
-
-Here follows the non-GRAN @ReSchedule@.
-
-\begin{code}
-#else /* !GRAN */
-
-/* If you are concurrent and maybe even parallel please use this door. */
-
-void
-ReSchedule(again)
-int again; /* Run the current thread again? */
-{
- P_ spark;
- PP_ sparkp;
- P_ tso;
-
-#ifdef PAR
- /*
- * In the parallel world, we do unfair scheduling for the moment.
- * Ultimately, this should all be merged with the more
- * sophisticated GrAnSim scheduling options. (Of course, some
- * provision should be made for *required* threads to make sure
- * that they don't starve, but for now we assume that no one is
- * running concurrent Haskell on a multi-processor platform.)
- */
-
- sameThread = again;
-
- if (again) {
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure)
- RunnableThreadsTl = CurrentTSO;
- TSO_LINK(CurrentTSO) = RunnableThreadsHd;
- RunnableThreadsHd = CurrentTSO;
- }
-
-#else
-
- /*
- * In the sequential world, we assume that the whole point of running
- * the threaded build is for concurrent Haskell, so we provide round-robin
- * scheduling.
- */
-
- if (again) {
- if(RunnableThreadsHd == PrelBase_Z91Z93_closure) {
- RunnableThreadsHd = CurrentTSO;
- } else {
- TSO_LINK(RunnableThreadsTl) = CurrentTSO;
- if (DO_QP_PROF > 1) {
- QP_Event1("GA", CurrentTSO);
- }
- }
- RunnableThreadsTl = CurrentTSO;
- }
-#endif
-
-#if 1
- /*
- * Debugging code, which is useful enough (and cheap enough) to compile
- * in all the time. This makes sure that we don't access saved registers,
- * etc. in threads which are supposed to be sleeping.
- */
- CurrentTSO = PrelBase_Z91Z93_closure;
- CurrentRegTable = NULL;
-#endif
-
- /* First the required sparks */
-
- for (sparkp = PendingSparksHd[REQUIRED_POOL];
- sparkp < PendingSparksTl[REQUIRED_POOL]; sparkp++) {
- spark = *sparkp;
- if (SHOULD_SPARK(spark)) {
- if ((tso = NewThread(spark, T_REQUIRED)) == NULL)
- break;
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure) {
- RunnableThreadsHd = tso;
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- DumpGranEvent(GR_START, tso);
- sameThread = rtsTrue;
- }
-#endif
- } else {
- TSO_LINK(RunnableThreadsTl) = tso;
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats)
- DumpGranEvent(GR_STARTQ, tso);
-#endif
- }
- RunnableThreadsTl = tso;
- } else {
- if (DO_QP_PROF)
- QP_Event0(threadId++, spark);
-#if 0
- /* ToDo: Fix log entries for pruned sparks in GUM -- HWL */
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpGranEvent(SP_PRUNED,threadId++);
- ^^^^^^^^ should be a TSO
-#endif
- }
- }
- PendingSparksHd[REQUIRED_POOL] = sparkp;
-
- /* Now, almost the same thing for advisory sparks */
-
- for (sparkp = PendingSparksHd[ADVISORY_POOL];
- sparkp < PendingSparksTl[ADVISORY_POOL]; sparkp++) {
- spark = *sparkp;
- if (SHOULD_SPARK(spark)) {
- if (
-#ifdef PAR
- /* In the parallel world, don't create advisory threads if we are
- * about to rerun the same thread, or already have runnable threads,
- * or the main thread has terminated */
- (RunnableThreadsHd != PrelBase_Z91Z93_closure ||
- (required_thread_count == 0 && IAmMainThread)) ||
-#endif
- advisory_thread_count == RTSflags.ConcFlags.maxThreads ||
- (tso = NewThread(spark, T_ADVISORY)) == NULL)
- break;
- advisory_thread_count++;
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure) {
- RunnableThreadsHd = tso;
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- DumpGranEvent(GR_START, tso);
- sameThread = rtsTrue;
- }
-#endif
- } else {
- TSO_LINK(RunnableThreadsTl) = tso;
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats)
- DumpGranEvent(GR_STARTQ, tso);
-#endif
- }
- RunnableThreadsTl = tso;
- } else {
- if (DO_QP_PROF)
- QP_Event0(threadId++, spark);
-#if 0
- /* ToDo: Fix log entries for pruned sparks in GUM -- HWL */
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpGranEvent(SP_PRUNED,threadId++);
- ^^^^^^^^ should be a TSO
-#endif
- }
- }
- PendingSparksHd[ADVISORY_POOL] = sparkp;
-
-#ifndef PAR
-# if defined(i386_TARGET_ARCH)
- if (entersFromC) { /* more than one thread has entered the Haskell world
- via C (and stable pointers) */
- /* Don't squeeze C stack */
- if (required_thread_count <= 0) {
- longjmp(scheduler_loop, -1);
- } else {
- SchedLoop(required_thread_count <= 0 ? -1 : 1);
- longjmp(scheduler_loop, -1);
- }
- } else {
- longjmp(scheduler_loop, required_thread_count == 0 ? -1 : 1);
- }
-# else
- longjmp(scheduler_loop, required_thread_count == 0 ? -1 : 1);
-# endif
-#else
- longjmp(scheduler_loop, required_thread_count == 0 && IAmMainThread ? -1 : 1);
-#endif
-}
-
-#endif /* !GRAN */
-
-\end{code}
-
-%****************************************************************************
-%
-\subsection[thread-gransim-execution]{Starting, Idling and Migrating
- Threads (GrAnSim only)}
-%
-%****************************************************************************
-
-Thread start, idle and migration code for GrAnSim (i.e. simulating multiple
-processors).
-
-\begin{code}
-#if defined(GRAN)
-
-/* ngoqvam che' {GrAnSim}! */
-
-# if defined(GRAN_CHECK)
-/* This routine is only used for keeping a statistics of thread queue
- lengths to evaluate the impact of priority scheduling. -- HWL
- {spark_queue_len}vo' jInIHta'
-*/
-I_
-thread_queue_len(PROC proc)
-{
- P_ prev, next;
- I_ len;
-
- for (len = 0, prev = PrelBase_Z91Z93_closure, next = RunnableThreadsHd[proc];
- next != PrelBase_Z91Z93_closure;
- len++, prev = next, next = TSO_LINK(prev))
- {}
-
- return (len);
-}
-# endif /* GRAN_CHECK */
-\end{code}
-
-A large portion of @StartThread@ deals with maintaining a sorted thread
-queue, which is needed for the Priority Sparking option. Without that
-complication the code boils down to FIFO handling.
-
-\begin{code}
-StartThread(event,event_type)
-eventq event;
-enum gran_event_types event_type;
-{
- P_ tso = EVENT_TSO(event),
- node = EVENT_NODE(event);
- PROC proc = EVENT_PROC(event),
- creator = EVENT_CREATOR(event);
- P_ prev, next;
- I_ count = 0;
- rtsBool found = rtsFalse;
-
- ASSERT(CurrentProc==proc);
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
- fprintf(stderr,"Qagh {StartThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-
- /* A wee bit of statistics gathering */
- ++tot_add_threads;
- tot_tq_len += thread_queue_len(CurrentProc);
-# endif
-
- ASSERT(TSO_LINK(CurrentTSO)==PrelBase_Z91Z93_closure);
-
- /* Idle proc; same for pri spark and basic version */
- if(ThreadQueueHd==PrelBase_Z91Z93_closure)
- {
- CurrentTSO = ThreadQueueHd = ThreadQueueTl = tso;
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadqueuetime;
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,tso,PrelBase_Z91Z93_closure,NULL);
-
- if(RTSflags.GranFlags.granSimStats &&
- !( (event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
- DumpRawGranEvent(CurrentProc,creator,event_type,
- tso,node,
- TSO_SPARKNAME(tso));
- /* ^^^ SN (spark name) as optional info */
- /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
- /* ^^^ spark length as optional info */
-
- ASSERT(IS_IDLE(CurrentProc) || event_type==GR_RESUME ||
- (procStatus[CurrentProc]==Fishing && event_type==GR_STOLEN) ||
- procStatus[CurrentProc]==Starting);
- MAKE_BUSY(CurrentProc);
- return;
- }
-
- /* In GrAnSim-Light we always have an idle `virtual' proc.
- The semantics of the one-and-only thread queue is different here:
- all threads in the queue are running (each on its own virtual processor);
- the queue is only needed internally in the simulator to interleave the
- reductions of the different processors.
- The one-and-only thread queue is sorted by the local clocks of the TSOs.
- */
- if(RTSflags.GranFlags.Light)
- {
- ASSERT(ThreadQueueHd!=PrelBase_Z91Z93_closure);
- ASSERT(TSO_LINK(tso)==PrelBase_Z91Z93_closure);
-
- /* If only one thread in queue so far we emit DESCHEDULE in debug mode */
- if(RTSflags.GranFlags.granSimStats &&
- (RTSflags.GranFlags.debug & 0x20000) &&
- TSO_LINK(ThreadQueueHd)==PrelBase_Z91Z93_closure) {
- DumpRawGranEvent(CurrentProc,CurrentProc,GR_DESCHEDULE,
- ThreadQueueHd,PrelBase_Z91Z93_closure,0);
- resched = rtsTrue;
- }
-
- if ( InsertThread(tso) ) { /* new head of queue */
- new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,tso,PrelBase_Z91Z93_closure,NULL);
-
- }
- if(RTSflags.GranFlags.granSimStats &&
- !(( event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
- DumpRawGranEvent(CurrentProc,creator,event_type,
- tso,node,
- TSO_SPARKNAME(tso));
- /* ^^^ SN (spark name) as optional info */
- /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
- /* ^^^ spark length as optional info */
-
- /* MAKE_BUSY(CurrentProc); */
- return;
- }
-
- /* Only for Pri Sparking */
- if (RTSflags.GranFlags.DoPriorityScheduling && TSO_PRI(tso)!=0)
- /* {add_to_spark_queue}vo' jInIHta'; Qu' wa'DIch yIleghQo' */
- for (prev = ThreadQueueHd, next = TSO_LINK(ThreadQueueHd), count=0;
- (next != PrelBase_Z91Z93_closure) &&
- !(found = (TSO_PRI(tso) >= TSO_PRI(next)));
- prev = next, next = TSO_LINK(next), count++)
- {}
-
-
- ASSERT(!IS_IDLE(CurrentProc));
-
- /* found can only be rtsTrue if pri sparking enabled */
- if (found) {
-# if defined(GRAN_CHECK)
- ++non_end_add_threads;
-# endif
- /* Add tso to ThreadQueue between prev and next */
- TSO_LINK(tso) = next;
- if ( next == PrelBase_Z91Z93_closure ) {
- ThreadQueueTl = tso;
- } else {
- /* no back link for TSO chain */
- }
-
- if ( prev == PrelBase_Z91Z93_closure ) {
- /* Never add TSO as first elem of thread queue; the first */
- /* element should be the one that is currently running -- HWL */
-# if defined(GRAN_CHECK)
- fprintf(stderr,"Qagh: NewThread (w/ PriorityScheduling): Trying to add TSO %#lx (PRI=%d) as first elem of threadQ (%#lx) on proc %u (@ %u)\n",
- tso, TSO_PRI(tso), ThreadQueueHd, CurrentProc,
- CurrentTime[CurrentProc]);
-# endif
- } else {
- TSO_LINK(prev) = tso;
- }
- } else { /* !found */ /* or not pri sparking! */
- /* Add TSO to the end of the thread queue on that processor */
- TSO_LINK(ThreadQueueTl) = EVENT_TSO(event);
- ThreadQueueTl = EVENT_TSO(event);
- }
- CurrentTime[CurrentProc] += count *
- RTSflags.GranFlags.gran_pri_sched_overhead +
- RTSflags.GranFlags.gran_threadqueuetime;
-
- if(RTSflags.GranFlags.DoThreadMigration)
- ++SurplusThreads;
-
- if(RTSflags.GranFlags.granSimStats &&
- !(( event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
- DumpRawGranEvent(CurrentProc,creator,event_type+1,
- tso,node,
- TSO_SPARKNAME(tso));
- /* ^^^ SN (spark name) as optional info */
- /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
- /* ^^^ spark length as optional info */
-
-# if defined(GRAN_CHECK)
- /* Check if thread queue is sorted. Only for testing, really! HWL */
- if ( RTSflags.GranFlags.DoPriorityScheduling && (RTSflags.GranFlags.debug & 0x400) ) {
- rtsBool sorted = rtsTrue;
- P_ prev, next;
-
- if (ThreadQueueHd==PrelBase_Z91Z93_closure || TSO_LINK(ThreadQueueHd)==PrelBase_Z91Z93_closure) {
- /* just 1 elem => ok */
- } else {
- /* Qu' wa'DIch yIleghQo' (ignore first elem)! */
- for (prev = TSO_LINK(ThreadQueueHd), next = TSO_LINK(prev);
- (next != PrelBase_Z91Z93_closure) ;
- prev = next, next = TSO_LINK(prev)) {
- sorted = sorted &&
- (TSO_PRI(prev) >= TSO_PRI(next));
- }
- }
- if (!sorted) {
- fprintf(stderr,"Qagh: THREADQ on PE %d is not sorted:\n",
- CurrentProc);
- G_THREADQ(ThreadQueueHd,0x1);
- }
- }
-# endif
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadqueuetime;
-}
-\end{code}
-
-@InsertThread@, which is only used for GranSim Light, is similar to
-@StartThread@ in that it adds a TSO to a thread queue. However, it assumes
-that the thread queue is sorted by local clocks and it inserts the TSO at the
-right place in the queue. Don't create any event, just insert.
-
-\begin{code}
-rtsBool
-InsertThread(tso)
-P_ tso;
-{
- P_ prev, next;
- I_ count = 0;
- rtsBool found = rtsFalse;
-
-# if defined(GRAN_CHECK)
- if ( !RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh {InsertThread}Daq: InsertThread should only be used in a GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-
- if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
- fprintf(stderr,"Qagh {StartThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- /* Idle proc; same for pri spark and basic version */
- if(ThreadQueueHd==PrelBase_Z91Z93_closure)
- {
- ThreadQueueHd = ThreadQueueTl = tso;
- /* MAKE_BUSY(CurrentProc); */
- return (rtsTrue);
- }
-
- for (prev = ThreadQueueHd, next = TSO_LINK(ThreadQueueHd), count=0;
- (next != PrelBase_Z91Z93_closure) &&
- !(found = (TSO_CLOCK(tso) < TSO_CLOCK(next)));
- prev = next, next = TSO_LINK(next), count++)
- {}
-
- /* found can only be rtsTrue if pri sparking enabled */
- if (found) {
- /* Add tso to ThreadQueue between prev and next */
- TSO_LINK(tso) = next;
- if ( next == PrelBase_Z91Z93_closure ) {
- ThreadQueueTl = tso;
- } else {
- /* no back link for TSO chain */
- }
-
- if ( prev == PrelBase_Z91Z93_closure ) {
- ThreadQueueHd = tso;
- } else {
- TSO_LINK(prev) = tso;
- }
- } else { /* !found */ /* or not pri sparking! */
- /* Add TSO to the end of the thread queue on that processor */
- TSO_LINK(ThreadQueueTl) = tso;
- ThreadQueueTl = tso;
- }
- return (prev == PrelBase_Z91Z93_closure);
-}
-
-\end{code}
-
-Export work to idle PEs. This function is called from @ReSchedule@ before
- dispatching on the current event. @HandleIdlePEs@ iterates over all PEs,
-trying to get work for idle PEs. Note, that this is a simplification
-compared to GUM's fishing model. We try to compensate for that by making
-the cost for stealing work dependent on the number of idle processors and
-thereby on the probability with which a randomly sent fish would find work.
-
-\begin{code}
-HandleIdlePEs()
-{
- PROC proc;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh {HandleIdlePEs}Daq: Should never be entered in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- if(ANY_IDLE)
- for(proc = 0; proc < RTSflags.GranFlags.proc; proc++)
- if(IS_IDLE(proc)) /* && IS_SPARKING(proc) && IS_STARTING(proc) */
- /* First look for local work! */
- if (PendingSparksHd[proc][ADVISORY_POOL]!=NULL)
- {
- new_event(proc,proc,CurrentTime[proc],
- FINDWORK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,NULL);
- MAKE_SPARKING(proc);
- }
- /* Then try to get remote work! */
- else if ((RTSflags.GranFlags.max_fishes==0 ||
- OutstandingFishes[proc]<RTSflags.GranFlags.max_fishes) )
-
- {
- if(RTSflags.GranFlags.DoStealThreadsFirst &&
- (RTSflags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[proc] == 0))
- {
- if (SurplusThreads > 0l) /* Steal a thread */
- StealThread(proc);
-
- if(!IS_IDLE(proc))
- break;
- }
-
- if(SparksAvail > 0l &&
- (RTSflags.GranFlags.FetchStrategy >= 3 || OutstandingFetches[proc] == 0)) /* Steal a spark */
- StealSpark(proc);
-
- if (SurplusThreads > 0l &&
- (RTSflags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[proc] == 0)) /* Steal a thread */
- StealThread(proc);
- }
-}
-\end{code}
-
-Steal a spark and schedule moving it to proc. We want to look at PEs in
-clock order -- most retarded first. Currently sparks are only stolen from
-the @ADVISORY_POOL@ never from the @REQUIRED_POOL@. Eventually, this should
-be changed to first steal from the former then from the latter.
-
-We model a sort of fishing mechanism by counting the number of sparks and
-threads we are currently stealing.
-
-\begin{code}
-StealSpark(proc)
-PROC proc;
-{
- PROC p;
- sparkq spark, prev, next;
- rtsBool stolen = rtsFalse;
- TIME times[MAX_PROC], stealtime;
- unsigned ntimes=0, i, j;
- int first_later, upb, r;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh {StealSpark}Daq: Should never be entered in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- /* times shall contain processors from which we may steal sparks */
- for(p=0; p < RTSflags.GranFlags.proc; ++p)
- if(proc != p &&
- PendingSparksHd[p][ADVISORY_POOL] != NULL &&
- CurrentTime[p] <= CurrentTime[CurrentProc])
- times[ntimes++] = p;
-
- /* sort times */
- for(i=0; i < ntimes; ++i)
- for(j=i+1; j < ntimes; ++j)
- if(CurrentTime[times[i]] > CurrentTime[times[j]])
- {
- unsigned temp = times[i];
- times[i] = times[j];
- times[j] = temp;
- }
-
- /* Choose random processor to steal spark from; first look at processors */
- /* that are earlier than the current one (i.e. proc) */
-
- for(first_later=0;
- (first_later < ntimes) && (CurrentTime[times[first_later]] < CurrentTime[proc]);
- ++first_later)
- /* nothing */ ;
-
- while (!stolen && (ntimes>0)) {
- long unsigned int r, q=0;
-
- upb = (first_later==0) ? ntimes : first_later;
-
- if (RTSflags.GranFlags.RandomSteal) {
- r = lrand48(); /* [0, RAND_MAX] */
- } else {
- r = 0;
- }
- /* -- ASSERT(r<=RAND_MAX); */
- i = (unsigned int) (r % upb); /* [0, upb) */
- /* -- ASSERT((i>=0) && (i<=upb)); */
- p = times[i];
- /* -- ASSERT((p>=0) && (p<MAX_PROC)); */
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x2000 )
- fprintf(stderr,"RANDOM_STEAL: [index %u of %u] from %u (@ %lu) to %u (@ %lu) (q=%d) [rand value: %lu]\n",
- i, ntimes, p, CurrentTime[p], proc, CurrentTime[proc], q, r);
-# endif
-
- /* Now go through sparkq and steal the first one that should be sparked*/
- for(prev=NULL, spark = PendingSparksHd[p][ADVISORY_POOL];
- spark != NULL && !stolen;
- spark=next)
- {
- next = SPARK_NEXT(spark);
-
- if ((IS_IDLE(p) || procStatus[p]==Sparking || procStatus[p]==Fishing) &&
- SPARK_NEXT(spark)==NULL)
- {
- /* Be social! Don't steal the only spark of an idle processor */
- break;
- }
- else if(SHOULD_SPARK(SPARK_NODE(spark)))
- {
- /* Don't Steal local sparks */
- if(!SPARK_GLOBAL(spark))
- {
- prev=spark;
- continue;
- }
-
- /* Prepare message for sending spark */
- CurrentTime[p] += RTSflags.GranFlags.gran_mpacktime;
-
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(p,(PROC)0,SP_EXPORTED,PrelBase_Z91Z93_closure,
- SPARK_NODE(spark),
- spark_queue_len(p,ADVISORY_POOL));
-
- SPARK_NEXT(spark) = NULL;
-
- stealtime = (CurrentTime[p] > CurrentTime[proc] ?
- CurrentTime[p] :
- CurrentTime[proc])
- + SparkStealTime();
-
-
- new_event(proc,p /* CurrentProc */,stealtime,
- MOVESPARK,PrelBase_Z91Z93_closure,PrelBase_Z91Z93_closure,spark);
-
- /* MAKE_BUSY(proc); not yet; busy when TSO in threadq */
- stolen = rtsTrue;
- ++OutstandingFishes[proc];
- if (IS_IDLE(proc))
- MAKE_FISHING(proc);
- ++SPARK_GLOBAL(spark);
- --SparksAvail;
-
- CurrentTime[p] += RTSflags.GranFlags.gran_mtidytime;
- }
- else /* !(SHOULD_SPARK(SPARK_NODE(spark))) */
- {
- if(RTSflags.GranFlags.granSimStats_Sparks)
- DumpRawGranEvent(p,(PROC)0,SP_PRUNED,PrelBase_Z91Z93_closure,
- SPARK_NODE(spark),
- spark_queue_len(p,ADVISORY_POOL));
- --SparksAvail;
- DisposeSpark(spark);
- }
-
- if(spark == PendingSparksHd[p][ADVISORY_POOL])
- PendingSparksHd[p][ADVISORY_POOL] = next;
-
- if(prev!=NULL)
- SPARK_NEXT(prev) = next;
- } /* for (spark=... iterating over sparkq */
-
- if(PendingSparksHd[p][ADVISORY_POOL] == NULL)
- PendingSparksTl[p][ADVISORY_POOL] = NULL;
-
- if (!stolen && (ntimes>0)) { /* nothing stealable from proc p :( */
- ASSERT(times[i]==p);
-
- /* remove p from the list (at pos i) */
- for (j=i; j+1<ntimes; j++)
- times[j] = times[j+1];
- ntimes--;
-
- /* update index to first proc which is later (or equal) than proc */
- for ( ;
- (first_later>0) &&
- (CurrentTime[times[first_later-1]]>CurrentTime[proc]);
- first_later--)
- /* nothing */ ;
- }
- } /* while */
-# if defined(GRAN_CHECK)
- if (stolen && (i!=0)) { /* only for statistics */
- rs_sp_count++;
- ntimes_total += ntimes;
- fl_total += first_later;
- no_of_steals++;
- }
-# endif
-}
-\end{code}
-
-Steal a spark and schedule moving it to proc.
-
-\begin{code}
-StealThread(proc)
-PROC proc;
-{
- PROC p;
- rtsBool found;
- P_ thread, prev;
- TIME times[MAX_PROC], stealtime;
- unsigned ntimes=0, i, j;
- int first_later, upb, r;
-
- /* Hunt for a thread */
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh {StealThread}: Should never be entered in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- /* times shall contain processors from which we may steal threads */
- for(p=0; p < RTSflags.GranFlags.proc; ++p)
- if(proc != p && RunnableThreadsHd[p] != PrelBase_Z91Z93_closure &&
- CurrentTime[p] <= CurrentTime[CurrentProc])
- times[ntimes++] = p;
-
- /* sort times */
- for(i=0; i < ntimes; ++i)
- for(j=i+1; j < ntimes; ++j)
- if(CurrentTime[times[i]] > CurrentTime[times[j]])
- {
- unsigned temp = times[i];
- times[i] = times[j];
- times[j] = temp;
- }
-
- /* Choose random processor to steal spark from; first look at processors */
- /* that are earlier than the current one (i.e. proc) */
-
- for(first_later=0;
- (first_later < ntimes) && (CurrentTime[times[first_later]] < CurrentTime[proc]);
- ++first_later)
- /* nothing */ ;
-
- while (!found && (ntimes>0)) {
- long unsigned int r, q=0;
-
- upb = (first_later==0) ? ntimes : first_later;
-
- if (RTSflags.GranFlags.RandomSteal) {
- r = lrand48(); /* [0, RAND_MAX] */
- } else {
- r = 0;
- }
- /* -- ASSERT(r<=RAND_MAX); */
- if ( RTSflags.GranFlags.debug & 0x2000 )
- fprintf(stderr,"rand value: %d " , r);
- i = (unsigned int) (r % upb); /* [0, upb] */
- /* -- ASSERT((i>=0) && (i<=upb)); */
- p = times[i];
- /* -- ASSERT((p>=0) && (p<MAX_PROC)); */
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x2000 )
- fprintf(stderr,"RANDOM_STEAL; [index %u] from %u (@ %lu) to %u (@ %lu) (q=%d)\n",
- i, p, CurrentTime[p], proc, CurrentTime[proc], q);
-# endif
-
- /* Steal the first exportable thread in the runnable queue after the */
- /* first one */
-
- if(RunnableThreadsHd[p] != PrelBase_Z91Z93_closure)
- {
- for(prev = RunnableThreadsHd[p], thread = TSO_LINK(RunnableThreadsHd[p]);
- thread != PrelBase_Z91Z93_closure && TSO_LOCKED(thread);
- prev = thread, thread = TSO_LINK(thread))
- /* SKIP */;
-
- if(thread != PrelBase_Z91Z93_closure) /* Take thread out of runnable queue */
- {
- TSO_LINK(prev) = TSO_LINK(thread);
-
- TSO_LINK(thread) = PrelBase_Z91Z93_closure;
-
- if(RunnableThreadsTl[p] == thread)
- RunnableThreadsTl[p] = prev;
-
- /* Turn magic constants into params !? -- HWL */
-
- CurrentTime[p] += 5l * RTSflags.GranFlags.gran_mpacktime;
-
- stealtime = (CurrentTime[p] > CurrentTime[proc] ?
- CurrentTime[p] :
- CurrentTime[proc])
- + SparkStealTime()
- + 4l * RTSflags.GranFlags.gran_additional_latency
- + 5l * RTSflags.GranFlags.gran_munpacktime;
-
- /* Move the thread; set bitmask to 0 while TSO is `on-the-fly' */
- SET_PROCS(thread,Nowhere /* PE_NUMBER(proc) */);
-
- /* Move from one queue to another */
- new_event(proc,p,stealtime,MOVETHREAD,thread,PrelBase_Z91Z93_closure,NULL);
- /* MAKE_BUSY(proc); not yet; only when thread is in threadq */
- ++OutstandingFishes[proc];
- if (IS_IDLE(proc))
- MAKE_FISHING(proc);
- --SurplusThreads;
-
- if(RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(p,proc,GR_STEALING,thread,
- PrelBase_Z91Z93_closure,0);
-
- CurrentTime[p] += 5l * RTSflags.GranFlags.gran_mtidytime;
-
- /* Found one */
- found = rtsTrue;
- /* break; */
- }
- }
-
- if (!found && (ntimes>0)) { /* nothing stealable from proc p */
- ASSERT(times[i]==p);
-
- /* remove p from the list (at pos i) */
- for (j=i; j+1<ntimes; j++)
- times[j] = times[j+1];
- ntimes--;
- }
- } /* while */
-# if defined(GRAN_CHECK) && defined(GRAN)
- if (found && (i!=0)) { /* only for statistics */
- rs_t_count++;
- }
-# endif
-}
-
-TIME
-SparkStealTime(void)
-{
- double fishdelay, sparkdelay, latencydelay;
- fishdelay = (double)RTSflags.GranFlags.proc/2;
- sparkdelay = fishdelay -
- ((fishdelay-1)/(double)(RTSflags.GranFlags.proc-1))*(double)idlers();
- latencydelay = sparkdelay*((double)RTSflags.GranFlags.gran_latency);
-
- return((TIME)latencydelay);
-}
-#endif /* GRAN ; HWL */
-
-\end{code}
-
-
-%****************************************************************************
-%
-\subsection[thread-execution]{Executing Threads}
-%
-%****************************************************************************
-
-First a set of functions for handling sparks and spark-queues that are
-attached to the processors. Currently, there are two spark-queues per
-processor:
-
-\begin{itemize}
-\item A queue of @REQUIRED@ sparks i.e. these sparks will be definitely
- turned into threads ({\em non-discardable\/}). They are mainly used in concurrent
- Haskell. We don't use them in GrAnSim.
-\item A queue of @ADVISORY@ sparks i.e. they may be turned into threads if
- the RTS thinks that it is a good idea. However, these sparks are {\em
- discardable}. They will be discarded if the associated closure is
- generally not worth creating a new thread (indicated by a tag in the
- closure) or they may be pruned during GC if there are too many sparks
- around already.
-\end{itemize}
-
-\begin{code}
-EXTDATA_RO(StkO_info);
-EXTDATA_RO(TSO_info);
-EXTDATA_RO(realWorldZh_closure);
-
-EXTFUN(EnterNodeCode);
-UNVEC(EXTFUN(stopThreadDirectReturn);,EXTDATA(vtbl_stopStgWorld);)
-
-#if defined(GRAN)
-/* ngoqvam che' {GrAnSim} */
-
-/* Slow but relatively reliable method uses stgMallocBytes */
-/* Eventually change that to heap allocated sparks. */
-
-/* -------------------------------------------------------------------------
- This is the main point where handling granularity information comes into
- play.
- ------------------------------------------------------------------------- */
-
-#define MAX_RAND_PRI 100
-
-/*
- Granularity info transformers.
- Applied to the GRAN_INFO field of a spark.
-*/
-static I_ ID(I_ x) { return(x); };
-static I_ INV(I_ x) { return(-x); };
-static I_ IGNORE(I_ x) { return (0); };
-static I_ RAND(I_ x) { return ((lrand48() % MAX_RAND_PRI) + 1); }
-
-/* NB: size_info and par_info are currently unused (what a shame!) -- HWL */
-
-sparkq
-NewSpark(node,name,gran_info,size_info,par_info,local)
-P_ node;
-I_ name, gran_info, size_info, par_info, local;
-{
- I_ pri;
- sparkq newspark;
-
- pri = RTSflags.GranFlags.RandomPriorities ? RAND(gran_info) :
- RTSflags.GranFlags.InversePriorities ? INV(gran_info) :
- RTSflags.GranFlags.IgnorePriorities ? IGNORE(gran_info) :
- gran_info;
-
- if ( RTSflags.GranFlags.SparkPriority!=0 && pri<RTSflags.GranFlags.SparkPriority ) {
- if ( RTSflags.GranFlags.debug & 0x40 ) {
- fprintf(stderr,"NewSpark: Ignoring spark of priority %u (SparkPriority=%u); node=0x%lx; name=%u\n",
- pri, RTSflags.GranFlags.SparkPriority, node, name);
- }
- return ((sparkq)NULL);
- }
-
- newspark = (sparkq) stgMallocBytes(sizeof(struct spark), "NewSpark");
- SPARK_PREV(newspark) = SPARK_NEXT(newspark) = NULL;
- SPARK_NODE(newspark) = node;
- SPARK_NAME(newspark) = (name==1) ? TSO_SPARKNAME(CurrentTSO) : name;
- SPARK_GRAN_INFO(newspark) = pri;
- SPARK_GLOBAL(newspark) = !local; /* Check that with parAt, parAtAbs !!*/
- return(newspark);
-}
-
-/* To make casm more convenient use this function to label strategies */
-int
-set_sparkname(P_ tso, int name) {
- TSO_SPARKNAME(tso) = name ;
-
- if(0 && RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(CurrentProc,99,GR_START,
- tso,PrelBase_Z91Z93_closure,
- TSO_SPARKNAME(tso));
- /* ^^^ SN (spark name) as optional info */
- /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
- /* ^^^ spark length as optional info */
-
- return(0); }
-
-int
-reset_sparkname(P_ tso) {
- TSO_SPARKNAME(tso) = 0;
- return (0);
-}
-
-/*
- With PrioritySparking add_to_spark_queue performs an insert sort to keep
- the spark queue sorted. Otherwise the spark is just added to the end of
- the queue.
-*/
-
-void
-add_to_spark_queue(spark)
-sparkq spark;
-{
- sparkq prev, next;
- I_ count = 0;
- rtsBool found = rtsFalse;
-
- if ( spark == (sparkq)NULL ) {
- return;
- }
-
- if (RTSflags.GranFlags.DoPrioritySparking && (SPARK_GRAN_INFO(spark)!=0) ) {
-
- for (prev = NULL, next = PendingSparksHd[CurrentProc][ADVISORY_POOL], count=0;
- (next != NULL) &&
- !(found = (SPARK_GRAN_INFO(spark) >= SPARK_GRAN_INFO(next)));
- prev = next, next = SPARK_NEXT(next), count++)
- {}
-
- } else { /* 'utQo' */
-
- found = rtsFalse; /* to add it at the end */
-
- }
-
- if (found) {
- SPARK_NEXT(spark) = next;
- if ( next == NULL ) {
- PendingSparksTl[CurrentProc][ADVISORY_POOL] = spark;
- } else {
- SPARK_PREV(next) = spark;
- }
- SPARK_PREV(spark) = prev;
- if ( prev == NULL ) {
- PendingSparksHd[CurrentProc][ADVISORY_POOL] = spark;
- } else {
- SPARK_NEXT(prev) = spark;
- }
- } else { /* (RTSflags.GranFlags.DoPrioritySparking && !found) || !DoPrioritySparking */
- 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;
- }
- ++SparksAvail;
-
- if (RTSflags.GranFlags.DoPrioritySparking) {
- CurrentTime[CurrentProc] += count * RTSflags.GranFlags.gran_pri_spark_overhead;
- }
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x1000 ) {
- for (prev = NULL, next = PendingSparksHd[CurrentProc][ADVISORY_POOL];
- (next != NULL);
- prev = next, next = SPARK_NEXT(next))
- {}
- if ( (prev!=NULL) && (prev!=PendingSparksTl[CurrentProc][ADVISORY_POOL]) )
- fprintf(stderr,"SparkQ inconsistency after adding spark %#lx: (PE %u, pool %u) PendingSparksTl (%#lx) not end of queue (%#lx)\n",
- spark,CurrentProc,ADVISORY_POOL,
- PendingSparksTl[CurrentProc][ADVISORY_POOL], prev);
- }
-# endif
-
-# if defined(GRAN_CHECK)
- /* Check if the sparkq is still sorted. Just for testing, really! */
- if ( RTSflags.GranFlags.debug & 0x400 ) {
- rtsBool sorted = rtsTrue;
- sparkq prev, next;
-
- if (PendingSparksHd[CurrentProc][ADVISORY_POOL] == NULL ||
- SPARK_NEXT(PendingSparksHd[CurrentProc][ADVISORY_POOL]) == NULL ) {
- /* just 1 elem => ok */
- } else {
- for (prev = PendingSparksHd[CurrentProc][ADVISORY_POOL],
- next = SPARK_NEXT(PendingSparksHd[CurrentProc][ADVISORY_POOL]);
- (next != NULL) ;
- prev = next, next = SPARK_NEXT(next)) {
- sorted = sorted &&
- (SPARK_GRAN_INFO(prev) >= SPARK_GRAN_INFO(next));
- }
- }
- if (!sorted) {
- fprintf(stderr,"Warning: SPARKQ on PE %d is not sorted:\n",
- CurrentProc);
- G_SPARKQ(PendingSparksHd[CurrentProc][ADVISORY_POOL],1);
- }
- }
-# endif
-}
-
-void
-DisposeSpark(spark)
-sparkq spark;
-{
- /* A SP_PRUNED line should be dumped when this is called from pruning or */
- /* discarding a spark! */
-
- if(spark!=NULL)
- free(spark);
-
- --SparksAvail;
-}
-
-void
-DisposeSparkQ(spark)
-sparkq spark;
-{
- if (spark==NULL)
- return;
-
- DisposeSparkQ(SPARK_NEXT(spark));
-
-# ifdef GRAN_CHECK
- if (SparksAvail < 0)
- fprintf(stderr,"DisposeSparkQ: SparksAvail<0 after disposing sparkq @ 0x%lx\n", spark);
-# endif
-
- free(spark);
-}
-
-#endif /* GRAN */
-\end{code}
-
-% {GrAnSim}vaD (Notes on GrAnSim) -- HWL:
-% Qu'vaD ngoq
-% NB: mayQo' wIvwI'
-
-\paragraph{Notes on GrAnSim:}
-The following routines are for handling threads. Currently, we use an
-unfair scheduling policy in GrAnSim. Thus there are no explicit functions for
-scheduling here. If other scheduling policies are added to the system that
-code should go in here.
-
-\begin{code}
-/* Create a new TSO, with the specified closure to enter and thread type */
-
-#if defined(GRAN)
-P_
-NewThread(topClosure, type, pri)
-P_ topClosure;
-W_ type;
-I_ pri;
-#else
-P_
-NewThread(topClosure, type)
-P_ topClosure;
-W_ type;
-#endif /* GRAN */
-{
- P_ stko, tso;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.Light && CurrentProc!=0) {
- fprintf(stderr,"Qagh {NewThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
- if (AvailableTSO != PrelBase_Z91Z93_closure) {
- tso = AvailableTSO;
-#if defined(GRAN)
- SET_PROCS(tso,ThisPE); /* Allocate it locally! */
-#endif
- AvailableTSO = TSO_LINK(tso);
- } else if (SAVE_Hp + TSO_HS + TSO_CTS_SIZE > SAVE_HpLim) {
- return(NULL);
- } else {
- ALLOC_TSO(TSO_HS,BYTES_TO_STGWORDS(sizeof(STGRegisterTable)),
- BYTES_TO_STGWORDS(sizeof(StgDouble)));
- tso = SAVE_Hp + 1;
- SAVE_Hp += TSO_HS + TSO_CTS_SIZE;
- SET_TSO_HDR(tso, TSO_info, CCC);
- }
-
- TSO_LINK(tso) = PrelBase_Z91Z93_closure;
-#if defined(GRAN)
- TSO_PRI(tso) = pri; /* Priority of that TSO -- HWL */
-#endif
-#if defined(PROFILING) || defined(PAR)
- TSO_CCC(tso) = (CostCentre)STATIC_CC_REF(CC_MAIN);
-#endif
- TSO_NAME(tso) = (P_) INFO_PTR(topClosure); /* A string would be nicer -- JSM */
- TSO_ID(tso) = threadId++;
- TSO_TYPE(tso) = type;
- TSO_PC1(tso) = TSO_PC2(tso) = EnterNodeCode;
- TSO_ARG1(tso) = /* TSO_ARG2(tso) = */ 0;
- TSO_SWITCH(tso) = NULL;
-
-#ifdef TICKY_TICKY
- TSO_AHWM(tso) = 0;
- TSO_BHWM(tso) = 0;
-#endif
-
-#if defined(GRAN) || defined(PAR)
- TSO_SPARKNAME(tso) = 0;
-# if defined(GRAN)
- TSO_STARTEDAT(tso) = CurrentTime[CurrentProc];
-# else
- TSO_STARTEDAT(tso) = CURRENT_TIME;
-# endif
- TSO_EXPORTED(tso) = 0;
- TSO_BASICBLOCKS(tso) = 0;
- TSO_ALLOCS(tso) = 0;
- TSO_EXECTIME(tso) = 0;
- TSO_FETCHTIME(tso) = 0;
- TSO_FETCHCOUNT(tso) = 0;
- TSO_BLOCKTIME(tso) = 0;
- TSO_BLOCKCOUNT(tso) = 0;
- TSO_BLOCKEDAT(tso) = 0;
- TSO_GLOBALSPARKS(tso) = 0;
- TSO_LOCALSPARKS(tso) = 0;
-# if defined(GRAN)
- if (RTSflags.GranFlags.Light)
- TSO_CLOCK(tso) = TSO_STARTEDAT(tso); /* local clock */
- else
-# endif
- TSO_CLOCK(tso) = 0;
-#endif
- /*
- * set pc, Node (R1), liveness
- */
- CurrentRegTable = TSO_INTERNAL_PTR(tso);
- SAVE_Liveness = LIVENESS_R1;
- SAVE_R1.p = topClosure;
-
-# ifndef PAR
- if (type == T_MAIN) {
- stko = MainStkO;
- } else {
-# endif
- if (AvailableStack != PrelBase_Z91Z93_closure) {
- stko = AvailableStack;
-#if defined(GRAN)
- SET_PROCS(stko,ThisPE);
-#endif
- AvailableStack = STKO_LINK(AvailableStack);
- } else if (SAVE_Hp + STKO_HS + RTSflags.ConcFlags.stkChunkSize > SAVE_HpLim) {
- return(NULL);
- } else {
- /* ALLOC_STK(STKO_HS,STKO_CHUNK_SIZE,0); use RTSflag now*/
- ALLOC_STK(STKO_HS,RTSflags.ConcFlags.stkChunkSize,0);
- stko = SAVE_Hp + 1;
- SAVE_Hp += STKO_HS + RTSflags.ConcFlags.stkChunkSize;
- SET_STKO_HDR(stko, StkO_info, CCC);
- }
- STKO_SIZE(stko) = RTSflags.ConcFlags.stkChunkSize + STKO_VHS;
- STKO_SpB(stko) = STKO_SuB(stko) = STKO_BSTK_BOT(stko) + BREL(1);
- STKO_SpA(stko) = STKO_SuA(stko) = STKO_ASTK_BOT(stko) + AREL(1);
- STKO_LINK(stko) = PrelBase_Z91Z93_closure;
- STKO_RETURN(stko) = NULL;
-# ifndef PAR
- }
-# endif
-
-#ifdef TICKY_TICKY
- STKO_ADEP(stko) = STKO_BDEP(stko) = 0;
-#endif
-
- if (type == T_MAIN) {
- STKO_SpB(stko) -= BREL(1);
- *STKO_SpB(stko) = (P_) realWorldZh_closure;
- }
-
- SAVE_Ret = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
- SAVE_StkO = stko;
-
- if (DO_QP_PROF) {
- QP_Event1(do_qp_prof > 1 ? "*A" : "*G", tso);
- }
-#if defined(GRAN_CHECK)
- tot_sq_len += spark_queue_len(CurrentProc,ADVISORY_POOL);
- tot_sq_probes++;
-#endif
- return tso;
-}
-
-\end{code}
-
-In GrAnSim the @EndThread@ function is the place where statistics about the
-simulation are printed. I guess, that could be moved into @main.lc@.
-
-\begin{code}
-
-void
-EndThread(STG_NO_ARGS)
-{
- P_ stko;
-#if defined(PAR)
- TIME now = CURRENT_TIME;
-#endif
-
-#ifdef TICKY_TICKY
- if (RTSflags.TickyFlags.showTickyStats) {
- fprintf(RTSflags.TickyFlags.tickyFile,
- "Thread %d (%lx)\n\tA stack max. depth: %ld words\n",
- TSO_ID(CurrentTSO), TSO_NAME(CurrentTSO), TSO_AHWM(CurrentTSO));
- fprintf(RTSflags.TickyFlags.tickyFile,
- "\tB stack max. depth: %ld words\n",
- TSO_BHWM(CurrentTSO));
- }
-#endif
-
- if (DO_QP_PROF) {
- QP_Event1("G*", CurrentTSO);
- }
-
-#if defined(GRAN)
- ASSERT(CurrentTSO == ThreadQueueHd);
-
- if (RTSflags.GranFlags.DoThreadMigration)
- --SurplusThreads;
-
- if(TSO_TYPE(CurrentTSO)==T_MAIN)
- {
- int i;
- rtsBool is_first;
- for(i=0; i < RTSflags.GranFlags.proc; ++i) {
- is_first = rtsTrue;
- while(RunnableThreadsHd[i] != PrelBase_Z91Z93_closure)
- {
- /* We schedule runnable threads before killing them to */
- /* make the job of bookkeeping the running, runnable, */
- /* blocked threads easier for scripts like gr2ps -- HWL */
-
- if (RTSflags.GranFlags.granSimStats && !is_first &&
- (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
- DumpRawGranEvent(i,(PROC)0,GR_SCHEDULE,
- RunnableThreadsHd[i],
- PrelBase_Z91Z93_closure,0);
- if (!RTSflags.GranFlags.granSimStats_suppressed &&
- TSO_TYPE(RunnableThreadsHd[i])!=T_MAIN)
- DumpGranInfo(i,RunnableThreadsHd[i],rtsTrue);
- RunnableThreadsHd[i] = TSO_LINK(RunnableThreadsHd[i]);
- is_first = rtsFalse;
- }
- }
-
- ThreadQueueHd = PrelBase_Z91Z93_closure;
- /* Printing of statistics has been moved into end_gr_simulation */
- } /* ... T_MAIN */
-
- if (RTSflags.GranFlags.labelling && RTSflags.GranFlags.granSimStats &&
- !RTSflags.GranFlags.granSimStats_suppressed)
- DumpStartEventAt(TSO_STARTEDAT(CurrentTSO),where_is(CurrentTSO),0,GR_START,
- CurrentTSO,PrelBase_Z91Z93_closure,
- TSO_SPARKNAME(CurrentTSO));
- /* ^^^ SN (spark name) as optional info */
- /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
- /* ^^^ spark length as optional info */
-
- if (RTSflags.GranFlags.granSimStats &&
- !RTSflags.GranFlags.granSimStats_suppressed)
- DumpGranInfo(CurrentProc,CurrentTSO,
- TSO_TYPE(CurrentTSO) != T_ADVISORY);
-
- if (RTSflags.GranFlags.granSimStats_Binary &&
- TSO_TYPE(CurrentTSO)==T_MAIN &&
- !RTSflags.GranFlags.granSimStats_suppressed)
- grterminate(CurrentTime[CurrentProc]);
-
- if (TSO_TYPE(CurrentTSO)!=T_MAIN)
- ActivateNextThread(CurrentProc);
-
- /* Note ThreadQueueHd is Nil when the main thread terminates
- if(ThreadQueueHd != PrelBase_Z91Z93_closure)
- {
- if (RTSflags.GranFlags.granSimStats && !RTSflags.GranFlags.granSimStats_suppressed &&
- (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
- DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadscheduletime;
- }
- */
-
-#endif /* GRAN */
-
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
- DumpGranInfo(thisPE, CurrentTSO, TSO_TYPE(CurrentTSO) != T_ADVISORY);
- }
-#endif
-
- switch (TSO_TYPE(CurrentTSO)) {
- case T_MAIN:
- required_thread_count--;
-
-#ifdef PAR
- if (GRANSIMSTATS_BINARY)
- grterminate(now);
-#endif
-#ifdef GRAN
- longjmp(scheduler_loop, -1); /* i.e. the world comes to an end NOW */
-#else
- ReSchedule(0); /* i.e. the world will eventually come to an end */
-#endif
-
- case T_REQUIRED:
- required_thread_count--;
- break;
-
- case T_ADVISORY:
- advisory_thread_count--;
- break;
-
- case T_FAIL:
- EXIT(EXIT_FAILURE);
-
- default:
- fflush(stdout);
- fprintf(stderr, "EndThread: %x unknown\n", TSO_TYPE(CurrentTSO));
- EXIT(EXIT_FAILURE);
- }
-
- /* Reuse stack object space */
- ASSERT(STKO_LINK(SAVE_StkO) == PrelBase_Z91Z93_closure);
- STKO_LINK(SAVE_StkO) = AvailableStack;
- AvailableStack = SAVE_StkO;
- /* Reuse TSO */
- TSO_LINK(CurrentTSO) = AvailableTSO;
- AvailableTSO = CurrentTSO;
- CurrentTSO = PrelBase_Z91Z93_closure;
- CurrentRegTable = NULL;
-
-#if defined(GRAN)
- /* NB: Now ThreadQueueHd is either the next runnable thread on this */
- /* proc or it's PrelBase_Z91Z93_closure. In the latter case, a FINDWORK will be */
- /* issued by ReSchedule. */
- ReSchedule(SAME_THREAD); /* back for more! */
-#else
- ReSchedule(0); /* back for more! */
-#endif
-}
-
-\end{code}
-
-%****************************************************************************
-%
-\subsection[thread-blocking]{Local Blocking}
-%
-%****************************************************************************
-
-\begin{code}
-
-#if defined(GRAN_COUNT)
-/* Some non-essential maybe-useful statistics-gathering */
-void CountnUPDs() { ++nUPDs; }
-void CountnUPDs_old() { ++nUPDs_old; }
-void CountnUPDs_new() { ++nUPDs_new; }
-
-void CountnPAPs() { ++nPAPs; }
-#endif
-
-EXTDATA_RO(BQ_info);
-
-#ifndef GRAN
-/* NB: non-GRAN version ToDo
- *
- * AwakenBlockingQueue awakens a list of TSOs and FBQs.
- */
-
-P_ PendingFetches = PrelBase_Z91Z93_closure;
-
-void
-AwakenBlockingQueue(bqe)
- P_ bqe;
-{
- P_ last_tso = NULL;
-
-# ifdef PAR
- P_ next;
- TIME now = CURRENT_TIME;
-
-# endif
-
-# ifndef PAR
- while (bqe != PrelBase_Z91Z93_closure) {
-# else
- while (IS_MUTABLE(INFO_PTR(bqe))) {
- switch (INFO_TYPE(INFO_PTR(bqe))) {
- case INFO_TSO_TYPE:
-# endif
- if (DO_QP_PROF) {
- QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
- }
-# ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- DumpGranEvent(GR_RESUMEQ, bqe);
- switch (TSO_QUEUE(bqe)) {
- case Q_BLOCKED:
- TSO_BLOCKTIME(bqe) += now - TSO_BLOCKEDAT(bqe);
- break;
- case Q_FETCHING:
- TSO_FETCHTIME(bqe) += now - TSO_BLOCKEDAT(bqe);
- break;
- default:
- fflush(stdout);
- fprintf(stderr, "ABQ: TSO_QUEUE invalid.\n");
- EXIT(EXIT_FAILURE);
- }
- }
-# endif
- if (last_tso == NULL) {
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure) {
- RunnableThreadsHd = bqe;
- } else {
- TSO_LINK(RunnableThreadsTl) = bqe;
- }
- }
- last_tso = bqe;
- bqe = TSO_LINK(bqe);
-# ifdef PAR
- break;
- case INFO_BF_TYPE:
- next = BF_LINK(bqe);
- BF_LINK(bqe) = PendingFetches;
- PendingFetches = bqe;
- bqe = next;
- if (last_tso != NULL)
- TSO_LINK(last_tso) = next;
- break;
- default:
- fprintf(stderr, "Unexpected IP (%#lx) in blocking queue at %#lx\n",
- INFO_PTR(bqe), (W_) bqe);
- EXIT(EXIT_FAILURE);
- }
- }
-# else
- }
-# endif
- if (last_tso != NULL) {
- RunnableThreadsTl = last_tso;
-# ifdef PAR
- TSO_LINK(last_tso) = PrelBase_Z91Z93_closure;
-# endif
- }
-}
-#endif /* !GRAN */
-
-#ifdef GRAN
-
-# if defined(GRAN_CHECK)
-
-/* First some useful test functions */
-
-EXTFUN(RBH_Save_0_info);
-EXTFUN(RBH_Save_1_info);
-EXTFUN(RBH_Save_2_info);
-
-void
-PRINT_BQ(bqe)
-P_ bqe;
-{
- W_ it;
- P_ last = NULL;
- char str[80], str0[80];
-
- fprintf(stderr,"\n[PE %d] @ %lu BQ: ",
- CurrentProc,CurrentTime[CurrentProc]);
- if ( bqe == PrelBase_Z91Z93_closure ) {
- fprintf(stderr," NIL.\n");
- return;
- }
- if ( bqe == NULL ) {
- fprintf(stderr," NULL\n");
- return;
- }
- while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
- W_ proc; /* RBH_Save_? closures! */
-
- /* Find where the tso lives */
- proc = where_is(bqe);
- it = INFO_TYPE(INFO_PTR(bqe));
-
- switch (it) {
- case INFO_TSO_TYPE:
- strcpy(str0,"TSO");
- break;
- case INFO_BQ_TYPE:
- strcpy(str0,"BQ");
- break;
- default:
- strcpy(str0,"???");
- break;
- }
-
- if(proc == CurrentProc)
- fprintf(stderr," %#lx (%x) L %s,", bqe, TSO_ID(bqe), str0);
- else
- fprintf(stderr," %#lx (%x) G (PE %d) %s,", bqe, TSO_ID(bqe), proc, str0);
-
- last = bqe;
- switch (it) {
- case INFO_TSO_TYPE:
- bqe = TSO_LINK(bqe);
- break;
- case INFO_BQ_TYPE:
- bqe = TSO_LINK(bqe);
- break;
- default:
- bqe = PrelBase_Z91Z93_closure;
- break;
- }
- /* TSO_LINK(last_tso) = PrelBase_Z91Z93_closure; */
- }
- if ( bqe == PrelBase_Z91Z93_closure )
- fprintf(stderr," NIL.\n");
- else if (
- (INFO_PTR(bqe) == (P_) RBH_Save_0_info) ||
- (INFO_PTR(bqe) == (P_) RBH_Save_1_info) ||
- (INFO_PTR(bqe) == (P_) RBH_Save_2_info) )
- fprintf(stderr," RBH.\n");
- /* fprintf(stderr,"\n%s\n",str); */
- }
-
-rtsBool
-CHECK_BQ(node, tso, proc)
-P_ node, tso;
-PROC proc;
-{
- P_ bqe;
- W_ it;
- P_ last = NULL;
- PROC p = where_is(tso);
- rtsBool ok = rtsTrue;
-
- if ( p != proc) {
- fprintf(stderr,"ERROR in CHECK_BQ: CurrentTSO %#lx (%x) on proc %d but CurrentProc = %d\n",
- tso, TSO_ID(tso), proc);
- ok = rtsFalse;
- }
-
- switch (INFO_TYPE(INFO_PTR(node))) {
- case INFO_BH_TYPE:
- case INFO_BH_U_TYPE:
- bqe = (P_) BQ_ENTRIES(node);
- return (rtsTrue); /* BHs don't have BQs */
- break;
- case INFO_BQ_TYPE:
- bqe = (P_) BQ_ENTRIES(node);
- break;
- case INFO_FMBQ_TYPE:
- fprintf(stderr,"CHECK_BQ: ERROR: FMBQ closure (%#lx) found in GrAnSim (TSO=%#lx (%x))\n",
- node, tso, TSO_ID(tso));
- EXIT(EXIT_FAILURE);
- break;
- case INFO_SPEC_RBH_TYPE:
- bqe = (P_) SPEC_RBH_BQ(node);
- break;
- case INFO_GEN_RBH_TYPE:
- bqe = (P_) GEN_RBH_BQ(node);
- break;
- default:
- {
- P_ info_ptr;
- I_ size, ptrs, nonptrs, vhs;
- char info_hdr_ty[80];
-
- fprintf(stderr, "CHECK_BQ: thought %#lx was a black hole (IP %#lx)",
- node, INFO_PTR(node));
- info_ptr = get_closure_info(node,
- &size, &ptrs, &nonptrs, &vhs,
- info_hdr_ty);
- fprintf(stderr, " %s\n",info_hdr_ty);
- /* G_PRINT_NODE(node); */
- return (rtsFalse);
- /* EXIT(EXIT_FAILURE); */
- }
- }
-
- while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
- W_ proc; /* RBH_Save_? closures! */
-
- /* Find where the tso lives */
- proc = where_is(bqe);
- it = INFO_TYPE(INFO_PTR(bqe));
-
- if ( bqe == tso ) {
- fprintf(stderr,"ERROR in CHECK_BQ [Node = 0x%lx, PE %d]: TSO %#lx (%x) already in BQ: ",
- node, proc, tso, TSO_ID(tso));
- PRINT_BQ(BQ_ENTRIES(node));
- ok = rtsFalse;
- }
-
- bqe = TSO_LINK(bqe);
- }
- return (ok);
-}
-/* End of test functions */
-# endif /* GRAN_CHECK */
-
-/* This version of AwakenBlockingQueue has been originally taken from the
- GUM code. It is now assimilated into GrAnSim */
-
-/* Note: This version assumes a pointer to a blocking queue rather than a
- node with an attached blocking queue as input */
-
-P_
-AwakenBlockingQueue(bqe)
-P_ bqe;
-{
- /* P_ tso = (P_) BQ_ENTRIES(node); */
- P_ last = NULL;
- /* P_ prev; */
- W_ notifytime;
-
-# if 0
- if(do_gr_sim)
-# endif
-
- /* Compatibility mode with old libaries! 'oH jIvoQmoH */
- if (IS_BQ_CLOSURE(bqe))
- bqe = (P_)BQ_ENTRIES(bqe);
- else if ( INFO_TYPE(INFO_PTR(bqe)) == INFO_SPEC_RBH_TYPE )
- bqe = (P_)SPEC_RBH_BQ(bqe);
- else if ( INFO_TYPE(INFO_PTR(bqe)) == INFO_GEN_RBH_TYPE )
- bqe = (P_)GEN_RBH_BQ(bqe);
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- PRINT_BQ(bqe);
- }
-# endif
-
-# if defined(GRAN_COUNT)
- ++nUPDs;
- if (tso != PrelBase_Z91Z93_closure)
- ++nUPDs_BQ;
-# endif
-
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x100)
- fprintf(stderr,"----- AwBQ: ");
-# endif
-
- while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
- W_ proc; /* RBH_Save_? closures! */
- ASSERT(INFO_TYPE(INFO_PTR(bqe)) == INFO_TSO_TYPE);
-
- if (DO_QP_PROF) {
- QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
- }
-# if defined(GRAN_COUNT)
- ++BQ_lens;
-# endif
-
- /* Find where the tso lives */
- proc = where_is(bqe);
-
- if(proc == CurrentProc) {
- notifytime = CurrentTime[CurrentProc] + RTSflags.GranFlags.gran_lunblocktime;
- } else {
- /* A better way of handling this would be to introduce a
- GLOBALUNBLOCK event which is created here. -- HWL */
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
- notifytime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[proc]) +
- RTSflags.GranFlags.gran_gunblocktime;
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
- /* new_event(proc, CurrentProc, notifytime,
- GLOBALUNBLOCK,bqe,PrelBase_Z91Z93_closure,NULL); */
- }
- /* cost the walk over the queue */
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_lunblocktime;
- /* GrAnSim Light: make blocked TSO aware of the time that passed */
- if (RTSflags.GranFlags.Light)
- TSO_CLOCK(bqe) = notifytime;
- /* and create a resume message */
- new_event(proc, CurrentProc, notifytime,
- RESUMETHREAD,bqe,PrelBase_Z91Z93_closure,NULL);
-
- if (notifytime<TimeOfNextEvent)
- TimeOfNextEvent = notifytime;
-
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x100) {
- fprintf(stderr," TSO %x (PE %d) %s,",
- TSO_ID(bqe), proc, ( (proc==CurrentProc) ? "L" : "G") );
- }
-# endif
-
- last = bqe;
- bqe = TSO_LINK(bqe);
- TSO_LINK(last) = PrelBase_Z91Z93_closure;
- } /* while */
-
-# if 0
- /* This was once used in a !do_gr_sim setup. Now only GrAnSim setup is */
- /* supported. */
- else /* Check if this is still valid for non-GrAnSim code -- HWL */
- {
- if (ThreadQueueHd == PrelBase_Z91Z93_closure)
- ThreadQueueHd = bqe;
- else
- TSO_LINK(ThreadQueueTl) = bqe;
-
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure)
- RunnableThreadsHd = tso;
- else
- TSO_LINK(RunnableThreadsTl) = tso;
-
-
- while(TSO_LINK(bqe) != PrelBase_Z91Z93_closure) {
- assert(TSO_INTERNAL_PTR(bqe)->rR[0].p == node);
-# if 0
- if (DO_QP_PROF) {
- QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
- }
-# endif
- bqe = TSO_LINK(bqe);
- }
-
- assert(TSO_INTERNAL_PTR(bqe)->rR[0].p == node);
-# if 0
- if (DO_QP_PROF) {
- QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
- }
-# endif
- }
-# endif /* 0 */
-
- if (RTSflags.GranFlags.debug & 0x100)
- fprintf(stderr,".\n");
-
- return (bqe);
- /* ngo' {GrAnSim}Qo' ngoq: RunnableThreadsTl = tso; */
-}
-#endif /* GRAN */
-
-EXTFUN(Continue);
-
-
-#if defined(GRAN)
-
-/* Different interface for GRAN */
-void
-Yield(liveness)
-W_ liveness;
-{
- SAVE_Liveness = liveness;
- TSO_PC1(CurrentTSO) = Continue;
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
- ReSchedule(SAME_THREAD);
-}
-
-#else /* !GRAN */
-
-void
-Yield(args)
-W_ args;
-{
- SAVE_Liveness = args >> 1;
- TSO_PC1(CurrentTSO) = Continue;
- if (DO_QP_PROF) {
- QP_Event1("GR", CurrentTSO);
- }
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats) {
- /* Note that CURRENT_TIME may perform an unsafe call */
- TSO_EXECTIME(CurrentTSO) += CURRENT_TIME - TSO_BLOCKEDAT(CurrentTSO);
- }
-#endif
- ReSchedule(args & 1);
-}
-
-#endif /* GRAN */
-\end{code}
-
-
-%****************************************************************************
-%
-\subsection[gr-fetch]{Fetching Nodes (GrAnSim only)}
-%
-%****************************************************************************
-
-The following GrAnSim routines simulate the fetching of nodes from a remote
-processor. We use a 1 word bitmask to indicate on which processor a node is
-lying. Thus, moving or copying a node from one processor to another just
-requires an appropriate change in this bitmask (using @SET_GA@).
-Additionally, the clocks have to be updated.
-
-A special case arises when the node that is needed by processor A has been
-moved from a processor B to a processor C between sending out a @FETCH@
-(from A) and its arrival at B. In that case the @FETCH@ has to be forwarded
-to C.
-
-
-\begin{code}
-#if defined(GRAN)
-/* ngoqvam che' {GrAnSim}! */
-
-/* Fetch node "node" to processor "p" */
-
-int
-FetchNode(node,from,to)
-P_ node;
-PROC from, to;
-{
- /* In case of RTSflags.GranFlags.DoGUMMFetching this fct should never be
- entered! Instead, UnpackGraph is used in ReSchedule */
- P_ closure;
-
- ASSERT(to==CurrentProc);
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.Light ) {
- fprintf(stderr,"Qagh {FetchNode}Daq: Should never be entered in GrAnSim Light setup\n");
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- if ( RTSflags.GranFlags.DoGUMMFetching ) {
- fprintf(stderr,"Qagh: FetchNode should never be entered with DoGUMMFetching\n");
- EXIT(EXIT_FAILURE);
- }
-
- /* Now fetch the children */
- if (!IS_LOCAL_TO(PROCS(node),from) &&
- !IS_LOCAL_TO(PROCS(node),to) )
- return 1;
-
- if(IS_NF(INFO_PTR(node))) /* Old: || IS_BQ(node) */
- PROCS(node) |= PE_NUMBER(to); /* Copy node */
- else
- PROCS(node) = PE_NUMBER(to); /* Move node */
-
- return 0;
-}
-
-/* --------------------------------------------------
- Cost of sending a packet of size n = C + P*n
- where C = packet construction constant,
- P = cost of packing one word into a packet
- [Should also account for multiple packets].
- -------------------------------------------------- */
-
-/* Return codes:
- 0 ... ok (FETCHREPLY event with a buffer containing addresses of the
- nearby graph has been scheduled)
- 1 ... node is already local (fetched by somebody else; no event is
- scheduled in here)
- 2 ... fetch request has been forwrded to the PE that now contains the
- node
- 3 ... node is a black hole (BH, BQ or RBH); no event is scheduled, and
- the current TSO is put into the blocking queue of that node
- 4 ... out of heap in PackNearbyGraph; GC should be triggered in calling
- function to guarantee that the tso and node inputs are valid
- (they may be moved during GC).
-
- ToDo: Symbolic return codes; clean up code (separate GUMMFetching from
- single node fetching.
-*/
-
-I_
-HandleFetchRequest(node,p,tso)
-P_ node, tso;
-PROC p;
-{
- ASSERT(!RTSflags.GranFlags.Light);
-
- if (IS_LOCAL_TO(PROCS(node),p) ) /* Somebody else moved node already => */
- { /* start tso */
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x100 ) {
- P_ info_ptr;
- I_ size, ptrs, nonptrs, vhs;
- char info_hdr_ty[80];
-
- info_ptr = get_closure_info(node,
- &size, &ptrs, &nonptrs, &vhs,
- info_hdr_ty);
- fprintf(stderr,"Warning: HandleFetchRequest entered with local node %#lx (%s) (PE %d)\n",
- node,info_hdr_ty,p);
- }
-# endif
- if (RTSflags.GranFlags.DoGUMMFetching) {
- W_ size;
- P_ graph;
-
- /* Create a 1-node-buffer and schedule a FETCHREPLY now */
- graph = PackOneNode(node, tso, &size);
- new_event(p,CurrentProc,CurrentTime[CurrentProc],
- FETCHREPLY,tso,graph,NULL);
- } else {
- new_event(p,CurrentProc,CurrentTime[CurrentProc],
- FETCHREPLY,tso,node,NULL);
- }
- return (1);
- }
- else if (IS_LOCAL_TO(PROCS(node),CurrentProc) ) /* Is node still here? */
- {
- if(RTSflags.GranFlags.DoGUMMFetching) { /* {GUM}vo' ngoqvam vInIHta' (code from GUM) */
- W_ size;
- P_ graph;
-
- if (IS_BLACK_HOLE(INFO_PTR(node))) { /* block on BH or RBH */
- new_event(p,CurrentProc,CurrentTime[p],
- GLOBALBLOCK,tso,node,NULL);
- /* Note: blockFetch is done when handling GLOBALBLOCK event */
- /* When this thread is reawoken it does the usual: it tries to
- enter the updated node and issues a fetch if it's remote.
- It has forgotten that it has sent a fetch already (i.e. a
- FETCHNODE is swallowed by a BH, leaving the thread in a BQ */
- --OutstandingFetches[p];
- return (3);
- }
-
-# if defined(GRAN_CHECK)
- if (!RTSflags.GranFlags.DoReScheduleOnFetch && (tso != RunnableThreadsHd[p])) {
- fprintf(stderr,"Qagh {HandleFetchRequest}Daq: tso 0x%lx (%x) not at head of proc %d (0x%lx)\n",
- tso, TSO_ID(tso), p, RunnableThreadsHd[p]);
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- if ((graph = PackNearbyGraph(node, tso, &size)) == NULL)
- return (4); /* out of heap */
-
- /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
- /* Send a reply to the originator */
- /* ToDo: Replace that by software costs for doing graph packing! */
- CurrentTime[CurrentProc] += size * RTSflags.GranFlags.gran_mpacktime;
-
- new_event(p,CurrentProc,CurrentTime[CurrentProc]+RTSflags.GranFlags.gran_latency,
- FETCHREPLY,tso,graph,NULL);
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
- return (0);
- } else { /* incremental (single closure) fetching */
- /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
- /* Send a reply to the originator */
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
-
- new_event(p,CurrentProc,CurrentTime[CurrentProc]+RTSflags.GranFlags.gran_latency,
- FETCHREPLY,tso,node,NULL);
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
- return (0);
- }
- }
- else /* Qu'vatlh! node has been grabbed by another proc => forward */
- {
- PROC p_new = where_is(node);
- TIME fetchtime;
-
-# if defined(GRAN_CHECK)
- if (RTSflags.GranFlags.debug & 0x2)
- fprintf(stderr,"Qu'vatlh! node %#lx has been grabbed by PE %d (current=%d; demander=%d) @ %d\n",
- node,p_new,CurrentProc,p,CurrentTime[CurrentProc]);
-# endif
- /* Prepare FORWARD message to proc p_new */
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
-
- fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p_new]) +
- RTSflags.GranFlags.gran_latency;
-
- new_event(p_new,p,fetchtime,FETCHNODE,tso,node,NULL);
-
- CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
-
- return (2);
- }
-}
-#endif
-\end{code}
-
-@blockFetch@ blocks a @BlockedFetch@ node on some kind of black hole.
-
-Taken from gum/HLComms.lc. [find a better place for that ?] -- HWL
-
-{\bf Note:} In GranSim we don't have @FETCHME@ nodes and therefore don't
-create @FMBQ@'s (FetchMe blocking queues) to cope with global
-blocking. Instead, non-local TSO are put into the BQ in the same way as
-local TSOs. However, we have to check if a TSO is local or global in order
-to account for the latencies involved and for keeping track of the number
-of fetches that are really going on.
-
-\begin{code}
-#if defined(GRAN)
-
-/* Return codes:
- 0 ... ok; tso is now at beginning of BQ attached to the bh closure
- 1 ... the bh closure is no BH any more; tso is immediately unblocked
-*/
-
-I_
-blockFetch(tso, proc, bh)
-P_ tso; /* TSO which gets blocked */
-PROC proc; /* PE where that tso was running */
-P_ bh; /* closure to block on (BH, RBH, BQ) */
-{
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- P_ info_ptr;
- I_ size, ptrs, nonptrs, vhs;
- char info_hdr_ty[80];
-
- info_ptr = get_closure_info(bh,
- &size, &ptrs, &nonptrs, &vhs,
- info_hdr_ty);
- fprintf(stderr,"Blocking TSO %#lx (%x)(PE %d) on node %#lx (%s) (PE %d). No graph is packed!\n",
- tso, TSO_ID(tso), proc, bh, info_hdr_ty, where_is(bh));
- }
-
- if ( !RTSflags.GranFlags.DoReScheduleOnFetch && (tso != RunnableThreadsHd[proc]) ) {
- fprintf(stderr,"Qagh {blockFetch}Daq: TSO 0x%lx (%x) is not first on runnable list of proc %d (first is 0x%lx)\n",
- tso,TSO_ID(tso),proc,RunnableThreadsHd[proc]);
- EXIT(EXIT_FAILURE);
- }
-# endif
-
- if (!IS_BLACK_HOLE(INFO_PTR(bh))) { /* catches BHs and RBHs */
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x100 ) {
- P_ info;
- W_ size, ptrs, nonptrs, vhs;
- char str[80], junk_str[80];
-
- info = get_closure_info(bh, &size, &ptrs, &nonptrs, &vhs, str);
- fprintf(stderr,"blockFetch: node %#lx (%s) is not a BH => awakening TSO %#lx (%x) (PE %u)\n",
- bh, str, tso, TSO_ID(tso), proc);
- G_PRINT_NODE(bh);
- }
-# endif
- /* No BH anymore => immediately unblock tso */
- new_event(proc,proc,CurrentTime[proc],
- UNBLOCKTHREAD,tso,bh,NULL);
-
- /* Is this always a REPLY to a FETCH in the profile ? */
- if (RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(proc,proc,GR_REPLY,tso,bh,0);
- return (1);
- }
-
- /* DaH {BQ}Daq Qu' Suq 'e' wISov!
- Now we know that we have to put the tso into the BQ.
- 2 case: If block-on-fetch, tso is at head of threadq =>
- => take it out of threadq and into BQ
- If reschedule-on-fetch, tso is only pointed to be event
- => just put it into BQ
- */
- if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* block-on-fetch */
- GranSimBlock(tso, proc, bh); /* get tso out of threadq & activate next
- thread (same as in BQ_entry) */
- } else { /* reschedule-on-fetch */
- if(RTSflags.GranFlags.granSimStats)
- DumpRawGranEvent(proc,where_is(bh),GR_BLOCK,tso,bh,0);
-
- ++TSO_BLOCKCOUNT(tso);
- TSO_BLOCKEDAT(tso) = CurrentTime[proc];
- }
-
- ASSERT(TSO_LINK(tso)==PrelBase_Z91Z93_closure);
-
- /* Put tso into BQ */
- switch (INFO_TYPE(INFO_PTR(bh))) {
- case INFO_BH_TYPE:
- case INFO_BH_U_TYPE:
- TSO_LINK(tso) = PrelBase_Z91Z93_closure;
- SET_INFO_PTR(bh, BQ_info);
- BQ_ENTRIES(bh) = (W_) tso;
-
-#ifdef GC_MUT_REQUIRED
- /*
- * If we modify a black hole in the old generation, we have to make
- * sure it goes on the mutables list
- */
-
- if (bh <= StorageMgrInfo.OldLim) {
- MUT_LINK(bh) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = bh;
- } else
- MUT_LINK(bh) = MUT_NOT_LINKED;
-#endif
- break;
- case INFO_BQ_TYPE:
- /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
- TSO_LINK(tso) = (P_) BQ_ENTRIES(bh);
- BQ_ENTRIES(bh) = (W_) tso;
- break;
- case INFO_FMBQ_TYPE:
- fprintf(stderr,"ERROR: FMBQ closure (%#lx) found in GrAnSim (TSO=%#lx (%x))\n",
- bh, tso, TSO_ID(tso));
- EXIT(EXIT_FAILURE);
- case INFO_SPEC_RBH_TYPE:
- /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
- TSO_LINK(tso) = (P_) SPEC_RBH_BQ(bh);
- SPEC_RBH_BQ(bh) = (W_) tso;
- break;
- case INFO_GEN_RBH_TYPE:
- /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
- TSO_LINK(tso) = (P_) GEN_RBH_BQ(bh);
- GEN_RBH_BQ(bh) = (W_) tso;
- break;
- default:
- {
- P_ info_ptr;
- I_ size, ptrs, nonptrs, vhs;
- char info_hdr_ty[80];
-
- fprintf(stderr, "Panic: thought %#lx was a black hole (IP %#lx)",
- bh, INFO_PTR(bh));
-# if defined(GRAN_CHECK)
- info_ptr = get_closure_info(bh,
- &size, &ptrs, &nonptrs, &vhs,
- info_hdr_ty);
- fprintf(stderr, " %s\n",info_hdr_ty);
- G_PRINT_NODE(bh);
-# endif
- EXIT(EXIT_FAILURE);
- }
- }
- return (0);
-}
-
-#endif /* GRAN */
-\end{code}
-
-%****************************************************************************
-%
-\subsection[qp-profile]{Quasi-Parallel Profiling}
-%
-%****************************************************************************
-
-\begin{code}
-/* ToDo: Check if this is really still used anywhere!? */
-
-I_ do_qp_prof;
-FILE *qp_file;
-
-/* *Virtual* Time in milliseconds */
-#if !defined(GRAN)
-long
-qp_elapsed_time(STG_NO_ARGS)
-{
- extern StgDouble usertime();
-
- return ((long) (usertime() * 1e3));
-}
-#else
-long
-qp_elapsed_time(STG_NO_ARGS)
-{
- return ((long) CurrentTime[CurrentProc] );
-}
-#endif
-
-static void
-init_qp_profiling(STG_NO_ARGS)
-{
- I_ i;
- char qp_filename[STATS_FILENAME_MAXLEN];
-
- sprintf(qp_filename, QP_FILENAME_FMT, prog_argv[0]);
- if ((qp_file = fopen(qp_filename,"w")) == NULL ) {
- fprintf(stderr, "Can't open quasi-parallel profile report file %s\n",
- qp_filename);
- do_qp_prof = 0;
- } else {
- fputs(prog_argv[0], qp_file);
- for(i = 1; prog_argv[i]; i++) {
- fputc(' ', qp_file);
- fputs(prog_argv[i], qp_file);
- }
- fprintf(qp_file, " +RTS -C%d -t%d\n"
- , RTSflags.ConcFlags.ctxtSwitchTime
- , RTSflags.ConcFlags.maxThreads);
-
- fputs(time_str(), qp_file);
- fputc('\n', qp_file);
- }
-}
-
-void
-QP_Event0(tid, node)
-I_ tid;
-P_ node;
-{
- fprintf(qp_file, "%lu ** %lu 0x%lx\n", qp_elapsed_time(), tid, INFO_PTR(node));
-}
-
-void
-QP_Event1(event, tso)
-char *event;
-P_ tso;
-{
- fprintf(qp_file, "%lu %s %lu 0x%lx\n", qp_elapsed_time(), event,
- TSO_ID(tso), TSO_NAME(tso));
-}
-
-void
-QP_Event2(event, tso1, tso2)
-char *event;
-P_ tso1, tso2;
-{
- fprintf(qp_file, "%lu %s %lu 0x%lx %lu 0x%lx\n", qp_elapsed_time(), event,
- TSO_ID(tso1), TSO_NAME(tso1), TSO_ID(tso2), TSO_NAME(tso2));
-}
-
-\end{code}
-
-%****************************************************************************
-%
-\subsection[gc-GrAnSim]{Garbage collection routines for GrAnSim objects}
-%
-%****************************************************************************
-
-Garbage collection code for the event queue. We walk the event queue
-so that if the only reference to a TSO is in some event (e.g. RESUME),
-the TSO is still preserved.
-
-The GC code now uses a breadth-first pruning strategy. This prevents
-the GC from keeping all sparks of the low-numbered PEs while discarding all
-sparks from high-numbered PEs. Such a depth-first pruning may have
-disastrous effects for programs that generate a huge number of sparks!
-
-\begin{code}
-#if defined(GRAN)
-
-extern smInfo StorageMgrInfo;
-
-/* Auxiliary functions needed in Save/RestoreSparkRoots if breadth-first */
-/* pruning is done. */
-
-static W_
-arr_and(W_ arr[], I_ max)
-{
- I_ i;
- W_ res;
-
- /* Doesn't work with max==0; but then, many things don't work in this */
- /* special case. */
- for (i=1, res = arr[0]; i<max; i++)
- res &= arr[i];
-
- return (res);
-}
-
-static W_
-arr_max(W_ arr[], I_ max)
-{
- I_ i;
- W_ res;
-
- /* Doesn't work with max==0; but then, many things don't work in this */
- /* special case. */
- for (i=1, res = arr[0]; i<max; i++)
- res = (arr[i]>res) ? arr[i] : res;
-
- return (res);
-}
-
-/*
- Routines working on spark queues.
- It would be a good idea to make that an ADT!
-*/
-
-I_
-spark_queue_len(PROC proc, I_ pool)
-{
- sparkq prev, spark; /* prev only for testing !! */
- I_ len;
-
- for (len = 0, prev = NULL, spark = PendingSparksHd[proc][pool];
- spark != NULL;
- len++, prev = spark, spark = SPARK_NEXT(spark))
- {}
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x1000 )
- if ( (prev!=NULL) && (prev!=PendingSparksTl[proc][pool]) )
- fprintf(stderr,"ERROR in spark_queue_len: (PE %u, pool %u) PendingSparksTl (%#lx) not end of queue (%#lx)\n",
- proc, pool, PendingSparksTl[proc][pool], prev);
-# endif
-
- return (len);
-}
-
-sparkq
-delete_from_spark_queue (prev,spark) /* unlink and dispose spark */
-sparkq prev, spark;
-{ /* Global Vars: CurrentProc, SparkQueueHd, SparkQueueTl */
- sparkq tmp;
-
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x10000 ) {
- fprintf(stderr,"** |%#x:%#x| prev=%#x->(%#x), (%#x)<-spark=%#x->(%#x) <-(%#x)\n",
- SparkQueueHd, SparkQueueTl,
- prev, (prev==NULL ? 0 : SPARK_NEXT(prev)),
- SPARK_PREV(spark), spark, SPARK_NEXT(spark),
- (SPARK_NEXT(spark)==NULL ? 0 : SPARK_PREV(SPARK_NEXT(spark))));
- }
-# endif
-
- tmp = SPARK_NEXT(spark);
- if (prev==NULL) {
- SparkQueueHd = SPARK_NEXT(spark);
- } else {
- SPARK_NEXT(prev) = SPARK_NEXT(spark);
- }
- if (SPARK_NEXT(spark)==NULL) {
- SparkQueueTl = prev;
- } else {
- SPARK_PREV(SPARK_NEXT(spark)) = prev;
- }
- if(SparkQueueHd == NULL)
- SparkQueueTl = NULL;
- SPARK_NEXT(spark) = NULL;
-
- DisposeSpark(spark);
-
- spark = tmp;
-# if defined(GRAN_CHECK)
- if ( RTSflags.GranFlags.debug & 0x10000 ) {
- fprintf(stderr,"## prev=%#x->(%#x)\n",
- prev, (prev==NULL ? 0 : SPARK_NEXT(prev)));
- }
-# endif
- return (tmp);
-}
-
-#if 0
-/* NB: These functions have been replaced by functions:
- EvacuateEvents, EvacuateSparks, (in ../storage/SMcopying.lc)
- LinkEvents, LinkSparks (in ../storage/SMcompacting.lc)
- Thus, GrAnSim does not need additional entries in the list of roots
- any more.
-*/
-
-I_
-SaveEventRoots(num_ptr_roots)
-I_ num_ptr_roots;
-{
- eventq event = EventHd;
- while(event != NULL)
- {
- if(EVENT_TYPE(event) == RESUMETHREAD ||
- EVENT_TYPE(event) == MOVETHREAD ||
- EVENT_TYPE(event) == CONTINUETHREAD ||
- /* EVENT_TYPE(event) >= CONTINUETHREAD1 || */
- EVENT_TYPE(event) == STARTTHREAD )
- StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
-
- else if(EVENT_TYPE(event) == MOVESPARK)
- StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(EVENT_SPARK(event));
-
- else if (EVENT_TYPE(event) == FETCHNODE ||
- EVENT_TYPE(event) == FETCHREPLY )
- {
- StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
- /* In the case of packet fetching, EVENT_NODE(event) points to */
- /* the packet (currently, malloced). The packet is just a list of */
- /* closure addresses, with the length of the list at index 1 (the */
- /* structure of the packet is defined in Pack.lc). */
- if ( RTSflags.GranFlags.DoGUMMFetching && (EVENT_TYPE(event)==FETCHREPLY)) {
- P_ buffer = (P_) EVENT_NODE(event);
- int size = (int) buffer[PACK_SIZE_LOCN], i;
-
- for (i = PACK_HDR_SIZE; i <= size-1; i++) {
- StorageMgrInfo.roots[num_ptr_roots++] = (P_) buffer[i];
- }
- } else
- StorageMgrInfo.roots[num_ptr_roots++] = EVENT_NODE(event);
- }
- else if (EVENT_TYPE(event) == GLOBALBLOCK)
- {
- StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
- StorageMgrInfo.roots[num_ptr_roots++] = EVENT_NODE(event);
- }
- else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
- {
- StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
- }
- event = EVENT_NEXT(event);
- }
- return(num_ptr_roots);
-}
-
-#if defined(DEPTH_FIRST_PRUNING)
-/* Is it worthwhile keeping the depth-first pruning code !? -- HWL */
-
-I_
-SaveSparkRoots(num_ptr_roots)
-I_ num_ptr_roots;
-{
- sparkq spark, /* prev, */ disposeQ=NULL;
- PROC proc;
- I_ i, sparkroots=0, prunedSparks=0;
- I_ tot_sparks[MAX_PROC], tot = 0;;
-
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- tot_sparks[proc] = 0;
- for(i = 0; i < SPARK_POOLS; ++i) {
- for(/* prev = &PendingSparksHd[proc][i],*/ spark = PendingSparksHd[proc][i];
- spark != NULL;
- /* prev = &SPARK_NEXT(spark), */ spark = SPARK_NEXT(spark))
- {
- if(++sparkroots <= MAX_SPARKS)
- {
- if ( RTSflags.GcFlags.giveStats )
- if (i==ADVISORY_POOL) {
- tot_sparks[proc]++;
- tot++;
- }
- StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(spark);
- }
- else
- {
- SPARK_NODE(spark) = PrelBase_Z91Z93_closure;
- if (prunedSparks==0) {
- disposeQ = spark;
- /*
- *prev = NULL;
- */
- }
- prunedSparks++;
- }
- } /* forall spark ... */
- if ( (RTSflags.GcFlags.giveStats) && (prunedSparks>0) ) {
- fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu excess sparks (> %lu) on proc %d for GC purposes\n",
- prunedSparks,MAX_SPARKS,proc);
- if (disposeQ == PendingSparksHd[proc][i])
- PendingSparksHd[proc][i] = NULL;
- else
- SPARK_NEXT(SPARK_PREV(disposeQ)) = NULL;
- DisposeSparkQ(disposeQ);
- prunedSparks = 0;
- disposeQ = NULL;
- }
- } /* forall i ... */
- } /*forall proc .. */
-
- if ( RTSflags.GcFlags.giveStats ) {
- fprintf(RTSflags.GcFlags.statsFile,
- "Spark statistics (after pruning) (total sparks = %d):",tot);
- for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
- if (proc % 4 == 0)
- fprintf(RTSflags.GcFlags.statsFile,"\n> ");
- fprintf(RTSflags.GcFlags.statsFile,"\tPE %d: %d ",proc,tot_sparks[proc]);
- }
- fprintf(RTSflags.GcFlags.statsFile,".\n");
- }
-
- return(num_ptr_roots);
-}
-
-#else /* !DEPTH_FIRST_PRUNING */
-
-/* In case of an excessive number of sparks, depth first pruning is a Bad */
-/* Idea as we might end up with all remaining sparks on processor 0 and */
-/* none on the other processors. So, this version uses breadth first */
-/* pruning. -- HWL */
-
-I_
-SaveSparkRoots(num_ptr_roots)
-I_ num_ptr_roots;
-{
- sparkq spark,
- curr_spark[MAX_PROC][SPARK_POOLS];
- PROC proc;
- W_ allProcs = 0,
- endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
- I_ i, sparkroots=0,
- prunedSparks[MAX_PROC][SPARK_POOLS];
- I_ tot_sparks[MAX_PROC], tot = 0;;
-
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x40 )
- fprintf(stderr,"D> Saving spark roots for GC ...\n");
-# endif
-
- /* Init */
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- allProcs |= PE_NUMBER(proc);
- tot_sparks[proc] = 0;
- for(i = 0; i < SPARK_POOLS; ++i) {
- curr_spark[proc][i] = PendingSparksHd[proc][i];
- prunedSparks[proc][i] = 0;
- endQueues[i] = 0;
- finishedQueues[i] = 0;
- }
- }
-
- /* Breadth first pruning */
- do {
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(i = 0; i < SPARK_POOLS; ++i) {
- spark = curr_spark[proc][i];
- if ( spark != NULL ) {
-
- if(++sparkroots <= MAX_SPARKS)
- {
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( (RTSflags.GranFlags.debug & 0x1000) &&
- (RTSflags.GcFlags.giveStats) )
- fprintf(RTSflags.GcFlags.statsFile,"Saving Spark Root %d(proc: %d; pool: %d): 0x%lx \t(info ptr=%#lx)\n",
- num_ptr_roots,proc,i,SPARK_NODE(spark),
- INFO_PTR(SPARK_NODE(spark)));
-# endif
- if ( RTSflags.GcFlags.giveStats )
- if (i==ADVISORY_POOL) {
- tot_sparks[proc]++;
- tot++;
- }
- StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(spark);
- curr_spark[proc][i] = spark = SPARK_NEXT(spark);
- }
- else /* sparkroots > MAX_SPARKS */
- {
- if (curr_spark[proc][i] == PendingSparksHd[proc][i])
- PendingSparksHd[proc][i] = NULL;
- else
- SPARK_NEXT(SPARK_PREV(curr_spark[proc][i])) = NULL;
- PendingSparksTl[proc][i] = SPARK_PREV(curr_spark[proc][i]);
- endQueues[i] |= PE_NUMBER(proc);
- }
- } else { /* spark == NULL ; actually, this only has to be done once */
- endQueues[i] |= PE_NUMBER(proc);
- }
- }
- }
- } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
-
- /* The buffer for spark roots in StorageMgrInfo.roots is full */
- /* now. Prune all sparks on all processor starting with */
- /* curr_spark[proc][i]. */
-
- do {
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(i = 0; i < SPARK_POOLS; ++i) {
- spark = curr_spark[proc][i];
-
- if ( spark != NULL ) {
- SPARK_NODE(spark) = PrelBase_Z91Z93_closure;
- curr_spark[proc][i] = SPARK_NEXT(spark);
-
- prunedSparks[proc][i]++;
- DisposeSpark(spark);
- } else {
- finishedQueues[i] |= PE_NUMBER(proc);
- }
- }
- }
- } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
-
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x1000) {
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(i = 0; i < SPARK_POOLS; ++i) {
- if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][i]>0)) {
- fprintf(RTSflags.GcFlags.statsFile,
- "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
- prunedSparks[proc][i],proc,i);
- }
- }
- }
-
- if ( RTSflags.GcFlags.giveStats ) {
- fprintf(RTSflags.GcFlags.statsFile,
- "Spark statistics (after discarding) (total sparks = %d):",tot);
- for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
- if (proc % 4 == 0)
- fprintf(RTSflags.GcFlags.statsFile,"\n> ");
- fprintf(RTSflags.GcFlags.statsFile,
- "\tPE %d: %d ",proc,tot_sparks[proc]);
- }
- fprintf(RTSflags.GcFlags.statsFile,".\n");
- }
- }
-# endif
-
- return(num_ptr_roots);
-}
-
-#endif /* DEPTH_FIRST_PRUNING */
-
-/*
- GC roots must be restored in *reverse order*.
- The recursion is a little ugly, but is better than
- in-place pointer reversal.
-*/
-
-static I_
-RestoreEvtRoots(event,num_ptr_roots)
-eventq event;
-I_ num_ptr_roots;
-{
- if(event != NULL)
- {
- num_ptr_roots = RestoreEvtRoots(EVENT_NEXT(event),num_ptr_roots);
-
- if(EVENT_TYPE(event) == RESUMETHREAD ||
- EVENT_TYPE(event) == MOVETHREAD ||
- EVENT_TYPE(event) == CONTINUETHREAD ||
- /* EVENT_TYPE(event) >= CONTINUETHREAD1 || */
- EVENT_TYPE(event) == STARTTHREAD )
- EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
-
- else if(EVENT_TYPE(event) == MOVESPARK )
- SPARK_NODE(EVENT_SPARK(event)) = StorageMgrInfo.roots[--num_ptr_roots];
-
- else if (EVENT_TYPE(event) == FETCHNODE ||
- EVENT_TYPE(event) == FETCHREPLY )
- {
- if ( RTSflags.GranFlags.DoGUMMFetching && (EVENT_TYPE(event)==FETCHREPLY)) {
- P_ buffer = (P_) EVENT_NODE(event);
- int size = (int) buffer[PACK_SIZE_LOCN], i;
-
- for (i = size-1; i >= PACK_HDR_SIZE; i--) {
- buffer[i] = StorageMgrInfo.roots[--num_ptr_roots];
- }
- } else
- EVENT_NODE(event) = StorageMgrInfo.roots[--num_ptr_roots];
-
- EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
- }
- else if (EVENT_TYPE(event) == GLOBALBLOCK)
- {
- EVENT_NODE(event) = StorageMgrInfo.roots[--num_ptr_roots];
- EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
- }
- else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
- {
- EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
- }
- }
- return(num_ptr_roots);
-}
-
-I_
-RestoreEventRoots(num_ptr_roots)
-I_ num_ptr_roots;
-{
- return(RestoreEvtRoots(EventHd,num_ptr_roots));
-}
-
-#if defined(DEPTH_FIRST_PRUNING)
-
-static I_
-RestoreSpkRoots(spark,num_ptr_roots,sparkroots)
-sparkq spark;
-I_ num_ptr_roots, sparkroots;
-{
- if(spark != NULL)
- {
- num_ptr_roots = RestoreSpkRoots(SPARK_NEXT(spark),num_ptr_roots,++sparkroots);
- if(sparkroots <= MAX_SPARKS)
- {
- P_ n = SPARK_NODE(spark);
- SPARK_NODE(spark) = StorageMgrInfo.roots[--num_ptr_roots];
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( RTSflags.GranFlags.debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,
- "Restoring Spark Root %d: 0x%lx \t(info ptr=%#lx\n",
- num_ptr_roots,SPARK_NODE(spark),
- INFO_PTR(SPARK_NODE(spark)));
-# endif
- }
-# if defined(GRAN_CHECK) && defined(GRAN)
- else
- if ( RTSflags.GranFlags.debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,
- "Error in RestoreSpkRoots (%d; @ spark %#lx): More than MAX_SPARKS (%d) sparks\n",
- num_ptr_roots,SPARK_NODE(spark),MAX_SPARKS);
-# endif
-
- }
- return(num_ptr_roots);
-}
-
-I_
-RestoreSparkRoots(num_ptr_roots)
-I_ num_ptr_roots;
-{
- PROC proc;
- I_ i;
-
-#if defined(GRAN_JSM_SPARKS)
- fprintf(stderr,"Error: RestoreSparkRoots should be never be entered in a JSM style sparks set-up\n");
- EXIT(EXIT_FAILURE);
-#endif
-
- /* NB: PROC is currently an unsigned datatype i.e. proc>=0 is always */
- /* true ((PROC)-1 == (PROC)255). So we need a second clause in the head */
- /* of the for loop. For i that is currently not necessary. C is really */
- /* impressive in datatype abstraction! -- HWL */
-
- for(proc = RTSflags.GranFlags.proc - 1; (proc >= 0) && (proc < RTSflags.GranFlags.proc); --proc) {
- for(i = SPARK_POOLS - 1; (i >= 0) && (i < SPARK_POOLS) ; --i) {
- num_ptr_roots = RestoreSpkRoots(PendingSparksHd[proc][i],num_ptr_roots,0);
- }
- }
- return(num_ptr_roots);
-}
-
-#else /* !DEPTH_FIRST_PRUNING */
-
-I_
-RestoreSparkRoots(num_ptr_roots)
-I_ num_ptr_roots;
-{
- sparkq spark,
- curr_spark[MAX_PROC][SPARK_POOLS];
- PROC proc;
- I_ i, max_len, len, pool, count,
- queue_len[MAX_PROC][SPARK_POOLS];
-
- /* NB: PROC is currently an unsigned datatype i.e. proc>=0 is always */
- /* true ((PROC)-1 == (PROC)255). So we need a second clause in the head */
- /* of the for loop. For i that is currently not necessary. C is really */
- /* impressive in datatype abstraction! -- HWL */
-
- max_len=0;
- for (proc=0; proc < RTSflags.GranFlags.proc; proc++) {
- for (i=0; i<SPARK_POOLS; i++) {
- curr_spark[proc][i] = PendingSparksTl[proc][i];
- queue_len[proc][i] = spark_queue_len(proc,i);
- max_len = (queue_len[proc][i]>max_len) ? queue_len[proc][i] : max_len;
- }
- }
-
- for (len=max_len; len > 0; len--){
- for(proc = RTSflags.GranFlags.proc - 1; (proc >= 0) && (proc < RTSflags.GranFlags.proc); --proc) {
- for(i = SPARK_POOLS - 1; (i >= 0) && (i < SPARK_POOLS) ; --i) {
- if (queue_len[proc][i]>=len) {
- spark = curr_spark[proc][i];
- SPARK_NODE(spark) = StorageMgrInfo.roots[--num_ptr_roots];
-# if defined(GRAN_CHECK) && defined(GRAN)
- count++;
- if ( (RTSflags.GranFlags.debug & 0x1000) &&
- (RTSflags.GcFlags.giveStats) )
- fprintf(RTSflags.GcFlags.statsFile,
- "Restoring Spark Root %d (PE %u, pool %u): 0x%lx \t(info ptr=%#lx)\n",
- num_ptr_roots,proc,i,SPARK_NODE(spark),
- INFO_PTR(SPARK_NODE(spark)));
-# endif
- curr_spark[proc][i] = SPARK_PREV(spark);
- /*
- num_ptr_roots = RestoreSpkRoots(PendingSparksHd[proc][i],
- num_ptr_roots,0);
- */
- }
- }
- }
- }
-# if defined(GRAN_CHECK) && defined(GRAN)
- if ( (RTSflags.GranFlags.debug & 0x1000) && (RTSflags.GcFlags.giveStats) )
- fprintf(RTSflags.GcFlags.statsFile,"Number of restored spark roots: %d\n",
- count);
-# endif
- return(num_ptr_roots);
-}
-
-#endif /* DEPTH_FIRST_PRUNING */
-
-#endif /* 0 */
-
-#endif /* GRAN */
-
-#endif /* CONCURRENT */ /* the whole module! */
-\end{code}
-
-
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1993
-%
-%************************************************************************
-%* *
-\section[Ticky.lc]{Stuff for ``ticky-ticky'' profiling}
-%* *
-%************************************************************************
-
-Goes with \tr{includes/Ticky.lh}; more documentation there.
-
-%************************************************************************
-%* *
-\subsection[Ticky-counters]{Declare all the counters}
-%* *
-%************************************************************************
-
-\begin{code}
-#define NULL_REG_MAP /* Not threaded */
-
-#include "../storage/SMinternal.h" /* Bad boy, Will (ToDo) */
-
-#if defined(TICKY_TICKY)
-
-I_ ALLOC_HEAP_ctr = 0;
-I_ ALLOC_HEAP_tot = 0;
-
-PP_ max_SpA; /* set in re_enterable_part_of_main */
-P_ max_SpB;
-
-/* not used at all
-I_ A_STK_REUSE_ctr = 0;
-I_ B_STK_REUSE_ctr = 0;
-*/
-I_ A_STK_STUB_ctr = 0;
-
-I_ ALLOC_FUN_ctr = 0;
-I_ ALLOC_FUN_adm = 0;
-I_ ALLOC_FUN_gds = 0;
-I_ ALLOC_FUN_slp = 0;
-I_ ALLOC_FUN_hst[5] = {0,0,0,0,0};
-I_ ALLOC_THK_ctr = 0;
-I_ ALLOC_THK_adm = 0;
-I_ ALLOC_THK_gds = 0;
-I_ ALLOC_THK_slp = 0;
-I_ ALLOC_THK_hst[5] = {0,0,0,0,0};
-I_ ALLOC_CON_ctr = 0;
-I_ ALLOC_CON_adm = 0;
-I_ ALLOC_CON_gds = 0;
-I_ ALLOC_CON_slp = 0;
-I_ ALLOC_CON_hst[5] = {0,0,0,0,0};
-I_ ALLOC_TUP_ctr = 0;
-I_ ALLOC_TUP_adm = 0;
-I_ ALLOC_TUP_gds = 0;
-I_ ALLOC_TUP_slp = 0;
-I_ ALLOC_TUP_hst[5] = {0,0,0,0,0};
-I_ ALLOC_BH_ctr = 0;
-I_ ALLOC_BH_adm = 0;
-I_ ALLOC_BH_gds = 0;
-I_ ALLOC_BH_slp = 0;
-I_ ALLOC_BH_hst[5] = {0,0,0,0,0};
-I_ ALLOC_PRIM_ctr = 0;
-I_ ALLOC_PRIM_adm = 0;
-I_ ALLOC_PRIM_gds = 0;
-I_ ALLOC_PRIM_slp = 0;
-I_ ALLOC_PRIM_hst[5] = {0,0,0,0,0};
-I_ ALLOC_UPD_PAP_ctr = 0;
-I_ ALLOC_UPD_PAP_adm = 0;
-I_ ALLOC_UPD_PAP_gds = 0;
-I_ ALLOC_UPD_PAP_slp = 0;
-I_ ALLOC_UPD_PAP_hst[5] = {0,0,0,0,0};
-
-#ifdef CONCURRENT
-I_ ALLOC_STK_ctr = 0;
-I_ ALLOC_STK_adm = 0;
-I_ ALLOC_STK_gds = 0;
-I_ ALLOC_STK_slp = 0;
-I_ ALLOC_STK_hst[5] = {0,0,0,0,0};
-I_ ALLOC_TSO_ctr = 0;
-I_ ALLOC_TSO_adm = 0;
-I_ ALLOC_TSO_gds = 0;
-I_ ALLOC_TSO_slp = 0;
-I_ ALLOC_TSO_hst[5] = {0,0,0,0,0};
-
-# ifdef PAR
-I_ ALLOC_FMBQ_ctr = 0;
-I_ ALLOC_FMBQ_adm = 0;
-I_ ALLOC_FMBQ_gds = 0;
-I_ ALLOC_FMBQ_slp = 0;
-I_ ALLOC_FMBQ_hst[5] = {0,0,0,0,0};
-I_ ALLOC_FME_ctr = 0;
-I_ ALLOC_FME_adm = 0;
-I_ ALLOC_FME_gds = 0;
-I_ ALLOC_FME_slp = 0;
-I_ ALLOC_FME_hst[5] = {0,0,0,0,0};
-I_ ALLOC_BF_ctr = 0;
-I_ ALLOC_BF_adm = 0;
-I_ ALLOC_BF_gds = 0;
-I_ ALLOC_BF_slp = 0;
-I_ ALLOC_BF_hst[5] = {0,0,0,0,0};
-# endif
-#endif
-
-I_ ENT_VIA_NODE_ctr = 0;
-I_ ENT_CON_ctr = 0;
-I_ ENT_FUN_STD_ctr = 0;
-I_ ENT_FUN_DIRECT_ctr = 0;
-I_ ENT_IND_ctr = 0;
-I_ ENT_PAP_ctr = 0;
-I_ ENT_THK_ctr = 0;
-
-I_ RET_NEW_IN_HEAP_ctr = 0;
-I_ RET_NEW_IN_REGS_ctr = 0;
-I_ RET_OLD_IN_HEAP_ctr = 0;
-I_ RET_OLD_IN_REGS_ctr = 0;
-I_ RET_SEMI_BY_DEFAULT_ctr = 0;
-I_ RET_SEMI_IN_HEAP_ctr = 0;
-I_ RET_SEMI_IN_REGS_ctr = 0;
-I_ RET_SEMI_FAILED_IND_ctr = 0;
-I_ RET_SEMI_FAILED_UNEVAL_ctr = 0;
-I_ VEC_RETURN_ctr = 0;
-
-I_ RET_NEW_IN_HEAP_hst[9] = {0,0,0,0,0,0,0,0,0};
-I_ RET_NEW_IN_REGS_hst[9] = {0,0,0,0,0,0,0,0,0};
-I_ RET_OLD_IN_HEAP_hst[9] = {0,0,0,0,0,0,0,0,0};
-I_ RET_OLD_IN_REGS_hst[9] = {0,0,0,0,0,0,0,0,0};
-/* no such thing: I_ RET_SEMI_BY_DEFAULT_hst[9] = {0,0,0,0,0,0,0,0,0}; */
-I_ RET_SEMI_IN_HEAP_hst[9] = {0,0,0,0,0,0,0,0,0};
-I_ RET_SEMI_IN_REGS_hst[9] = {0,0,0,0,0,0,0,0,0};
-I_ RET_VEC_RETURN_hst[9] = {0,0,0,0,0,0,0,0,0};
-
-I_ RET_SEMI_loads_avoided = 0;
-
-I_ ReturnInRegsNodeValid = 0; /* i.e., False */
-
-I_ UPDF_OMITTED_ctr = 0;
-I_ UPDF_STD_PUSHED_ctr = 0;
-I_ UPDF_CON_PUSHED_ctr = 0;
-I_ UPDF_HOLE_PUSHED_ctr = 0;
-
-I_ UPDF_RCC_PUSHED_ctr = 0;
-I_ UPDF_RCC_OMITTED_ctr = 0;
-
-I_ UPD_EXISTING_ctr = 0;
-I_ UPD_SQUEEZED_ctr = 0;
-I_ UPD_CON_W_NODE_ctr = 0;
-I_ UPD_CON_IN_PLACE_ctr = 0;
-I_ UPD_CON_IN_NEW_ctr = 0;
-I_ UPD_PAP_IN_PLACE_ctr = 0;
-I_ UPD_PAP_IN_NEW_ctr = 0;
-
-I_ UPD_CON_IN_PLACE_hst[9] = {0,0,0,0,0,0,0,0,0};
-I_ UPD_CON_IN_NEW_hst[9] = {0,0,0,0,0,0,0,0,0};
-I_ UPD_PAP_IN_NEW_hst[9] = {0,0,0,0,0,0,0,0,0};
-
-I_ UPD_ENTERED_hst[9] = {0,0,0,0,0,0,0,0,0};
-
-I_ UPD_NEW_IND_ctr = 0;
-I_ UPD_NEW_IN_PLACE_PTRS_ctr = 0;
-I_ UPD_NEW_IN_PLACE_NOPTRS_ctr = 0;
-I_ UPD_OLD_IND_ctr = 0;
-I_ UPD_OLD_IN_PLACE_PTRS_ctr = 0;
-I_ UPD_OLD_IN_PLACE_NOPTRS_ctr = 0;
-
-I_ UPD_IN_PLACE_COPY_ctr = 0;
-
-I_ GC_SEL_ABANDONED_ctr = 0;
-I_ GC_SEL_MINOR_ctr = 0;
-I_ GC_SEL_MAJOR_ctr = 0;
-
-I_ GC_SHORT_IND_ctr = 0;
-I_ GC_SHORT_CAF_ctr = 0;
-I_ GC_COMMON_CHARLIKE_ctr = 0;
-I_ GC_COMMON_INTLIKE_ctr = 0;
-I_ GC_COMMON_INTLIKE_FAIL_ctr = 0;
-I_ GC_COMMON_CONST_ctr = 0;
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Ticky-print]{Print out all the counters}
-%* *
-%************************************************************************
-
-\begin{code}
-static void printRegisteredCounterInfo (FILE *); /* fwd decl */
-
-#define INTAVG(a,b) ((b == 0) ? 0.0 : ((StgDouble) (a) / (StgDouble) (b)))
-#define PC(a) (100.0 * a)
-
-#define AVG(thing) \
- StgDouble CAT2(avg,thing) = INTAVG(CAT2(tot,thing),CAT2(ctr,thing))
-
-void
-PrintTickyInfo()
-{
- I_ i;
- I_ tot_allocs = /* total number of things allocated */
- ALLOC_FUN_ctr + ALLOC_THK_ctr + ALLOC_CON_ctr + ALLOC_TUP_ctr +
-#ifdef CONCURRENT
- ALLOC_STK_ctr + ALLOC_TSO_ctr +
-# ifdef PAR
- ALLOC_FMBQ_ctr + ALLOC_FME_ctr + ALLOC_BF_ctr +
-# endif
-#endif
- ALLOC_BH_ctr + ALLOC_UPD_PAP_ctr + ALLOC_PRIM_ctr;
- I_ tot_adm_wds = /* total number of admin words allocated */
- ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm +
-#ifdef CONCURRENT
- ALLOC_STK_adm + ALLOC_TSO_adm +
-# ifdef PAR
- ALLOC_FMBQ_adm + ALLOC_FME_adm + ALLOC_BF_adm +
-# endif
-#endif
- ALLOC_BH_adm + ALLOC_UPD_PAP_adm + ALLOC_PRIM_adm;
- I_ tot_gds_wds = /* total number of words of ``good stuff'' allocated */
- ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds +
-#ifdef CONCURRENT
- ALLOC_STK_gds + ALLOC_TSO_gds +
-# ifdef PAR
- ALLOC_FMBQ_gds + ALLOC_FME_gds + ALLOC_BF_gds +
-# endif
-#endif
- ALLOC_BH_gds + ALLOC_UPD_PAP_gds + ALLOC_PRIM_gds;
- I_ tot_slp_wds = /* total number of ``slop'' words allocated */
- ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp +
-#ifdef CONCURRENT
- ALLOC_STK_slp + ALLOC_TSO_slp +
-# ifdef PAR
- ALLOC_FMBQ_slp + ALLOC_FME_slp + ALLOC_BF_slp +
-# endif
-#endif
- ALLOC_BH_slp + ALLOC_UPD_PAP_slp + ALLOC_PRIM_slp;
- I_ tot_wds = /* total words */
- tot_adm_wds + tot_gds_wds + tot_slp_wds;
-
- I_ tot_enters =
- ENT_CON_ctr + ENT_FUN_DIRECT_ctr +
- ENT_IND_ctr + ENT_PAP_ctr + ENT_THK_ctr;
- I_ jump_direct_enters =
- tot_enters - ENT_VIA_NODE_ctr;
- I_ bypass_enters =
- ENT_FUN_DIRECT_ctr -
- (ENT_FUN_STD_ctr - UPD_PAP_IN_PLACE_ctr - UPD_PAP_IN_NEW_ctr);
-
- I_ tot_returns_in_regs =
- RET_NEW_IN_REGS_ctr + RET_OLD_IN_REGS_ctr + RET_SEMI_IN_REGS_ctr;
- I_ tot_returns_in_heap =
- RET_NEW_IN_HEAP_ctr + RET_OLD_IN_HEAP_ctr + RET_SEMI_IN_HEAP_ctr + RET_SEMI_BY_DEFAULT_ctr/*?*/;
- I_ tot_returns_of_new =
- RET_NEW_IN_REGS_ctr + RET_NEW_IN_HEAP_ctr;
- I_ tot_returns_of_old = /* NB: NOT USED ?! 94/05 WDP */
- RET_OLD_IN_REGS_ctr + RET_OLD_IN_HEAP_ctr +
- RET_SEMI_BY_DEFAULT_ctr + RET_SEMI_IN_HEAP_ctr + RET_SEMI_IN_REGS_ctr /*?*/;
-
- I_ tot_returns =
- tot_returns_in_regs + tot_returns_in_heap;
-
- I_ tot_upd_frames =
- UPDF_STD_PUSHED_ctr + UPDF_CON_PUSHED_ctr; /*DBH*/
-
- I_ con_updates =
- UPD_CON_W_NODE_ctr + UPD_CON_IN_PLACE_ctr + UPD_CON_IN_NEW_ctr;
- I_ pap_updates =
- UPD_PAP_IN_PLACE_ctr + UPD_PAP_IN_NEW_ctr;
- I_ tot_updates =
- UPD_EXISTING_ctr + UPD_SQUEEZED_ctr + con_updates + pap_updates;
- I_ tot_in_place_updates =
- UPD_CON_IN_PLACE_ctr + UPD_PAP_IN_PLACE_ctr;
-
- I_ tot_new_updates =
- UPD_NEW_IN_PLACE_NOPTRS_ctr + UPD_NEW_IN_PLACE_PTRS_ctr + UPD_NEW_IND_ctr;
- I_ tot_old_updates =
- UPD_OLD_IN_PLACE_NOPTRS_ctr + UPD_OLD_IN_PLACE_PTRS_ctr + UPD_OLD_IND_ctr;
- I_ tot_gengc_updates =
- tot_new_updates + tot_old_updates;
-
- FILE *tf = RTSflags.TickyFlags.tickyFile;
-
- fprintf(tf,"\n\nALLOCATIONS: %ld (%ld words total: %ld admin, %ld goods, %ld slop)\n",
- tot_allocs, tot_wds, tot_adm_wds, tot_gds_wds, tot_slp_wds);
- fprintf(tf,"\t\t\t\ttotal words:\t 2 3 4 5 6+\n");
-
-#define ALLOC_HISTO_MAGIC(categ) \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[0], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[1], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[2], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[3], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[4], CAT3(ALLOC_,categ,_ctr))))
-
- fprintf(tf,"%7ld (%5.1f%%) function values",
- ALLOC_FUN_ctr,
- PC(INTAVG(ALLOC_FUN_ctr, tot_allocs)));
- if (ALLOC_FUN_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FUN));
-
- fprintf(tf,"\n%7ld (%5.1f%%) thunks",
- ALLOC_THK_ctr,
- PC(INTAVG(ALLOC_THK_ctr, tot_allocs)));
- if (ALLOC_THK_ctr != 0)
- fprintf(tf,"\t\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(THK));
-
- fprintf(tf,"\n%7ld (%5.1f%%) data values",
- ALLOC_CON_ctr,
- PC(INTAVG(ALLOC_CON_ctr, tot_allocs)));
- if (ALLOC_CON_ctr != 0)
- fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(CON));
-
- fprintf(tf,"\n%7ld (%5.1f%%) big tuples",
- ALLOC_TUP_ctr,
- PC(INTAVG(ALLOC_TUP_ctr, tot_allocs)));
- if (ALLOC_TUP_ctr != 0)
- fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(TUP));
-
- fprintf(tf,"\n%7ld (%5.1f%%) black holes",
- ALLOC_BH_ctr,
- PC(INTAVG(ALLOC_BH_ctr, tot_allocs)));
- if (ALLOC_BH_ctr != 0)
- fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(BH));
-
- fprintf(tf,"\n%7ld (%5.1f%%) prim things",
- ALLOC_PRIM_ctr,
- PC(INTAVG(ALLOC_PRIM_ctr, tot_allocs)));
- if (ALLOC_PRIM_ctr != 0)
- fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(PRIM));
-
- fprintf(tf,"\n%7ld (%5.1f%%) partial applications",
- ALLOC_UPD_PAP_ctr,
- PC(INTAVG(ALLOC_UPD_PAP_ctr, tot_allocs)));
- if (ALLOC_UPD_PAP_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(UPD_PAP));
-
-#ifdef CONCURRENT
- fprintf(tf,"\n%7ld (%5.1f%%) stack objects",
- ALLOC_STK_ctr,
- PC(INTAVG(ALLOC_STK_ctr, tot_allocs)));
- if (ALLOC_STK_ctr != 0)
- fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(STK));
- fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_TSO_ctr,
- PC(INTAVG(ALLOC_TSO_ctr, tot_allocs)));
- if (ALLOC_TSO_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(TSO));
-# ifdef PAR
- fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_FMBQ_ctr,
- PC(INTAVG(ALLOC_FMBQ_ctr, tot_allocs)));
- if (ALLOC_FMBQ_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FMBQ));
- fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_FME_ctr,
- PC(INTAVG(ALLOC_FME_ctr, tot_allocs)));
- if (ALLOC_FME_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FME));
- fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_BF_ctr,
- PC(INTAVG(ALLOC_BF_ctr, tot_allocs)));
- if (ALLOC_BF_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(BF));
-# endif
-#endif
- fprintf(tf,"\n");
-
- fprintf(tf,"\nTotal storage-manager allocations: %ld (%ld words)\n\t[%ld words lost to speculative heap-checks]\n", ALLOC_HEAP_ctr, ALLOC_HEAP_tot, ALLOC_HEAP_tot - tot_wds);
-
- fprintf(tf,"\nSTACK USAGE:\n"); /* NB: some bits are direction sensitive */
- fprintf(tf,"\tA stack slots stubbed: %ld\n", A_STK_STUB_ctr);
-/* not used at all
- fprintf(tf,"\tA stack slots re-used: %ld\n", A_STK_REUSE_ctr);
- fprintf(tf,"\tB stack slots re-used: %ld\n", B_STK_REUSE_ctr);
-*/
-#ifndef CONCURRENT
- fprintf(tf,"\tA stack max. depth: %ld words\n",
- (I_) (stackInfo.botA - max_SpA));
- fprintf(tf,"\tB stack max. depth: %ld words\n",
- (I_) (max_SpB - stackInfo.botB)); /* And cheating, too (ToDo) */
-#endif
-
- fprintf(tf,"\nENTERS: %ld of which %ld (%.1f%%) direct to the entry code\n\t\t [the rest indirected via Node's info ptr]\n",
- tot_enters,
- jump_direct_enters,
- PC(INTAVG(jump_direct_enters,tot_enters)));
- fprintf(tf,"%7ld (%5.1f%%) thunks\n",
- ENT_THK_ctr,
- PC(INTAVG(ENT_THK_ctr,tot_enters)));
- fprintf(tf,"%7ld (%5.1f%%) data values\n",
- ENT_CON_ctr,
- PC(INTAVG(ENT_CON_ctr,tot_enters)));
- fprintf(tf,"%7ld (%5.1f%%) function values\n\t\t [of which %ld (%.1f%%) bypassed arg-satisfaction chk]\n",
- ENT_FUN_DIRECT_ctr,
- PC(INTAVG(ENT_FUN_DIRECT_ctr,tot_enters)),
- bypass_enters,
- PC(INTAVG(bypass_enters,ENT_FUN_DIRECT_ctr)));
- fprintf(tf,"%7ld (%5.1f%%) partial applications\n",
- ENT_PAP_ctr,
- PC(INTAVG(ENT_PAP_ctr,tot_enters)));
- fprintf(tf,"%7ld (%5.1f%%) indirections\n",
- ENT_IND_ctr,
- PC(INTAVG(ENT_IND_ctr,tot_enters)));
-
- fprintf(tf,"\nRETURNS: %ld\n", tot_returns);
- fprintf(tf,"%7ld (%5.1f%%) in registers [the rest in the heap]\n",
- tot_returns_in_regs,
- PC(INTAVG(tot_returns_in_regs,tot_returns)));
- fprintf(tf,"%7ld (%5.1f%%) from entering a new constructor\n\t\t [the rest from entering an existing constructor]\n",
- tot_returns_of_new,
- PC(INTAVG(tot_returns_of_new,tot_returns)));
- fprintf(tf,"%7ld (%5.1f%%) vectored [the rest unvectored]\n",
- VEC_RETURN_ctr,
- PC(INTAVG(VEC_RETURN_ctr,tot_returns)));
-
-/*
- fprintf(tf, "RET_xxx: %7ld: ", RET_xxx_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
- PC(INTAVG(RET_xxx_hst[i],RET_xxx_ctr))); }
- fprintf(tf, "\n");
-*/
- fprintf(tf, "\nRET_OLD_IN_REGS: %7ld: ", RET_OLD_IN_REGS_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
- PC(INTAVG(RET_OLD_IN_REGS_hst[i],RET_OLD_IN_REGS_ctr))); }
- fprintf(tf, "\n");
- fprintf(tf, "RET_NEW_IN_REGS: %7ld: ", RET_NEW_IN_REGS_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
- PC(INTAVG(RET_NEW_IN_REGS_hst[i],RET_NEW_IN_REGS_ctr))); }
- fprintf(tf, "\n");
- fprintf(tf, "RET_OLD_IN_HEAP: %7ld: ", RET_OLD_IN_HEAP_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
- PC(INTAVG(RET_OLD_IN_HEAP_hst[i],RET_OLD_IN_HEAP_ctr))); }
- fprintf(tf, "\n");
- fprintf(tf, "RET_NEW_IN_HEAP: %7ld: ", RET_NEW_IN_HEAP_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
- PC(INTAVG(RET_NEW_IN_HEAP_hst[i],RET_NEW_IN_HEAP_ctr))); }
- fprintf(tf, "\n");
- fprintf(tf, "\nRET_VEC_RETURN : %7ld: ", VEC_RETURN_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
- PC(INTAVG(RET_VEC_RETURN_hst[i],VEC_RETURN_ctr))); }
- fprintf(tf, "\n");
-
- fprintf(tf,"\nUPDATE FRAMES: %ld (%ld omitted from thunks)\n",
- tot_upd_frames,
- UPDF_OMITTED_ctr);
- fprintf(tf,"%7ld (%5.1f%%) standard frames\n",
- UPDF_STD_PUSHED_ctr,
- PC(INTAVG(UPDF_STD_PUSHED_ctr,tot_upd_frames)));
- fprintf(tf,"%7ld (%5.1f%%) constructor frames\n",
- UPDF_CON_PUSHED_ctr,
- PC(INTAVG(UPDF_CON_PUSHED_ctr,tot_upd_frames)));
- fprintf(tf,"\t\t [of which %ld (%.1f%%) were for black-holes]\n",
- UPDF_HOLE_PUSHED_ctr,
- PC(INTAVG(UPDF_HOLE_PUSHED_ctr,UPDF_CON_PUSHED_ctr))); /*DBH*/
-
- if (UPDF_RCC_PUSHED_ctr != 0)
- fprintf(tf,"%7ld restore cost centre frames (%ld omitted)\n",
- UPDF_RCC_PUSHED_ctr,
- UPDF_RCC_OMITTED_ctr);
-
- fprintf(tf,"\nUPDATES: %ld\n", tot_updates);
- fprintf(tf,"%7ld (%5.1f%%) data values\n\t\t [%ld in place, %ld allocated new space, %ld with Node]\n",
- con_updates,
- PC(INTAVG(con_updates,tot_updates)),
- UPD_CON_IN_PLACE_ctr, UPD_CON_IN_NEW_ctr, UPD_CON_W_NODE_ctr);
- fprintf(tf,"%7ld (%5.1f%%) partial applications\n\t\t [%ld in place, %ld allocated new space]\n",
- pap_updates,
- PC(INTAVG(pap_updates,tot_updates)),
- UPD_PAP_IN_PLACE_ctr, UPD_PAP_IN_NEW_ctr);
- fprintf(tf,"%7ld (%5.1f%%) updates to existing heap objects (%ld by squeezing)\n",
- UPD_EXISTING_ctr + UPD_SQUEEZED_ctr,
- PC(INTAVG(UPD_EXISTING_ctr + UPD_SQUEEZED_ctr, tot_updates)),
- UPD_SQUEEZED_ctr);
- fprintf(tf,"%7ld (%5.1f%%) in-place updates copied\n",
- UPD_IN_PLACE_COPY_ctr,
- PC(INTAVG(UPD_IN_PLACE_COPY_ctr,tot_in_place_updates)));
-#if 0
- if (UPD_ENTERED_ctr != 0) {
- fprintf(tf,"%7ld (%5.1f%%) subsequently entered\n",
- UPD_ENTERED_ctr,
- PC(INTAVG(UPD_ENTERED_ctr,tot_updates)));
- fprintf(tf,"%7ld (%5.1f%%) subsequently entered more than once\n",
- UPD_ENTERED_AGAIN_ctr,
- PC(INTAVG(UPD_ENTERED_AGAIN_ctr,tot_updates)));
- }
-#endif
-/*
- fprintf(tf, "UPD_xxx: %7ld: ", UPD_xxx_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_xxx_hst[i]); }
- fprintf(tf, "\n");
-*/
- fprintf(tf, "UPD_CON_IN_PLACE: %7ld: ", UPD_CON_IN_PLACE_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_CON_IN_PLACE_hst[i]); }
- fprintf(tf, "\n");
- fprintf(tf, "UPD_CON_IN_NEW: %7ld: ", UPD_CON_IN_NEW_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_CON_IN_NEW_hst[i]); }
- fprintf(tf, "\n");
- fprintf(tf, "UPD_PAP_IN_NEW: %7ld: ", UPD_PAP_IN_NEW_ctr);
- for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_PAP_IN_NEW_hst[i]); }
- fprintf(tf, "\n");
-
- if (tot_gengc_updates != 0) {
- fprintf(tf,"\nNEW GEN UPDATES: %ld (%5.1f%%)\n",
- tot_new_updates,
- PC(INTAVG(tot_new_updates,tot_gengc_updates)));
- fprintf(tf,"%7ld (%5.1f%%) indirections\n",
- UPD_NEW_IND_ctr,
- PC(INTAVG(UPD_NEW_IND_ctr,tot_gengc_updates)));
- fprintf(tf,"%7ld (%5.1f%%) inplace with ptrs\n",
- UPD_NEW_IN_PLACE_PTRS_ctr,
- PC(INTAVG(UPD_NEW_IN_PLACE_PTRS_ctr,tot_gengc_updates)));
- fprintf(tf,"%7ld (%5.1f%%) inplace without ptrs\n",
- UPD_NEW_IN_PLACE_NOPTRS_ctr,
- PC(INTAVG(UPD_NEW_IN_PLACE_NOPTRS_ctr,tot_gengc_updates)));
- fprintf(tf,"\nOLD GEN UPDATES: %ld (%5.1f%%)\n",
- tot_old_updates,
- PC(INTAVG(tot_old_updates,tot_gengc_updates)));
- fprintf(tf,"%7ld (%5.1f%%) indirections\n",
- UPD_OLD_IND_ctr,
- PC(INTAVG(UPD_OLD_IND_ctr,tot_gengc_updates)));
- fprintf(tf,"%7ld (%5.1f%%) inplace with ptrs\n",
- UPD_OLD_IN_PLACE_PTRS_ctr,
- PC(INTAVG(UPD_OLD_IN_PLACE_PTRS_ctr,tot_gengc_updates)));
- fprintf(tf,"%7ld (%5.1f%%) inplace without ptrs\n",
- UPD_OLD_IN_PLACE_NOPTRS_ctr,
- PC(INTAVG(UPD_OLD_IN_PLACE_NOPTRS_ctr,tot_gengc_updates)));
- }
-
- printRegisteredCounterInfo(tf);
-
- fprintf(tf,"\n**************************************************\n");
-
- /* here, we print out all the raw numbers; these are really
- more useful when we want to snag them for subsequent
- rdb-etc processing. WDP 95/11
- */
-
-#define PR_CTR(ctr) \
- do { fprintf(tf,"%7ld " #ctr "\n", ctr); } while(0)
-#define PR_HST(hst,i) \
- do { fprintf(tf,"%7ld " #hst "_" #i "\n", hst[i]); } while(0)
-
- PR_CTR(ALLOC_HEAP_ctr);
- PR_CTR(ALLOC_HEAP_tot);
-
-#ifndef CONCURRENT
- fprintf(tf,"%7ld HWM_SpA\n", (I_) (stackInfo.botA - max_SpA));
- fprintf(tf,"%7ld HWM_SpB\n", (I_) (max_SpB - stackInfo.botB));
-#endif
-
- PR_CTR(A_STK_STUB_ctr);
-
- PR_CTR(ALLOC_FUN_ctr);
- PR_CTR(ALLOC_FUN_adm);
- PR_CTR(ALLOC_FUN_gds);
- PR_CTR(ALLOC_FUN_slp);
- PR_HST(ALLOC_FUN_hst,0);
- PR_HST(ALLOC_FUN_hst,1);
- PR_HST(ALLOC_FUN_hst,2);
- PR_HST(ALLOC_FUN_hst,3);
- PR_HST(ALLOC_FUN_hst,4);
- PR_CTR(ALLOC_THK_ctr);
- PR_CTR(ALLOC_THK_adm);
- PR_CTR(ALLOC_THK_gds);
- PR_CTR(ALLOC_THK_slp);
- PR_HST(ALLOC_THK_hst,0);
- PR_HST(ALLOC_THK_hst,1);
- PR_HST(ALLOC_THK_hst,2);
- PR_HST(ALLOC_THK_hst,3);
- PR_HST(ALLOC_THK_hst,4);
- PR_CTR(ALLOC_CON_ctr);
- PR_CTR(ALLOC_CON_adm);
- PR_CTR(ALLOC_CON_gds);
- PR_CTR(ALLOC_CON_slp);
- PR_HST(ALLOC_CON_hst,0);
- PR_HST(ALLOC_CON_hst,1);
- PR_HST(ALLOC_CON_hst,2);
- PR_HST(ALLOC_CON_hst,3);
- PR_HST(ALLOC_CON_hst,4);
- PR_CTR(ALLOC_TUP_ctr);
- PR_CTR(ALLOC_TUP_adm);
- PR_CTR(ALLOC_TUP_gds);
- PR_CTR(ALLOC_TUP_slp);
- PR_HST(ALLOC_TUP_hst,0);
- PR_HST(ALLOC_TUP_hst,1);
- PR_HST(ALLOC_TUP_hst,2);
- PR_HST(ALLOC_TUP_hst,3);
- PR_HST(ALLOC_TUP_hst,4);
- PR_CTR(ALLOC_BH_ctr);
- PR_CTR(ALLOC_BH_adm);
- PR_CTR(ALLOC_BH_gds);
- PR_CTR(ALLOC_BH_slp);
- PR_HST(ALLOC_BH_hst,0);
- PR_HST(ALLOC_BH_hst,1);
- PR_HST(ALLOC_BH_hst,2);
- PR_HST(ALLOC_BH_hst,3);
- PR_HST(ALLOC_BH_hst,4);
- PR_CTR(ALLOC_PRIM_ctr);
- PR_CTR(ALLOC_PRIM_adm);
- PR_CTR(ALLOC_PRIM_gds);
- PR_CTR(ALLOC_PRIM_slp);
- PR_HST(ALLOC_PRIM_hst,0);
- PR_HST(ALLOC_PRIM_hst,1);
- PR_HST(ALLOC_PRIM_hst,2);
- PR_HST(ALLOC_PRIM_hst,3);
- PR_HST(ALLOC_PRIM_hst,4);
- PR_CTR(ALLOC_UPD_PAP_ctr);
- PR_CTR(ALLOC_UPD_PAP_adm);
- PR_CTR(ALLOC_UPD_PAP_gds);
- PR_CTR(ALLOC_UPD_PAP_slp);
- PR_HST(ALLOC_UPD_PAP_hst,0);
- PR_HST(ALLOC_UPD_PAP_hst,1);
- PR_HST(ALLOC_UPD_PAP_hst,2);
- PR_HST(ALLOC_UPD_PAP_hst,3);
- PR_HST(ALLOC_UPD_PAP_hst,4);
-
-#ifdef CONCURRENT
- PR_CTR(ALLOC_STK_ctr);
- PR_CTR(ALLOC_STK_adm);
- PR_CTR(ALLOC_STK_gds);
- PR_CTR(ALLOC_STK_slp);
- PR_HST(ALLOC_STK_hst,0);
- PR_HST(ALLOC_STK_hst,1);
- PR_HST(ALLOC_STK_hst,2);
- PR_HST(ALLOC_STK_hst,3);
- PR_HST(ALLOC_STK_hst,4);
- PR_CTR(ALLOC_TSO_ctr);
- PR_CTR(ALLOC_TSO_adm);
- PR_CTR(ALLOC_TSO_gds);
- PR_CTR(ALLOC_TSO_slp);
- PR_HST(ALLOC_TSO_hst,0);
- PR_HST(ALLOC_TSO_hst,1);
- PR_HST(ALLOC_TSO_hst,2);
- PR_HST(ALLOC_TSO_hst,3);
- PR_HST(ALLOC_TSO_hst,4);
-
-# ifdef PAR
- PR_CTR(ALLOC_FMBQ_ctr);
- PR_CTR(ALLOC_FMBQ_adm);
- PR_CTR(ALLOC_FMBQ_gds);
- PR_CTR(ALLOC_FMBQ_slp);
- PR_HST(ALLOC_FMBQ_hst,0);
- PR_HST(ALLOC_FMBQ_hst,1);
- PR_HST(ALLOC_FMBQ_hst,2);
- PR_HST(ALLOC_FMBQ_hst,3);
- PR_HST(ALLOC_FMBQ_hst,4);
- PR_CTR(ALLOC_FME_ctr);
- PR_CTR(ALLOC_FME_adm);
- PR_CTR(ALLOC_FME_gds);
- PR_CTR(ALLOC_FME_slp);
- PR_HST(ALLOC_FME_hst,0);
- PR_HST(ALLOC_FME_hst,1);
- PR_HST(ALLOC_FME_hst,2);
- PR_HST(ALLOC_FME_hst,3);
- PR_HST(ALLOC_FME_hst,4);
- PR_CTR(ALLOC_BF_ctr);
- PR_CTR(ALLOC_BF_adm);
- PR_CTR(ALLOC_BF_gds);
- PR_CTR(ALLOC_BF_slp);
- PR_HST(ALLOC_BF_hst,0);
- PR_HST(ALLOC_BF_hst,1);
- PR_HST(ALLOC_BF_hst,2);
- PR_HST(ALLOC_BF_hst,3);
- PR_HST(ALLOC_BF_hst,4);
-# endif
-#endif
-
- PR_CTR(ENT_VIA_NODE_ctr);
- PR_CTR(ENT_CON_ctr);
- PR_CTR(ENT_FUN_STD_ctr);
- PR_CTR(ENT_FUN_DIRECT_ctr);
- PR_CTR(ENT_IND_ctr);
- PR_CTR(ENT_PAP_ctr);
- PR_CTR(ENT_THK_ctr);
-
- PR_CTR(RET_NEW_IN_HEAP_ctr);
- PR_CTR(RET_NEW_IN_REGS_ctr);
- PR_CTR(RET_OLD_IN_HEAP_ctr);
- PR_CTR(RET_OLD_IN_REGS_ctr);
- PR_CTR(RET_SEMI_BY_DEFAULT_ctr);
- PR_CTR(RET_SEMI_IN_HEAP_ctr);
- PR_CTR(RET_SEMI_IN_REGS_ctr);
- PR_CTR(RET_SEMI_FAILED_IND_ctr);
- PR_CTR(RET_SEMI_FAILED_UNEVAL_ctr);
- PR_CTR(VEC_RETURN_ctr);
-
- PR_HST(RET_NEW_IN_HEAP_hst,0);
- PR_HST(RET_NEW_IN_HEAP_hst,1);
- PR_HST(RET_NEW_IN_HEAP_hst,2);
- PR_HST(RET_NEW_IN_HEAP_hst,3);
- PR_HST(RET_NEW_IN_HEAP_hst,4);
- PR_HST(RET_NEW_IN_HEAP_hst,5);
- PR_HST(RET_NEW_IN_HEAP_hst,6);
- PR_HST(RET_NEW_IN_HEAP_hst,7);
- PR_HST(RET_NEW_IN_HEAP_hst,8);
- PR_HST(RET_NEW_IN_REGS_hst,0);
- PR_HST(RET_NEW_IN_REGS_hst,1);
- PR_HST(RET_NEW_IN_REGS_hst,2);
- PR_HST(RET_NEW_IN_REGS_hst,3);
- PR_HST(RET_NEW_IN_REGS_hst,4);
- PR_HST(RET_NEW_IN_REGS_hst,5);
- PR_HST(RET_NEW_IN_REGS_hst,6);
- PR_HST(RET_NEW_IN_REGS_hst,7);
- PR_HST(RET_NEW_IN_REGS_hst,8);
- PR_HST(RET_OLD_IN_HEAP_hst,0);
- PR_HST(RET_OLD_IN_HEAP_hst,1);
- PR_HST(RET_OLD_IN_HEAP_hst,2);
- PR_HST(RET_OLD_IN_HEAP_hst,3);
- PR_HST(RET_OLD_IN_HEAP_hst,4);
- PR_HST(RET_OLD_IN_HEAP_hst,5);
- PR_HST(RET_OLD_IN_HEAP_hst,6);
- PR_HST(RET_OLD_IN_HEAP_hst,7);
- PR_HST(RET_OLD_IN_HEAP_hst,8);
- PR_HST(RET_OLD_IN_REGS_hst,0);
- PR_HST(RET_OLD_IN_REGS_hst,1);
- PR_HST(RET_OLD_IN_REGS_hst,2);
- PR_HST(RET_OLD_IN_REGS_hst,3);
- PR_HST(RET_OLD_IN_REGS_hst,4);
- PR_HST(RET_OLD_IN_REGS_hst,5);
- PR_HST(RET_OLD_IN_REGS_hst,6);
- PR_HST(RET_OLD_IN_REGS_hst,7);
- PR_HST(RET_OLD_IN_REGS_hst,8);
- PR_HST(RET_SEMI_IN_HEAP_hst,0);
- PR_HST(RET_SEMI_IN_HEAP_hst,1);
- PR_HST(RET_SEMI_IN_HEAP_hst,2);
- PR_HST(RET_SEMI_IN_HEAP_hst,3);
- PR_HST(RET_SEMI_IN_HEAP_hst,4);
- PR_HST(RET_SEMI_IN_HEAP_hst,5);
- PR_HST(RET_SEMI_IN_HEAP_hst,6);
- PR_HST(RET_SEMI_IN_HEAP_hst,7);
- PR_HST(RET_SEMI_IN_HEAP_hst,8);
- PR_HST(RET_SEMI_IN_REGS_hst,0);
- PR_HST(RET_SEMI_IN_REGS_hst,1);
- PR_HST(RET_SEMI_IN_REGS_hst,2);
- PR_HST(RET_SEMI_IN_REGS_hst,3);
- PR_HST(RET_SEMI_IN_REGS_hst,4);
- PR_HST(RET_SEMI_IN_REGS_hst,5);
- PR_HST(RET_SEMI_IN_REGS_hst,6);
- PR_HST(RET_SEMI_IN_REGS_hst,7);
- PR_HST(RET_SEMI_IN_REGS_hst,8);
- PR_HST(RET_VEC_RETURN_hst,0);
- PR_HST(RET_VEC_RETURN_hst,1);
- PR_HST(RET_VEC_RETURN_hst,2);
- PR_HST(RET_VEC_RETURN_hst,3);
- PR_HST(RET_VEC_RETURN_hst,4);
- PR_HST(RET_VEC_RETURN_hst,5);
- PR_HST(RET_VEC_RETURN_hst,6);
- PR_HST(RET_VEC_RETURN_hst,7);
- PR_HST(RET_VEC_RETURN_hst,8);
-
- PR_CTR(RET_SEMI_loads_avoided);
-
- PR_CTR(UPDF_OMITTED_ctr);
- PR_CTR(UPDF_STD_PUSHED_ctr);
- PR_CTR(UPDF_CON_PUSHED_ctr);
- PR_CTR(UPDF_HOLE_PUSHED_ctr);
-
- PR_CTR(UPDF_RCC_PUSHED_ctr);
- PR_CTR(UPDF_RCC_OMITTED_ctr);
-
- PR_CTR(UPD_EXISTING_ctr);
- PR_CTR(UPD_SQUEEZED_ctr);
- PR_CTR(UPD_CON_W_NODE_ctr);
- PR_CTR(UPD_CON_IN_PLACE_ctr);
- PR_CTR(UPD_CON_IN_NEW_ctr);
- PR_CTR(UPD_PAP_IN_PLACE_ctr);
- PR_CTR(UPD_PAP_IN_NEW_ctr);
-
- PR_HST(UPD_CON_IN_PLACE_hst,0);
- PR_HST(UPD_CON_IN_PLACE_hst,1);
- PR_HST(UPD_CON_IN_PLACE_hst,2);
- PR_HST(UPD_CON_IN_PLACE_hst,3);
- PR_HST(UPD_CON_IN_PLACE_hst,4);
- PR_HST(UPD_CON_IN_PLACE_hst,5);
- PR_HST(UPD_CON_IN_PLACE_hst,6);
- PR_HST(UPD_CON_IN_PLACE_hst,7);
- PR_HST(UPD_CON_IN_PLACE_hst,8);
- PR_HST(UPD_CON_IN_NEW_hst,0);
- PR_HST(UPD_CON_IN_NEW_hst,1);
- PR_HST(UPD_CON_IN_NEW_hst,2);
- PR_HST(UPD_CON_IN_NEW_hst,3);
- PR_HST(UPD_CON_IN_NEW_hst,4);
- PR_HST(UPD_CON_IN_NEW_hst,5);
- PR_HST(UPD_CON_IN_NEW_hst,6);
- PR_HST(UPD_CON_IN_NEW_hst,7);
- PR_HST(UPD_CON_IN_NEW_hst,8);
- PR_HST(UPD_PAP_IN_NEW_hst,0);
- PR_HST(UPD_PAP_IN_NEW_hst,1);
- PR_HST(UPD_PAP_IN_NEW_hst,2);
- PR_HST(UPD_PAP_IN_NEW_hst,3);
- PR_HST(UPD_PAP_IN_NEW_hst,4);
- PR_HST(UPD_PAP_IN_NEW_hst,5);
- PR_HST(UPD_PAP_IN_NEW_hst,6);
- PR_HST(UPD_PAP_IN_NEW_hst,7);
- PR_HST(UPD_PAP_IN_NEW_hst,8);
-
- PR_HST(UPD_ENTERED_hst,0);
- PR_HST(UPD_ENTERED_hst,1);
- PR_HST(UPD_ENTERED_hst,2);
- PR_HST(UPD_ENTERED_hst,3);
- PR_HST(UPD_ENTERED_hst,4);
- PR_HST(UPD_ENTERED_hst,5);
- PR_HST(UPD_ENTERED_hst,6);
- PR_HST(UPD_ENTERED_hst,7);
- PR_HST(UPD_ENTERED_hst,8);
-
- PR_CTR(UPD_NEW_IND_ctr);
- PR_CTR(UPD_NEW_IN_PLACE_PTRS_ctr);
- PR_CTR(UPD_NEW_IN_PLACE_NOPTRS_ctr);
- PR_CTR(UPD_OLD_IND_ctr);
- PR_CTR(UPD_OLD_IN_PLACE_PTRS_ctr);
- PR_CTR(UPD_OLD_IN_PLACE_NOPTRS_ctr);
-
- PR_CTR(UPD_IN_PLACE_COPY_ctr);
-
- PR_CTR(GC_SEL_ABANDONED_ctr);
- PR_CTR(GC_SEL_MINOR_ctr);
- PR_CTR(GC_SEL_MAJOR_ctr);
- PR_CTR(GC_SHORT_IND_ctr);
- PR_CTR(GC_SHORT_CAF_ctr);
- PR_CTR(GC_COMMON_CHARLIKE_ctr);
- PR_CTR(GC_COMMON_INTLIKE_ctr);
- PR_CTR(GC_COMMON_INTLIKE_FAIL_ctr);
- PR_CTR(GC_COMMON_CONST_ctr);
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Ticky-ent-counters]{Handle named entry counters}
-%* *
-%************************************************************************
-
-Data structure used in ``registering'' one of these counters.
-\begin{code}
-struct ent_counter *ListOfEntryCtrs = NULL; /* root of list of them */
-\end{code}
-
-To print out all the registered-counter info:
-\begin{code}
-static void
-printRegisteredCounterInfo (FILE *tf)
-{
- struct ent_counter *p;
-
- if ( ListOfEntryCtrs != NULL ) {
- fprintf(tf,"\n**************************************************\n");
- }
-
- for (p = ListOfEntryCtrs; p != NULL; p = p->link) {
- /* common stuff first; then the wrapper info if avail */
- fprintf(tf, "%-40s%u\t%u\t%u\t%-16s%ld",
- p->f_str,
- p->arity,
- p->Astk_args,
- p->Bstk_args,
- p->f_arg_kinds,
- p->ctr);
-
- if ( p->wrap_str == NULL ) {
- fprintf(tf, "\n");
-
- } else {
- fprintf(tf, "\t%s\t%s\n",
- p->wrap_str,
- p->wrap_arg_kinds);
- }
- }
-}
-\end{code}
-
-That's all, folks.
-\begin{code}
-#endif /* TICKY_TICKY */
-\end{code}
+++ /dev/null
-/* this one will be linked in for Haskell 1.3 */
-\begin{code}
-#include "rtsdefs.h"
-
-EXTDATA(PrelMain_mainIO_closure);
-
-P_ TopClosure = PrelMain_mainIO_closure;
-\end{code}
+++ /dev/null
-%/****************************************************************
-%* *
-%* This is where everything starts *
-%* *
-%****************************************************************/
-
-\begin{code}
-#if defined(PROFILING) || defined(PAR) || defined(CONCURRENT)
-#if !defined(_AIX)
-#define NON_POSIX_SOURCE /* time things on Solaris -- sigh */
-#endif
-#endif
-
-#include "rtsdefs.h"
-#include <setjmp.h>
-
-#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
-# include <string.h>
-/* An ANSI string.h and pre-ANSI memory.h might conflict. */
-# if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
-# include <memory.h>
-# endif /* not STDC_HEADERS and HAVE_MEMORY_H */
-
-#else /* not STDC_HEADERS and not HAVE_STRING_H */
-# include <strings.h>
-/* memory.h and strings.h conflict on some systems. */
-#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-
-#if defined(PROFILING) || defined(PAR) || defined(GRAN)
-/* need some "time" things */
-
-/* ToDo: This is a mess! Improve ? */
-
-# ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-# endif
-
-# ifdef HAVE_SYS_TIMES_H
-# include <sys/times.h>
-# endif
-
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# endif
-#endif /* PROFILING || PAR */
-
-#ifndef PAR
-STGRegisterTable MainRegTable;
-#endif
-
-/* fwd decls */
-void shutdownHaskell(STG_NO_ARGS);
-
-EXTFUN(startStgWorld);
-extern void PrintTickyInfo(STG_NO_ARGS);
-extern void checkAStack(STG_NO_ARGS);
-
-/* a real nasty Global Variable */
-/* moved to main/TopClosure(13)?.lc -- *one* of them will get linked in
-P_ TopClosure = GHCmain_mainPrimIO_closure;
- */
-
-/* structure to carry around info about the storage manager */
-smInfo StorageMgrInfo;
-
-#ifdef PAR
-extern I_ OkToGC, buckets;
-extern rtsBool TraceSparks, DelaySparks,
- DeferGlobalUpdates;
-
-void RunParallelSystem PROTO((P_));
-void initParallelSystem(STG_NO_ARGS);
-void SynchroniseSystem(STG_NO_ARGS);
-
-void SetTrace PROTO((W_ address, I_ level/*?*/));
-#endif
-
-void *stgAllocForGMP PROTO((size_t));
-void *stgReallocForGMP PROTO ((void *, size_t, size_t));
-void stgDeallocForGMP PROTO ((void *, size_t));
-
-/* NeXTs can't just reach out and touch "end", to use in
- distinguishing things in static vs dynamic (malloc'd) memory.
-*/
-#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
-void *get_end_result;
-#endif
-
-int prog_argc; /* an "int" so as to match normal "argc" */
-char **prog_argv;
-int rts_argc; /* ditto */
-char *rts_argv[MAX_RTS_ARGS];
-
-#ifndef PAR
-jmp_buf restart_main; /* For restarting after a signal */
-#endif
-
-#if defined(PAR)
-int nPEs = 0; /* Number of PEs */
-#endif
-
-\end{code}
-
-Setting up and initialising the run-time system:
-(used by main(), and people that don't allow Haskell
-to stay in control.)
-
-\begin{code}
-void
-initRTS(int argc, char *argv[])
-{
-#ifdef GRAN
- int i;
-#endif
-\end{code}
-
-The very first thing we do is grab the start time...just in case we're
-collecting timing statistics.
-
-\begin{code}
- start_time();
-\end{code}
-
-The parallel system needs to be initialised and synchronised before
-the program is run. This is done {\em before} heap allocation, so we
-can grab all remaining heap without needing to consider the System
-Manager's requirements.
-
-\begin{code}
-#ifdef PAR
- if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
- IAmMainThread = rtsTrue;
- argv++; argc--; /* Strip off flag argument */
- }
- /*
- * Grab the number of PEs out of the argument vector, and
- * eliminate it from further argument processing.
- */
- nPEs = atoi(argv[1]);
- argv[1] = argv[0];
- argv++; argc--;
- initEachPEHook(); /* HWL: hook to be execed on each PE */
- SynchroniseSystem();
-#endif
-
-#if defined(PROFILING) || defined(PAR) || defined(GRAN)
- /* setup string indicating time of run -- only used for profiling */
- (void) time_str();
-#endif
-
-#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
- get_end_result = get_end();
-#endif
-
- /*
- divide the command-line args between pgm and RTS; figure out
- what statsfile to use (if any); [if so, write the whole
- cmd-line into it]
-
- */
- initRtsFlagsDefaults();
- defaultsHook(); /* the one supplied does nothing;
- the user may have supplied a more interesting one.
- */
-
- setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
- prog_argc = argc;
- prog_argv = argv;
-
-#if defined(PAR)
- /* Initialise the parallel system -- before initHeap! */
- initParallelSystem();
-#endif /* PAR */
-
-#if defined(PROFILING) || defined(PAR)
- if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
- fflush(stdout);
- fprintf(stderr, "init_cc_profiling failed!\n");
- EXIT(EXIT_FAILURE);
- }
-#endif
-
-#if defined(GRAN)
- if (!RTSflags.GranFlags.granSimStats_suppressed)
- if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
- fprintf(stderr, "init_gr_simulation failed!\n");
- EXIT(EXIT_FAILURE);
- }
-#endif
-
-#ifdef PAR
- if (RTSflags.ParFlags.granSimStats)
- init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
-#endif
-
- /* initialize the storage manager */
- initSM();
-
-#ifndef PAR
- if (! initStacks( &StorageMgrInfo )) {
- fflush(stdout);
- fprintf(stderr, "initStacks failed!\n");
- EXIT(EXIT_FAILURE);
- }
-#endif
-
- if (! initHeap( &StorageMgrInfo )) {
- fflush(stdout);
- fprintf(stderr, "initHeap failed!\n");
- EXIT(EXIT_FAILURE);
- }
-
-#if defined(CONCURRENT) && !defined(GRAN)
- if (!initThreadPools()) {
- fflush(stdout);
- fprintf(stderr, "initThreadPools failed!\n");
- EXIT(EXIT_FAILURE);
- }
-#endif
-
-#if defined(PROFILING) || defined(PAR)
- /* call cost centre registering routine (after heap allocated) */
- cc_register();
-#endif
-
-#if defined(TICKY_TICKY)
- max_SpA = MAIN_SpA; /* initial high-water marks */
- max_SpB = MAIN_SpB;
-#endif
-
- /* Tell GNU multi-precision pkg about our custom alloc functions */
- mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
-
- /* Record initialization times */
- end_init();
-
-#if defined(PROFILING) || defined(CONCURRENT)
- /*
- * Both the context-switcher and the cost-center profiler use
- * a virtual timer.
- */
- if (install_vtalrm_handler()) {
- fflush(stdout);
- fprintf(stderr, "Can't install VTALRM handler.\n");
- EXIT(EXIT_FAILURE);
- }
-#if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
- if (! time_profiling)
- RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
- else {
- if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
- RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
- else
- RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;
-
- RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
- RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
- }
-#endif
-
-#ifndef CONCURRENT
- START_TIME_PROFILER;
-#endif
-
-#endif /* PROFILING || CONCURRENT */
-
-#ifndef PAR
- setjmp(restart_main);
- initUserSignals();
-#endif
-
-
-}
-
-int /* return type of "main" is defined by the C standard */
-main(int argc, char *argv[])
-{
- initRTS(argc,argv);
-
-#ifdef CONCURRENT
- AvailableStack = AvailableTSO = PrelBase_Z91Z93_closure;
-# if defined(GRAN) /* HWL */
- /* Moved in here from ScheduleThreads, to handle a restart_main
- (because of a signal) properly. */
- for (i=0; i<RTSflags.GranFlags.proc; i++)
- {
- RunnableThreadsHd[i] = RunnableThreadsTl[i] = PrelBase_Z91Z93_closure;
- WaitThreadsHd[i] = WaitThreadsTl[i] = PrelBase_Z91Z93_closure;
- PendingSparksHd[i][REQUIRED_POOL] = PendingSparksHd[i][ADVISORY_POOL] =
- PendingSparksTl[i][REQUIRED_POOL] = PendingSparksTl[i][ADVISORY_POOL] =
- NULL;
- }
-# else
- RunnableThreadsHd = RunnableThreadsTl = PrelBase_Z91Z93_closure;
- WaitingThreadsHd = WaitingThreadsTl = PrelBase_Z91Z93_closure;
- PendingSparksHd[REQUIRED_POOL] =
- PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
- PendingSparksHd[ADVISORY_POOL] =
- PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
-# endif
-
- CurrentTSO = PrelBase_Z91Z93_closure;
-
-# ifdef PAR
- RunParallelSystem(TopClosure);
-# else
- STKO_LINK(MainStkO) = PrelBase_Z91Z93_closure;
- ScheduleThreads(TopClosure);
-# endif /* PAR */
-
-#else /* not threaded (sequential) */
-
- miniInterpret((StgFunPtr)startStgWorld);
-
-#endif /* !CONCURRENT */
-
- shutdownHaskell();
- return(EXIT_SUCCESS); /* don't use EXIT! :-) */
-}
-\end{code}
-
-It should be possible to call @shutdownHaskell@ whenever you want to
-shut a Haskell program down in an orderly way.
-
-Note that some of this code probably depends on the integrity of
-various internal data structures so this should not be called in
-response to detecting a catastrophic error.
-
-\begin{code}
-void
-shutdownHaskell(STG_NO_ARGS)
-{
- STOP_TIME_PROFILER;
-
-#if defined(GRAN)
- /* For some reason this must be before exitSM */
- if (!RTSflags.GranFlags.granSimStats_suppressed)
- end_gr_simulation();
-#endif
-
- if (! exitSM(&StorageMgrInfo) ) {
- fflush(stdout);
- fprintf(stderr, "exitSM failed!\n");
- EXIT(EXIT_FAILURE);
- }
-
-#if defined(PROFILING)
- heap_profile_finish();
-#endif
-#if defined(PROFILING) || defined(PAR)
- report_cc_profiling(1 /* final */ );
-#endif
-
-#if defined(TICKY_TICKY)
- if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
-#endif
-
- /* Give the application a chance to do something sensible
- on-exit
- */
- OnExitHook();
-
- fflush(stdout);
- /* This fflush is important, because: if "main" just returns,
- then we will end up in pre-supplied exit code that will close
- streams and flush buffers. In particular we have seen: it
- will close fd 0 (stdin), then flush fd 1 (stdout), then <who
- cares>...
-
- But if you're playing with sockets, that "close fd 0" might
- suggest to the daemon that all is over, only to be presented
- with more stuff on "fd 1" at the flush.
-
- The fflush avoids this sad possibility.
- */
-}
-\end{code}
-
-Sets up and returns a string indicating the date/time of the run.
-Successive calls simply return the same string again. Initially
-called by @main.lc@ to initialise the string at the start of the run.
-Only used for profiling.
-
-\begin{code}
-#if defined(PROFILING) || defined(CONCURRENT) || defined(GRAN)
-# include <time.h>
-
-char *
-time_str(STG_NO_ARGS)
-{
- static time_t now = 0;
- static char nowstr[26];
-
- if (now == 0) {
- time(&now);
- strcpy(nowstr, ctime(&now));
- strcpy(nowstr+16,nowstr+19);
- nowstr[21] = '\0';
- }
- return nowstr;
-}
-#endif /* profiling */
-\end{code}
-
-ToDo: Will this work under threads?
-
-\begin{code}
-StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
-
-StgInt
-getErrorHandler(STG_NO_ARGS)
-{
- return (StgInt) errorHandler;
-}
-
-#if !defined(PAR)
-
-void
-raiseError( handler )
- StgStablePtr handler;
-{
- if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
- shutdownHaskell();
- EXIT(EXIT_FAILURE);
- } else {
- TopClosure = deRefStablePointer( handler );
- longjmp(restart_main,1);
- }
-}
-\end{code}
-
-\begin{code}
-StgInt
-catchError( newErrorHandler )
- StgStablePtr newErrorHandler;
-{
- StgStablePtr oldErrorHandler = errorHandler;
- errorHandler = newErrorHandler;
- return oldErrorHandler;
-}
-
-#endif
-\end{code}
-
-If we have installed an error handler, we might want to
-indicate that we have successfully recovered from an error by
-decrementing the counter.
-
-\begin{code}
-void
-decrementErrorCount()
-{
- ErrorIO_call_count-=1;
-}
-
-\end{code}
+++ /dev/null
-%
-%
-%
-
-Miscellaneous primitive operations on StgInt64 and StgWord64s.
-
-Instead of going the normal (boring) route of making the list
-of primitive operations even longer to cope with operations
-over 64-bit entities, we implement them instead 'out-of-line'.
-
-The primitive ops get their own routine (in C) that implements
-the operation, requiring the caller to _ccall_ out. This has
-performance implications of course, but we currently don't
-expect intensive use of the Int64 and Word64 types.
-
-The exceptions to the rule are primops that cast to and from
-64-bit entities.
-
-NOTE: We prefix all these primops with "stg_". No particular
-reason why.
-
-%
-%
-
-Comparison operators:
-
-\begin{code}
-#include "rtsdefs.h"
-
-#if HAVE_LONG_LONG
-StgInt
-stg_gtWord64(StgWord64 l1, StgWord64 l2)
-{ return ( l1 > l2); }
-
-StgInt
-stg_geWord64(StgWord64 l1, StgWord64 l2)
-{ return ( l1 >= l2); }
-
-StgInt
-stg_eqWord64(StgWord64 l1, StgWord64 l2)
-{ return ( l1 == l2); }
-
-StgInt
-stg_neWord64(StgWord64 l1, StgWord64 l2)
-{ return ( l1 != l2); }
-
-StgInt
-stg_ltWord64(StgWord64 l1, StgWord64 l2)
-{ return ( l1 < l2); }
-
-StgInt
-stg_leWord64(StgWord64 l1, StgWord64 l2)
-{ return ( l1 <= l2); }
-
-/* ------------------ */
-
-StgInt
-stg_gtInt64(StgInt64 l1, StgInt64 l2)
-{ return ( l1 > l2); }
-
-StgInt
-stg_geInt64(StgInt64 l1, StgInt64 l2)
-{ return ( l1 >= l2); }
-
-StgInt
-stg_eqInt64(StgInt64 l1, StgInt64 l2)
-{ return ( l1 == l2); }
-
-StgInt
-stg_neInt64(StgInt64 l1, StgInt64 l2)
-{ return ( l1 != l2); }
-
-StgInt
-stg_ltInt64(StgInt64 l1, StgInt64 l2)
-{ return ( l1 < l2); }
-
-StgInt
-stg_leInt64(StgInt64 l1, StgInt64 l2)
-{ return ( l1 <= l2); }
-\end{code}
-
-%
-%
-
-Arithmetic operators
-
-\begin{code}
-
-StgWord64
-stg_remWord64(StgWord64 a, StgWord64 b)
-{ return (a%b); }
-
-StgWord64
-stg_quotWord64(StgWord64 a, StgWord64 b)
-{ return (a/b); }
-
-StgInt64
-stg_remInt64(StgInt64 a, StgInt64 b)
-{ return (a%b); }
-
-StgInt64
-stg_quotInt64(StgInt64 a, StgInt64 b)
-{ return (a/b); }
-
-StgInt64
-stg_negateInt64(StgInt64 a)
-{ return (-a); }
-
-StgInt64
-stg_plusInt64(StgInt64 a, StgInt64 b)
-{ return (a+b); }
-
-StgInt64
-stg_minusInt64(StgInt64 a, StgInt64 b)
-{ return (a-b); }
-
-StgInt64
-stg_timesInt64(StgInt64 a, StgInt64 b)
-{ return (a*b); }
-
-\end{code}
-
-%
-%
-
-Logical operators:
-
-\begin{code}
-StgWord64
-stg_and64(StgWord64 a, StgWord64 b)
-{ return (a&b); }
-
-StgWord64
-stg_or64(StgWord64 a, StgWord64 b)
-{ return (a|b); }
-
-StgWord64
-stg_xor64(StgWord64 a, StgWord64 b)
-{ return (a^b); }
-
-StgWord64
-stg_not64(StgWord64 a)
-{ return (~a); }
-
-StgWord64
-stg_shiftL64(StgWord64 a, StgInt b)
-{ return (a << b); }
-
-StgWord64
-stg_shiftRL64(StgWord64 a, StgInt b)
-{ return (a >> b); }
-
-StgInt64
-stg_iShiftL64(StgInt64 a, StgInt b)
-{ return ( a<<b ); }
-
-/* Right shifting of signed quantities is not portable in C, so
- the behaviour you'll get from using these primops depends
- on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98
-*/
-
-StgInt64
-stg_iShiftRA64(StgInt64 a, StgInt b)
-{ return ( a>>b ); }
-
-StgInt64
-stg_iShiftRL64(StgInt64 a, StgInt b)
-{ return ( a>>b ); }
-
-\end{code}
-
-%
-%
-
-Casting between longs and longer longs:
-(the primops that cast from to/from Integers and long longs are
-expressed as macros, since these may cause some heap allocation).
-
-\begin{code}
-StgInt64
-stg_intToInt64(StgInt i)
-{ return ( (StgInt64)i ); }
-
-StgInt
-stg_int64ToInt(StgInt64 i)
-{ return ( (StgInt)i ); }
-
-StgWord64
-stg_int64ToWord64(StgInt64 i)
-{ return ( (StgWord64)i ); }
-
-StgWord64
-stg_wordToWord64(StgWord w)
-{ return ( (StgWord64)w ); }
-
-StgWord
-stg_word64ToWord(StgWord64 w)
-{ return ( (StgWord)w ); }
-
-StgInt64
-stg_word64ToInt64(StgWord64 w)
-{ return ( (StgInt64)w ); }
-
-#endif
-
-\end{code}
+++ /dev/null
-%---------------------------------------------------------------*
-%
-\section{Executable code for arithmetic primitives}
-%
-%---------------------------------------------------------------*
-
-\begin{code}
-/* basic definitions, just as if this were a module */
-
-/*
- Sigh, ieee-flpt.h (which we need here) uses
- __GLASGOW_HASKELL__ in a place or two to check
- whether it is being included in a Haskell source file
- or not. This is no longer the case! __GLASGOW_HASKELL__
- is also defined when compiling .c files (C code that
- depend on the RTS API needs to know this).
-
- An unfortunate state of affairs, but since this is
- the only place where the two uses of __GLASGOW_HASKELL__
- clash, we hack around and undefine it before including
- the header file. -- sof 8/98
-*/
-#ifdef __GLASGOW_HASKELL__
-#undef __GLASGOW_HASKELL__
-#endif
-
-#include "rtsdefs.h"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rts-prims-int]{Things for Int}
-%* *
-%************************************************************************
-
-Well, really just one little devil:
-
-\begin{code}
-I_
-stg_div(a, b)
- I_ a, b;
-{
- if (b >= 0) {
- if (a >= 0) { return( a / b ); }
- else { return( ((a+1) / b) - 1 ); }
- } else {
- if (a > 0) { return( ((a-1) / b) - 1 ); }
- else { return( a / b ); }
- /* ToDo: something for division by zero? */
- }
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rts-prims-float]{Things for floating-point}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection[rts-mving-float]{Moving floatish things around}
-%* *
-%************************************************************************
-
-See \tr{imports/StgMacros.h} for more about these things.
-\begin{code}
-#if defined(FLOAT_ALIGNMENT_TROUBLES) && ! defined(__STG_GCC_REGS__)
-/* Not all machines suffer from these (e.g., m68k). */
-/* If we are registerizing, we must *not* have this code! */
-
-STG_INLINE
-void
-ASSIGN_DBL(W_ p_dest[], StgDouble src)
-{
- double_thing y;
- y.d = src;
- p_dest[0] = y.du.dhi;
- p_dest[1] = y.du.dlo;
-}
-
-STG_INLINE
-StgDouble
-PK_DBL(W_ p_src[])
-{
- double_thing y;
- y.du.dhi = p_src[0];
- y.du.dlo = p_src[1];
- return(y.d);
-}
-
-STG_INLINE
-void
-ASSIGN_FLT(W_ p_dest[], StgFloat src)
-{
- float_thing y;
- y.f = src;
- *p_dest = y.fu;
-}
-
-STG_INLINE
-StgFloat
-PK_FLT(W_ p_src[])
-{
- float_thing y;
- y.fu = *p_src;
- return(y.f);
-}
-
-#endif /* FLOAT_ALIGNMENT_TROUBLES and not registerizing */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[rts-coding-floats]{Encoding/decoding float-ish things}
-%* *
-%************************************************************************
-
-Encoding and decoding Doubles. Code based on the HBC code
-(lib/fltcode.c).
-
-\begin{code}
-#define GMP_BASE 4294967296.0
-#if alpha_TARGET_ARCH
-#define DNBIGIT 1 /* mantissa of a double will fit in one long */
-#else
-#define DNBIGIT 2 /* mantissa of a double will fit in two longs */
-#endif
-#define FNBIGIT 1 /* for float, one long */
-
-#if IEEE_FLOATING_POINT
-#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
-/* DMINEXP is defined in values.h on Linux (for example) */
-#define DHIGHBIT 0x00100000
-#define DMSBIT 0x80000000
-
-#define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
-#define FHIGHBIT 0x00800000
-#define FMSBIT 0x80000000
-#endif
-
-#ifdef BIGENDIAN
-#define L 1
-#define H 0
-#else
-#define L 0
-#define H 1
-#endif
-\end{code}
-
-\begin{code}
-StgDouble
-__encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */
-{
- StgDouble r;
- I_ i;
-/* char *temp; */
-
- /* Convert MP_INT to a double; knows a lot about internal rep! */
- i = __abs(s->size)-1;
- if (i < 0) {
- r = 0.0;
- } else {
- for(r = s->d[i], i--; i >= 0; i--)
- r = r * GMP_BASE + s->d[i];
- }
-
- /* Now raise to the exponent */
- if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
- r = ldexp(r, e);
-
- /* sign is encoded in the size */
- if (s->size < 0)
- r = -r;
-
-/*
- temp = stgMallocBytes(mpz_sizeinbase(s,10)+2);
- fprintf(stderr, "__encodeDouble(%s, %ld) => %g\n", mpz_get_str(temp,10,s), e, r);
-*/
-
- return r;
-}
-
-#if ! alpha_TARGET_ARCH
- /* On the alpha, Stg{Floats,Doubles} are the same */
-StgFloat
-__encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */
-{
- StgFloat r;
- I_ i;
-
- /* Convert MP_INT to a float; knows a lot about internal rep! */
- for(r = 0.0, i = __abs(s->size)-1; i >= 0; i--)
- r = (r * GMP_BASE) + s->d[i];
-
- /* Now raise to the exponent */
- if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
- r = ldexp(r, e);
-
- /* sign is encoded in the size */
- if (s->size < 0)
- r = -r;
-
- return r;
-}
-#endif /* alpha */
-
-void
-__decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl)
-{
-#if ! IEEE_FLOATING_POINT
- fprintf(stderr, "__decodeDouble: non-IEEE not yet supported\n");
- abort();
-
-#else /* IEEE fl-pt */
- /* Do some bit fiddling on IEEE */
- unsigned int low, high; /* assuming 32 bit ints */
- int sign, iexp;
- union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
-/* char *temp; */
-
- u.d = dbl; /* grab chunks of the double */
- low = u.i[L];
- high = u.i[H];
-
- /* we know the MP_INT* passed in has size zero, so we realloc
- no matter what.
- */
- man->alloc = DNBIGIT;
-
- if (low == 0 && (high & ~DMSBIT) == 0) {
- man->size = 0;
- *exp = 0L;
- } else {
- man->size = DNBIGIT;
- iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
- sign = high;
- /* fprintf(stderr, "decode %g %08x %08x %d\n", u.d, high, low, iexp); */
-
- high &= DHIGHBIT-1;
- if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
- high |= DHIGHBIT;
- else {
- iexp++;
- /* A denorm, normalize the mantissa */
- while (! (high & DHIGHBIT)) {
- high <<= 1;
- if (low & DMSBIT)
- high++;
- low <<= 1;
- iexp--;
- }
- }
- *exp = (I_) iexp;
-#if DNBIGIT == 2
- man->d[0] = low;
- man->d[1] = high;
-#else
-#if DNBIGIT == 1
- man->d[0] = ((unsigned long)high) << 32 | (unsigned long)low;
-#else
- error : error : error : Cannae cope with DNBIGIT
-#endif
-#endif
- if (sign < 0)
- man->size = -man->size;
- }
-
-/*
- temp = stgMallocBytes(mpz_sizeinbase(man,10)+2);
- fprintf(stderr, "__decodeDouble(%g) => %s, %ld\n", dbl, mpz_get_str(temp,10,man), *exp);
-*/
-
-#endif /* IEEE fl-pt */
-}
-
-#if ! alpha_TARGET_ARCH
- /* Again, on the alpha we do not have separate "StgFloat" routines */
-void
-__decodeFloat (MP_INT *man, I_ *exp, StgFloat flt)
-{
-#if ! IEEE_FLOATING_POINT
- fprintf(stderr, "__decodeFloat: non-IEEE not yet supported\n");
- abort();
-
-#else /* IEEE fl-pt */
- /* Do some bit fiddling on IEEE */
- int high, sign; /* assuming 32 bit ints */
- union { float f; int i; } u; /* assuming 32 bit float and int */
-
- u.f = flt; /* grab the float */
- high = u.i;
-
- /* we know the MP_INT* passed in has size zero, so we realloc
- no matter what.
- */
- man->alloc = FNBIGIT;
-
- if ((high & ~FMSBIT) == 0) {
- man->size = 0;
- *exp = 0;
- } else {
- man->size = FNBIGIT;
- *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
- sign = high;
-
- high &= FHIGHBIT-1;
- if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
- high |= FHIGHBIT;
- else {
- (*exp)++;
- /* A denorm, normalize the mantissa */
- while (! (high & FHIGHBIT)) {
- high <<= 1;
- (*exp)--;
- }
- }
-#if FNBIGIT == 1
- man->d[0] = high;
-#else
- error : error : error : Cannae cope with FNBIGIT
-#endif
- if (sign < 0)
- man->size = -man->size;
- }
-
-#endif /* IEEE fl-pt */
-}
-#endif /* alpha */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rts-prims-integer]{Things for Integers (using GNU MP pkg)}
-%* *
-%************************************************************************
-
-See ghc/compiler/prelude/TyInteger.lhs for the comment on this stuff.
-
-%************************************************************************
-%* *
-\subsubsection[rts-gmp-alloc]{Our custom memory allocation routines}
-%* *
-%************************************************************************
-
-The GMP documentation says what these must do.
-
-\begin{code}
-#ifdef ALLOC_DEBUG
-StgInt DEBUG_GMPAllocBudget = 0;
- /* # of _words_ known to be available for stgAllocForGMP */
-#endif
-
-void *
-stgAllocForGMP (size_in_bytes)
- size_t size_in_bytes;
-{
- void *stuff_ptr;
- I_ data_size_in_words, total_size_in_words;
-
- /* the new object will be "DATA_HS + BYTES_TO_STGWORDS(size_in_bytes)" words
- */
- data_size_in_words = BYTES_TO_STGWORDS(size_in_bytes);
- total_size_in_words = DATA_HS + data_size_in_words;
-#ifdef ALLOC_DEBUG
- /* Check that we are within the current budget */
- if (DEBUG_GMPAllocBudget < total_size_in_words) {
- fprintf(stderr, "stgAllocForGMP: budget error: %ld %ld\n",
- DEBUG_GMPAllocBudget, total_size_in_words);
- abort();
- }
- else {
- DEBUG_GMPAllocBudget -= total_size_in_words;
- }
-#endif
-
- /* if it's a DATA thingy, we'd better fill it in.
- */
- SET_DATA_HDR(SAVE_Hp+1,ArrayOfData_info,CCC,DATA_VHS+data_size_in_words,0);
-
- /* we're gonna return a pointer to the non-hdr part of the beast
- */
- stuff_ptr = (void *) (SAVE_Hp + 1 + DATA_HS);
-
- /* move the heap pointer right along...
- (tell [ticky-ticky and regular] profiling about it, too)
- */
- SAVE_Hp += total_size_in_words;
-
- ALLOC_HEAP(total_size_in_words); /* ticky-ticky profiling */
-/* ALLOC_CON(DATA_HS,data_size_in_words,0); */
- ALLOC_PRIM(DATA_HS,data_size_in_words,0,total_size_in_words);
-
- CC_ALLOC(CCC,total_size_in_words,CON_K); /* cc profiling */
- /* NB: HACK WARNING: The above line will do The WRONG THING
- if the CurrCostCentre reg is ever put in a Real Machine Register (TM).
- */
-
- /* and return what we said we would */
- return(stuff_ptr);
-}
-
-void *
-stgReallocForGMP (ptr, old_size, new_size)
- void *ptr;
- size_t old_size, new_size;
-{
- void *new_stuff_ptr = stgAllocForGMP(new_size);
- unsigned int i = 0;
- char *p = (char *) ptr;
- char *q = (char *) new_stuff_ptr;
-
- for (; i < old_size; i++, p++, q++) {
- *q = *p;
- }
-
- return(new_stuff_ptr);
-}
-
-void
-stgDeallocForGMP (ptr, size)
- void *ptr;
- size_t size;
-{
- /* easy for us: the garbage collector does the dealloc'n */
-}
-\end{code}
+++ /dev/null
-%---------------------------------------------------------------*
-%
-\section{Executable code for random primitives}
-%
-%---------------------------------------------------------------*
-
-\begin{code}
-#include "rtsdefs.h"
-
-I_ __GenSymCounter = 0;
-I_ __SeqWorldCounter = 0;
-
-I_
-genSymZh(STG_NO_ARGS)
-{
- return(__GenSymCounter++);
-}
-I_
-resetGenSymZh(STG_NO_ARGS) /* it's your funeral */
-{
- __GenSymCounter=0;
- return(__GenSymCounter);
-}
-
-I_
-byteArrayHasNUL__ (ba, len)
- const char *ba;
- I_ len;
-{
- I_ i;
-
- for (i = 0; i < len; i++) {
- if (*(ba + i) == '\0') {
- return(1); /* true */
- }
- }
-
- return(0); /* false */
-}
-
-I_
-stg_exit (n) /* can't call regular "exit" from Haskell
- because it has no return value */
- I_ n;
-{
- /* Storage manager shutdown */
- shutdownHaskell();
- EXIT(n);
- return(0); /* GCC warning food */
-}
-\end{code}
-
-This may not be the right place for this: (ToDo?)
-\begin{code}
-#ifdef DEBUG
-void
-_stgAssert (filename, linenum)
- char *filename;
- unsigned int linenum;
-{
- fflush(stdout);
- fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
- abort();
-}
-#endif /* DEBUG */
-\end{code}
-
-A little helper for the native code generator (it can't stomach
-loops):
-\begin{code}
-void
-newArrZh_init(result, n, init)
-P_ result;
-I_ n;
-P_ init;
-{
- P_ p;
-
- SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+n,0)
- for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+n); p++) {
- *p = (W_) (init);
- }
-}
-
-\end{code}
-
-Phantom info table vectors for multiple constructor primitive types that
-might have to perform a DynamicReturn (just Bool at the moment).
-
-\begin{code}
-ED_RO_(PrelBase_False_inregs_info);
-ED_RO_(PrelBase_True_inregs_info);
-
-#ifndef aix_TARGET_OS /* AIX gives link errors with this as a const (RO assembler section) */
-const
-#endif
- W_ PrelBase_Bool_itblvtbl[] = {
- (W_) PrelBase_False_inregs_info,
- (W_) PrelBase_True_inregs_info
-};
-\end{code}
+++ /dev/null
-/* compile with something vaguely like...
-
-gcc -o test-float -g -I ../includes prims/test-float.c prims/PrimArith_ap_o.o gmp/libgmp.a
-
-*/
-#include "rtsdefs.h"
-#include <errno.h>
-
-StgFloat float_val[] = {
- 0.0, -1.0, 1.0, 1.2, -1.5, 1.5, -1.5e19, -1.5e-19, 1.5e19, 1.5e-19, 1.5e30, 1.5e-30,
- 3.14159265, -3.14159265, 42, -42, 42.2, -42.2
-};
-#define NF 18
-
-StgDouble double_val[] = {
- 0.0, -1.0, 1.0, 1.2, -1.5, 1.5, -1.5e19, -1.5e-19, 1.5e19, 1.5e-19, 1.5e30, 1.5e-30,
- 3.14159265, -3.14159265, 42, -42, 42.2, -42.2
-};
-#define ND 18
-
-P_ Hp_SAVE;
-const W_ ArrayOfData_info[4];
-
-void
-main ()
-{
- MP_INT m;
- I_ e;
- StgFloat f;
- StgDouble d;
- int i;
- char *str;
-
- mpz_init ( &m );
-
- __decodeDouble( &m, &e, (StgDouble) 42 );
-
- str = mpz_get_str( NULL, 10, &m );
-
- printf("decoded 42: mant=%s, expon=%d (0x%x)\n", str, e,e);
-
- /* test decoding (doubles) */
- for (i = 0; i < ND; i++) {
- __decodeDouble( &m, &e, double_val[i]);
- str = mpz_get_str( NULL, 10, &m );
- d = __encodeDouble( &m, e);
-
- printf("decodedD: d=%g, mant=%s, expon=%d (0x%x)\n",
- double_val[i], str, e,e);
- printf("encodedD: d=%g\n\n", d);
- }
-
- /* test decoding (floats) */
-#if 0
- for (i = 0; i < NF; i++) {
- m = floatSignificandZh(float_val[i]);
- e = floatExponentZh(float_val[i]);
-
- f = encodeFloatZh(m, e);
-
- printf("decodedF: f=%g, mant=%d (0x%x), expon=%d (0x%x)\n",
- float_val[i], m,m, e,e);
- printf("encodedF: f=%g\n\n", f);
- }
-#endif
-}
+++ /dev/null
-
-Adding @scc@ to the Haskell compiler -- A note of changes required
-
-
-Haskell Compiler:
-----------------
-
-SCC FRONT END SYNTAX: scc "label" expr
-
- hslexer.lex scc recognised as SCC
- hsparser.y scc expression parsed
- tree.ugn new tree construct
- printtree.c print scc (k bytecode)
- main.c -S flag for scc (else warning)
-
-SCC THROUGH COMPILER:
- reader PrefixSyn new construct (SCC')
- ReadPrefix read k bytecode
- PrefixToHs -> AbsSyn
-
- abstractSyn HsExpr new construct (SCC)
- BackSubst
- rename RenameExpr4 rename body
- typecheck TcExpr no unify, use type of body
- deSugar DsExpr -> CoreSyn
-
- Core Syntax & Transformations:
- coreSyn CoreSyn new construct (CoSCC) not primop
- AnnCoreSyn new construct
- FreeVars
- CoreFuns
-
- simplCore0 SubstAnal0
- SimplCore0
- RmTrivLets0
-
- simplCore default: not used n
- stranal-sem default: not used n
- interpreter york: ??? n
-
- Stg Syntax & Transformations:
- stgSyn CoreToStg -> StgSyn
- StgSyn new construct (StgSCC)
-
- StgInfo (new) pass gathering CC codegen info
-
- LetFloat default: not used n
- StgToStg default: not used n
- FreeVariables default: not used n
-
- Abstract C & Code Generation:
- main Main -scc flag for update flavour y
- codeGen CgMonad -scc new Cg info y
- absCSyn AbsCSyn new construct (CCostCentre) y
-
- codeGen CodeGen declaring cost centers y
- codeGen ClosureInfo closure kind y
- type y
- codeGen CgClosure closure description y
-
- abstractC PprAbsC info table kind y
- description y
- type y
-
- Real Code Generation Changes
- Scc Expression:
- +RCC update frame -- stack space required
- +set new cost centre
-
- Closure Entry:
- !different sizes for STD and CON update frames
- +single entry now requires RCC update frame
- +resume the CC in closure entered
-
- Return in Registers:
- +register return set RetCC (form closure or CCC)
- +register update reset closures CC to RetCC
- +attribute register update allocation to RetCC
-
- CC_ALLOC calls with heap allocation
-
- Optimisations:
- update closure entry with scc -- no RCC frame ToDo
-
-
-RTS stuff:
----------
-
-Time interupt y
-
-Cost centre declaration macros y
-
-Info table macros with "description" etc? y
-
-Modify update frames to include cost centres y
-Dummy update frame return vector y
-Recognition of dummy ret vect UpdatePAP y
-
-Heap profiling (2s)
- Cost Centre y
- Description y
-
-Profile info reported y
-
-Conditionalise need for timer interupt todo
-
-
-
-ADDING GRP_NAME to CC and TYPE to CAT:
--------------------------------------
-
-driver -- -Ggroup flag y
-main/Main.lhs -- -Ggroup flag y
- -- pass to codegen y
-codeGen -- grp_name passed into CCostCentre y
-absCSyn -- add group to CCostCentre y
- -- print group with CC decl y
- -- print type with INFO_TABLE decl y
-uniType -- getUniTyDescription y
-
-runtime -- Add group to CostCentre y
- -- Add group to CC_DECALRE y
- -- Add type to ClCategory y
- -- Add type to CAT_DECLARE y
- -- Add type to INFO_TABLEs y
-
- -- Report group in profiling report y
-
- -- Heap profiling with group/module/type
- -- selection by mod,grp,typ y
- -- profiling by cc,mod,grp,descr,type y
- -- always hash on feature y
- -- report by cc,mod,grp,descr,type y
-
- This is different to York as we can have unprofiled
- costs/heap inherited from other modules/groups.
-
- TESTING TESTING TESTING TESTING ToDo
-
-
-AUTO SCCS ...
--------------
-
-driver -- -prof-auto y
-main/Main.lhs -- -scc-auto y
- -- doSCCauto pass (desugared) Improve?
-profiling/SCCauto.lhs -- sccAutoTop Improve?
-
- Need to compare to all explicitly annotated. ToDo
-
- I think this needs to be incorperated into ToDo
- the desugarer/typechecker? as the dict stuff
- currently distorts this.
- OK if we are using lexical scoping !!!
- eg: See tautclause in clausify1.hs (cl.*)
-
-
-
-
-EXTENDING SCC ANNOTATIONS ... ToDo
------------------------------
-
-Front End: let scc "label"
- where scc "label"
- decl scc "label"
-
- hsparser.y extended scc expressions parsed
- tree.ugn new scc language constructs
- printtree.c print new scc bytecode forms
-
-Compiler:
- reader PrefixSyn new constructs
- ReadPrefix read bytecodes
- PrefixToHs -> AbsSyn
-
- abstractSyn HsExpr new constructs
- BackSubst
- rename RenameExpr4 rename body
- typecheck TcExpr no unify, use type of body
- deSugar desugar new scc constructs -> SCC
-
-
-LEXICAL/EVALUATION SCOPING ...
-
-driver -- -prof-eval -prof-lex (def) y
-main/Main.lhs -- -scc-eval -scc-lex y
- -- doSCClex pass (stg_binds') ToDo
-??? -- lexical scoping transform pass ToDo
-
-
-
-OTHER POSSIBLE STUFF:
-
-codegen/CodeGen.lhs -- code to declare mod and group strings
- -- use references in CCostCentre
-
-profiling cost report -- Reporting group / module costs
- with / without components
- Eg sort on group time
- with module time sub-sort
- with label time sub-sort
+++ /dev/null
-\section[CostCentre.lc]{Code for Cost Centre Profiling}
-
-\begin{code}
-#include "rtsdefs.h"
-\end{code}
-
-Only have cost centres if @PROFILING@ defined (by the driver),
-or if running PAR.
-
-\begin{code}
-#if defined(PROFILING) || defined(PAR)
-CC_DECLARE(CC_MAIN, "MAIN", "MAIN", "MAIN", CC_IS_BORING,/*not static*/);
-CC_DECLARE(CC_GC, "GC", "GC", "GC", CC_IS_BORING,/*not static*/);
-
-# ifdef PAR
-CC_DECLARE(CC_MSG, "MSG", "MSG", "MSG", CC_IS_BORING,/*not static*/);
-CC_DECLARE(CC_IDLE, "IDLE", "IDLE", "IDLE", CC_IS_BORING,/*not static*/);
-# endif
-\end{code}
-
-\begin{code}
-CostCentre CCC; /* _not_ initialised */
-
-#endif /* defined(PROFILING) || defined(PAR) */
-\end{code}
-
-The rest is for real cost centres (not thread activities).
-
-\begin{code}
-#if defined(PROFILING) || defined(PAR)
-\end{code}
-%************************************************************************
-%* *
-\subsection{Initial Cost Centres}
-%* *
-%************************************************************************
-
-Cost centres which are always required:
-\begin{code}
-#if defined(PROFILING)
-
-CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", "PROFILING", CC_IS_CAF, /*not static*/);
-CC_DECLARE(CC_SUBSUMED, "SUBSUMED", "MAIN", "MAIN", CC_IS_SUBSUMED, /*not static*/);
-CC_DECLARE(CC_DONTZuCARE,"DONT_CARE", "MAIN", "MAIN", CC_IS_BORING, /*not static*/);
-#endif
-\end{code}
-
-The list of registered cost centres, initially empty:
-\begin{code}
-CostCentre Registered_CC = REGISTERED_END;
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Profiling RTS Arguments}
-%* *
-%************************************************************************
-
-\begin{code}
-I_ dump_intervals = 0;
-
-/* And for the report ... */
-static char prof_filename[STATS_FILENAME_MAXLEN]; /* prof report file name = <program>.prof */
-static char **prog_argv_save;
-static char **rts_argv_save;
-
-/* And the serial report ... */
-static char serial_filename[STATS_FILENAME_MAXLEN]; /* serial time profile file name = <program>.time */
-static FILE *serial_file = NULL; /* serial time profile file */
-
-I_
-init_cc_profiling(rts_argc, rts_argv, prog_argv)
- I_ rts_argc;
- char *rts_argv[], *prog_argv[];
-{
- I_ arg, ch;
-
- prog_argv_save = prog_argv;
- rts_argv_save = rts_argv;
-
-#ifdef PAR
- sprintf(prof_filename, PROF_FILENAME_FMT_GUM, prog_argv[0], thisPE);
-#else
- sprintf(prof_filename, PROF_FILENAME_FMT, prog_argv[0]);
-#endif
-
- /* Now perform any work to initialise profiling ... */
-
- if (RTSflags.CcFlags.doCostCentres
-#ifdef PROFILING
- || RTSflags.ProfFlags.doHeapProfile
-#endif
- ) {
-
- time_profiling++;
-
- /* set dump_intervals: if heap profiling only dump every 10 intervals */
-#ifdef PROFILING
- dump_intervals = (RTSflags.ProfFlags.doHeapProfile) ? 10 : 1;
-#else
- dump_intervals = 1;
-#endif
-
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
- /* produce serial time profile */
-
-#ifdef PAR
- sprintf(serial_filename, TIME_FILENAME_FMT_GUM, prog_argv[0], thisPE);
-#else
- sprintf(serial_filename, TIME_FILENAME_FMT, prog_argv[0]);
-#endif
- if ( (serial_file = fopen(serial_filename,"w")) == NULL ) {
- fprintf(stderr, "Can't open serial time log file %s\n", serial_filename);
- return 1;
- }
-
- fprintf(serial_file, "JOB \"%s", prog_argv[0]);
- fprintf(serial_file, " +RTS -P -i%4.2f -RTS",
- interval_ticks/(StgFloat)TICK_FREQUENCY);
- for(arg = 1; prog_argv[arg]; arg++)
- fprintf(serial_file, " %s", prog_argv[arg]);
- fprintf(serial_file, "\"\n");
- fprintf(serial_file, "DATE \"%s\"\n", time_str());
-
- fprintf(serial_file, "SAMPLE_UNIT \"seconds\"\n");
-#ifdef PAR
- fprintf(serial_file, "VALUE_UNIT \"percentage time\"\n");
-#else
- fprintf(serial_file, "VALUE_UNIT \"time ticks\"\n");
-#endif
-
- /* output initial 0 sample */
- fprintf(serial_file, "BEGIN_SAMPLE 0.00\n");
- fprintf(serial_file, "END_SAMPLE 0.00\n");
- }
- }
-
-#if defined(PROFILING)
- if (heap_profile_init(prog_argv))
- return 1;
-#endif
-
- return 0;
-}
-\end{code}
-
-Registering the cost centres is done after heap allocated as we use
-the area to hold the stack of modules still to register.
-
-\begin{code}
-extern P_ heap_space; /* pointer to the heap space */
-StgFunPtr * register_stack; /* stack of register routines -- heap area used */
-
-EXTFUN(startCcRegisteringWorld);
-
-void
-cc_register()
-{
- REGISTER_CC(CC_MAIN); /* register cost centre CC_MAIN */
- REGISTER_CC(CC_GC); /* register cost centre CC_GC */
-
-#if defined(PAR)
- REGISTER_CC(CC_MSG); /* register cost centre CC_MSG */
- REGISTER_CC(CC_IDLE); /* register cost centre CC_MSG */
-#endif
-
-#if defined(PROFILING)
- REGISTER_CC(CC_OVERHEAD); /* register cost centre CC_OVERHEAD */
- REGISTER_CC(CC_DONTZuCARE); /* register cost centre CC_DONT_CARE Right??? ToDo */
-#endif
-
- SET_CCC_RTS(CC_MAIN,0,1); /* without the sub_scc_count++ */
-
-#if defined(PROFILING)
-/* always register -- if we do not, we get warnings (WDP 94/12) */
-/* if (RTSflags.CcFlags.doCostCentres || RTSflags.ProfFlags.doHeapProfile) */
-
- register_stack = (StgFunPtr *) heap_space;
- miniInterpret((StgFunPtr) startCcRegisteringWorld);
-#endif
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Cost Centre Profiling Report}
-%* *
-%************************************************************************
-
-\begin{code}
-static I_ dump_interval = 0;
-
-rtsBool
-cc_to_ignore (CostCentre cc)
- /* return rtsTrue if it is one of the ones that
- should not be reported normally (because it confuses
- the users)
- */
-{
-# if !defined(PROFILING)
- /* in parallel land, everything is interesting (not ignorable) */
- return rtsFalse;
-
-# else
- if ( cc == CC_OVERHEAD || cc == CC_DONTZuCARE || cc == CC_GC ) {
- return rtsTrue;
- } else {
- return rtsFalse;
- }
-# endif /* PROFILING */
-}
-
-rtsBool
-have_interesting_groups(CostCentre cc)
-{
- char* interesting_group = NULL;
-
- for (; cc != REGISTERED_END; cc = cc->registered) {
- if (! cc_to_ignore(cc) && strcmp(cc->module,cc->group) != 0) {
- if (interesting_group && strcmp(cc->group, interesting_group) != 0) {
- return(rtsTrue);
- } else {
- interesting_group = cc->group;
- }
- }
- }
- return(rtsFalse);
-}
-
-void
-report_cc_profiling(final)
- I_ final;
-{
- FILE *prof_file;
- CostCentre cc;
- I_ count;
- char temp[128]; /* sigh: magic constant */
- W_ total_ticks, ignored_ticks;
- W_ total_alloc = 0, total_allocs = 0;
- rtsBool do_groups = rtsFalse;
-#ifdef PAR
- I_ final_ticks; /*No. ticks in last sample*/
-#endif
-
- if (!RTSflags.CcFlags.doCostCentres)
- return;
-
- blockVtAlrmSignal();
- /* To avoid inconsistency, initialise the tick variables
- after having blocked out VTALRM */
- total_ticks = 0;
- ignored_ticks = 0;
-#ifdef PAR
- final_ticks = 0;
-#endif
-
- if (serial_file) {
- StgFloat seconds = (previous_ticks + current_ticks) / (StgFloat) TICK_FREQUENCY;
-
- if (final) {
- fprintf(serial_file, "BEGIN_SAMPLE %0.2f\n", seconds);
-#ifdef PAR
- /*In the parallel world we're particularly interested in the last sample*/
- for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
- if (! cc_to_ignore(cc))
- final_ticks += cc->time_ticks;
- }
-
- for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
- if (cc->time_ticks != 0 && ! cc_to_ignore(cc))
- fprintf(serial_file, " %s:%s %3ld\n",
- cc->module, cc->label, cc->time_ticks*100 / final_ticks);
- }
-#endif
- /* In the sequential world, ignore partial sample at end of execution */
- fprintf(serial_file, "END_SAMPLE %0.2f\n", seconds);
- fclose(serial_file);
- serial_file = NULL;
-
- } else {
- /* output serial profile sample */
-
- fprintf(serial_file, "BEGIN_SAMPLE %0.2f\n", seconds);
-
- for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
- ASSERT_IS_REGISTERED(cc, 0);
- if (cc->time_ticks != 0 && !cc_to_ignore(cc)) {
-#ifdef PAR
- /* Print _percentages_ in the parallel world */
- fprintf(serial_file, " %s:%s %3ld\n",
- cc->module, cc->label, cc->time_ticks * 100/TICK_FREQUENCY);
-#else
- fprintf(serial_file, " %s:%s %3ld\n",
- cc->module, cc->label, cc->time_ticks);
-#endif
- }
- }
-
- fprintf(serial_file, "END_SAMPLE %0.2f\n", seconds);
- fflush(serial_file);
- }
- }
-
- for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
- ASSERT_IS_REGISTERED(cc, 0);
- cc->prev_ticks += cc->time_ticks;
- cc->time_ticks = 0;
-
- if ( cc_to_ignore(cc) ) { /* reporting these just confuses users... */
- ignored_ticks += cc->prev_ticks;
- } else {
- total_ticks += cc->prev_ticks;
- total_alloc += cc->mem_alloc;
-#if defined(PROFILING_DETAIL_COUNTS)
- total_allocs += cc->mem_allocs;
-#endif
- }
- }
-
- if (total_ticks + ignored_ticks != current_ticks + previous_ticks)
- fprintf(stderr, "Warning: Cost Centre tick inconsistency: total=%ld, ignored=%ld, current=%ld, previous=%ld\n", total_ticks, ignored_ticks, current_ticks, previous_ticks);
-
- unblockVtAlrmSignal();
-
- /* return if no cc profile required */
- if (!final && ++dump_interval < dump_intervals)
- return;
-
- /* reset dump_interval -- dump again after dump_intervals */
- dump_interval = 0;
-
- /* sort cost centres */
- cc_sort(&Registered_CC, RTSflags.CcFlags.sortBy);
-
- /* open profiling output file */
- if ((prof_file = fopen(prof_filename, "w")) == NULL) {
- fprintf(stderr, "Can't open profiling report file %s\n", prof_filename);
- return;
- }
- fprintf(prof_file, "\t%s Time and Allocation Profiling Report (%s)\n", time_str(),
- final ? "Final" : "PARTIAL");
-
- fprintf(prof_file, "\n\t ");
- fprintf(prof_file, " %s", prog_argv_save[0]);
- fprintf(prof_file, " +RTS");
- for (count = 0; rts_argv_save[count]; count++)
- fprintf(prof_file, " %s", rts_argv_save[count]);
- fprintf(prof_file, " -RTS");
- for (count = 1; prog_argv_save[count]; count++)
- fprintf(prof_file, " %s", prog_argv_save[count]);
- fprintf(prof_file, "\n\n");
-
-
- fprintf(prof_file, "\ttotal time = %11.2f secs (%lu ticks @ %d ms)\n",
- total_ticks / (StgFloat) TICK_FREQUENCY, total_ticks, TICK_MILLISECS);
- fprintf(prof_file, "\ttotal alloc = %11s bytes",
- ullong_format_string((ullong) total_alloc * sizeof(W_), temp, rtsTrue/*commas*/));
- /* ToDo: 64-bit error! */
-
-#if defined(PROFILING_DETAIL_COUNTS)
- fprintf(prof_file, " (%lu closures)", total_allocs);
-#endif
- fprintf(prof_file, " (excludes profiling overheads)\n\n");
-
-
- fprintf(prof_file, "%-16s %-11s", "COST CENTRE", "MODULE");
-
- do_groups = have_interesting_groups(Registered_CC);
- if (do_groups) fprintf(prof_file, " %-11.11s", "GROUP");
-
- fprintf(prof_file, "%8s %6s %6s %8s %5s %5s", "scc", "%time", "%alloc", "inner", "cafs", "dicts");
-
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
- fprintf(prof_file, " %5s %9s", "ticks", "bytes");
-#if defined(PROFILING_DETAIL_COUNTS)
- fprintf(prof_file, " %8s %8s %8s %8s %8s %8s %8s",
- "closures", "thunks", "funcs", "PAPs", "subfuns", "subcafs", "cafssub");
-#endif
- }
- fprintf(prof_file, "\n\n");
-
- for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
- ASSERT_IS_REGISTERED(cc, 0);
-
- /* Only print cost centres with non 0 data ! */
-
- if ( (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_ALL
- /* force printing of *all* cost centres if -P -P */ )
-
- || ( ! cc_to_ignore(cc)
- && (cc->scc_count || cc->sub_scc_count || cc->prev_ticks || cc->mem_alloc
- || (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
- && (cc->sub_cafcc_count || cc->sub_dictcc_count
-#if defined(PROFILING_DETAIL_COUNTS)
- || cc->thunk_count || cc->function_count || cc->pap_count
-#endif
- ))))) {
- fprintf(prof_file, "%-16s %-11s", cc->label, cc->module);
- if (do_groups) fprintf(prof_file, " %-11.11s",cc->group);
-
- fprintf(prof_file, "%8ld %5.1f %5.1f %8ld %5ld %5ld",
- cc->scc_count,
- total_ticks == 0 ? 0.0 : (cc->prev_ticks / (StgFloat) total_ticks * 100),
- total_alloc == 0 ? 0.0 : (cc->mem_alloc / (StgFloat) total_alloc * 100),
- cc->sub_scc_count, cc->sub_cafcc_count, cc->sub_dictcc_count);
-
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
- fprintf(prof_file, " %5ld %9ld", cc->prev_ticks, cc->mem_alloc*sizeof(W_));
-#if defined(PROFILING_DETAIL_COUNTS)
- fprintf(prof_file, " %8ld %8ld %8ld %8ld %8ld %8ld %8ld",
- cc->mem_allocs, cc->thunk_count,
- cc->function_count, cc->pap_count,
- cc->subsumed_fun_count, cc->subsumed_caf_count,
- cc->caffun_subsumed);
-#endif
- }
- fprintf(prof_file, "\n");
- }
- }
-
- fclose(prof_file);
-}
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Miscellaneous profiling routines}
-%* *
-%************************************************************************
-
-Routine to sort the list of registered cost centres. Uses a simple
-insertion sort. First we need the different comparison routines.
-
-\begin{code}
-
-static I_
-cc_lt_label(CostCentre cc1, CostCentre cc2)
-{
- I_ cmp;
-
- cmp = strcmp(cc1->group, cc2->group);
-
- if (cmp< 0)
- return 1; /* group < */
- else if (cmp > 0)
- return 0; /* group > */
-
- cmp = strcmp(cc1->module, cc2->module);
-
- if (cmp < 0)
- return 1; /* mod < */
- else if (cmp > 0)
- return 0; /* mod > */
-
- return (strcmp(cc1->label, cc2->label) < 0); /* cmp labels */
-}
-
-static I_
-cc_gt_time(CostCentre cc1, CostCentre cc2)
-{
- /* ToDo: normal then caf then dict (instead of scc at top) */
-
- if (cc1->scc_count && ! cc2->scc_count) /* scc counts at top */
- return 1;
- if (cc2->scc_count && ! cc1->scc_count) /* scc counts at top */
- return 0;
-
- if (cc1->prev_ticks > cc2->prev_ticks) /* time greater */
- return 1;
- else if (cc1->prev_ticks < cc2->prev_ticks) /* time less */
- return 0;
-
- if (cc1->mem_alloc > cc2->mem_alloc) /* time equal; alloc greater */
- return 1;
- else if (cc1->mem_alloc < cc2->mem_alloc) /* time equal; alloc less */
- return 0;
-
- return (cc_lt_label(cc1, cc2)); /* all data equal: cmp labels */
-}
-
-static I_
-cc_gt_alloc(CostCentre cc1, CostCentre cc2)
-{
- /* ToDo: normal then caf then dict (instead of scc at top) */
-
- if (cc1->scc_count && ! cc2->scc_count) /* scc counts at top */
- return 1;
- if (cc2->scc_count && ! cc1->scc_count) /* scc counts at top */
- return 0;
-
- if (cc1->mem_alloc > cc2->mem_alloc) /* alloc greater */
- return 1;
- else if (cc1->mem_alloc < cc2->mem_alloc) /* alloc less */
- return 0;
-
- if (cc1->prev_ticks > cc2->prev_ticks) /* alloc equal; time greater */
- return 1;
- else if (cc1->prev_ticks < cc2->prev_ticks) /* alloc equal; time less */
- return 0;
-
- return (cc_lt_label(cc1, cc2)); /* all data equal: cmp labels */
-}
-
-void
-cc_sort(CostCentre *sort, char sort_on)
-{
- I_ (*cc_lt)();
- CostCentre sorted, insert, *search, insert_rest;
-
- switch (sort_on) {
- case SORTCC_LABEL:
- cc_lt = cc_lt_label;
- break;
- case SORTCC_TIME:
- cc_lt = cc_gt_time;
- break;
- case SORTCC_ALLOC:
- cc_lt = cc_gt_alloc;
- break;
- default:
- abort(); /* "can't happen" */
- }
-
- sorted = REGISTERED_END;
- insert = *sort;
-
- while (insert != REGISTERED_END) {
-
- /* set search to the address of cc required to follow insert */
- search = &sorted;
- while (*search != REGISTERED_END && (cc_lt)(*search,insert)) {
- search = &((*search)->registered);
- }
-
- /* place insert at *search and go to next insert */
- insert_rest = insert->registered;
- insert->registered = *search;
- *search = insert;
- insert = insert_rest;
- }
-
- *sort = sorted;
-}
-\end{code}
-
-\begin{code}
-#endif /* PROFILING || PAR */
-\end{code}
+++ /dev/null
-Hashing functions based on:
-
- "Fast Hashing of Variable Length Text Strings"
- Peter K. Pearson, CACM June 1990
-
-They return a 32 bit value containing 16 bits of hash value.
-
-\begin{code}
-#include "rtsdefs.h"
-
-static const StgChar auxTable[] = {
-(StgChar)0x01, (StgChar)0x57, (StgChar)0x31, (StgChar)0x0c, (StgChar)0xb0, (StgChar)0xb2, (StgChar)0x66, (StgChar)0xa6,
-(StgChar)0x79, (StgChar)0xc1, (StgChar)0x06, (StgChar)0x54, (StgChar)0xf9, (StgChar)0xe6, (StgChar)0x2c, (StgChar)0xa3,
-(StgChar)0x0e, (StgChar)0xc5, (StgChar)0xd5, (StgChar)0xb5, (StgChar)0xa1, (StgChar)0x55, (StgChar)0xda, (StgChar)0x50,
-(StgChar)0x40, (StgChar)0xef, (StgChar)0x18, (StgChar)0xe2, (StgChar)0xec, (StgChar)0x8e, (StgChar)0x26, (StgChar)0xc8,
-(StgChar)0x6e, (StgChar)0xb1, (StgChar)0x68, (StgChar)0x67, (StgChar)0x8d, (StgChar)0xfd, (StgChar)0xff, (StgChar)0x32,
-(StgChar)0x4d, (StgChar)0x65, (StgChar)0x51, (StgChar)0x12, (StgChar)0x2d, (StgChar)0x60, (StgChar)0x1f, (StgChar)0xde,
-(StgChar)0x19, (StgChar)0x6b, (StgChar)0xbe, (StgChar)0x46, (StgChar)0x56, (StgChar)0xed, (StgChar)0xf0, (StgChar)0x22,
-(StgChar)0x48, (StgChar)0xf2, (StgChar)0x14, (StgChar)0xd6, (StgChar)0xf4, (StgChar)0xe3, (StgChar)0x95, (StgChar)0xeb,
-(StgChar)0x61, (StgChar)0xea, (StgChar)0x39, (StgChar)0x16, (StgChar)0x3c, (StgChar)0xfa, (StgChar)0x52, (StgChar)0xaf,
-(StgChar)0xd0, (StgChar)0x05, (StgChar)0x7f, (StgChar)0xc7, (StgChar)0x6f, (StgChar)0x3e, (StgChar)0x87, (StgChar)0xf8,
-(StgChar)0xae, (StgChar)0xa9, (StgChar)0xd3, (StgChar)0x3a, (StgChar)0x42, (StgChar)0x9a, (StgChar)0x6a, (StgChar)0xc3,
-(StgChar)0xf5, (StgChar)0xab, (StgChar)0x11, (StgChar)0xbb, (StgChar)0xb6, (StgChar)0xb3, (StgChar)0x00, (StgChar)0xf3,
-(StgChar)0x84, (StgChar)0x38, (StgChar)0x94, (StgChar)0x4b, (StgChar)0x80, (StgChar)0x85, (StgChar)0x9e, (StgChar)0x64,
-(StgChar)0x82, (StgChar)0x7e, (StgChar)0x5b, (StgChar)0x0d, (StgChar)0x99, (StgChar)0xf6, (StgChar)0xd8, (StgChar)0xdb,
-(StgChar)0x77, (StgChar)0x44, (StgChar)0xdf, (StgChar)0x4e, (StgChar)0x53, (StgChar)0x58, (StgChar)0xc9, (StgChar)0x63,
-(StgChar)0x7a, (StgChar)0x0b, (StgChar)0x5c, (StgChar)0x20, (StgChar)0x88, (StgChar)0x72, (StgChar)0x34, (StgChar)0x0a,
-(StgChar)0x8a, (StgChar)0x1e, (StgChar)0x30, (StgChar)0xb7, (StgChar)0x9c, (StgChar)0x23, (StgChar)0x3d, (StgChar)0x1a,
-(StgChar)0x8f, (StgChar)0x4a, (StgChar)0xfb, (StgChar)0x5e, (StgChar)0x81, (StgChar)0xa2, (StgChar)0x3f, (StgChar)0x98,
-(StgChar)0xaa, (StgChar)0x07, (StgChar)0x73, (StgChar)0xa7, (StgChar)0xf1, (StgChar)0xce, (StgChar)0x03, (StgChar)0x96,
-(StgChar)0x37, (StgChar)0x3b, (StgChar)0x97, (StgChar)0xdc, (StgChar)0x5a, (StgChar)0x35, (StgChar)0x17, (StgChar)0x83,
-(StgChar)0x7d, (StgChar)0xad, (StgChar)0x0f, (StgChar)0xee, (StgChar)0x4f, (StgChar)0x5f, (StgChar)0x59, (StgChar)0x10,
-(StgChar)0x69, (StgChar)0x89, (StgChar)0xe1, (StgChar)0xe0, (StgChar)0xd9, (StgChar)0xa0, (StgChar)0x25, (StgChar)0x7b,
-(StgChar)0x76, (StgChar)0x49, (StgChar)0x02, (StgChar)0x9d, (StgChar)0x2e, (StgChar)0x74, (StgChar)0x09, (StgChar)0x91,
-(StgChar)0x86, (StgChar)0xe4, (StgChar)0xcf, (StgChar)0xd4, (StgChar)0xca, (StgChar)0xd7, (StgChar)0x45, (StgChar)0xe5,
-(StgChar)0x1b, (StgChar)0xbc, (StgChar)0x43, (StgChar)0x7c, (StgChar)0xa8, (StgChar)0xfc, (StgChar)0x2a, (StgChar)0x04,
-(StgChar)0x1d, (StgChar)0x6c, (StgChar)0x15, (StgChar)0xf7, (StgChar)0x13, (StgChar)0xcd, (StgChar)0x27, (StgChar)0xcb,
-(StgChar)0xe9, (StgChar)0x28, (StgChar)0xba, (StgChar)0x93, (StgChar)0xc6, (StgChar)0xc0, (StgChar)0x9b, (StgChar)0x21,
-(StgChar)0xa4, (StgChar)0xbf, (StgChar)0x62, (StgChar)0xcc, (StgChar)0xa5, (StgChar)0xb4, (StgChar)0x75, (StgChar)0x4c,
-(StgChar)0x8c, (StgChar)0x24, (StgChar)0xd2, (StgChar)0xac, (StgChar)0x29, (StgChar)0x36, (StgChar)0x9f, (StgChar)0x08,
-(StgChar)0xb9, (StgChar)0xe8, (StgChar)0x71, (StgChar)0xc4, (StgChar)0xe7, (StgChar)0x2f, (StgChar)0x92, (StgChar)0x78,
-(StgChar)0x33, (StgChar)0x41, (StgChar)0x1c, (StgChar)0x90, (StgChar)0xfe, (StgChar)0xdd, (StgChar)0x5d, (StgChar)0xbd,
-(StgChar)0xc2, (StgChar)0x8b, (StgChar)0x70, (StgChar)0x2b, (StgChar)0x47, (StgChar)0x6d, (StgChar)0xb8, (StgChar)0xd1};
-
-hash_t
-hash_str(str)
- char *str;
-{
- hash_t h1, h2;
- hash_t ch = (hash_t) *(str++);
-
- if (ch == 0) return 0;
-
- h1 = (hash_t) auxTable[ch];
- h2 = (hash_t) auxTable[ch+1];
-
- while ( (ch = (hash_t)*(str++) ) != 0) {
- h1 = (hash_t) auxTable[h1^ch];
- h2 = (hash_t) auxTable[h2^ch];
- }
-
- return ( h2 << 8 | h1 );
-}
-
-hash_t
-hash_fixed(data, len)
- char *data;
- I_ len; /* bytes in data, must be > 0 */
-{
- hash_t ch = (hash_t) *(data++);
- hash_t h1 = (hash_t) auxTable[ch];
- hash_t h2 = (hash_t) auxTable[ch+1];
-
- ASSERT(len > 0);
-
- while (--len > 0) {
- ch = (hash_t) *(data++);
- h1 = (hash_t) auxTable[h1^ch];
- h2 = (hash_t) auxTable[h2^ch];
- }
-
- return ( h2 << 8 | h1 );
-}
-\end{code}
-
-
-
+++ /dev/null
-Only have cost centres etc if @PROFILING@ defined
-
-\begin{code}
-/*
- Some of the code in here is pretty hairy for the compiler to deal
- with after we've swiped all of the useful registers. I don't believe
- any STG registers are live here, but I'm not completely certain.
-
- Any specific routines that require the preservation of caller-saves
- STG registers should be pulled out into another file and compiled
- with the the appropriate register map. (Presumably one of the GC
- register mappings?) --JSM
- */
-
-#define NULL_REG_MAP
-#include "../storage/SMinternal.h" /* for ???? */
-
-#if defined (PROFILING)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[heap-profiling]{Heap Profiling}
-%* *
-%************************************************************************
-
-The heap profiling reports the amount of heap space occupied by live
-closures pressent in the heap during a garbage collection. This
-profile may be broken down in a number of ways:
-\begin{itemize}
-\item {\bf Cost Centre:} The cost centres responsible for building the
-various closures in the heap.
-\item {\bf Module:} Aggregation of all the cost centres declared in a module.
-\item {\bf Group:} Aggregation of all the cost centres declared in a group.
-\item {\bf Closure Description:} The heap occupied by closures with a particular description (normally the data constructor).
-\item {\bf Type Description:} The heap occupied by closures with a particular type (normally the type constructor).
-\item {\bf Production time stamp:} The heap occupied by closures of produced during a particular time interval.
-\end{itemize}
-
-Relevant closures may be selected by the Cost Centre (label, module
-and group), by Closure Category (description, type, and kind) and/or
-by age. A cost centre will be selected if its label, module or group
-is selected (default is all). A closure category will be selected if
-its description, type or kind is selected (default is all). A closure
-will be selected if both its cost centre, closure category and age are
-selected.
-
-When recording the size of the heap objects the additional profiling
-etc words are disregarded. The profiling itself is considered an
-idealised process which should not affect the statistics gathered.
-
-\begin{code}
-#define MAX_SELECT 10
-
-static char heap_profiling_char[] /* indexed by RTSflags.ProfFlags.doHeapProfile */
- = {'?', CCchar, MODchar, GRPchar, DESCRchar, TYPEchar, TIMEchar};
-
-static I_ cc_select = 0; /* are we selecting on Cost Centre */
-static I_ clcat_select = 0; /* are we selecting on Closure Category*/
-
-static I_ cc_select_no = 0;
-static char *cc_select_strs[MAX_SELECT];
-static char *ccmod_select_strs[MAX_SELECT];
-
-static I_ mod_select_no = 0;
-static char *mod_select_strs[MAX_SELECT];
-static I_ grp_select_no = 0;
-static char *grp_select_strs[MAX_SELECT];
-
-static I_ descr_select_no = 0;
-static char *descr_select_strs[MAX_SELECT];
-static I_ type_select_no = 0;
-static char *type_select_strs[MAX_SELECT];
-static I_ kind_select_no = 0;
-static I_ kind_selected[] = {0, 0, 0, 0, 0, 0};
-static char *kind_select_strs[] = {"","CON","FN","PAP","THK","BH",0};
-
-I_ *resid = 0; /* residencies indexed by hashed feature */
-
-/* For production times we have a resid table of time_intervals */
-/* And a seperate resid counter stuff produced earlier & later */
-
-I_ resid_earlier = 0;
-I_ resid_later = 0;
-I_ resid_max = 0; /* Max residency -- used for aux file */
-
-I_ earlier_ticks = 0; /* No of earlier ticks grouped together */
-hash_t time_intervals = 18; /* No of time_intervals, also earlier & later */
-
-static hash_t earlier_intervals; /* No of earlier intervals grouped together + 1*/
-
-hash_t
-dummy_index_time(STG_NO_ARGS)
-{
- return time_intervals;
-}
-
-hash_t (* init_index_fns[])() = {
- 0,
- init_index_cc,
- init_index_mod,
- init_index_grp,
- init_index_descr,
- init_index_type,
- dummy_index_time
-};
-
-static char heap_filename[STATS_FILENAME_MAXLEN]; /* heap log file name = <program>.hp */
-static FILE *heap_file = NULL;
-
-I_
-heap_profile_init(argv)
- char *argv[];
-{
- char *cc_select_str = RTSflags.ProfFlags.ccSelector;
- char *mod_select_str = RTSflags.ProfFlags.modSelector;
- char *grp_select_str = RTSflags.ProfFlags.grpSelector;
- char *descr_select_str = RTSflags.ProfFlags.descrSelector;
- char *type_select_str = RTSflags.ProfFlags.typeSelector;
- char *kind_select_str = RTSflags.ProfFlags.kindSelector;
-
- hash_t count, max, first;
- W_ heap_prof_style;
-
- if (! RTSflags.ProfFlags.doHeapProfile)
- return 0;
-
- /* for now, if using a generational collector and trying
- to heap-profile, just force the GC to be used in two-space mode.
- WDP 94/07
- */
-#if defined(GCap) || defined(GCgn)
- RTSflags.GcFlags.force2s = rtsTrue;
-#endif
-
- heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
-
- /* process select strings -- will break them into bits */
-
- if (cc_select_str) {
- char *comma, *colon;
- while (cc_select_str && cc_select_no < MAX_SELECT) {
- if ((comma = strchr(cc_select_str, ',')) != 0) {
- *comma = '\0';
- }
- if ((colon = strchr(cc_select_str, ':')) != 0) {
- *colon = '\0';
- ccmod_select_strs[cc_select_no] = cc_select_str;
- cc_select_strs[cc_select_no++] = colon + 1;
- } else {
- ccmod_select_strs[cc_select_no] = (char *)0;
- cc_select_strs[cc_select_no++] = cc_select_str;
- }
- if (comma) {
- cc_select_str = comma + 1;
- } else {
- cc_select_str = (char *)0;
- }
- }
- if (cc_select_str && cc_select_no >= MAX_SELECT) {
- fprintf(stderr, "heap_profile_init: Too many Cost Centres selected\n %ld used %s remaining\n",
- cc_select_no, cc_select_str);
- return 1;
- }
- cc_select |= cc_select_no > 0;
- }
- if (mod_select_str) {
- char *comma;
- while ((comma = strchr(mod_select_str, ',')) && mod_select_no < MAX_SELECT) {
- mod_select_strs[mod_select_no++] = mod_select_str;
- *comma = '\0';
- mod_select_str = comma + 1;
- }
- if (mod_select_no < MAX_SELECT) {
- mod_select_strs[mod_select_no++] = mod_select_str;
- } else {
- fprintf(stderr, "heap_profile_init: Too many Modules selected\n %ld used %s remaining\n",
- mod_select_no, mod_select_str);
- return 1;
- }
- cc_select |= mod_select_no > 0;
- }
- if (grp_select_str) {
- char *comma;
- while ((comma = strchr(grp_select_str, ',')) && grp_select_no < MAX_SELECT) {
- grp_select_strs[grp_select_no++] = grp_select_str;
- *comma = '\0';
- grp_select_str = comma + 1;
- }
- if (grp_select_no < MAX_SELECT) {
- grp_select_strs[grp_select_no++] = grp_select_str;
- } else {
- fprintf(stderr, "heap_profile_init: Too many Groups selected\n %ld used %s remaining\n",
- grp_select_no, grp_select_str);
- return 1;
- }
- cc_select |= grp_select_no > 0;
- }
-
- if (descr_select_str) {
- char *comma;
- while ((comma = strchr(descr_select_str, ',')) && descr_select_no < MAX_SELECT) {
- descr_select_strs[descr_select_no++] = descr_select_str;
- *comma = '\0';
- descr_select_str = comma + 1;
- }
- if (descr_select_no < MAX_SELECT) {
- descr_select_strs[descr_select_no++] = descr_select_str;
- } else {
- fprintf(stderr, "heap_profile_init: Too many Closure Descriptions selected\n %ld used %s remaining\n",
- descr_select_no, descr_select_str);
- return 1;
- }
- clcat_select |= descr_select_no > 0;
- }
- if (type_select_str) {
- char *comma;
- while ((comma = strchr(type_select_str, ',')) && type_select_no < MAX_SELECT) {
- type_select_strs[type_select_no++] = type_select_str;
- *comma = '\0';
- type_select_str = comma + 1;
- }
- if (type_select_no < MAX_SELECT) {
- type_select_strs[type_select_no++] = type_select_str;
- } else {
- fprintf(stderr, "heap_profile_init: Too many Closure Types selected\n %ld used %s remaining\n",
- type_select_no, type_select_str);
- return 1;
- }
- clcat_select |= type_select_no > 0;
- }
- if (kind_select_str) {
- char *comma;
- while ((comma = strchr(kind_select_str, ',')) != 0) {
- *comma = '\0';
- for (count = 1; kind_select_strs[count]; count++) {
- if (strcmp(kind_select_strs[count],kind_select_str) == 0) {
- kind_selected[count] = 1;
- kind_select_no++;
- break;
- }
- }
- if (! kind_select_strs[count]) {
- fprintf(stderr, "heap_profile_init: Invalid Kind: %s\n", kind_select_str);
- return 1;
- }
- kind_select_str = comma + 1;
- }
- for (count = 1; kind_select_strs[count]; count++) {
- if (strcmp(kind_select_strs[count],kind_select_str) == 0) {
- kind_selected[count] = 1;
- kind_select_no++;
- break;
- }
- }
- if (! kind_select_strs[count]) {
- fprintf(stderr, "heap_profile_init: Invalid Kind: %s\n", kind_select_str);
- return 1;
- }
- clcat_select |= kind_select_no > 0;
- }
-
- /* open heap profiling log file */
-
- sprintf(heap_filename, HP_FILENAME_FMT, argv[0]);
- if ( (heap_file = fopen(heap_filename,"w")) == NULL ) {
- fprintf(stderr, "Can't open heap log file %s\n", heap_filename);
- return 1;
- }
-
- /* write start of log file */
-
- fprintf(heap_file, "JOB \"%s", argv[0]);
- fprintf(heap_file, " +RTS -h%c", heap_profiling_char[heap_prof_style]);
- if (heap_prof_style == HEAP_BY_TIME) {
- fprintf(heap_file, "%ld", time_intervals);
- if (earlier_ticks) {
- fprintf(heap_file, ",%3.1f",
- earlier_ticks / (StgFloat)TICK_FREQUENCY);
- }
- }
- if (cc_select_no) {
- fprintf(heap_file, " -c{%s:%s",
- ccmod_select_strs[0],
- cc_select_strs[0]);
- for (count = 1; count < cc_select_no; count++) {
- fprintf(heap_file, ",%s:%s",
- ccmod_select_strs[count],
- cc_select_strs[count]);
- }
- fprintf(heap_file, "}");
- }
- if (mod_select_no) {
- fprintf(heap_file, " -m{%s", mod_select_strs[0]);
- for (count = 1; count < mod_select_no; count++)
- fprintf(heap_file, ",%s", mod_select_strs[count]);
- fprintf(heap_file, "}");
- }
- if (grp_select_no) {
- fprintf(heap_file, " -g{%s", grp_select_strs[0]);
- for (count = 1; count < grp_select_no; count++)
- fprintf(heap_file, ",%s", grp_select_strs[count]);
- fprintf(heap_file, "}");
- }
- if (descr_select_no) {
- fprintf(heap_file, " -d{%s", descr_select_strs[0]);
- for (count = 1; count < descr_select_no; count++)
- fprintf(heap_file, ",%s", descr_select_strs[count]);
- fprintf(heap_file, "}");
- }
- if (type_select_no) {
- fprintf(heap_file, " -y{%s", type_select_strs[0]);
- for (count = 1; count < type_select_no; count++)
- fprintf(heap_file, ",%s", type_select_strs[count]);
- fprintf(heap_file, "}");
- }
- if (kind_select_no) {
- fprintf(heap_file, " -k{");
- for (count = 1, first = 1; kind_select_strs[count]; count++)
- if (kind_selected[count]) {
- fprintf(heap_file, "%s%s", first?"":",", kind_select_strs[count]);
- first = 0;
- }
- fprintf(heap_file, "}");
- }
-
- fprintf(heap_file, " -i%4.2f -RTS", interval_ticks/(StgFloat)TICK_FREQUENCY);
- for(count = 1; argv[count]; count++)
- fprintf(heap_file, " %s", argv[count]);
- fprintf(heap_file, "\"\n");
-
- fprintf(heap_file, "DATE \"%s\"\n", time_str());
-
- fprintf(heap_file, "SAMPLE_UNIT \"seconds\"\n");
- fprintf(heap_file, "VALUE_UNIT \"bytes\"\n");
-
- fprintf(heap_file, "BEGIN_SAMPLE 0.00\n");
- fprintf(heap_file, "END_SAMPLE 0.00\n");
-
-
- /* initialise required heap profiling data structures & hashing */
-
- earlier_intervals = (earlier_ticks / interval_ticks) + 1;
- max = (* init_index_fns[heap_prof_style])();
- resid = (I_ *) stgMallocBytes(max * sizeof(I_), "heap_profile_init");
-
- for (count = 0; count < max; count++)
- resid[count] = 0;
-
- return 0;
-}
-\end{code}
-
-Cost centre selection is set up before a heap profile by running
-through the list of registered cost centres and memoising the
-selection in the cost centre record. It is only necessary to memoise
-the cost centre selection if a selection profiling function is
-being called.
-
-Category selection is determined when each closure is encountered. It
-is memoised within the category record. We always have to check that
-the memoisation has been done as we do not have a list of categories
-we can process before hand.
-
-Age selection is done for every closure -- not memoised.
-
-\begin{code}
-void
-set_selected_ccs(STG_NO_ARGS) /* set selection before we profile heap */
-{
- I_ x;
- CostCentre cc;
-
- if (cc_select) {
- for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
- for (x = 0; ! cc->selected && x < cc_select_no; x++)
- cc->selected = (strcmp(cc->label, cc_select_strs[x]) == 0) &&
- (strcmp(cc->module, ccmod_select_strs[x]) == 0);
- for (x = 0; ! cc->selected && x < mod_select_no; x++)
- cc->selected = (strcmp(cc->module, mod_select_strs[x]) == 0);
- for (x = 0; ! cc->selected && x < grp_select_no; x++)
- cc->selected = (strcmp(cc->group, grp_select_strs[x]) == 0);
- }
- } else {
- for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered)
- cc->selected = 1; /* true if ! cc_select */
- }
-}
-
-
-I_
-selected_clcat(ClCategory clcat)
-{
- I_ x;
-
- if (clcat->selected == -1) { /* if not memoised check selection */
- if (clcat_select) {
- clcat->selected = 0;
- for (x = 0; ! clcat->selected && x < descr_select_no; x++)
- clcat->selected = (strcmp(clcat->descr, descr_select_strs[x]) == 0);
- for (x = 0; ! clcat->selected && x < type_select_no; x++)
- clcat->selected = (strcmp(clcat->type, type_select_strs[x]) == 0);
- if (kind_select_no) clcat->selected |= kind_selected[clcat->kind];
- } else {
- clcat->selected = 1;
- }
- }
- return clcat->selected; /* return memoised selection */
-}
-\end{code}
-
-
-Profiling functions called for each closure. The appropriate function
-is stored in @heap_profile_fn@ by @heap_profile_setup@.
-@heap_profile_fn@ is called for each live closure by the macros
-embedded in the garbage collector. They increment the appropriate
-resident space counter by the size of the closure (less any profiling
-words).
-
-\begin{code}
-#define NON_PROF_HS (FIXED_HS - PROF_FIXED_HDR - TICKY_FIXED_HDR)
-
-void
-profile_closure_cc(P_ closure, I_ size)
-{
- CostCentre cc = (CostCentre) CC_HDR(closure);
- resid[index_cc(cc)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_cc_select(P_ closure, I_ size)
-{
- CostCentre cc; ClCategory clcat;
-
- cc = (CostCentre) CC_HDR(closure);
- if (! cc->selected) /* selection determined before profile */
- return; /* all selected if ! cc_select */
-
- clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
- return;
-
- resid[index_cc(cc)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_mod(P_ closure, I_ size)
-{
- CostCentre cc = (CostCentre) CC_HDR(closure);
- resid[index_mod(cc)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_mod_select(P_ closure, I_ size)
-{
- CostCentre cc; ClCategory clcat;
-
- cc = (CostCentre) CC_HDR(closure);
- if (! cc->selected) /* selection determined before profile */
- return;
-
- clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
- return;
-
- resid[index_mod(cc)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_grp(P_ closure, I_ size)
-{
- CostCentre cc = (CostCentre) CC_HDR(closure);
- resid[index_grp(cc)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_grp_select(P_ closure, I_ size)
-{
- CostCentre cc; ClCategory clcat;
-
- cc = (CostCentre) CC_HDR(closure);
- if (! cc->selected) /* selection determined before profile */
- return;
-
- clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
- return;
-
- resid[index_grp(cc)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_descr(P_ closure, I_ size)
-{
- ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- resid[index_descr(clcat)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_descr_select(P_ closure, I_ size)
-{
- CostCentre cc; ClCategory clcat;
-
- cc = (CostCentre) CC_HDR(closure);
- if (! cc->selected) /* selection determined before profile */
- return; /* all selected if ! cc_select */
-
- clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
- return;
-
- resid[index_descr(clcat)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_type(P_ closure, I_ size)
-{
- ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- resid[index_type(clcat)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_type_select(P_ closure, I_ size)
-{
- CostCentre cc; ClCategory clcat;
-
- cc = (CostCentre) CC_HDR(closure);
- if (! cc->selected) /* selection determined before profile */
- return; /* all selected if ! cc_select */
-
- clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
- return;
-
- resid[index_type(clcat)] += size + NON_PROF_HS;
- return;
-}
-
-void
-profile_closure_time(P_ closure, I_ size)
-{
- return;
-}
-
-void
-profile_closure_time_select(P_ closure, I_ size)
-{
- return;
-}
-\end{code}
-
-@heap_profile_setup@ is called before garbage collection to initialise
-for the profile. It assigns the appropriate closure profiling function
-to @heap_profile_fn@ and memoises any cost centre selection. If no
-profile is required @heap_profile_fn@ is assigned NULL.
-
-On completion of garbage collection @heap_profile_done@ is called. It
-produces a heap profile report and resets the residency counts to 0.
-
-\begin{code}
-
-void (* heap_profile_fn) PROTO((P_,I_)) = NULL;
-
-void (* profiling_fns_select[]) PROTO((P_,I_)) = {
- NULL,
- profile_closure_cc_select,
- profile_closure_mod_select,
- profile_closure_grp_select,
- profile_closure_descr_select,
- profile_closure_type_select,
- profile_closure_time_select
-};
-
-void (* profiling_fns[]) PROTO((P_,I_)) = {
- NULL,
- profile_closure_cc,
- profile_closure_mod,
- profile_closure_grp,
- profile_closure_descr,
- profile_closure_type,
- profile_closure_time
-};
-
-void
-heap_profile_setup(STG_NO_ARGS) /* called at start of heap profile */
-{
- W_ heap_prof_style;
-
- if (! RTSflags.ProfFlags.doHeapProfile)
- return;
-
- heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
-
- if (cc_select || clcat_select) {
- set_selected_ccs(); /* memoise cc selection */
- heap_profile_fn = profiling_fns_select[heap_prof_style];
- } else {
- heap_profile_fn = profiling_fns[heap_prof_style];
- }
-}
-
-void
-heap_profile_done(STG_NO_ARGS) /* called at end of heap profile */
-{
- CostCentre cc;
- ClCategory clcat;
- hash_t ind, max;
- StgFloat seconds;
- W_ heap_prof_style;
-
- if (! RTSflags.ProfFlags.doHeapProfile)
- return;
-
- heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
- heap_profile_fn = NULL;
-
- seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
- fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);
-
- max = (* init_index_fns[heap_prof_style])();
-
- switch (heap_prof_style) {
- case HEAP_BY_CC:
- for (ind = 0; ind < max; ind++) {
- if ((cc = index_cc_table[ind]) != 0 && ! cc_to_ignore(cc)) {
- fprintf(heap_file, " %s:%s %ld\n", cc->module, cc->label, resid[ind] * sizeof(W_));
- }
- resid[ind] = 0;
- }
- break;
-
- case HEAP_BY_MOD:
- for (ind = 0; ind < max; ind++) {
- if ((cc = index_mod_table[ind]) != 0 && ! cc_to_ignore(cc)) {
- fprintf(heap_file, " %s %ld\n", cc->module, resid[ind] * sizeof(W_));
- }
- resid[ind] = 0;
- }
- break;
-
- case HEAP_BY_GRP:
- for (ind = 0; ind < max; ind++) {
- if ((cc = index_grp_table[ind]) != 0 && ! cc_to_ignore(cc)) {
- fprintf(heap_file, " %0.11s %ld\n", cc->group, resid[ind] * sizeof(W_));
- }
- resid[ind] = 0;
- }
- break;
-
- case HEAP_BY_DESCR:
- for (ind = 0; ind < max; ind++) {
- if ((clcat = index_descr_table[ind]) != 0 && ! cc_to_ignore(cc)) {
- fprintf(heap_file, " %0.28s %ld\n", clcat->descr, resid[ind] * sizeof(W_));
- }
- resid[ind] = 0;
- }
- break;
-
- case HEAP_BY_TYPE:
- for (ind = 0; ind < max; ind++) {
- if ((clcat = index_type_table[ind]) != 0 && ! cc_to_ignore(cc)) {
- fprintf(heap_file, " %0.28s %ld\n", clcat->type, resid[ind] * sizeof(W_));
- }
- resid[ind] = 0;
- }
- break;
- }
-
- fprintf(heap_file, "END_SAMPLE %0.2f\n", seconds);
- fflush(heap_file);
-}
-
-void
-heap_profile_finish(STG_NO_ARGS) /* called at end of execution */
-{
- StgFloat seconds;
-
- if (! RTSflags.ProfFlags.doHeapProfile)
- return;
-
- seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
- fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);
- fprintf(heap_file, "END_SAMPLE %0.2f\n", seconds);
- fclose(heap_file);
-
- return;
-}
-\end{code}
-
-\begin{code}
-#endif /* PROFILING */
-\end{code}
+++ /dev/null
-Only have cost centres etc if @PROFILING@ defined
-
-\begin{code}
-#define NULL_REG_MAP /* Not threaded */
-#include "../storage/SMinternal.h" /* for ??? */
-#if defined (PROFILING)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[indexing]{Indexing Cost Centres and Closure Categories}
-%* *
-%************************************************************************
-
-See \tr{CostCentre.lh} for an overview.
-
-\begin{code}
-
-CostCentre *index_cc_table = 0;
-hash_t max_cc_no = DEFAULT_MAX_CC;
-
-static hash_t index_cc_no = 0;
-static hash_t mask_cc;
-
-hash_t
-init_index_cc()
-{
- hash_t max2 = 1, count;
-
- if (index_cc_table) {
- if (max_cc_no != mask_cc + 1) {
- fprintf(stderr, "init_index_cc: twice %ld %ld\n", max_cc_no, mask_cc + 1);
- abort();
- }
- return mask_cc + 1;
- }
-
- while (max2 < max_cc_no) max2 <<= 1;
-
- max_cc_no = max2;
- mask_cc = max2 - 1;
-
- index_cc_table = (CostCentre *) stgMallocBytes(max2 * sizeof(CostCentre), "init_index_cc");
-
- for (count = 0; count < max2; count++)
- index_cc_table[count] = 0;
-
- return max2;
-}
-
-hash_t index_cc(cc)
- CostCentre cc;
-{
- if (cc->index_val == UNHASHED) {
-
- hash_t h = hash_fixed((char *)&cc, sizeof(CostCentre)) & mask_cc;
- while (index_cc_table[h])
- h = (h + 1) & mask_cc;
-
- cc->index_val = h;
- index_cc_table[h] = cc;
-
- if (++index_cc_no > mask_cc - (mask_cc >> 6)) {
- fprintf(stderr, "Cost Centre hash table full: %ld entries (in %ld table)\n",
- index_cc_no, mask_cc+1);
- fprintf(stderr, " +RTS -z%c<size> option will increase the hash table size\n", CCchar);
- EXIT(EXIT_FAILURE);
- }
- }
- return cc->index_val;
-}
-\end{code}
-
-\begin{code}
-
-CostCentre *index_mod_table = 0;
-hash_t max_mod_no = DEFAULT_MAX_MOD;
-
-static hash_t index_mod_no = 0;
-static hash_t mask_mod;
-
-hash_t
-init_index_mod()
-{
- hash_t max2 = 1, count;
-
- if (index_mod_table) {
- if (max_mod_no != mask_mod + 1) {
- fprintf(stderr, "init_index_mod: twice %ld %ld\n", max_mod_no, mask_mod + 1);
- abort();
- }
- return mask_mod + 1;
- }
-
- while (max2 < max_mod_no) max2 <<= 1;
-
- max_mod_no = max2;
- mask_mod = max2 - 1;
-
- index_mod_table = (CostCentre *) stgMallocBytes(max2 * sizeof(CostCentre), "init_index_mod");
-
- for (count = 0; count < max2; count++)
- index_mod_table[count] = 0;
-
- return max2;
-}
-
-hash_t
-index_mod(cc)
- CostCentre cc;
-{
- if (cc->index_val == UNHASHED) {
-
- hash_t h = hash_str(cc->module) & mask_mod;
-
- while (index_mod_table[h] && (strcmp(index_mod_table[h]->module, cc->module) != 0))
- h = (h + 1) & mask_mod;
-
- cc->index_val = h;
- index_mod_table[h] = cc; /* may replace existing cc at h index */
-
- if (++index_mod_no > mask_mod - (mask_mod >> 6)) {
- fprintf(stderr, "Module hash table full: %ld entries (in %ld table)\n",
- index_mod_no, mask_mod+1);
- fprintf(stderr, " +RTS -z%c<size> option will increase the hash table size\n", MODchar);
- EXIT(EXIT_FAILURE);
- }
- }
- return cc->index_val;
-}
-\end{code}
-
-
-\begin{code}
-
-CostCentre *index_grp_table = 0;
-hash_t max_grp_no = DEFAULT_MAX_GRP;
-
-static hash_t index_grp_no = 0;
-static hash_t mask_grp;
-
-hash_t
-init_index_grp()
-{
- hash_t max2 = 1, count;
-
- if (index_grp_table) {
- if (max_grp_no != mask_grp + 1) {
- fprintf(stderr, "init_index_grp: twice %ld %ld\n", max_grp_no, mask_grp + 1);
- abort();
- }
- return mask_grp + 1;
- }
-
- while (max2 < max_grp_no) max2 <<= 1;
-
- max_grp_no = max2;
- mask_grp = max2 - 1;
-
- index_grp_table = (CostCentre *) stgMallocBytes(max2 * sizeof(CostCentre), "init_index_grp");
-
- for (count = 0; count < max2; count++)
- index_grp_table[count] = 0;
-
- return max2;
-}
-
-hash_t
-index_grp(cc)
- CostCentre cc;
-{
- if (cc->index_val == UNHASHED) {
-
- hash_t h = hash_str(cc->group) & mask_grp;
-
- while (index_grp_table[h] && (strcmp(index_grp_table[h]->group, cc->group) != 0))
- h = (h + 1) & mask_grp;
-
- cc->index_val = h;
- index_grp_table[h] = cc; /* may replace existing cc at h index */
-
- if (++index_grp_no > mask_grp - (mask_grp >> 6)) {
- fprintf(stderr, "Group hash table full: %ld entries (in %ld table)\n",
- index_grp_no, mask_grp+1);
- fprintf(stderr, " +RTS -z%c<size> option will increase the hash table size\n", GRPchar);
- EXIT(EXIT_FAILURE);
- }
- }
- return cc->index_val;
-}
-\end{code}
-
-
-\begin{code}
-
-ClCategory *index_descr_table = 0;
-hash_t max_descr_no = DEFAULT_MAX_DESCR;
-
-static hash_t index_descr_no = 0;
-static hash_t mask_descr;
-
-hash_t
-init_index_descr()
-{
- hash_t max2 = 1, count;
-
- if (index_descr_table) {
- if (max_descr_no != mask_descr + 1) {
- fprintf(stderr, "init_index_descr: twice %ld %ld\n", max_descr_no, mask_descr + 1);
- abort();
- }
- return mask_descr + 1;
- }
-
- while (max2 < max_descr_no) max2 <<= 1;
-
- max_descr_no = max2;
- mask_descr = max2 - 1;
-
- index_descr_table = (ClCategory *) stgMallocBytes(max2 * sizeof(ClCategory), "init_index_descr");
-
- for (count = 0; count < max2; count++)
- index_descr_table[count] = 0;
-
- return max2;
-}
-
-hash_t
-index_descr(clcat)
- ClCategory clcat;
-{
- if (clcat->index_val == UNHASHED) {
-
- hash_t h = hash_str(clcat->descr) & mask_descr;
-
- while (index_descr_table[h] && (strcmp(index_descr_table[h]->descr, clcat->descr) != 0))
- h = (h + 1) & mask_descr;
-
- clcat->index_val = h;
- index_descr_table[h] = clcat; /* may replace existing clcat at h index */
-
- if (++index_descr_no > mask_descr - (mask_descr >> 6)) {
- fprintf(stderr, "Closure Description hash table full: %ld entries (in %ld table)\n",
- index_descr_no, mask_descr+1);
- fprintf(stderr, " +RTS -z%c<size> option will increase the hash table size\n", DESCRchar);
- EXIT(EXIT_FAILURE);
- }
- }
- return clcat->index_val;
-}
-\end{code}
-
-
-\begin{code}
-
-ClCategory *index_type_table = 0;
-hash_t max_type_no = DEFAULT_MAX_TYPE;
-
-static hash_t index_type_no = 0;
-static hash_t mask_type;
-
-hash_t
-init_index_type()
-{
- hash_t max2 = 1, count;
-
- if (index_type_table) {
- if (max_type_no != mask_type + 1) {
- fprintf(stderr, "init_index_type: twice %ld %ld\n", max_type_no, mask_type + 1);
- abort();
- }
- return mask_type + 1;
- }
-
- while (max2 < max_type_no) max2 <<= 1;
-
- max_type_no = max2;
- mask_type = max2 - 1;
-
- index_type_table = (ClCategory *) stgMallocBytes(max2 * sizeof(ClCategory), "init_index_type");
-
- for (count = 0; count < max2; count++)
- index_type_table[count] = 0;
-
- return max2;
-}
-
-hash_t index_type(clcat)
- ClCategory clcat;
-{
- if (clcat->index_val == UNHASHED) {
-
- hash_t h = hash_str(clcat->type) & mask_type;
-
- while (index_type_table[h] && (strcmp(index_type_table[h]->type, clcat->type) != 0))
- h = (h + 1) & mask_type;
-
- clcat->index_val = h;
- index_type_table[h] = clcat; /* may replace existing clcat at h index */
-
- if (++index_type_no > mask_type - (mask_type >> 6)) {
- fprintf(stderr, "Type Description hash table full: %ld entries (in %ld table)\n",
- index_type_no, mask_type+1);
- fprintf(stderr, " +RTS -z%c<size> option will increase the hash table size\n", TYPEchar);
- EXIT(EXIT_FAILURE);
- }
- }
- return clcat->index_val;
-}
-\end{code}
-
-\begin{code}
-#endif /* PROFILING */
-\end{code}
+++ /dev/null
-Only have cost centres etc if @PROFILING@ defined
-
-\begin{code}
-#include "rtsdefs.h"
-
-#if defined (PROFILING) || defined(PAR)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[timer-interrupts]{Processing of Profiling Timer Signals}
-%* *
-%************************************************************************
-
-Problem: If we set @HpLim = Hp@ in handler neither can be in registers!
- Rather add test for flag to Hp check macros.
-
-\begin{code}
-
-I_ time_profiling = 0; /* Flag to indicate timer/serial profiling */
-
-I_ interval_expired = 0; /* Flag tested by HP_CHK routines */
-I_ current_interval = 1; /* Current interval number -- stored in AGE */
-I_ interval_ticks = DEFAULT_INTERVAL; /* No of ticks in an interval */
-
-I_ previous_ticks = 0; /* ticks in previous intervals */
-I_ current_ticks = 0; /* ticks in current interval */
-
-void
-set_profile_timer(I_ ms)
-{
- if (initialize_virtual_timer(ms)) {
- fflush(stdout);
- fprintf(stderr, "Can't initialize virtual timer.\n");
- EXIT(EXIT_FAILURE);
- }
-}
-
-void
-handle_tick_serial(STG_NO_ARGS)
-{
- CC_TICK(CCC);
-
- /* fprintf(stderr,"tick for %s\n", CCC->label); */
-#if defined(PROFILING) && defined(DEBUG)
- /* Why is this here? --JSM Debugging --WDP */
- if (CCC == STATIC_CC_REF(CC_OVERHEAD))
- abort();
-#endif
-
-#if 0
- /* Experimental - don't tick if we're in the middle
- of reporting a cc_profile. Untested.
- */
- if (interval_expired)
- return;
-#endif
-
- if (++current_ticks >= interval_ticks && CCC != STATIC_CC_REF(CC_GC)) {
-#if defined(PROFILING)
- interval_expired = 1; /* stop to process interval */
-#else
- report_cc_profiling(0 /*partial*/);
- restart_time_profiler();
-#endif
- }
- return;
-}
-
-void
-handle_tick_noserial(STG_NO_ARGS)
-{
- CC_TICK(CCC);
- ++current_ticks;
- return;
-}
-
-void
-stop_time_profiler()
-{ /* Stops time profile */
- if (time_profiling) {
- set_profile_timer(0);
- }
-}
-
-void
-restart_time_profiler()
-{ /* Restarts time profile */
-#if defined(PROFILING)
- if (interval_expired)
-#endif
- {
- current_interval++;
- previous_ticks += current_ticks;
- current_ticks = 0;
- interval_expired = 0;
- }
-}
-
-void
-start_time_profiler()
-{ /* Starts time profile */
- if (time_profiling) {
-#ifdef PAR
- set_profile_timer(RTSflags.CcFlags.msecsPerTick);
-#else
- set_profile_timer(TICK_MILLISECS);
-#endif
- }
-}
-\end{code}
-
-\begin{code}
-#endif /* PROFILING || PAR */
-\end{code}
+++ /dev/null
-***************************************************************************
-
- COMPACTING GARBAGE COLLECTION
-
-Additional Global Data Requirements:
- ++ All the root locations are in malloced space (and info tables in
- static data space). This is to simplify the location list end test.
-
-***************************************************************************
-
-[Someone needs to document this too. KH]
-
-\begin{code}
-#if defined(GC1s)
-
-ToDo: Soft heap limits
-
-#define SCAN_REG_DUMP
-#include "SMinternal.h"
-#include "SMcompacting.h"
-#include "SMextn.h"
-
-REGDUMP(ScanRegDump);
-
-compactingData compactingInfo = {0, 0, 0, 0, 0};
-
-P_ heap_space = 0; /* Address of first word of slab
- of memory allocated for heap */
-
-P_ hp_start; /* Value of Hp when reduction was resumed */
-
-rtsBool
-initHeap( smInfo *sm )
-{
- if (heap_space == 0) { /* allocates if it doesn't already exist */
-
- /* Allocate the roots space */
- sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
-
- /* Allocate the heap */
- heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
- "initHeap (heap)");
-
- compactingInfo.bit_words
- = (RTSflags.GcFlags.heapSize + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- compactingInfo.bits
- = (BitWord *)(heap_space + RTSflags.GcFlags.heapSize) - compactingInfo.bit_words;
-
- compactingInfo.heap_words = RTSflags.GcFlags.heapSize - compactingInfo.bit_words;
- compactingInfo.base = HEAP_FRAME_BASE(heap_space, compactingInfo.heap_words);
- compactingInfo.lim = HEAP_FRAME_LIMIT(heap_space, compactingInfo.heap_words);
-
- stat_init("COMPACTING", "", "");
- }
-
- sm->hp = hp_start = compactingInfo.base - 1;
-
- if (! RTSflags.GcFlags.allocAreaSizeGiven) {
- sm->hplim = compactingInfo.lim;
- } else {
- sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
-
- RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
-
- if (sm->hplim > compactingInfo.lim) {
- fprintf(stderr, "Not enough heap for requested alloc size\n");
- return rtsFalse;
- }
- }
-
- sm->CAFlist = NULL;
-
-#ifndef PAR
- initExtensions( sm );
-#endif /* !PAR */
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "COMPACTING Heap: Base 0x%lx, Lim 0x%lx, Bits 0x%lx, bit words 0x%lx\n",
- (W_) compactingInfo.base, (W_) compactingInfo.lim,
- (W_) compactingInfo.bits, (W_) compactingInfo.bit_words);
- fprintf(stderr, "COMPACTING Initial: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- (W_) compactingInfo.base,
- (W_) compactingInfo.lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
- }
-
- return rtsTrue; /* OK */
-}
-
-I_
-collectHeap(reqsize, sm, do_full_collection)
- W_ reqsize;
- smInfo *sm;
- rtsBool do_full_collection; /* ignored */
-{
- I_ free_space, /* No of words of free space following GC */
- alloc, /* Number of words allocated since last GC */
- resident; /* Number of words remaining after GC */
-
- SAVE_REGS(&ScanRegDump); /* Save registers */
-
- if (RTSflags.GcFlags.trace) {
- fflush(stdout); /* Flush stdout at start of GC */
- fprintf(stderr, "COMPACTING Start: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
- (W_) compactingInfo.base, (W_) compactingInfo.lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
- }
-
- alloc = sm->hp - hp_start;
-
- stat_startGC(alloc);
-
- /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAN_REG_MAP */
- RESTORE_REGS(&ScanRegDump);
-
- markHeapRoots(sm, sm->CAFlist, 0,
- compactingInfo.base,
- compactingInfo.lim,
- compactingInfo.bits);
-
- SAVE_REGS(&ScanRegDump);
- /* end of bracket */
-
-#ifndef PAR
- sweepUpDeadForeignObjs(sm->ForeignObjList,
- compactingInfo.base,
- compactingInfo.bits );
-#endif
-
- LinkCAFs(sm->CAFlist);
-
- LinkRoots( sm->roots, sm->rootno );
-#if defined(GRAN)
- LinkEvents();
-#endif
-#if defined(CONCURRENT)
- LinkSparks();
-#endif
-#ifdef PAR
- LinkLiveGAs(compactingInfo.base, compactingInfo.bits);
-#else
- /*
- The stable pointer table is reachable via sm->roots,
- (Reason: in markHeapRoots all roots have to be considered,
- including the StablePointerTable)
-
- DEBUG_STRING("Linking Stable Pointer Table:");
- LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
-
- */
- LinkAStack( MAIN_SpA, stackInfo.botA );
- LinkBStack( MAIN_SuB, stackInfo.botB );
-#endif /* parallel */
-
- /* Do Inplace Compaction */
- /* Returns start of next closure, -1 gives last allocated word */
-
- sm->hp = Inplace_Compaction(compactingInfo.base,
- compactingInfo.lim,
- 0, 0,
- compactingInfo.bits,
- compactingInfo.bit_words
-#if ! defined(PAR)
- , &(sm->ForeignObjList)
-#endif
- ) - 1;
-
- resident = sm->hp - (compactingInfo.base - 1);
- DO_MAX_RESIDENCY(resident); /* stats only */
-
- if (! RTSflags.GcFlags.allocAreaSizeGiven) {
- sm->hplim = compactingInfo.lim;
- free_space = sm->hplim - sm->hp;
- } else {
- sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
- if (sm->hplim > compactingInfo.lim) {
- free_space = 0;
- } else {
- free_space = RTSflags.GcFlags.allocAreaSize;
- }
- }
-
- hp_start = sm->hp;
-
- stat_endGC(alloc, compactingInfo.heap_words, resident, "");
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "COMPACTING Done: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- (W_) compactingInfo.base, (W_) compactingInfo.lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating. */
- TrashMem(sm->hp+1, sm->hplim);
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScanRegDump); /* Restore Registers */
-
- if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_space < reqsize)
- return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */
- else
- return GC_SUCCESS; /* Heap OK */
-}
-
-#endif /* GC1s */
-
-\end{code}
-
+++ /dev/null
-***************************************************************************
-
- TWO SPACE COLLECTION
-
-***************************************************************************
-
-\begin{code}
-#if defined(GC2s)
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-#include "SMcopying.h"
-#include "SMextn.h"
-
-REGDUMP(ScavRegDump);
-
-I_ semispace = 0; /* 0 or 1 */
-semispaceData semispaceInfo[2]
- = {{0,0}, {0,0}};
-
-P_ heap_space = 0; /* Address of first word of slab
- of memory allocated for heap */
-
-P_ hp_start; /* Value of Hp when reduction was resumed */
-
-
-rtsBool
-initHeap(smInfo * sm)
-{
- if (heap_space == 0) { /* allocates if it doesn't already exist */
-
- I_ semispaceSize = RTSflags.GcFlags.heapSize / 2;
-
- /* Allocate the roots space */
- sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
-
- /* Allocate the heap */
- heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
- "initHeap (heap)");
-
- /* Define the semi-spaces */
- semispaceInfo[0].base = HEAP_FRAME_BASE(heap_space, semispaceSize);
- semispaceInfo[1].base = HEAP_FRAME_BASE(heap_space + semispaceSize, semispaceSize);
- semispaceInfo[0].lim = HEAP_FRAME_LIMIT(heap_space, semispaceSize);
- semispaceInfo[1].lim = HEAP_FRAME_LIMIT(heap_space + semispaceSize, semispaceSize);
-
- stat_init("TWOSPACE",
- " No of Roots Caf Caf Astk Bstk",
- "Astk Bstk Reg No bytes bytes bytes");
- }
-
- /* Initialise heap pointer and limit */
- sm->hp = hp_start = semispaceInfo[semispace].base - 1;
- sm->hardHpOverflowSize = 0;
-
- if (! RTSflags.GcFlags.allocAreaSizeGiven) {
- sm->hplim = semispaceInfo[semispace].lim;
- } else {
- sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
-
- RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
-
- if (sm->hplim > semispaceInfo[semispace].lim) {
- fprintf(stderr, "Not enough heap for requested alloc size\n");
- return rtsFalse;
- }
- }
-
- if (RTSflags.GcFlags.forceGC) {
- if (sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
- sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
- } else {
- RTSflags.GcFlags.forceGC = rtsFalse;
- /* forcing GC has no effect, as semi-space is smaller than forcingInterval */
- }
- }
-
- sm->CAFlist = NULL;
-
-#ifndef PAR
- initExtensions( sm );
-#endif /* !PAR */
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "TWO SPACE Heap: 0base, 0lim, 1base, 1lim\n 0x%lx, 0x%lx, 0x%lx, 0x%lx\n",
- (W_) semispaceInfo[0].base, (W_) semispaceInfo[0].lim,
- (W_) semispaceInfo[1].base, (W_) semispaceInfo[1].lim);
- fprintf(stderr, "TWO SPACE Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- semispace,
- (W_) semispaceInfo[semispace].base,
- (W_) semispaceInfo[semispace].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
- }
-
- return rtsTrue; /* OK */
-}
-
-I_
-collectHeap(reqsize, sm, do_full_collection)
- W_ reqsize;
- smInfo *sm;
- rtsBool do_full_collection; /* ignored */
-{
- I_ free_space, /* No of words of free space following GC */
- alloc, /* Number of words allocated since last GC */
- resident, /* Number of words remaining after GC */
- extra_caf_words,/* Extra words referenced from CAFs */
- caf_roots, /* Number of CAFs */
- bstk_roots; /* Number of update frames on B stack */
-
- fflush(stdout); /* Flush stdout at start of GC */
- SAVE_REGS(&ScavRegDump); /* Save registers */
-
-#if defined(PROFILING)
- if (interval_expired) { heap_profile_setup(); }
-#endif /* PROFILING */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "TWO SPACE Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
- semispace, (W_) semispaceInfo[semispace].base,
- (W_) semispaceInfo[semispace].lim,
- (W_) sm->hp, (W_) sm->hplim, reqsize * sizeof(W_));
-
- alloc = sm->hp - hp_start;
- stat_startGC(alloc);
-
- /* Set Up For Collecting:
- - Flip Spaces
- - Set ToHp to point one below bottom of to-space (last allocated)
- - Set CAFs to Evac & Upd
- */
-
- semispace = NEXT_SEMI_SPACE(semispace);
- ToHp = semispaceInfo[semispace].base - 1;
- Scav = semispaceInfo[semispace].base;
-
- SetCAFInfoTables( sm->CAFlist );
-#ifdef PAR
- EvacuateLocalGAs(rtsTrue);
-#else
- /* evacSPTable( sm ); stable pointers now reachable via sm->roots */
-#endif /* PAR */
- EvacuateRoots( sm->roots, sm->rootno );
-#if defined(GRAN)
- EvacuateEvents();
-#endif
-#if defined(CONCURRENT)
- EvacuateSparks();
-#endif
-#if !defined(PAR) /* && !defined(GRAN) */
- EvacuateAStack( MAIN_SpA, stackInfo.botA );
- EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
-#endif /* !PAR */
-
- Scavenge();
-
- EvacAndScavengeCAFs( sm->CAFlist, &extra_caf_words, &caf_roots );
-
-#ifdef PAR
- RebuildGAtables(rtsTrue);
-#else
- reportDeadForeignObjs(sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
-#endif /* PAR */
-
- /* TIDY UP AND RETURN */
-
- sm->hp = hp_start = ToHp; /* Last allocated word */
-
- resident = sm->hp - (semispaceInfo[semispace].base - 1);
- DO_MAX_RESIDENCY(resident); /* stats only */
-
- if (! RTSflags.GcFlags.allocAreaSizeGiven) {
- sm->hplim = semispaceInfo[semispace].lim;
- free_space = sm->hplim - sm->hp;
- } else {
- sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
- if (sm->hplim > semispaceInfo[semispace].lim) {
- free_space = 0;
- } else {
- free_space = RTSflags.GcFlags.allocAreaSize;
- }
- }
-
- if (RTSflags.GcFlags.giveStats) {
- char comment_str[BIG_STRING_LEN];
-#ifndef PAR
- sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu",
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
- bstk_roots, sm->rootno,
- caf_roots, extra_caf_words*sizeof(W_),
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
- (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
-#else
- /* ToDo: come up with some interesting statistics for the parallel world */
- sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu",
- 0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
-#endif
-
-#if defined(PROFILING)
- if (interval_expired) { strcat(comment_str, " prof"); }
-#endif
-
- stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
- } else {
- stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
- }
-
-#if defined(PROFILING) || defined(PAR)
- if (interval_expired) {
-#if defined(PROFILING)
- heap_profile_done();
-#endif
- report_cc_profiling(0 /*partial*/);
- }
-#endif /* PROFILING */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "TWO SPACE Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- semispace, (W_) semispaceInfo[semispace].base,
- (W_) semispaceInfo[semispace].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating and all of the other semispace. */
- TrashMem(sm->hp+1, sm->hplim);
- TrashMem(semispaceInfo[NEXT_SEMI_SPACE(semispace)].base,
- semispaceInfo[NEXT_SEMI_SPACE(semispace)].lim);
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_sapce < reqsize)
- return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */
-
- else {
- if (RTSflags.GcFlags.forceGC
- && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
- sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
- }
-
- if (reqsize + sm->hardHpOverflowSize > free_space) {
- return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */
- } else {
- return( GC_SUCCESS ); /* Heap OK */
- }
- }
-}
-
-#endif /* GC2s */
-\end{code}
+++ /dev/null
-***************************************************************************
-
- APPEL'S GARBAGE COLLECTION
-
-Global heap requirements as for 1s and 2s collectors.
- ++ All closures in the old generation that are updated must be
- updated with indirections and placed on the linked list of
- updated old generation closures.
-
-***************************************************************************
-
-\begin{code}
-#if defined(GCap)
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-#include "SMcopying.h"
-#include "SMcompacting.h"
-#include "SMextn.h"
-
-REGDUMP(ScavRegDump);
-
-appelData appelInfo = {0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, {{0, 0}, {0, 0}}
- };
-
-P_ heap_space = 0; /* Address of first word of slab
- of memory allocated for heap */
-
-P_ hp_start; /* Value of Hp when reduction was resumed */
-
-static I_ allocd_since_last_major_GC = 0;
- /* words alloced since last major GC; used when forcing GC */
-
-#if defined(DEBUG)
-void
-debug_look_for (start, stop, villain)
- P_ start, stop, villain;
-{
- P_ i;
- for (i = start; i <= stop; i++) {
- if ( (P_) *i == villain ) {
- fprintf(stderr, "* %x : %x\n", i, villain);
- }
- }
-}
-#endif
-
-rtsBool
-initHeap(smInfo * sm)
-{
- if (heap_space == 0) { /* allocates if it doesn't already exist */
-
- /* Allocate the roots space */
- sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
-
- /* Allocate the heap */
- heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
- "initHeap (heap)");
-
- /* ToDo (ADR): trash entire heap contents */
-
- if (RTSflags.GcFlags.force2s) {
- stat_init("TWOSPACE(APPEL)",
- " No of Roots Caf Caf Astk Bstk",
- "Astk Bstk Reg No bytes bytes bytes");
- } else {
- stat_init("APPEL",
- " No of Roots Caf Mut- Old Collec Resid",
- "Astk Bstk Reg No able Gen tion %heap");
- }
- }
- sm->hardHpOverflowSize = 0;
-
- if (RTSflags.GcFlags.force2s) {
- I_ semi_space_words = RTSflags.GcFlags.heapSize / 2;
- appelInfo.space[0].base = HEAP_FRAME_BASE(heap_space, semi_space_words);
- appelInfo.space[1].base = HEAP_FRAME_BASE(heap_space + semi_space_words, semi_space_words);
- appelInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, semi_space_words);
- appelInfo.space[1].lim = HEAP_FRAME_LIMIT(heap_space + semi_space_words, semi_space_words);
- appelInfo.semi_space = 0;
- appelInfo.oldlim = heap_space - 1; /* Never in old generation */
-
- sm->hp = hp_start = appelInfo.space[appelInfo.semi_space].base - 1;
-
- if (! RTSflags.GcFlags.allocAreaSizeGiven) {
- sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
- } else {
- sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
-
- RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
-
- if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) {
- fprintf(stderr, "Not enough heap for requested alloc size\n");
- return rtsFalse;
- }
- }
-
- if (RTSflags.GcFlags.forceGC) {
- if (sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
- sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
- } else {
- /* no point in forcing GC,
- as the semi-space is smaller than forcingInterval */
- RTSflags.GcFlags.forceGC = rtsFalse;
- }
- }
-
- sm->OldLim = appelInfo.oldlim;
- sm->CAFlist = NULL;
-
-#ifndef PAR
- initExtensions( sm );
-#endif
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "APPEL(2s) Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space - 1 + RTSflags.GcFlags.heapSize));
- fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- appelInfo.semi_space,
- (W_) appelInfo.space[appelInfo.semi_space].base,
- (W_) appelInfo.space[appelInfo.semi_space].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
- }
- return rtsTrue;
- }
-
-
-/* So not forced 2s */
-
- appelInfo.newlim = heap_space + RTSflags.GcFlags.heapSize - 1;
- if (RTSflags.GcFlags.allocAreaSizeGiven) {
- appelInfo.newfixed = RTSflags.GcFlags.allocAreaSize;
- appelInfo.newmin = RTSflags.GcFlags.allocAreaSize;
- appelInfo.newbase = heap_space + RTSflags.GcFlags.heapSize - appelInfo.newfixed;
- } else {
- appelInfo.newfixed = 0;
- appelInfo.newmin = RTSflags.GcFlags.minAllocAreaSize;
- appelInfo.newbase = heap_space + (RTSflags.GcFlags.heapSize / 2);
- }
-
- appelInfo.oldbase = heap_space;
- appelInfo.oldlim = heap_space - 1;
- appelInfo.oldlast = heap_space - 1;
- appelInfo.oldmax = heap_space - 1 + RTSflags.GcFlags.heapSize - 2*appelInfo.newmin;
-
- if (appelInfo.oldbase > appelInfo.oldmax) {
- fprintf(stderr, "Not enough heap for requested/minimum allocation area\n");
- fprintf(stderr, "heap_space=%ld\n", (W_) heap_space);
- fprintf(stderr, "heapSize=%ld\n", RTSflags.GcFlags.heapSize);
- fprintf(stderr, "newmin=%ld\n", appelInfo.newmin);
- return rtsFalse;
- }
-
- appelInfo.bit_words = (RTSflags.GcFlags.heapSize + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- appelInfo.bits = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words;
-
- if (appelInfo.bit_words > appelInfo.newmin)
- appelInfo.oldmax = heap_space - 1 + RTSflags.GcFlags.heapSize - appelInfo.bit_words - appelInfo.newmin;
-
- if (RTSflags.GcFlags.specifiedOldGenSize) {
- appelInfo.oldthresh = heap_space -1 + RTSflags.GcFlags.specifiedOldGenSize;
- if (appelInfo.oldthresh > appelInfo.oldmax) {
- fprintf(stderr, "Not enough heap for requested major resid size\n");
- return rtsFalse;
- }
- } else {
- appelInfo.oldthresh = heap_space + RTSflags.GcFlags.heapSize * 2 / 3; /* Initial threshold -- 2/3rds */
- if (appelInfo.oldthresh > appelInfo.oldmax)
- appelInfo.oldthresh = appelInfo.oldmax;
- }
-
- sm->hp = hp_start = appelInfo.newbase - 1;
- sm->hplim = appelInfo.newlim;
-
- if (RTSflags.GcFlags.forceGC
- && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
- sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
- }
-
- sm->OldLim = appelInfo.oldlim;
-
- sm->CAFlist = NULL;
- appelInfo.OldCAFlist = NULL;
- appelInfo.OldCAFno = 0;
-
-#ifndef PAR
- initExtensions( sm );
-#endif
-
- appelInfo.PromMutables = 0;
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "APPEL Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space - 1 + RTSflags.GcFlags.heapSize));
- fprintf(stderr, "Initial: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx\n",
- (W_) appelInfo.newbase, (W_) appelInfo.newlim,
- (W_) appelInfo.oldbase, (W_) appelInfo.oldlim,
- (W_) appelInfo.oldthresh, (W_) appelInfo.oldmax,
- (W_) sm->hp, (W_) sm->hplim);
- }
-
- return rtsTrue; /* OK */
-}
-
-static I_
-collect2s(W_ reqsize, smInfo *sm)
-{
- I_ free_space, /* No of words of free space following GC */
- alloc, /* Number of words allocated since last GC */
- resident, /* Number of words remaining after GC */
- extra_caf_words,/* Extra words referenced from CAFs */
- caf_roots, /* Number of CAFs */
- bstk_roots; /* Number of update frames in B stack */
-
- SAVE_REGS(&ScavRegDump); /* Save registers */
-
-#if defined(PROFILING)
- if (interval_expired) { heap_profile_setup(); }
-#endif /* PROFILING */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
- appelInfo.semi_space,
- (W_) appelInfo.space[appelInfo.semi_space].base,
- (W_) appelInfo.space[appelInfo.semi_space].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
-
- alloc = sm->hp - hp_start;
- stat_startGC(alloc);
-
- appelInfo.semi_space = NEXT_SEMI_SPACE(appelInfo.semi_space);
- ToHp = appelInfo.space[appelInfo.semi_space].base - 1;
- Scav = appelInfo.space[appelInfo.semi_space].base;
- OldGen = sm->OldLim; /* always evac ! */
-
- SetCAFInfoTables( sm->CAFlist );
-#ifdef PAR
- EvacuateLocalGAs(rtsTrue);
-#else
- /* evacSPTable( sm ); StablePointerTable now accessable in sm->roots SOF 4/96 */
-#endif /* PAR */
- EvacuateRoots( sm->roots, sm->rootno );
-#if defined(GRAN)
- EvacuateEvents();
-#endif
-#if defined(CONCURRENT)
- EvacuateSparks();
-#endif
-#if !defined(PAR)
- EvacuateAStack( MAIN_SpA, stackInfo.botA );
- EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
-#endif /* !PAR */
-
- Scavenge();
-
- EvacAndScavengeCAFs( sm->CAFlist, &extra_caf_words, &caf_roots );
-
-#ifdef PAR
- RebuildGAtables(rtsTrue);
-#else
- reportDeadForeignObjs( sm->ForeignObjList, NULL, &(sm->ForeignObjList));
-#endif /* PAR */
-
- /* TIDY UP AND RETURN */
-
- sm->hp = hp_start = ToHp; /* Last allocated word */
-
- resident = sm->hp - (appelInfo.space[appelInfo.semi_space].base - 1);
- DO_MAX_RESIDENCY(resident); /* stats only */
-
- if (! RTSflags.GcFlags.allocAreaSizeGiven) {
- sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
- free_space = sm->hplim - sm->hp;
- } else {
- sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
- if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) {
- free_space = 0;
- } else {
- free_space = RTSflags.GcFlags.allocAreaSize;
- }
- }
-
- if (RTSflags.GcFlags.forceGC
- && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
- sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
- }
-
- if (RTSflags.GcFlags.giveStats) {
- char comment_str[BIG_STRING_LEN];
-#if !defined(PAR)
- sprintf(comment_str, "%4lu %4ld %3ld %3ld %6lu %6lu %6lu 2s",
- (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
- bstk_roots, sm->rootno,
- caf_roots, extra_caf_words*sizeof(W_),
- (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
- (W_) (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
-#else
- /* ToDo: come up with some interesting statistics for the parallel world */
- sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s",
- 0, 0L, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0L, 0L);
-
-#endif
-
-#if defined(PROFILING)
- if (interval_expired) { strcat(comment_str, " prof"); }
-#endif
-
- stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
- } else {
- stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
- }
-
-#if defined(PROFILING) || defined(PAR)
- if (interval_expired) {
-# if defined(PROFILING)
- heap_profile_done();
-# endif
- report_cc_profiling(0 /*partial*/);
- }
-#endif /* PROFILING */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- appelInfo.semi_space,
- (W_) appelInfo.space[appelInfo.semi_space].base,
- (W_) appelInfo.space[appelInfo.semi_space].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating, and all of the space
- we just came from. */
- {
- I_ old_space = NEXT_SEMI_SPACE(appelInfo.semi_space);
-
- TrashMem(appelInfo.space[old_space].base, appelInfo.space[old_space].lim);
- TrashMem(sm->hp+1, sm->hplim);
- }
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_space < reqsize)
- return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */
- else {
- if (reqsize + sm->hardHpOverflowSize > free_space) {
- return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */
- } else {
- return( GC_SUCCESS ); /* Heap OK */
- }
- }
-}
-
-
-I_
-collectHeap(reqsize, sm, do_full_collection)
- W_ reqsize;
- smInfo *sm;
- rtsBool do_full_collection; /* do a major collection regardless? */
-{
- I_ bstk_roots, caf_roots, mutable, old_words;
- P_ old_start, mutptr, prevmut;
- P_ CAFptr, prevCAF;
-
- I_ alloc, /* Number of words allocated since last GC */
- resident; /* Number of words remaining after GC */
-
- fflush(stdout); /* Flush stdout at start of GC */
-
- if (RTSflags.GcFlags.force2s) {
- return collect2s(reqsize, sm);
- }
-
- SAVE_REGS(&ScavRegDump); /* Save registers */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "Start: newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
- (W_) appelInfo.newbase, (W_) appelInfo.newlim, (W_) sm->hp, (W_) sm->hplim, reqsize * sizeof(W_));
-
- alloc = sm->hp - hp_start;
- stat_startGC(alloc);
-
- allocd_since_last_major_GC += sm->hplim - hp_start;
- /* this is indeed supposed to be less precise than alloc above */
-
- /* COPYING COLLECTION */
-
- /* Set ToHp to end of old gen */
- ToHp = appelInfo.oldlim;
-
- /* Set OldGen register so we only evacuate new gen closures */
- OldGen = appelInfo.oldlim;
-
- /* FIRST: Evacuate and Scavenge CAFs and roots in the old generation */
- old_start = ToHp;
-
- SetCAFInfoTables( sm->CAFlist );
-
- DEBUG_STRING("Evacuate CAFs:");
- caf_roots = 0;
- CAFptr = sm->CAFlist;
- prevCAF = ((P_)(&sm->CAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */
- while (CAFptr) {
- EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
- caf_roots++;
- prevCAF = CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr);
- }
- IND_CLOSURE_LINK(prevCAF) = (W_) appelInfo.OldCAFlist;
- appelInfo.OldCAFlist = sm->CAFlist;
- appelInfo.OldCAFno += caf_roots;
- sm->CAFlist = NULL;
-
- DEBUG_STRING("Evacuate Mutable Roots:");
- mutable = 0;
- mutptr = sm->OldMutables;
- /* Clever, but completely illegal: */
- prevmut = ((P_)&sm->OldMutables) - FIXED_HS;
- /* See MUT_LINK */
- while ( mutptr ) {
-
- /* Scavenge the OldMutable */
- P_ info = (P_) INFO_PTR(mutptr);
- StgScavPtr scav_code = SCAV_CODE(info);
- Scav = mutptr;
- (scav_code)();
-
- /* Remove from OldMutables if no longer mutable */
- if (!IS_MUTABLE(info)) {
- P_ tmp = mutptr;
- MUT_LINK(prevmut) = MUT_LINK(mutptr);
- mutptr = (P_) MUT_LINK(mutptr);
- MUT_LINK(tmp) = MUT_NOT_LINKED;
- } else {
- prevmut = mutptr;
- mutptr = (P_) MUT_LINK(mutptr);
- }
-
- mutable++;
- }
-
-#if 0 && defined(GRAN)
- {
- extern ex_RBH_q;
- closq prev_ptr, clos_ptr;
-
- DEBUG_STRING("Evacuate reverted RBHs:");
- clos_ptr = ex_RBH_q;
- while ( clos_ptr ) {
-
- /* Scavenge the OldMutable */
- P_ info = (P_) INFO_PTR(CLOS_CLOSURE(clos_ptr));
- StgScavPtr scav_code = SCAV_CODE(info);
- Scav = CLOS_CLOSURE(clos_ptr);
- (scav_code)();
-
- /* No mutable closure are put on the ex_RBH_q */
- /* ASSERT(IS_MUTABLE(info)); */
- prev_ptr = clos_ptr;
- clos_ptr = CLOS_NEXT(clos_ptr);
- free(prev_ptr);
- }
- ex_RBH_q = NULL;
- }
-#endif /* GRAN */
-
-#ifdef PAR
- EvacuateLocalGAs(rtsFalse);
-#else
- /* evacSPTable( sm ); SP table is now in sm->roots*/
-#endif /* PAR */
-
- DEBUG_STRING("Scavenge evacuated old generation roots:");
-
- Scav = appelInfo.oldlim + 1; /* Point to (info field of) first closure */
-
- Scavenge();
-
- old_words = ToHp - old_start;
-
- /* PROMOTE closures rooted in the old generation and reset list of old gen roots */
-
- appelInfo.oldlim = ToHp;
-
- /* SECOND: Evacuate and scavenge remaining roots
- These may already have been evacuated -- just get new address
- */
-
- EvacuateRoots( sm->roots, sm->rootno );
-
-#if defined(GRAN)
- EvacuateEvents();
-#endif
-#if defined(CONCURRENT)
- EvacuateSparks();
-#endif
-#if !defined(PAR)
- EvacuateAStack( MAIN_SpA, stackInfo.botA );
- EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
- /* ToDo: Optimisation which squeezes out garbage update frames */
-#endif /* PAR */
-
- Scav = appelInfo.oldlim + 1; /* Point to (info field of) first closure */
-
- Scavenge();
-
- appelInfo.oldlim = ToHp;
-
- /* record newly promoted mutuple roots */
- MUT_LINK(prevmut) = (W_) appelInfo.PromMutables;
- appelInfo.PromMutables = 0;
-
- /* set new generation base, if not fixed */
- if (! appelInfo.newfixed) {
- appelInfo.newbase = appelInfo.oldlim + 1 + (((appelInfo.newlim - appelInfo.oldlim) + 1) / 2);
- }
-
-#ifdef PAR
- RebuildGAtables(rtsFalse);
-#else
- reportDeadForeignObjs(sm->ForeignObjList,
- sm->OldForeignObjList,
- &(sm->OldForeignObjList));
- sm->ForeignObjList = NULL; /* all (new) ForeignObjs have been promoted */
-#endif /* PAR */
-
- resident = appelInfo.oldlim - sm->OldLim;
- /* DONT_DO_MAX_RESIDENCY -- it is just a minor collection */
-
- if (RTSflags.GcFlags.giveStats) {
- char minor_str[BIG_STRING_LEN];
-#if !defined(PAR)
- sprintf(minor_str, "%4lu %4ld %3ld %3ld %4ld Minor",
- (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
- bstk_roots, sm->rootno, caf_roots, mutable); /* oldnew_roots, old_words */
-#else
- /* ToDo: come up with some interesting statistics for the parallel world */
- sprintf(minor_str, "%4u %4ld %3ld %3ld %4ld Minor",
- 0, 0L, sm->rootno, caf_roots, mutable);
-#endif
- stat_endGC(alloc, alloc, resident, minor_str);
- } else {
- stat_endGC(alloc, alloc, resident, "");
- }
-
- /* Note: if do_full_collection we want to force a full collection. [ADR] */
-
- if (RTSflags.GcFlags.forceGC
- && allocd_since_last_major_GC >= RTSflags.GcFlags.forcingInterval) {
- do_full_collection = 1;
- }
-
- if ((appelInfo.oldlim < appelInfo.oldthresh) &&
- (reqsize + sm->hardHpOverflowSize <= appelInfo.newlim - appelInfo.newbase) &&
- (! do_full_collection) ) {
-
- sm->hp = hp_start = appelInfo.newbase - 1;
- sm->hplim = appelInfo.newlim;
-
- if (RTSflags.GcFlags.forceGC
- && (allocd_since_last_major_GC + (sm->hplim - hp_start) > RTSflags.GcFlags.forcingInterval)) {
- sm->hplim = sm->hp + (RTSflags.GcFlags.forcingInterval - allocd_since_last_major_GC);
- }
-
- sm->OldLim = appelInfo.oldlim;
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "Minor: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- (W_) appelInfo.newbase, (W_) appelInfo.newlim,
- (W_) appelInfo.oldbase, (W_) appelInfo.oldlim,
- (W_) appelInfo.oldthresh, (W_) appelInfo.oldmax,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
- }
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating. */
- TrashMem(sm->hp+1, sm->hplim);
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- return GC_SUCCESS; /* Heap OK -- Enough space to continue */
- }
-
- DEBUG_STRING("Major Collection Required");
-
- allocd_since_last_major_GC = 0;
-
- stat_startGC(0);
-
- alloc = (appelInfo.oldlim - appelInfo.oldbase) + 1;
-
- appelInfo.bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- appelInfo.bits = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words;
- /* For some reason, this doesn't seem to use the last
- allocatable word at appelInfo.newlim */
-
- if (appelInfo.bits <= appelInfo.oldlim) {
- fprintf(stderr, "APPEL Major: Not enough space for bit vector\n");
- return GC_HARD_LIMIT_EXCEEDED;
- }
-
- /* Zero bit vector for marking phase of major collection */
- { BitWord *ptr = appelInfo.bits,
- *end = appelInfo.bits + appelInfo.bit_words;
- while (ptr < end) { *(ptr++) = 0; };
- }
-
-#ifdef HAVE_VADVISE
- vadvise(VA_ANOM);
-#endif
-
- /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
- RESTORE_REGS(&ScavRegDump);
-
- markHeapRoots(sm,
- appelInfo.OldCAFlist,
- NULL,
- appelInfo.oldbase,
- appelInfo.oldlim,
- appelInfo.bits);
-
- SAVE_REGS(&ScavRegDump);
- /* end of bracket */
-
-#ifndef PAR
- sweepUpDeadForeignObjs(sm->OldForeignObjList,
- appelInfo.oldbase,
- appelInfo.bits
- );
-#endif /* !PAR */
-
- /* Reset OldMutables -- this will be reconstructed during scan */
- sm->OldMutables = 0;
-
- LinkCAFs(appelInfo.OldCAFlist);
-
- LinkRoots( sm->roots, sm->rootno );
-#if defined(GRAN)
- LinkEvents();
-#endif
-#if defined(CONCURRENT)
- LinkSparks();
-#endif
-#ifdef PAR
- LinkLiveGAs(appelInfo.oldbase, appelInfo.bits);
-#else
-/* stable pointers now included in sm->roots -- SOF
- DEBUG_STRING("Linking Stable Pointer Table:");
- LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
-*/
- LinkAStack( MAIN_SpA, stackInfo.botA );
- LinkBStack( MAIN_SuB, stackInfo.botB );
-#endif
-
- /* Do Inplace Compaction */
- /* Returns start of next closure, -1 gives last allocated word */
-
- appelInfo.oldlim = Inplace_Compaction(appelInfo.oldbase,
- appelInfo.oldlim,
- 0, 0,
- appelInfo.bits,
- appelInfo.bit_words
-#ifndef PAR
- ,&(sm->OldForeignObjList)
-#endif
- ) - 1;
-
- appelInfo.oldlast = appelInfo.oldlim;
- resident = (appelInfo.oldlim - appelInfo.oldbase) + 1;
- DO_MAX_RESIDENCY(resident); /* stats only */
-
- /* set new generation base, if not fixed */
- if (! appelInfo.newfixed) {
- appelInfo.newbase = appelInfo.oldlim + 1 + (((appelInfo.newlim - appelInfo.oldlim) + 1) / 2);
- }
-
- /* set major threshold, if not fixed */
- /* next major collection when old gen occupies 2/3rds of the free space or exceeds oldmax */
- if (! RTSflags.GcFlags.specifiedOldGenSize) {
- appelInfo.oldthresh = appelInfo.oldlim + (appelInfo.newlim - appelInfo.oldlim) * 2 / 3;
- if (appelInfo.oldthresh > appelInfo.oldmax)
- appelInfo.oldthresh = appelInfo.oldmax;
- }
-
- sm->hp = hp_start = appelInfo.newbase - 1;
- sm->hplim = appelInfo.newlim;
-
- if (RTSflags.GcFlags.forceGC
- && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
- sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
- }
-
- sm->OldLim = appelInfo.oldlim;
-
-#ifdef HAVE_VADVISE
- vadvise(VA_NORM);
-#endif
-
- if (RTSflags.GcFlags.giveStats) {
- char major_str[BIG_STRING_LEN];
-#if !defined(PAR)
- sprintf(major_str, "%4lu %4ld %3ld %3ld %4d %4d *Major* %4.1f%%",
- (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
- bstk_roots, sm->rootno, appelInfo.OldCAFno,
- 0, 0, resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
-#else
- /* ToDo: come up with some interesting statistics for the parallel world */
- sprintf(major_str, "%4u %4ld %3ld %3ld %4d %4d *Major* %4.1f%%",
- 0, 0L, sm->rootno, appelInfo.OldCAFno, 0, 0,
- resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
-#endif
-
- stat_endGC(0, alloc, resident, major_str);
- } else {
- stat_endGC(0, alloc, resident, "");
- }
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "Major: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- (W_) appelInfo.newbase, (W_) appelInfo.newlim,
- (W_) appelInfo.oldbase, (W_) appelInfo.oldlim,
- (W_) appelInfo.oldthresh, (W_) appelInfo.oldmax,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
- }
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating. */
- TrashMem(sm->hp+1, sm->hplim);
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- if ((appelInfo.oldlim > appelInfo.oldmax)
- || (reqsize > sm->hplim - sm->hp) ) {
- return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */
- } else if (reqsize + sm->hardHpOverflowSize > sm->hplim - sm->hp) {
- return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */
- } else {
- return( GC_SUCCESS ); /* Heap OK */
- /* linked = IS_MUTABLE(INFO_PTR(closure)) && MUT_LINK(closure) !=
- MUT_NOT_LINKED; */
- }
-}
-
-#endif /* GCap */
-
-\end{code}
+++ /dev/null
-\section[storage-manager-check]{Checking Consistency of Storage Manager}
-
-This code performs consistency/sanity checks on the stacks and heap.
-It can be called each time round the mini-interpreter loop. Not
-required if we're tail-jumping (no mini-interpreter).
-
-\begin{code}
-
-#if ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) )
-
-/* Insist on the declaration of STG-machine registers */
-#define MAIN_REG_MAP
-
-#include "SMinternal.h"
-
-#define isHeapPtr(p) \
- ((p) >= heap_space && (p) < heap_space + RTSflags.GcFlags.heapSize)
-
-#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
-#define validInfoPtr(i) \
- ((i) < (StgPtr) (get_end_result) /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */)
- /* No Internal info tables allowed (type -1) */
-
-#else /* non-NeXT */
-#define validInfoPtr(i) \
- ((i) < (P_) &end /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */)
- /* No Internal info tables allowed (type -1) */
-
-#endif /* non-NeXT */
-
-#define suspectPtr(p) ((p) < (P_)256)
-
-#if defined(GC2s)
-#define validHeapPtr(p) \
- ((p) >= semispaceInfo[semispace].base && (p) <= semispaceInfo[semispace].lim)
-#else
-#if defined(GC1s)
-#define validHeapPtr(p) \
- ((p) >= compactingInfo.base && (p) <= compactingInfo.lim)
-#else
-#if defined(GCdu)
-#define validHeapPtr(p) \
- ((p) >= dualmodeInfo.modeinfo[dualmodeInfo.mode].base && \
- (p) <= dualmodeInfo.modeinfo[dualmodeInfo.mode].lim)
-
-#else
-#if defined(GCap)
-/* Two cases needed, depending on whether the 2-space GC is forced
- SLPJ 17 June 93 */
-#define validHeapPtr(p) \
- (RTSflags.GcFlags.force2s ? \
- ((p) >= appelInfo.space[appelInfo.semi_space].base && \
- (p) <= appelInfo.space[appelInfo.semi_space].lim) : \
- (((p) >= appelInfo.oldbase && (p) <= appelInfo.oldlim) || \
- ((p) >= appelInfo.newbase && (p) <= appelInfo.newlim)) \
- )
-
-#else
-#if defined(GCgn)
-#define validHeapPtr(p) \
- (((p) >= genInfo.oldbase && (p) <= genInfo.oldlim) || \
- ((p) >= genInfo.newgen[genInfo.curnew].newbase && (p) <= genInfo.newgen[genInfo.curnew].newlim) || \
- ((p) >= genInfo.allocbase && (p) <= genInfo.alloclim))
-#else
-#define validHeapPtr(p) 0
-#endif
-#endif
-#endif
-#endif
-#endif
-
-
-void checkAStack(STG_NO_ARGS)
-{
- PP_ stackptr;
- P_ closurePtr;
- P_ infoPtr;
- I_ error = 0;
-
- if (SuB > SpB + 1) {
- fprintf(stderr, "SuB (%lx) > SpB (%lx)\n", (W_) SuB, (W_) SpB);
- error = 1;
- }
- if (SuA < SpA) {
- fprintf(stderr, "SuA (%lx) < SpA (%lx)\n", (W_) SuA, (W_) SpA);
- error = 1;
- }
-
- for (stackptr = SpA;
- SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
- stackptr = stackptr + AREL(1)) {
-
- closurePtr = (P_) *stackptr;
-
- if (suspectPtr(closurePtr)) {
- fprintf(stderr, "Suspect heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n",
- (W_) SpA, (W_) stackptr, (W_) closurePtr);
- error = 1;
-
- } else if (isHeapPtr(closurePtr) && ! validHeapPtr(closurePtr)) {
-
- fprintf(stderr, "Bad heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n",
- (W_) SpA, (W_) stackptr, (W_) closurePtr);
- error = 1;
-
- } else {
- infoPtr = (P_) *closurePtr;
-
- if (suspectPtr(infoPtr)) {
- fprintf(stderr, "Suspect info ptr on A stk; SpA %lx, sp %lx, closure %lx info %lx\n",
- (W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr);
- error = 1;
-
- } else if ( ! validInfoPtr(infoPtr)) {
- fprintf(stderr, "Bad info ptr in A stk; SpA %lx, sp %lx, closure %lx, info %lx\n",
- (W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr/* , INFO_TYPE(infoPtr) */);
- error = 1;
- }
- }
- }
-
- if (error) abort();
-}
-
-#endif /* ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) ) */
-
-\end{code}
+++ /dev/null
-\section[SM-compacting]{Compacting Collector Subroutines}
-
-This is a collection of C functions used in implementing the compacting
-collectors.
-
-The motivation for making this a separate file/section is twofold:
-
-1) It lets us focus on one thing.
-
-2) If we don't do this, there will be a huge amount of repetition
- between the various GC schemes --- a maintenance nightmare.
-
-The second is the major motivation.
-
-ToDo ADR: trash contents of other semispace after GC in debugging version
-
-\begin{code}
-#if defined(GC1s) || defined(GCdu) || defined(GCap) || defined(GCgn)
- /* to the end */
-
-#if defined(GC1s)
-
-#define SCAN_REG_DUMP
-#include "SMinternal.h"
-REGDUMP(ScanRegDump);
-
-#else /* GCdu, GCap, GCgn */
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-REGDUMP(ScavRegDump);
-
-#endif
-
-#include "SMcompacting.h"
-\end{code}
-
-\begin{code}
-void
-LinkRoots(roots, rootno)
-P_ roots[];
-I_ rootno;
-{
- I_ root;
-
- DEBUG_STRING("Linking Roots:");
- for (root = 0; root < rootno; root++) {
- LINK_LOCATION_TO_CLOSURE(&(roots[root]));
- }
-}
-
-\end{code}
-
-\begin{code}
-#if defined(GRAN)
-void
-LinkEvents(STG_NO_ARGS)
-{
- eventq event = EventHd;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"Linking Events ...\n");
-#endif
-
- DEBUG_STRING("Linking Events:");
- while(event != NULL)
- {
- if(EVENT_TYPE(event) == RESUMETHREAD ||
- EVENT_TYPE(event) == MOVETHREAD ||
- EVENT_TYPE(event) == CONTINUETHREAD ||
- EVENT_TYPE(event) == STARTTHREAD )
-
- { LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) ); }
-
- else if(EVENT_TYPE(event) == MOVESPARK)
-
- { LINK_LOCATION_TO_CLOSURE( &(SPARK_NODE(EVENT_SPARK(event))) ); }
-
- else if (EVENT_TYPE(event) == FETCHNODE ||
- EVENT_TYPE(event) == FETCHREPLY )
- {
- LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) );
-
- /* In the case of packet fetching, EVENT_NODE(event) points to */
- /* the packet (currently, malloced). The packet is just a list of */
- /* closure addresses, with the length of the list at index 1 (the */
- /* structure of the packet is defined in Pack.lc). */
- if ( RTSflags.GranFlags.DoGUMMFetching &&
- (EVENT_TYPE(event)==FETCHREPLY)) {
- P_ buffer = (P_) EVENT_NODE(event);
- int size = (int) buffer[PACK_SIZE_LOCN], i;
-
- for (i = PACK_HDR_SIZE; i <= size-1; i++) {
- LINK_LOCATION_TO_CLOSURE( (buffer+i) );
- }
- } else
- { LINK_LOCATION_TO_CLOSURE( &(EVENT_NODE(event)) ); }
- }
- else if (EVENT_TYPE(event) == GLOBALBLOCK)
- {
- LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) );
- LINK_LOCATION_TO_CLOSURE( &(EVENT_NODE(event)) );
- }
- else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
- {
- LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) );
- }
- event = EVENT_NEXT(event);
- }
-}
-#endif /* GRAN */
-\end{code}
-
-\begin{code}
-
-#if defined(CONCURRENT)
-# if defined(GRAN)
-void
-LinkSparks(STG_NO_ARGS)
-{
- sparkq spark;
- PROC proc;
- I_ pool, total_sparks=0;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"Linking Sparks ...\n");
-#endif
-
- DEBUG_STRING("Linking Sparks:");
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(pool = 0; pool < SPARK_POOLS; ++pool) {
- for(spark = PendingSparksHd[proc][pool];
- spark != NULL;
- spark = SPARK_NEXT(spark))
- {
- LINK_LOCATION_TO_CLOSURE( &(SPARK_NODE(spark)));
- } /* forall spark ... */
- } /* forall pool ... */
- } /*forall proc .. */
-}
-
-# else /* ! GRAN */
-
-void
-LinkSparks(STG_NO_ARGS)
-{
- PP_ sparkptr;
- int pool;
-
- DEBUG_STRING("Linking Sparks:");
- for (pool = 0; pool < SPARK_POOLS; pool++) {
- for (sparkptr = PendingSparksHd[pool];
- sparkptr < PendingSparksTl[pool]; sparkptr++) {
- LINK_LOCATION_TO_CLOSURE(sparkptr);
- }
- }
-}
-#endif /* GRAN */
-#endif /* CONCURRENT */
-
-\end{code}
-
-\begin{code}
-
-#ifdef PAR
-
-void
-LinkLiveGAs(P_ base, BitWord *bits)
-{
- GALA *gala;
- GALA *next;
- GALA *prev;
- long _hp_word, bit_index, bit;
-
- DEBUG_STRING("Linking Live GAs:");
-
- for (gala = liveIndirections, prev = NULL; gala != NULL; gala = next) {
- next = gala->next;
- ASSERT(gala->ga.loc.gc.gtid == mytid);
- if (gala->ga.weight != MAX_GA_WEIGHT) {
- LINK_LOCATION_TO_CLOSURE(&gala->la);
- gala->next = prev;
- prev = gala;
- } else {
- /* Since we have all of the weight, this GA is no longer needed */
- W_ pga = PackGA(thisPE, gala->ga.loc.gc.slot);
-
-#ifdef FREE_DEBUG
- fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot);
-#endif
- gala->next = freeIndirections;
- freeIndirections->next = gala;
- (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
-#ifdef DEBUG
- gala->ga.weight = 0x0d0d0d0d;
- gala->la = (P_) 0xbadbad;
-#endif
- }
- }
- liveIndirections = prev;
-
- prepareFreeMsgBuffers();
-
- for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
- next = gala->next;
- ASSERT(gala->ga.loc.gc.gtid != mytid);
-
- _hp_word = gala->la - base;
- bit_index = _hp_word / BITS_IN(BitWord);
- bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1));
- if (!(bits[bit_index] & bit)) {
- int pe = taskIDtoPE(gala->ga.loc.gc.gtid);
- W_ pga = PackGA(pe, gala->ga.loc.gc.slot);
-
- (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
- freeRemoteGA(pe, &(gala->ga));
- gala->next = freeGALAList;
- freeGALAList = gala;
- } else {
- LINK_LOCATION_TO_CLOSURE(&gala->la);
- gala->next = prev;
- prev = gala;
- }
- }
- liveRemoteGAs = prev;
-
- /* If we have any remaining FREE messages to send off, do so now */
- sendFreeMessages();
-}
-
-#endif
-
-\end{code}
-
-Note: no \tr{Link[AB]Stack} for ``parallel'' systems, because they
-don't have a single main stack.
-
-\begin{code}
-#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
-
-void
-LinkAStack(stackA, botA)
-PP_ stackA;
-PP_ botA;
-{
- PP_ stackptr;
-
- DEBUG_STRING("Linking A Stack:");
- for (stackptr = stackA;
- SUBTRACT_A_STK(stackptr, botA) >= 0;
- stackptr = stackptr + AREL(1)) {
- LINK_LOCATION_TO_CLOSURE(stackptr);
- }
-}
-#endif /* PAR */
-\end{code}
-
-ToDo (Patrick?): Dont explicitly mark & compact unmarked Bstack frames
-
-\begin{code}
-#if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
-
-void
-LinkBStack(stackB, botB)
-P_ stackB;
-P_ botB; /* stackB points to topmost update frame */
-{
- P_ updateFramePtr;
-
- DEBUG_STRING("Linking B Stack:");
- for (updateFramePtr = stackB;
- SUBTRACT_B_STK(updateFramePtr, botB) > 0;
- updateFramePtr = GRAB_SuB(updateFramePtr)) {
-
- P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE);
-
- LINK_LOCATION_TO_CLOSURE(updateClosurePtr);
- }
-}
-#endif /* not PAR */
-\end{code}
-
-\begin{code}
-I_
-CountCAFs(P_ CAFlist)
-{
- I_ caf_no = 0;
-
- for (caf_no = 0; CAFlist != NULL; CAFlist = (P_) IND_CLOSURE_LINK(CAFlist))
- caf_no++;
-
- return caf_no;
-}
-\end{code}
-
-\begin{code}
-void
-LinkCAFs(P_ CAFlist)
-{
- DEBUG_STRING("Linking CAF Ptr Locations:");
- while(CAFlist != NULL) {
- DEBUG_LINK_CAF(CAFlist);
- LINK_LOCATION_TO_CLOSURE(&IND_CLOSURE_PTR(CAFlist));
- CAFlist = (P_) IND_CLOSURE_LINK(CAFlist);
- }
-}
-
-#endif /* defined(_INFO_COMPACTING) */
-\end{code}
+++ /dev/null
-\section[SMcompacting-header]{Header file for SMcompacting}
-
-\begin{code}
-void LinkRoots PROTO((P_ roots[], I_ rootno));
-void LinkAStack PROTO((PP_ stackA, PP_ botA));
-void LinkBStack PROTO((P_ stackB, P_ botB));
-I_ CountCAFs PROTO((P_ CAFlist));
-
-void LinkCAFs PROTO((P_ CAFlist));
-#ifdef GRAN
-void LinkEvents(STG_NO_ARGS);
-#endif
-#ifdef CONCURRENT
-void LinkSparks(STG_NO_ARGS);
-#endif
-\end{code}
-
+++ /dev/null
-\section[SM-copying]{Copying Collector Subroutines}
-
-This is a collection of C functions used in implementing the copying
-collectors.
-
-The motivation for making this a separate file/section is twofold:
-
-1) It lets us focus on one thing.
-
-2) If we don't do this, there will be a huge amount of repetition
- between the various GC schemes --- a maintenance nightmare.
-
-The second is the major motivation.
-
-
-\begin{code}
-#if defined(GC2s) || defined(GCdu) || defined(GCap) || defined(GCgn)
- /* to the end */
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-REGDUMP(ScavRegDump);
-
-#include "SMcopying.h"
-\end{code}
-
-Comment stolen from SMscav.lc: When doing a new generation copy
-collection for Appel's collector only evacuate references that point
-to the new generation. OldGen must be set to point to the end of old
-space.
-
-\begin{code}
-#ifdef GCap
-
-#define MAYBE_EVACUATE_CLOSURE( closure ) \
-do { \
- P_ evac = (P_) (closure); \
- if (evac > OldGen) { \
- (closure) = EVACUATE_CLOSURE(evac); \
- } \
-} while (0)
-
-#else
-
-#define MAYBE_EVACUATE_CLOSURE( closure ) \
-do { \
- P_ evac = (P_) (closure); \
- (closure) = EVACUATE_CLOSURE(evac); \
-} while (0)
-
-#endif
-\end{code}
-
-\begin{code}
-void
-SetCAFInfoTables(P_ CAFlist)
-{
- P_ CAFptr;
-
- /* Set CAF info tables for evacuation */
- DEBUG_STRING("Setting Evac & Upd CAFs:");
- for (CAFptr = CAFlist;
- CAFptr != NULL;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr) ) {
- INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
- }
-}
-\end{code}
-
-\begin{code}
-void
-EvacuateRoots(P_ roots[], I_ rootno)
-{
- I_ root;
-
- DEBUG_STRING("Evacuate (Reg) Roots:");
- for (root = 0; root < rootno; root++) {
- MAYBE_EVACUATE_CLOSURE( roots[root] );
- }
-}
-\end{code}
-
-Evacuating events is necessary in GRAN since some TSOs and closures are only
-pointed at by events we have to schedule later on.
-
-\begin{code}
-#if defined(GRAN)
-void
-EvacuateEvents(STG_NO_ARGS)
-{
- eventq event = EventHd;
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"Evacuating Events ...\n");
-#endif
-
- DEBUG_STRING("Evacuate Events:");
- while(event != NULL)
- {
- if(EVENT_TYPE(event) == RESUMETHREAD ||
- EVENT_TYPE(event) == MOVETHREAD ||
- EVENT_TYPE(event) == CONTINUETHREAD ||
- EVENT_TYPE(event) == STARTTHREAD )
-
- MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
-
- else if(EVENT_TYPE(event) == MOVESPARK)
-
- MAYBE_EVACUATE_CLOSURE( SPARK_NODE(EVENT_SPARK(event)) );
-
- else if (EVENT_TYPE(event) == FETCHNODE ||
- EVENT_TYPE(event) == FETCHREPLY )
- {
-
- MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
-
- /* In the case of packet fetching, EVENT_NODE(event) points to */
- /* the packet (currently, malloced). The packet is just a list of */
- /* closure addresses, with the length of the list at index 1 (the */
- /* structure of the packet is defined in Pack.lc). */
- if ( RTSflags.GranFlags.DoGUMMFetching &&
- (EVENT_TYPE(event)==FETCHREPLY)) {
- P_ buffer = (P_) EVENT_NODE(event);
- int size = (int) buffer[PACK_SIZE_LOCN], i;
-
- for (i = PACK_HDR_SIZE; i <= size-1; i++) {
- MAYBE_EVACUATE_CLOSURE( (P_)buffer[i] );
- }
- } else
- MAYBE_EVACUATE_CLOSURE( EVENT_NODE(event) );
- }
- else if (EVENT_TYPE(event) == GLOBALBLOCK)
- {
- MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
- MAYBE_EVACUATE_CLOSURE( EVENT_NODE(event) );
- }
- else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
- {
- MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
- }
- event = EVENT_NEXT(event);
- }
-}
-#endif /* GRAN */
-\end{code}
-
-\begin{code}
-#if defined(CONCURRENT)
-# if defined(GRAN)
-void
-EvacuateSparks(STG_NO_ARGS)
-{
- sparkq spark;
- PROC proc;
- I_ pool, total_sparks=0;
-
- /* Sparks have been pruned already at this point */
-
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
- fprintf(RTSflags.GcFlags.statsFile,"Evacuating Sparks ...\n");
-# endif
-
- DEBUG_STRING("Evacuate Sparks (GRAN):");
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(pool = 0; pool < SPARK_POOLS; ++pool) {
- for(spark = PendingSparksHd[proc][pool];
- spark != NULL;
- spark = SPARK_NEXT(spark))
- {
-# if defined(GRAN) && defined(GRAN_CHECK)
- if ( RTSflags.GcFlags.giveStats &&
- (RTSflags.GranFlags.debug & 0x40) &&
- !SHOULD_SPARK(SPARK_NODE(spark)) )
- fprintf(RTSflags.GcFlags.statsFile,"Qagh {EvacuateSparks}Daq: spark @ 0x%x with node 0x%x shouldn't spark!\n",
- spark,SPARK_NODE(spark));
-# endif
- MAYBE_EVACUATE_CLOSURE(SPARK_NODE(spark));
- } /* forall spark ... */
- } /* forall pool ... */
- } /* forall proc ... */
-}
-
-# else /* !GRAN */
-
-void
-EvacuateSparks(STG_NO_ARGS)
-{
- PP_ sparkptr;
- int pool;
-
-
- DEBUG_STRING("Evacuate Sparks:");
- for (pool = 0; pool < SPARK_POOLS; pool++) {
- for (sparkptr = PendingSparksHd[pool];
- sparkptr < PendingSparksTl[pool]; sparkptr++) {
- MAYBE_EVACUATE_CLOSURE(*((PP_) sparkptr));
- }
- }
-}
-# endif
-#endif /* CONCURRENT */
-\end{code}
-
-Note: no \tr{evacuate[AB]Stack} for ``parallel'' systems, because they
-don't have a single main stack.
-
-\begin{code}
-#if !defined(PAR)
-void
-EvacuateAStack(PP_ stackA, PP_ botA /* botA points to bottom-most word */)
-{
- PP_ stackptr;
-
- DEBUG_STRING("Evacuate A Stack:");
- for (stackptr = stackA;
- SUBTRACT_A_STK(stackptr, botA) >= 0;
- stackptr = stackptr + AREL(1)) {
- MAYBE_EVACUATE_CLOSURE( *((PP_) stackptr) );
- }
-}
-#endif /* not PAR */
-\end{code}
-
-ToDo: Optimisation which squeezes out update frames which point to
-garbage closures.
-
-Perform collection first
-
-Then process B stack removing update frames (bot to top via pointer
-reversal) that reference garbage closues (test infoptr !=
-EVACUATED_INFOPTR)
-
-Otherwise closure is live update reference to to-space address
-
-\begin{code}
-#if !defined(PAR)
-void
-EvacuateBStack( stackB, botB, roots )
- P_ stackB;
- P_ botB; /* botB points to bottom-most word */
- I_ *roots;
-{
- I_ bstk_roots;
- P_ updateFramePtr;
- P_ updatee;
-
- DEBUG_STRING("Evacuate B Stack:");
- bstk_roots = 0;
- for (updateFramePtr = stackB; /* stackB points to topmost update frame */
- SUBTRACT_B_STK(updateFramePtr, botB) > 0;
- updateFramePtr = GRAB_SuB(updateFramePtr)) {
-
- /* Evacuate the thing to be updated */
- updatee = GRAB_UPDATEE(updateFramePtr);
- MAYBE_EVACUATE_CLOSURE(updatee);
- PUSH_UPDATEE(updateFramePtr, updatee);
- bstk_roots++;
- }
- *roots = bstk_roots;
-}
-#endif /* not PAR */
-\end{code}
-
-When we do a copying collection, we want to evacuate all of the local
-entries in the GALA table for which there are outstanding remote
-pointers (i.e. for which the weight is not MAX_GA_WEIGHT.)
-
-\begin{code}
-#ifdef PAR
-
-void
-EvacuateLocalGAs(rtsBool full)
-{
- GALA *gala;
- GALA *next;
- GALA *prev = NULL;
-
- for (gala = liveIndirections; gala != NULL; gala = next) {
- next = gala->next;
- ASSERT(gala->ga.loc.gc.gtid == mytid);
- if (gala->ga.weight != MAX_GA_WEIGHT) {
- /* Remote references exist, so we must evacuate the local closure */
- P_ old = gala->la;
- MAYBE_EVACUATE_CLOSURE(gala->la);
- if (!full && gala->preferred && gala->la != old) {
- (void) removeHashTable(LAtoGALAtable, (W_) old, (void *) gala);
- insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
- }
- gala->next = prev;
- prev = gala;
- } else {
- /* Since we have all of the weight, this GA is no longer needed */
- W_ pga = PackGA(thisPE, gala->ga.loc.gc.slot);
-
-#ifdef FREE_DEBUG
- fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot);
-#endif
- gala->next = freeIndirections;
- freeIndirections = gala;
- (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
- if (!full && gala->preferred)
- (void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
-#ifdef DEBUG
- gala->ga.weight = 0x0d0d0d0d;
- gala->la = (P_) 0xbadbad;
-#endif
- }
- }
- liveIndirections = prev;
-}
-
-\end{code}
-
-\begin{code}
-
-EXTDATA_RO(Forward_Ref_info);
-
-void
-RebuildGAtables(rtsBool full)
-{
- GALA *gala;
- GALA *next;
- GALA *prev;
- P_ closure;
-
- prepareFreeMsgBuffers();
-
- for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
- next = gala->next;
- ASSERT(gala->ga.loc.gc.gtid != mytid);
-
- closure = gala->la;
-
- /*
- * If the old closure has not been forwarded, we let go. Note that this
- * approach also drops global aliases for PLCs.
- */
-
-#if defined(GCgn) || defined(GCap)
- if (closure > OldGen) {
-#endif
- if (!full && gala->preferred)
- (void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
-
- /* Follow indirection chains to the end, just in case */
- while (IS_INDIRECTION(INFO_PTR(closure)))
- closure = (P_) IND_CLOSURE_PTR(closure);
-
- /* Change later to incorporate a _FO bit in the INFO_TYPE for GCgn */
-#ifdef GCgn
- fall over, until _FO bits are added
-#endif
- if (INFO_PTR(closure) != (W_) Forward_Ref_info) {
- int pe = taskIDtoPE(gala->ga.loc.gc.gtid);
- W_ pga = PackGA(pe, gala->ga.loc.gc.slot);
-
- (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
- freeRemoteGA(pe, &(gala->ga));
- gala->next = freeGALAList;
- freeGALAList = gala;
- } else {
- /* Find the new space object */
- closure = (P_) FORWARD_ADDRESS(closure);
- gala->la = closure;
-
- if (!full && gala->preferred)
- insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
- gala->next = prev;
- prev = gala;
- }
-#if defined(GCgn) || defined(GCap)
- } else {
- /* Old generation, minor collection; just keep it */
- gala->next = prev;
- prev = gala;
- }
-#endif
- }
- liveRemoteGAs = prev;
-
- /* If we have any remaining FREE messages to send off, do so now */
- sendFreeMessages();
-
- if (full)
- RebuildLAGAtable();
-}
-
-#endif
-
-\end{code}
-
-\begin{code}
-void
-Scavenge(void)
-{
- DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
- while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
- DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
-}
-\end{code}
-
-\begin{code}
-#ifdef GCdu
-
-void
-EvacuateCAFs( CAFlist )
- P_ CAFlist;
-{
- P_ CAFptr;
-
- DEBUG_STRING("Evacuate CAFs:");
- for (CAFptr = CAFlist;
- CAFptr != NULL;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
- }
-}
-
-/* ToDo: put GCap EvacuateCAFs code here */
-
-#else /* not GCdu */
-
-void
-EvacAndScavengeCAFs( CAFlist, extra_words, roots )
- P_ CAFlist;
- I_ *extra_words;
- I_ *roots;
-{
- I_ caf_roots = 0;
- P_ caf_start = ToHp;
- P_ CAFptr;
-
- DEBUG_STRING("Evacuate & Scavenge CAFs:");
- for (CAFptr = CAFlist;
- CAFptr != NULL;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
-
- EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
- caf_roots++;
-
- DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
- while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
- DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
- }
- *extra_words = ToHp - caf_start;
- *roots = caf_roots;
-}
-
-#endif /* !GCdu */
-
-#endif /* defined(_INFO_COPYING) */
-\end{code}
+++ /dev/null
-\section[SMcopying-header]{Header file for SMcopying}
-
-\begin{code}
-void SetCAFInfoTables PROTO(( P_ CAFlist ));
-void EvacuateRoots PROTO(( P_ roots[], I_ rootno ));
-void EvacuateAStack PROTO(( PP_ stackA, PP_ botA ));
-void EvacuateBStack PROTO(( P_ stackB, P_ botB, I_ *roots ));
-void Scavenge (STG_NO_ARGS);
-
-#ifdef GRAN
-void EvacuateEvents(STG_NO_ARGS);
-#endif
-#ifdef CONCURRENT
-void EvacuateSparks(STG_NO_ARGS);
-#endif
-
-#ifdef GCdu
-void EvacuateCAFs PROTO(( P_ CAFlist ));
-#else /* !GCdu */
-void EvacAndScavengeCAFs PROTO(( P_ CAFlist, I_ *extra_words, I_ *roots ));
-#endif /* !GCdu */
-\end{code}
+++ /dev/null
-***************************************************************************
-
- COMPACTING GARBAGE COLLECTION
-
-Global heap requirements as for 1s and 2s collectors.
-
-***************************************************************************
-
-ToDo: soft heap limits.
-
-\begin{code}
-
-#if defined(GCdu)
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-#include "SMcopying.h"
-#include "SMcompacting.h"
-#include "SMextn.h"
-
-REGDUMP(ScavRegDump);
-
-dualmodeData dualmodeInfo = {TWO_SPACE_BOT,
- DEFAULT_RESID_TO_COMPACT,
- DEFAULT_RESID_FROM_COMPACT,
- {{0,0,0,"low->high"},
- {0,0,0,"high->low"},
- {0,0,0,"compacting"}},
- 0, 0
- };
-
-P_ heap_space = 0; /* Address of first word of slab
- of memory allocated for heap */
-
-P_ hp_start; /* Value of Hp when reduction was resumed */
-
-rtsBool
-initHeap(smInfo * sm)
-{
- if (heap_space == 0) { /* allocates if it doesn't already exist */
-
- I_ semispaceSize = RTSflags.GcFlags.heapSize / 2;
-
- /* Allocate the roots space */
- sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
-
- /* Allocate the heap */
- heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
- "initHeap (heap)");
-
- dualmodeInfo.modeinfo[TWO_SPACE_BOT].heap_words =
- dualmodeInfo.modeinfo[TWO_SPACE_TOP].heap_words = RTSflags.GcFlags.heapSize;
-
- dualmodeInfo.modeinfo[TWO_SPACE_BOT].base =
- HEAP_FRAME_BASE(heap_space, semispaceSize);
- dualmodeInfo.modeinfo[TWO_SPACE_BOT].lim =
- HEAP_FRAME_LIMIT(heap_space, semispaceSize);
- dualmodeInfo.modeinfo[TWO_SPACE_TOP].base =
- HEAP_FRAME_BASE(heap_space + semispaceSize, semispaceSize);
- dualmodeInfo.modeinfo[TWO_SPACE_TOP].lim =
- HEAP_FRAME_LIMIT(heap_space + semispaceSize, semispaceSize);
-
- dualmodeInfo.bit_words = (RTSflags.GcFlags.heapSize + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- dualmodeInfo.bits = (BitWord *)(heap_space + RTSflags.GcFlags.heapSize) - dualmodeInfo.bit_words;
-
- dualmodeInfo.modeinfo[COMPACTING].heap_words =
- RTSflags.GcFlags.heapSize - dualmodeInfo.bit_words;
- dualmodeInfo.modeinfo[COMPACTING].base =
- HEAP_FRAME_BASE(heap_space, RTSflags.GcFlags.heapSize - dualmodeInfo.bit_words);
- dualmodeInfo.modeinfo[COMPACTING].lim =
- HEAP_FRAME_LIMIT(heap_space, RTSflags.GcFlags.heapSize - dualmodeInfo.bit_words);
-
- stat_init("DUALMODE", "Collection", " Mode ");
- }
-
- sm->hp = hp_start = dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1;
-
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
-
- RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
-
- if (sm->hplim > dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) {
- fprintf(stderr, "Not enough heap for requested alloc size\n");
- return rtsFalse;
- }
- } else {
- sm->hplim = dualmodeInfo.modeinfo[dualmodeInfo.mode].lim;
- }
-
- sm->CAFlist = NULL;
-
-#ifndef PAR
- initExtensions( sm );
-#endif /* !PAR */
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "DUALMODE Heap: TS base, TS lim, TS base, TS lim, CM base, CM lim, CM bits, bit words\n 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx\n",
- (W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].base,
- (W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].lim,
- (W_) dualmodeInfo.modeinfo[TWO_SPACE_TOP].base,
- (W_) dualmodeInfo.modeinfo[TWO_SPACE_TOP].lim,
- (W_) dualmodeInfo.modeinfo[COMPACTING].base,
- (W_) dualmodeInfo.modeinfo[COMPACTING].lim,
- (W_) dualmodeInfo.bits, dualmodeInfo.bit_words);
- fprintf(stderr, "DUALMODE Initial: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- (W_) dualmodeInfo.mode,
- (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
- (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
- }
-
- return rtsTrue; /* OK */
-}
-
-I_
-collectHeap(reqsize, sm, do_full_collection)
- W_ reqsize;
- smInfo *sm;
- rtsBool do_full_collection;
-{
- I_ start_mode;
-
- I_ free_space, /* No of words of free space following GC */
- alloc, /* Number of words allocated since last GC */
- resident, /* Number of words remaining after GC */
- bstk_roots; /* Number of update frames on B stack */
- StgFloat residency; /* % Words remaining after GC */
-
- fflush(stdout); /* Flush stdout at start of GC */
- SAVE_REGS(&ScavRegDump); /* Save registers */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "DUALMODE Start: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
- dualmodeInfo.mode,
- (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
- (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
-
- alloc = sm->hp - hp_start;
- stat_startGC(alloc);
-
- start_mode = dualmodeInfo.mode;
- if (start_mode == COMPACTING) {
-
- /* PERFORM COMPACTING COLLECTION */
-
- /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
- RESTORE_REGS(&ScavRegDump);
-
- markHeapRoots(sm, sm->CAFlist, 0,
- dualmodeInfo.modeinfo[COMPACTING].base,
- dualmodeInfo.modeinfo[COMPACTING].lim,
- dualmodeInfo.bits);
-
- SAVE_REGS(&ScavRegDump);
- /* end of bracket */
-
-#ifndef PAR
- sweepUpDeadForeignObjs(sm->ForeignObjList,
- dualmodeInfo.modeinfo[COMPACTING].base,
- dualmodeInfo.bits);
-#endif
- LinkCAFs(sm->CAFlist);
-
- LinkRoots( sm->roots, sm->rootno );
-#ifdef CONCURRENT
- LinkSparks();
-#endif
-#ifdef PAR
- LinkLiveGAs(dualmodeInfo.modeinfo[COMPACTING].base, dualmodeInfo.bits);
-#else
-/* stable pointers are now accessed via sm->roots
- DEBUG_STRING("Linking Stable Pointer Table:");
- LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
-*/
-#if 1 /* !defined(GRAN) */ /* HWL */
- LinkAStack( MAIN_SpA, stackInfo.botA );
- LinkBStack( MAIN_SuB, stackInfo.botB );
-#endif
-#endif
-
- /* Do Inplace Compaction */
- /* Returns start of next closure, -1 gives last allocated word */
-
- sm->hp = Inplace_Compaction(dualmodeInfo.modeinfo[COMPACTING].base,
- dualmodeInfo.modeinfo[COMPACTING].lim,
- 0, 0,
- dualmodeInfo.bits,
- dualmodeInfo.bit_words
-#ifndef PAR
- ,&(sm->ForeignObjList)
-#endif
- ) - 1;
-
- } else {
-
- /* COPYING COLLECTION */
-
- dualmodeInfo.mode = NEXT_SEMI_SPACE(start_mode);
- ToHp = dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1;
- Scav = dualmodeInfo.modeinfo[dualmodeInfo.mode].base;
- /* Point to (info field of) first closure */
-
- SetCAFInfoTables( sm->CAFlist );
- EvacuateCAFs( sm->CAFlist );
-#ifdef PAR
- EvacuateLocalGAs(rtsTrue);
-#else
- /* evacSPTable( sm ); stable pointers now reachable via sm->roots */
-#endif /* PAR */
- EvacuateRoots( sm->roots, sm->rootno );
-#if defined(CONCURRENT) && !defined(GRAN)
- EvacuateSparks();
-#endif
-#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
- EvacuateAStack( MAIN_SpA, stackInfo.botA );
- EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
-#endif /* !PAR */
-
- Scavenge();
-
-#ifdef PAR
- RebuildGAtables(rtsTrue);
-#else
- reportDeadForeignObjs(sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
-#endif /* PAR */
-
- sm->hp = hp_start = ToHp; /* Last allocated word */
- }
-
- /* Use residency to determine if a change in mode is required */
-
- resident = sm->hp - (dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1);
- residency = resident / (StgFloat) RTSflags.GcFlags.heapSize;
- DO_MAX_RESIDENCY(resident); /* stats only */
-
- if ((start_mode == TWO_SPACE_TOP) &&
- (residency > dualmodeInfo.resid_to_compact)) {
- DEBUG_STRING("Changed Mode: Two Space => Compacting");
- dualmodeInfo.mode = COMPACTING;
-
- /* Zero bit vector for marking phase at next collection */
- { BitWord *ptr = dualmodeInfo.bits,
- *end = dualmodeInfo.bits + dualmodeInfo.bit_words;
- while (ptr < end) { *(ptr++) = 0; };
- }
-
- } else if ((start_mode == COMPACTING) &&
- (residency < dualmodeInfo.resid_from_compact)) {
- DEBUG_STRING("Changed Mode: Compacting => Two Space");
- dualmodeInfo.mode = TWO_SPACE_BOT;
- }
-
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
- if (sm->hplim > dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) {
- free_space = 0;
- } else {
- free_space = SM_alloc_size;
- }
- } else {
- sm->hplim = dualmodeInfo.modeinfo[dualmodeInfo.mode].lim;
- free_space = sm->hplim - sm->hp;
- }
-
- hp_start = sm->hp;
-
- stat_endGC(alloc, dualmodeInfo.modeinfo[start_mode].heap_words,
- resident, dualmodeInfo.modeinfo[start_mode].name);
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "DUALMODE Done: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- dualmodeInfo.mode,
- (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
- (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) ((sm->hplim - sm->hp) * sizeof(W_)));
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating. */
- TrashMem(sm->hp+1, sm->hplim);
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_space < reqsize)
- return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */
- else
- return GC_SUCCESS; /* Heap OK */
-}
-
-#endif /* GCdu */
-
-\end{code}
-
+++ /dev/null
-%****************************************************************************
-
-The files SMevac.lc and SMscav.lhc contain the basic routines required
-for two-space copying garbage collection.
-
-Two files are required as the evac routines are conventional call/return
-routines while the scavenge routines are continuation routines.
-
-This file SMevac.lc contains the evacuation routines ...
-
-See SMscav.lhc for calling convention documentation.
-
-%****************************************************************************
-
-\begin{code}
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-
-#if defined(_INFO_COPYING)
-
-/* Moves ToHp to point at the info pointer of the new to-space closure */
-#define START_ALLOC(size) ToHp += 1
-
-/* Moves ToHp to point to the last word allocated in to-space */
-#define FINISH_ALLOC(size) ToHp += (FIXED_HS-1) + (size)
-
-
-/* Copy the ith word (starting at 0) */
-#define COPY_WORD(position) ToHp[position] = evac[position]
-
-/* Copy the ith ptr (starting at 0), adjusting by offset */
-#define ADJUST_WORD(pos,off) ((PP_)ToHp)[pos] = ((PP_)evac)[pos] + (off)
-
-/* Copy the nth free var word in a SPEC closure (starting at 1) */
-#define SPEC_COPY_FREE_VAR(n) COPY_WORD((SPEC_HS-1) + (n))
-
-#if FIXED_HS == 1
-#define COPY_FIXED_HDR COPY_WORD(0)
-#else
-#if FIXED_HS == 2
-#define COPY_FIXED_HDR COPY_WORD(0);COPY_WORD(1)
-#else
-#if FIXED_HS == 3
-#define COPY_FIXED_HDR COPY_WORD(0);COPY_WORD(1);COPY_WORD(2)
-#else
-/* I don't think this will be needed (ToDo: #error?) */
-#endif /* FIXED_HS != 1, 2, or 3 */
-#endif
-#endif
-
-
-/*** DEBUGGING MACROS ***/
-
-#if defined(DEBUG)
-
-#define DEBUG_EVAC(sizevar) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \
- evac, ToHp, INFO_PTR(evac), sizevar)
-
-#define DEBUG_EVAC_DYN \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Dyn info 0x%lx, size %lu\n", \
- evac, ToHp, INFO_PTR(evac), DYN_CLOSURE_SIZE(evac))
-
-#define DEBUG_EVAC_TUPLE \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Tuple info 0x%lx, size %lu\n", \
- evac, ToHp, INFO_PTR(evac), TUPLE_CLOSURE_SIZE(evac))
-
-#define DEBUG_EVAC_MUTUPLE \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, MuTuple info 0x%lx, size %lu\n", \
- evac, ToHp, INFO_PTR(evac), MUTUPLE_CLOSURE_SIZE(evac))
-
-#define DEBUG_EVAC_DATA \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Data info 0x%lx, size %lu\n", \
- evac, ToHp, INFO_PTR(evac), DATA_CLOSURE_SIZE(evac))
-
-#define DEBUG_EVAC_BH(sizevar) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BH info 0x%lx, size %ld\n", \
- evac, ToHp, INFO_PTR(evac), sizevar)
-
-#define DEBUG_EVAC_FORWARD \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Forward 0x%lx -> 0x%lx, info 0x%lx\n", \
- evac, FORWARD_ADDRESS(evac), INFO_PTR(evac))
-
-#define DEBUG_EVAC_IND1 \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
- evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
-
-#define DEBUG_EVAC_IND2 \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Indirection Done -> 0x%lx\n", evac)
-
-#define DEBUG_EVAC_PERM_IND \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Permanent Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
- evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
-
-#define DEBUG_EVAC_CAF_EVAC1 \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Caf 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
- evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
-
-#define DEBUG_EVAC_CAF_EVAC2 \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Caf Done -> 0x%lx\n", evac)
-
-#define DEBUG_EVAC_CAF_RET \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Caf 0x%lx -> 0x%lx, info 0x%lx\n", \
- evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
-
-#define DEBUG_EVAC_STAT \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Static 0x%lx -> 0x%lx, info 0x%lx\n", \
- evac, evac, INFO_PTR(evac))
-
-#define DEBUG_EVAC_CONST \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: Const 0x%lx -> 0x%lx, info 0x%lx\n", \
- evac, CONST_STATIC_CLOSURE(INFO_PTR(evac)), INFO_PTR(evac))
-
-#define DEBUG_EVAC_CHARLIKE \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: CharLike (%lx) 0x%lx -> 0x%lx, info 0x%lx\n", \
- evac, CHARLIKE_VALUE(evac), CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac)), INFO_PTR(evac))
-
-#define DEBUG_EVAC_INTLIKE_TO_STATIC \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Evac: IntLike to Static (%ld) 0x%lx -> 0x%lx, info 0x%lx\n", \
- INTLIKE_VALUE(evac), evac, INTLIKE_CLOSURE(INTLIKE_VALUE(evac)), INFO_PTR(evac))
-
-#define DEBUG_EVAC_TO_OLD \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Old ")
-
-#define DEBUG_EVAC_TO_NEW \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "New ")
-
-#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, " OldRoot: 0x%lx -> Old 0x%lx (-> New 0x%lx)\n", \
- evac, oldind, newevac)
-
-#define DEBUG_EVAC_OLDROOT_FORWARD \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) { \
- fprintf(stderr, "Evac: OldRoot Forward 0x%lx -> Old 0x%lx ", evac, FORWARD_ADDRESS(evac)); \
- if (! InOldGen(Scav)) fprintf(stderr, "-> New 0x%lx ", IND_CLOSURE_PTR(FORWARD_ADDRESS(evac))); \
- fprintf(stderr, "info 0x%lx\n", INFO_PTR(evac)); \
- }
-
-#ifdef CONCURRENT
-#define DEBUG_EVAC_BQ \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BQ info 0x%lx, size %lu\n", \
- evac, ToHp, INFO_PTR(evac), BQ_CLOSURE_SIZE(evac))
-
-#define DEBUG_EVAC_TSO(size) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Evac TSO: 0x%lx -> 0x%lx, size %ld\n", \
- evac, ToHp, size)
-
-#define DEBUG_EVAC_STKO(a,b) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Evac StkO: 0x%lx -> 0x%lx, size %ld (A), %ld (B)\n", \
- evac, ToHp, a, b)
-
-# ifdef PAR
-# define DEBUG_EVAC_BF \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BF info 0x%lx, size %lu\n", \
- evac, ToHp, INFO_PTR(evac), BF_CLOSURE_SIZE(dummy))
-# endif
-
-#endif
-
-#else
-
-#define DEBUG_EVAC(size)
-#define DEBUG_EVAC_DYN
-#define DEBUG_EVAC_TUPLE
-#define DEBUG_EVAC_MUTUPLE
-#define DEBUG_EVAC_DATA
-#define DEBUG_EVAC_BH(size)
-#define DEBUG_EVAC_FORWARD
-#define DEBUG_EVAC_IND1
-#define DEBUG_EVAC_IND2
-#define DEBUG_EVAC_PERM_IND
-#define DEBUG_EVAC_CAF_EVAC1
-#define DEBUG_EVAC_CAF_EVAC2
-#define DEBUG_EVAC_CAF_RET
-#define DEBUG_EVAC_STAT
-#define DEBUG_EVAC_CONST
-#define DEBUG_EVAC_CHARLIKE
-#define DEBUG_EVAC_INTLIKE_TO_STATIC
-#define DEBUG_EVAC_TO_OLD
-#define DEBUG_EVAC_TO_NEW
-#define DEBUG_EVAC_OLDROOT_FORWARD
-#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new)
-
-#ifdef CONCURRENT
-# define DEBUG_EVAC_BQ
-# define DEBUG_EVAC_TSO(size)
-# define DEBUG_EVAC_STKO(s,size)
-# ifdef PAR
-# define DEBUG_EVAC_BF
-# endif
-#endif
-
-#endif /* not DEBUG */
-
-
-#if defined(GCgn)
-
-/* Evacuation with Promotion -- Have to decide if we promote ! */
-/* This is done by fiddling the ToHp pointer before calling */
-/* the real _do_Evacute code, passing reqd forward ref info */
-
-/* Is a heap ptr in the old generation ? */
-#define InOldGen(hpptr) (((P_)(hpptr)) <= OldGen)
-
-/* Should we promote to the old generation ? */
-#define ShouldPromote(evac) (((P_)(evac)) < AllocGen)
-
-
-/*** Real Evac Code -- passed closure & forward ref info ***/
-
-#define EVAC_FN(suffix) \
- P_ CAT2(_do_Evacuate_,suffix)(evac, forward_info) \
- P_ evac; P_ forward_info;
-
-
-/*** Evac Decision Code -- calls real evac code ***/
-
-extern P_ _Evacuate_Old_to_New();
-
-#define GEN_EVAC_CODE(suffix) \
- P_ CAT2(_Evacuate_,suffix)(evac) \
- P_ evac; \
- { \
- P_ newevac, tmp; \
- if (ShouldPromote(evac)) { \
- DEBUG_EVAC_TO_OLD; \
- tmp = ToHp; ToHp = OldHp; \
- newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_Old_info); \
- OldHp = ToHp; ToHp = tmp; \
- } else { \
- DEBUG_EVAC_TO_NEW; \
- newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_New_info); \
- \
- /* Check if new gen closure is scavenged from the old gen */ \
- if (InOldGen(Scav)) { \
- newevac = (P_) _Evacuate_Old_to_New(newevac, evac); \
- } \
- } \
- return newevac; \
- }
-
-
-/*** FORWARD REF STUFF ***/
-
-/*** Setting Forward Ref: grab argument passed to evac code ***/
-
-/* Note that writing in the forwarding address trashes part of the
- closure. This is normally fine since, if we want the data, we'll
- have made a copy of it.
-
- But, Foreign Object closures are special: we have to make sure that
- we don't damage either the linked list (which will include both
- copied and uncopied Foreign objs) or the data (which we must report
- to the outside world). Foreign Objects closures are carefully designed
- to have a little extra space in them that can be safely
- overwritten. [ADR]
-*/
-
-#define SET_FORWARD_REF(closure, forw) \
- SET_INFO_PTR(closure,forward); /* arg passed to evac function */ \
- FORWARD_ADDRESS(closure) = (W_)(forw)
-
-
-EVAC_FN(Old_Forward_Ref)
-{
- /* Forward ref to old generation -- just return */
- DEBUG_EVAC_FORWARD;
-
- evac = (P_) FORWARD_ADDRESS(evac);
- return(evac);
-}
-
-EVAC_FN(New_Forward_Ref)
-{
- /* Forward ref to new generation -- check scavenged from the old gen */
- DEBUG_EVAC_FORWARD;
-
- if (InOldGen(Scav)) {
- evac = (P_) _Evacuate_Old_to_New(FORWARD_ADDRESS(evac), evac);
- } else {
- evac = (P_) FORWARD_ADDRESS(evac);
- }
- return(evac);
-}
-
-EVAC_FN(OldRoot_Forward)
-{
- /* Forward ref to old generation root -- return old root or new gen closure */
- DEBUG_EVAC_OLDROOT_FORWARD;
-
- /* grab old generation root */
- evac = (P_) FORWARD_ADDRESS(evac);
-
- /* if scavenging new generation return the new generation
- closure rather than the old generation root */
- if (! InOldGen(Scav)) {
- evac = (P_) IND_CLOSURE_PTR(evac);
- }
-
- return(evac);
-}
-
-EXTDATA_RO(Forward_Ref_New_info);
-EXTDATA_RO(Forward_Ref_Old_info);
-EXTDATA_RO(OldRoot_Forward_Ref_info);
-
-/*** Old Gen Reference to New Gen Closure ***/
-
-P_
-_Evacuate_Old_to_New(newevac, evac)
-P_ newevac, evac;
-{
- /* New generation closure referenced from the old generation */
- /* allocate old generation indirection to newevac */
- /* reset forward reference in original allocation area to oldind */
- /* evacuating this should return the old root or the new gen */
- /* closure depending if referenced from the old generation */
- /* return oldind as evacuated location */
- /* reference from oldgen will be to this oldind closure */
-
- P_ oldind = OldHp + 1; /* see START_ALLOC */
- OldHp = oldind + (FIXED_HS-1) + MIN_UPD_SIZE; /* see FINISH_ALLOC */
-
- DEBUG_EVAC_OLD_TO_NEW(oldind, evac, newevac);
-
- INFO_PTR(evac) = (W_) OldRoot_Forward_Ref_info;
- FORWARD_ADDRESS(evac) = (W_)oldind;
-
- INFO_PTR(oldind) = (W_) OldRoot_info;
- IND_CLOSURE_PTR(oldind) = (W_) newevac;
- IND_CLOSURE_LINK(oldind) = (W_) genInfo.OldInNew;
- genInfo.OldInNew = oldind;
- genInfo.OldInNewno++;
-
- return oldind;
-}
-
-#define PROMOTE_MUTABLE(evac) \
- if (InOldGen(evac)) { \
- MUT_LINK(evac) = (W_) genInfo.PromMutables; \
- genInfo.PromMutables = (P_) evac; \
- }
-
-#else /* ! GCgn */
-
-#if defined(GCap)
-
-#define PROMOTE_MUTABLE(evac) \
- MUT_LINK(evac) = (W_) appelInfo.PromMutables; \
- appelInfo.PromMutables = (P_) evac;
-
-#else
-
-#define PROMOTE_MUTABLE(evac)
-
-#endif /* GCap */
-
-/*** Real Evac Code -- simply passed closure ***/
-
-#define EVAC_FN(suffix) P_ CAT2(_Evacuate_,suffix)(P_ evac)
-
-/*** FORWARD REF STUFF ***/
-
-#define SET_FORWARD_REF(closure, forw) \
- SET_INFO_PTR(closure, Forward_Ref_info); \
- FORWARD_ADDRESS(closure) = (W_) (forw)
-
-P_
-_Evacuate_Forward_Ref(evac)
-P_ evac;
-{
- DEBUG_EVAC_FORWARD;
- evac = (P_) FORWARD_ADDRESS(evac);
- return(evac);
-}
-
-EXTDATA_RO(Forward_Ref_info);
-
-#endif /* ! GCgn */
-
-
-/*** SPECIALISED CODE ***/
-
-/* Note: code for evacuating selectors is given near that for Ind(irections) */
-
-EVAC_FN(1)
-{
- START_ALLOC(1);
-
- DEBUG_EVAC(1);
- COPY_FIXED_HDR;
- SPEC_COPY_FREE_VAR(1);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(1);
- return(evac);
-}
-
-EVAC_FN(2)
-{
- START_ALLOC(2);
- DEBUG_EVAC(2);
- COPY_FIXED_HDR;
- SPEC_COPY_FREE_VAR(1);
- SPEC_COPY_FREE_VAR(2);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(2);
- return(evac);
-}
-
-EVAC_FN(3)
-{
- START_ALLOC(3);
- DEBUG_EVAC(3);
- COPY_FIXED_HDR;
- SPEC_COPY_FREE_VAR(1);
- SPEC_COPY_FREE_VAR(2);
- SPEC_COPY_FREE_VAR(3);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(3);
- return(evac);
-}
-
-EVAC_FN(4)
-{
- START_ALLOC(4);
- DEBUG_EVAC(4);
- COPY_FIXED_HDR;
- SPEC_COPY_FREE_VAR(1);
- SPEC_COPY_FREE_VAR(2);
- SPEC_COPY_FREE_VAR(3);
- SPEC_COPY_FREE_VAR(4);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(4);
- return(evac);
-}
-
-EVAC_FN(5)
-{
- START_ALLOC(5);
- DEBUG_EVAC(5);
- COPY_FIXED_HDR;
- SPEC_COPY_FREE_VAR(1);
- SPEC_COPY_FREE_VAR(2);
- SPEC_COPY_FREE_VAR(3);
- SPEC_COPY_FREE_VAR(4);
- SPEC_COPY_FREE_VAR(5);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(5);
- return(evac);
-}
-
-#define BIG_SPEC_EVAC_FN(n) \
-EVAC_FN(n) \
-{ \
- int i; \
- START_ALLOC(n); \
- DEBUG_EVAC(n); \
- COPY_FIXED_HDR; \
- for (i = 1; i <= n; i++) { SPEC_COPY_FREE_VAR(i); } \
- SET_FORWARD_REF(evac,ToHp); \
- evac = ToHp; \
- FINISH_ALLOC(n); \
- return(evac); \
-}
-
-/* instantiate for 6--12 */
-BIG_SPEC_EVAC_FN(6)
-BIG_SPEC_EVAC_FN(7)
-BIG_SPEC_EVAC_FN(8)
-BIG_SPEC_EVAC_FN(9)
-BIG_SPEC_EVAC_FN(10)
-BIG_SPEC_EVAC_FN(11)
-BIG_SPEC_EVAC_FN(12)
-
-\end{code}
-
-A @SPEC_RBH@ must be at least size @MIN_UPD_SIZE@ (Whom are we fooling?
-This means 2), and the first word after the fixed header is a
-@MUT_LINK@. The second word is a pointer to a blocking queue.
-Remaining words are the same as the underlying @SPEC@ closure. Unlike
-their @SPEC@ cousins, @SPEC_RBH@ closures require special handling for
-generational collectors, because the blocking queue is a mutable
-field.
-
-We don't expect to have a lot of these, so I haven't unrolled the
-first five instantiations of the macro, but feel free to do so if it
-turns you on.
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-
-#define SPEC_RBH_EVAC_FN(n) \
-EVAC_FN(CAT2(RBH_,n)) \
-{ \
- I_ count = FIXED_HS - 1; \
- I_ size = SPEC_RBH_VHS + (n); \
- START_ALLOC(size); \
- DEBUG_EVAC(size); \
- COPY_FIXED_HDR; \
- while (++count <= size + (FIXED_HS - 1)) { \
- COPY_WORD(count); \
- } \
- SET_FORWARD_REF(evac,ToHp); \
- evac = ToHp; \
- FINISH_ALLOC(size); \
- \
- PROMOTE_MUTABLE(evac); \
- \
- return(evac); \
-}
-
-/* instantiate for 2--12 */
-SPEC_RBH_EVAC_FN(2)
-SPEC_RBH_EVAC_FN(3)
-SPEC_RBH_EVAC_FN(4)
-SPEC_RBH_EVAC_FN(5)
-SPEC_RBH_EVAC_FN(6)
-SPEC_RBH_EVAC_FN(7)
-SPEC_RBH_EVAC_FN(8)
-SPEC_RBH_EVAC_FN(9)
-SPEC_RBH_EVAC_FN(10)
-SPEC_RBH_EVAC_FN(11)
-SPEC_RBH_EVAC_FN(12)
-
-#endif
-
-#ifndef PAR
-EVAC_FN(ForeignObj)
-{
- I_ size = ForeignObj_SIZE;
- START_ALLOC(size);
- DEBUG_EVAC(size);
-
-#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr,"DEBUG: Evacuating ForeignObj(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]);
- fprintf(stderr," Data = %x, Finaliser= %x, Next = %x\n",
- ForeignObj_CLOSURE_DATA(evac),
- ForeignObj_CLOSURE_FINALISER(evac),
- ForeignObj_CLOSURE_LINK(evac) );
- }
-#endif
-
- COPY_FIXED_HDR;
-
- SET_FORWARD_REF(evac,ToHp);
- ForeignObj_CLOSURE_DATA(ToHp) = ForeignObj_CLOSURE_DATA(evac);
- ForeignObj_CLOSURE_FINALISER(ToHp) = ForeignObj_CLOSURE_FINALISER(evac);
- ForeignObj_CLOSURE_LINK(ToHp) = ForeignObj_CLOSURE_LINK(evac);
-
-#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr,"DEBUG: Evacuated ForeignObj(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]);
- fprintf(stderr," Data = %x, Finaliser = %x, Next = %x\n",
- ForeignObj_CLOSURE_DATA(ToHp),
- ForeignObj_CLOSURE_FINALISER(ToHp),
- ForeignObj_CLOSURE_LINK(ToHp));
- }
-#endif
-
- evac = ToHp;
- FINISH_ALLOC(size);
- return(evac);
-}
-#endif /* !PAR */
-
-/*** GENERIC CASE CODE ***/
-
-EVAC_FN(S)
-{
- I_ count = FIXED_HS - 1;
- I_ size = GEN_CLOSURE_SIZE(evac);
-
- START_ALLOC(size);
- DEBUG_EVAC(size);
- COPY_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- COPY_WORD(count);
- }
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
- return(evac);
-}
-
-\end{code}
-
-Like a @SPEC_RBH@, a @GEN_RBH@ must be at least @MIN_UPD_SIZE@, and
-the first word after the fixed header is a @MUT_LINK@. The second
-word is a pointer to a blocking queue. Remaining words are the same
-as the underlying @GEN@ closure.
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-EVAC_FN(RBH_S)
-{
- I_ count = GEN_RBH_HS - 1;
- I_ size = GEN_RBH_CLOSURE_SIZE(evac);
-
- START_ALLOC(size);
- DEBUG_EVAC(size);
- COPY_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- COPY_WORD(count);
- }
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
-
- PROMOTE_MUTABLE(evac);
-
- return(evac);
-}
-#endif
-
-/*** DYNAMIC CLOSURE -- SIZE & PTRS STORED IN CLOSURE ***/
-
-EVAC_FN(Dyn)
-{
- I_ count = FIXED_HS - 1;
- I_ size = DYN_CLOSURE_SIZE(evac); /* Includes size and no-of-ptrs fields */
-
- START_ALLOC(size);
- DEBUG_EVAC_DYN;
- COPY_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- COPY_WORD(count);
- }
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
- return(evac);
-}
-
-/*** TUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/
-
-EVAC_FN(Tuple)
-{
- I_ count = FIXED_HS - 1;
- I_ size = TUPLE_CLOSURE_SIZE(evac);
-
- START_ALLOC(size);
- DEBUG_EVAC_TUPLE;
- COPY_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- COPY_WORD(count);
- }
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
- return(evac);
-}
-
-/*** MUTUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/
-/* Only if special GC treatment required */
-
-#ifdef GC_MUT_REQUIRED
-EVAC_FN(MuTuple)
-{
- I_ count = FIXED_HS - 1;
- I_ size = MUTUPLE_CLOSURE_SIZE(evac);
-
- START_ALLOC(size);
- DEBUG_EVAC_MUTUPLE;
-
- COPY_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- COPY_WORD(count);
- }
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
-
- /* Add to OldMutables list (if evacuated to old generation) */
- PROMOTE_MUTABLE(evac);
-
- return(evac);
-}
-#endif /* GCgn or GCap */
-
-
-/*** DATA CLOSURE -- SIZE STORED IN CLOSURE -- NO POINTERS ***/
-
-EVAC_FN(Data)
-{
- I_ count = FIXED_HS - 1;
- I_ size = DATA_CLOSURE_SIZE(evac);
-
- START_ALLOC(size);
- DEBUG_EVAC_DATA;
- COPY_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- COPY_WORD(count);
- }
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
- return(evac);
-}
-
-
-/*** STATIC CLOSURE CODE ***/
-
-/* Evacuation: Just return static address (no copying required)
- Evac already contains this address -- just return */
-/* Scavenging: Static closures should never be scavenged */
-
-EVAC_FN(Static)
-{
- DEBUG_EVAC_STAT;
- return(evac);
-}
-
-/*** BLACK HOLE CODE ***/
-
-EVAC_FN(BH_U)
-{
- START_ALLOC(BH_U_SIZE);
- DEBUG_EVAC_BH(BH_U_SIZE);
- COPY_FIXED_HDR;
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(BH_U_SIZE);
- return(evac);
-}
-
-EVAC_FN(BH_N)
-{
- START_ALLOC(BH_N_SIZE);
- DEBUG_EVAC_BH(BH_N_SIZE);
- COPY_FIXED_HDR;
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(BH_N_SIZE);
- return(evac);
-}
-
-/*** INDIRECTION CODE ***/
-
-/* permanent indirections first */
-#if defined(PROFILING) || defined(TICKY_TICKY)
-#undef PI
-
-EVAC_FN(PI) /* used for ticky in case just below... */
-{
-#ifdef TICKY_TICKY
- if (! AllFlags.doUpdEntryCounts) {
- DEBUG_EVAC_IND1;
- GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
-
- evac = (P_) IND_CLOSURE_PTR(evac);
-
-# if defined(GCgn) || defined(GCap)
- if (evac > OldGen) /* Only evacuate new gen with generational collector */
- evac = EVACUATE_CLOSURE(evac);
-# else
- evac = EVACUATE_CLOSURE(evac);
-# endif
-
- DEBUG_EVAC_IND2;
- } else {
-#endif
-
- /* *not* shorting one out... */
- START_ALLOC(IND_CLOSURE_SIZE(dummy));
- DEBUG_EVAC_PERM_IND;
- COPY_FIXED_HDR;
- COPY_WORD(IND_HS);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(IND_CLOSURE_SIZE(dummy));
-
-#ifdef TICKY_TICKY
- }
-#endif
- return(evac);
-}
-#endif /* PROFILING or TICKY */
-
-EVAC_FN(Ind) /* Indirections are shorted-out; if doing weird ticky
- stuff, we will have used *permanent* indirections
- for overwriting updatees...
- */
-{
- DEBUG_EVAC_IND1;
- GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
-
- evac = (P_) IND_CLOSURE_PTR(evac);
-
-# if defined(GCgn) || defined(GCap)
- if (evac > OldGen) /* Only evacuate new gen with generational collector */
- evac = EVACUATE_CLOSURE(evac);
-# else
- evac = EVACUATE_CLOSURE(evac);
-# endif
-
- DEBUG_EVAC_IND2;
-
- /* This will generate a stack of returns for a chain of indirections!
- However chains can only be 2 long.
- */
-
- return(evac);
-}
-
-/*** SELECTORS CODE (much like an indirection) ***/
-
-/* Evacuate a thunk which is selector; it has one free variable which
- points to something which will evaluate to a constructor in a
- single-constructor data type.
-
- If it is so evaluated at GC time, we want to simply select the n'th
- field.
-
- This thunk is of course always a Spec thing, since it has only one
- free var.
-
- The constructor is guaranteed to be a Spec thing, so we know where
- the n'th field is.
-
- ToDo: what if the constructor is a Gen thing?
-
- "selector_depth" stuff below: (WDP 95/12)
-
- It is possible to have a *very* considerable number of selectors
- all chained together, which will cause the code here to chew up
- enormous C stack space (very deeply nested set of calls), which
- can crash the program.
-
- Various solutions are possible, but we opt for a simple one --
- we run a "selector_depth" counter, and we stop doing the
- selections if we get beyond that depth. The main nice property
- is that it doesn't affect (or slow down) any of the rest of the
- GC.
-
- What should the depth be? For SPARC friendliness, it should
- probably be very small (e.g., 8 or 16), to avoid register-window
- spillage. However, that would increase the chances that
- selectors are left undone and lots of junk is promoted to the
- old generation. So we set it quite a bit higher -- we'd like to
- do all the selections except in the most extreme circumstances.
-*/
-static int selector_depth = 0;
-#define MAX_SELECTOR_DEPTH 100 /* reasonably arbitrary */
-
-static P_
-_EvacuateSelector_n(P_ evac, I_ n)
-{
- P_ maybe_con = (P_) evac[_FHS];
-
- /* must be a SPEC 2 1 closure */
- ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */
-
-#ifdef TICKY_TICKY
- /* if a thunk, its update-entry count must be zero */
- ASSERT(TICKY_HDR(evac) == 0);
-#endif
-
- selector_depth++; /* see story above */
-
-#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC)
- fprintf(stderr, "Evac Selector (depth %ld): 0x%lx, info 0x%lx, maybe_con 0x%lx, info 0x%lx, tag %ld\n",
- selector_depth, evac, INFO_PTR(evac), maybe_con,
- INFO_PTR(maybe_con), INFO_TAG(INFO_PTR(maybe_con)));
-#endif
-
- if (INFO_TAG(INFO_PTR(maybe_con)) < 0 /* not in WHNF */
-#if !defined(CONCURRENT)
- || (! RTSflags.GcFlags.lazyBlackHoling) /* see "price of laziness" paper */
-#endif
- || selector_depth > MAX_SELECTOR_DEPTH
- || (! RTSflags.GcFlags.doSelectorsAtGC)
- ) {
-#ifdef TICKY_TICKY
- if (INFO_TAG(INFO_PTR(maybe_con)) >= 0) { /* we *could* have done it */
- GC_SEL_ABANDONED();
- }
-#endif
- /* Evacuate as normal (it is size *2* because of MIN_UPD_SIZE) */
- return( _Evacuate_2(evac) );
- }
-
-#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC)
- fprintf(stderr, "Evac Selector:shorting: 0x%lx -> 0x%lx\n",
- evac, maybe_con[_FHS + n]);
-#endif
-
- /* Ha! Short it out */
- evac = (P_) (maybe_con[_FHS + n]); /* evac now has the result of the selection */
-
- GC_SEL_MINOR(); /* ticky-ticky */
-
-#if defined(GCgn) || defined(GCap)
- if (evac > OldGen) /* Only evacuate new gen with generational collector */
- evac = EVACUATE_CLOSURE(evac);
-#else
- evac = EVACUATE_CLOSURE(evac);
-#endif
-
- selector_depth--; /* see story above */
-
- return(evac);
-}
-
-#define DEF_SEL_EVAC(n) \
-P_ CAT2(_EvacuateSelector_,n) (evac) P_ evac; \
-{ return(_EvacuateSelector_n(evac,n)); }
-
-/* all the entry points */
-DEF_SEL_EVAC(0)
-DEF_SEL_EVAC(1)
-DEF_SEL_EVAC(2)
-DEF_SEL_EVAC(3)
-DEF_SEL_EVAC(4)
-DEF_SEL_EVAC(5)
-DEF_SEL_EVAC(6)
-DEF_SEL_EVAC(7)
-DEF_SEL_EVAC(8)
-DEF_SEL_EVAC(9)
-DEF_SEL_EVAC(10)
-DEF_SEL_EVAC(11)
-DEF_SEL_EVAC(12)
-
-#ifdef CONCURRENT
-EVAC_FN(BQ)
-{
- START_ALLOC(BQ_CLOSURE_SIZE(dummy));
- DEBUG_EVAC_BQ;
-
- COPY_FIXED_HDR;
- COPY_WORD(BQ_HS);
-
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(BQ_CLOSURE_SIZE(dummy));
-
- /* Add to OldMutables list (if evacuated to old generation) */
- PROMOTE_MUTABLE(evac);
-
- return(evac);
-}
-
-EVAC_FN(TSO)
-{
- I_ count;
- I_ size = TSO_VHS + TSO_CTS_SIZE;
-
- START_ALLOC(size);
- DEBUG_EVAC_TSO(size);
-
- COPY_FIXED_HDR;
- for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) {
- COPY_WORD(count);
- }
-
- *TSO_INTERNAL_PTR(ToHp) = *TSO_INTERNAL_PTR(evac);
-
- SET_FORWARD_REF(evac, ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
-
- /* Add to OldMutables list (if evacuated to old generation) */
- PROMOTE_MUTABLE(evac);
-
- return evac;
-}
-
-EVAC_FN(StkO)
-{
- I_ count;
- I_ size = STKO_CLOSURE_SIZE(evac);
- I_ spa_offset = STKO_SpA_OFFSET(evac);
- I_ spb_offset = STKO_SpB_OFFSET(evac);
- I_ sub_offset = STKO_SuB_OFFSET(evac);
- I_ offset;
-
- ASSERT(sanityChk_StkO(evac));
-
- START_ALLOC(size);
- DEBUG_EVAC_STKO(STKO_CLOSURE_CTS_SIZE(evac) - spa_offset + 1, spb_offset);
-
- COPY_FIXED_HDR;
-#ifdef TICKY_TICKY
- COPY_WORD(STKO_ADEP_LOCN);
- COPY_WORD(STKO_BDEP_LOCN);
-#endif
- COPY_WORD(STKO_SIZE_LOCN);
- COPY_WORD(STKO_RETURN_LOCN);
- COPY_WORD(STKO_LINK_LOCN);
-
- /* Adjust the four stack pointers -- ORDER IS IMPORTANT!! */
- offset = ToHp - evac;
-
- STKO_SuB(ToHp) = STKO_SuB(evac) + offset;
- STKO_SpB(ToHp) = STKO_SpB(evac) + offset;
- STKO_SpA(ToHp) = STKO_SpA(evac) + offset;
- STKO_SuA(ToHp) = STKO_SuA(evac) + offset;
-
-
- /* Slide the A stack */
- for (count = spa_offset; count <= STKO_CLOSURE_CTS_SIZE(evac); count++) {
- COPY_WORD((STKO_HS-1) + count);
- }
-
- /* Slide the B stack, repairing internal pointers */
- for (count = spb_offset; count >= 1;) {
- if (count > sub_offset) {
- COPY_WORD((STKO_HS-1) + count);
- count--;
- } else {
- P_ subptr;
- /* Repair the internal pointers in the update frame */
- COPY_WORD((STKO_HS-1) + count + BREL(UF_RET));
- COPY_WORD((STKO_HS-1) + count + BREL(UF_UPDATEE));
- ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUA),offset);
- ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUB),offset);
- subptr = GRAB_SuB(STKO_CLOSURE_ADDR(ToHp,sub_offset));
- sub_offset = STKO_CLOSURE_OFFSET(ToHp,subptr);
- count -= STD_UF_SIZE;
- }
- }
-
- SET_FORWARD_REF(evac, ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
-
- /* Add to OldMutables list (if evacuated to old generation) */
- PROMOTE_MUTABLE(evac);
-
- return evac;
-}
-
-#ifdef PAR
-EVAC_FN(FetchMe)
-{
- START_ALLOC(2);
- DEBUG_EVAC(2);
- COPY_FIXED_HDR;
- COPY_WORD(FETCHME_GA_LOCN);
- ASSERT(GALAlookup(FETCHME_GA(evac)) != NULL);
-
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(2);
-
- /* Add to OldMutables list (if evacuated to old generation) */
- PROMOTE_MUTABLE(evac);
-
- return(evac);
-}
-
-EVAC_FN(BF)
-{
- I_ count;
- I_ size = BF_CLOSURE_SIZE(evac);
-
- START_ALLOC(size);
- DEBUG_EVAC_BF;
-
- COPY_FIXED_HDR;
- for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) {
- COPY_WORD(count);
- }
- COPY_WORD(BF_LINK_LOCN);
- COPY_WORD(BF_NODE_LOCN);
- COPY_WORD(BF_GTID_LOCN);
- COPY_WORD(BF_SLOT_LOCN);
- COPY_WORD(BF_WEIGHT_LOCN);
-
- SET_FORWARD_REF(evac, ToHp);
- evac = ToHp;
- FINISH_ALLOC(size);
-
- /* Add to OldMutables list (if evacuated to old generation) */
- PROMOTE_MUTABLE(evac);
-
- return evac;
-}
-#endif /* PAR */
-#endif /* CONCURRENT */
-
-/*** SPECIAL CAF CODE ***/
-
-/* Evacuation: Return closure pointed to (already explicitly evacuated) */
-
-EVAC_FN(Caf)
-{
- DEBUG_EVAC_CAF_RET;
- GC_SHORT_CAF(); /* ticky: record that we shorted an indirection */
-
- evac = (P_) IND_CLOSURE_PTR(evac);
- return(evac);
-}
-
-/* In addition we need an internal Caf indirection which evacuates,
- updates and returns the indirection. Before GC is started, the
- @CAFlist@ must be traversed and the info tables set to this.
-*/
-
-EVAC_FN(Caf_Evac_Upd)
-{
- P_ closure = evac;
-
- DEBUG_EVAC_CAF_EVAC1;
-
- INFO_PTR(evac) = (W_) Caf_info; /* Change back to Caf_info */
-
- evac = (P_) IND_CLOSURE_PTR(evac); /* Grab reference and evacuate */
-
-#if defined(GCgn) || defined(GCap)
- if (evac > OldGen) /* Only evacuate new gen with generational collector */
- evac = EVACUATE_CLOSURE(evac);
-#else
- evac = EVACUATE_CLOSURE(evac);
-#endif
-
- IND_CLOSURE_PTR(closure) = (W_) evac; /* Update reference */
-
- DEBUG_EVAC_CAF_EVAC2;
- return(evac);
-
- /* This will generate a stack of returns for a chain of indirections!
- However chains can only be 2 long.
- */
-}
-
-
-/*** CONST CLOSURE CODE ***/
-
-/* Evacuation: Just return address of the static closure stored in the info table */
-
-EVAC_FN(Const)
-{
-#ifdef TICKY_TICKY
- if (AllFlags.doUpdEntryCounts) {
- /* evacuate as if a closure of size 0
- (there is no _Evacuate_0 to call)
- */
- START_ALLOC(0);
- DEBUG_EVAC(0);
- COPY_FIXED_HDR;
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(0);
-
- } else {
-#endif
-
- DEBUG_EVAC_CONST;
- GC_COMMON_CONST(); /* ticky */
-
- evac = CONST_STATIC_CLOSURE(INFO_PTR(evac));
-
-#ifdef TICKY_TICKY
- }
-#endif
- return(evac);
-}
-
-/*** CHARLIKE CLOSURE CODE ***/
-
-/* Evacuation: Just return address of the static closure stored fixed array */
-
-EVAC_FN(CharLike)
-{
-#ifdef TICKY_TICKY
- if (AllFlags.doUpdEntryCounts) {
- evac = _Evacuate_1(evac); /* evacuate closure of size 1 */
- } else {
-#endif
-
- DEBUG_EVAC_CHARLIKE;
- GC_COMMON_CHARLIKE(); /* ticky */
-
- evac = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac));
-
-#ifdef TICKY_TICKY
- }
-#endif
- return(evac);
-}
-\end{code}
-
---- INTLIKE CLOSURE CODE ---
-
-Evacuation: Return address of the static closure if available
-Otherwise evacuate converting to aux closure.
-
-There are some tricks here:
-\begin{enumerate}
-\item
-The main trick is that if the integer is in a certain range, we
-replace it by a pointer to a statically allocated integer.
-\end{enumerate}
-
-(Would it not be more efficient to update the copy directly since
-we're about to set a forwarding reference in the original? ADR)
-
-\begin{code}
-EVAC_FN(IntLike)
-{
- I_ val = INTLIKE_VALUE(evac);
-
- if (val >= MIN_INTLIKE /* in range of static closures */
- && val <= MAX_INTLIKE
-#ifdef TICKY_TICKY
- && !AllFlags.doUpdEntryCounts
-#endif
- ) {
- DEBUG_EVAC_INTLIKE_TO_STATIC;
- GC_COMMON_INTLIKE(); /* ticky */
-
- evac = (P_) INTLIKE_CLOSURE(val); /* return appropriate static closure */
- }
- else {
- evac = _Evacuate_1(evac); /* evacuate closure of size 1 */
-
-#ifdef TICKY_TICKY
- if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
-#endif
- }
-
- return(evac);
-}
-
-#if defined (GCgn)
-GEN_EVAC_CODE(1)
-GEN_EVAC_CODE(2)
-GEN_EVAC_CODE(3)
-GEN_EVAC_CODE(4)
-GEN_EVAC_CODE(5)
-GEN_EVAC_CODE(6)
-GEN_EVAC_CODE(7)
-GEN_EVAC_CODE(8)
-GEN_EVAC_CODE(9)
-GEN_EVAC_CODE(10)
-GEN_EVAC_CODE(11)
-GEN_EVAC_CODE(12)
-GEN_EVAC_CODE(S)
-GEN_EVAC_CODE(Dyn)
-GEN_EVAC_CODE(Tuple)
-GEN_EVAC_CODE(Data)
-GEN_EVAC_CODE(MuTuple)
-GEN_EVAC_CODE(IntLike) /* ToDo: may create oldgen roots referencing static ints */
-GEN_EVAC_CODE(CAT2(BH_,MIN_UPD_SIZE))
-GEN_EVAC_CODE(CAT2(BH_,MIN_NONUPD_SIZE))
-#endif /* GCgn */
-
-#else /* ! _INFO_COPYING */
-This really really should not ever ever come up!
-#endif /* ! _INFO_COPYING */
-\end{code}
+++ /dev/null
-\section[SM-extensions]{Storage Manager Extensions}
-
-ToDo ADR: Maybe this should be split between SMcopying.lc and
-SMcompacting.lc?
-
-
-This is a collection of C functions use in implementing the stable
-pointer and foreign object extensions.
-
-The motivation for making this a separate file/section is twofold:
-
-1) It let's us focus on one thing.
-
-2) If we don't do this, there will be a huge amount of repetition
- between the various GC schemes --- a maintenance nightmare.
-
-The second is the major motivation.
-
-There are three main parts to this file:
-
-1) Code which is common to all GC schemes.
-
-2) Code for use in a compacting collector used in the 1-space, dual
- mode and for collecting old generations in generational collectors.
-
-3) Code for use in a copying collector used in the 2-space, dual mode
- and for collecting young generations in generational collectors.
-
-When debugging, it is incredibly helpful to trash part of the heap
-(say) once you're done with it.
-
-Remembering that @sm->hp@ points to the next word to be allocated, a
-typical use is
-
-\begin{pseudocode}
-#ifdef DEBUG
- TrashMem(sm->hp+1, sm->hplim);
-#endif
-\end{pseudocode}
-
-\begin{code}
-
-#if defined(GC1s)
-
-#define SCAN_REG_DUMP
-#include "SMinternal.h"
-REGDUMP(ScanRegDump);
-
-#else /* GC2s, GCdu, GCap, GCgn */
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-REGDUMP(ScavRegDump);
-
-#endif
-#include "SMextn.h"
-
-#ifdef DEBUG
-
-void
-TrashMem(from, to)
- P_ from, to;
-{
-/* assertion overly strong - if free_mem == 0, sm->hp == sm->hplim */
-/* ASSERT( from <= to ); */
- if (RTSflags.GcFlags.trace)
- fprintf(stderr,"Trashing from 0x%lx to 0x%lx inclusive\n", (W_) from, (W_) to);
- while (from <= to) {
- *from++ = DEALLOCATED_TRASH;
- }
-}
-
-#endif /* DEBUG */
-\end{code}
-
-\begin{code}
-
-#if !defined(PAR) /* To end of the file */
-
-\end{code}
-
-\downsection
-\section[SM-extensions-common-code]{Code common to all GC schemes}
-
-\begin{code}
-EXTDATA(EmptySPTable_closure);
-
-void initExtensions( sm )
- smInfo *sm;
-{
- sm->ForeignObjList = NULL;
-#if defined(GCap) || defined(GCgn)
- sm->OldForeignObjList = NULL;
-#endif
-
- sm->StablePointerTable = (P_) EmptySPTable_closure;
-}
-
-\end{code}
-
-\begin{code}
-#if defined(DEBUG)
-\end{code}
-
-When a Foreign Object is released, there should be absolutely no
-references to it. To encourage and dangling references to show
-themselves, we'll trash its contents when we're done with it.
-
-\begin{code}
-#define TRASH_ForeignObj_CLOSURE( mptr ) Trash_ForeignObj_Closure(mptr)
-
-void
-Trash_ForeignObj_Closure(mptr)
- P_ mptr;
-{
- int i;
- for( i = 0; i < ForeignObj_SIZE + _FHS; i++ ) {
- mptr[ i ] = DEALLOCATED_TRASH;
- }
-}
-\end{code}
-
-Also, every time we fiddle with the ForeignObj list, we should check it
-still makes sense. This function returns @0@ if the list is sensible.
-
-(Would maintaining a separate Foreign Obj count allow better testing?)
-
-\begin{code}
-void
-Validate_ForeignObjList( ForeignObjList )
- P_ ForeignObjList;
-{
- P_ FOptr;
-
- for(FOptr = ForeignObjList;
- FOptr != NULL;
- FOptr = ForeignObj_CLOSURE_LINK(FOptr) ) {
- CHECK_ForeignObj_CLOSURE(FOptr);
- }
-}
-\end{code}
-
-\begin{code}
-#else /* !DEBUG */
-
-#define TRASH_ForeignObj_CLOSURE( mp ) /* nothing */
-
-#endif /* !DEBUG */
-\end{code}
-
-\begin{code}
-#ifdef DEBUG
-
-#define TRACE_ForeignObj(FOptr) Trace_ForeignObj( FOptr )
-#define TRACE_FOdies(FOptr) Trace_FOdies()
-#define TRACE_FOlives(FOptr) Trace_FOlives()
-#define TRACE_FOforwarded(FOptr, newAddress) Trace_FOforwarded( FOptr, newAddress )
-
-void
-Trace_ForeignObj( FOptr )
- P_ FOptr;
-{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr,"DEBUG: ForeignObj(%0x)=<%0x,%0x,%0x,%0x>\n", (W_) FOptr, (W_) FOptr[0], (W_) FOptr[1], (W_) FOptr[2], (W_) FOptr[3]);
- fprintf(stderr," Data = %0x, Finaliser = %0x, Next = %0x\n",
- (W_) ForeignObj_CLOSURE_DATA(FOptr),
- (W_) ForeignObj_CLOSURE_FINALISER(FOptr),
- (W_) ForeignObj_CLOSURE_LINK(FOptr) );
- }
-}
-
-void
-Trace_FOdies()
-{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr, " dying\n");
- }
-}
-
-void
-Trace_FOlives()
-{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr," lived to tell the tale\n");
- }
-}
-
-void
-Trace_FOforwarded( FOPtr, newAddress )
- P_ FOPtr, newAddress;
-{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr, " forwarded to %lx\n", (W_) newAddress);
- }
-}
-
-#else
-
-#define TRACE_ForeignObj(FOptr) /* nothing */
-#define TRACE_FOdies(FOptr) /* nothing */
-#define TRACE_FOlives(FOptr) /* nothing */
-#define TRACE_FOforwarded(FOptr, newAddress) /* nothing */
-
-#endif /* DEBUG */
-\end{code}
-
-
-\section[SM-extensions-compacting-code]{Compacting Collector Code}
-
-
-\begin{code}
-#if defined(_INFO_COMPACTING)
-
-/* Sweep up the dead ForeignObjs */
-
-/* Note that this has to happen before the linking phase trashes
- the stable pointer table so that the finaliser functions can
- safely call freeStablePointer.
-*/
-
-void
-sweepUpDeadForeignObjs( ForeignObjList, base, bits )
- P_ ForeignObjList;
- P_ base;
- BitWord *bits;
-{
- P_ FOptr, temp;
- I_ ForeignObj_deaths = 0;
- long _hp_word, bit_index, bit;
-
- /* At this point, the ForeignObjList is in an invalid state (since
- some info ptrs will have been mangled) so we can't validate
- it. ADR */
-
- DEBUG_STRING("Reporting Dead Foreign objects:");
- FOptr = ForeignObjList;
- while ( FOptr != NULL ) {
-
- TRACE_ForeignObj(FOptr);
-
- _hp_word = FOptr - base;
- bit_index = _hp_word / BITS_IN(BitWord);
- bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1));
- if ( !( bits[bit_index] & bit ) ) { /* dead */
-
- TRACE_FOdies( FOptr );
- if (ForeignObj_CLOSURE_FINALISER(FOptr) != NULL) {
- (*(void (*)(StgAddr))(ForeignObj_CLOSURE_FINALISER(FOptr)))((StgAddr)ForeignObj_CLOSURE_DATA(FOptr));
- ForeignObj_deaths++;
- }
-
- temp = FOptr;
- FOptr = ForeignObj_CLOSURE_LINK(FOptr);
- /* Now trash the closure to encourage bugs to show themselves */
- TRASH_ForeignObj_CLOSURE( temp );
-
- } else {
-
- TRACE_FOlives(FOptr);
- FOptr = ForeignObj_CLOSURE_LINK(FOptr);
- }
- }
-}
-
-#endif /* _INFO_COMPACTING */
-\end{code}
-
-\section[SM-extensions-copying-code]{Copying Collector Code}
-
-\begin{code}
-#if defined(_INFO_COPYING)
-
-/* ToDo: a possible optimisation would be to maintain a flag that
- told us whether the SPTable had been updated (with new
- pointers) and so needs to be GC'd. A simple way of doing this
- might be to generalise the MUTUPLE closures to MUGEN closures.
-*/
-void evacSPTable( sm )
-smInfo *sm;
-{
- DEBUG_STRING("Evacuate Stable Pointer Table:");
- {
- P_ evac = sm->StablePointerTable;
- sm->StablePointerTable = EVACUATE_CLOSURE(evac);
- }
-}
-
-
-
-/* First attempt at Foreign Obj hackery... Later versions might
- do something useful with the two counters. [ADR] */
-
-#if defined(DEBUG)
-#if defined(GCgn)
-
-EXTDATA_RO(Forward_Ref_New_info);
-EXTDATA_RO(Forward_Ref_Old_info);
-EXTDATA_RO(OldRoot_Forward_Ref_info);
-
-#else
-
-EXTDATA_RO(Forward_Ref_info);
-
-#endif
-#endif
-
-/*
- Call ForeignObj finalising routine on any dead FOs in oldFOList,
- add the remainder to new sticking the result into newFOList.
-*/
-void
-reportDeadForeignObjs(oldFOList, new, newFOList)
- P_ oldFOList;
- P_ new;
- P_ *newFOList;
-{
- P_ FOptr, temp;
- I_ FO_no = 0, FO_deaths = 0;
-
- /* At this point, the ForeignObjList is in an invalid state (since
- some info ptrs will have been mangled) so we can't validate
- it. ADR */
-
- DEBUG_STRING("Updating Foreign Objects List and reporting casualties:");
- FOptr = oldFOList;
- while ( FOptr != NULL ) {
- TRACE_ForeignObj(FOptr);
-
- if ((P_) INFO_PTR(FOptr) == ForeignObj_info ) {
- /* can't have been forwarded - must be dead */
-
- TRACE_FOdies(FOptr);
- if (ForeignObj_CLOSURE_FINALISER(FOptr) != NULL) {
- (*(void (*)(StgAddr))(ForeignObj_CLOSURE_FINALISER(FOptr)))((StgAddr)ForeignObj_CLOSURE_DATA(FOptr));
- FO_deaths++;
- }
-
- temp = FOptr;
- FOptr = ForeignObj_CLOSURE_LINK(FOptr);
-
- /* Now trash the closure to encourage bugs to show themselves */
- TRASH_ForeignObj_CLOSURE( temp );
- } else { /* Must have been forwarded - so it must be live */
-
- P_ newAddress = (P_) FORWARD_ADDRESS(FOptr);
-
-#if defined(GCgn)
- ASSERT( ( (P_) INFO_PTR(FOptr) == Forward_Ref_New_info ) ||
- ( (P_) INFO_PTR(FOptr) == Forward_Ref_Old_info ) ||
- ( (P_) INFO_PTR(FOptr) == OldRoot_Forward_Ref_info ) );
-#else
- ASSERT( (P_) INFO_PTR(FOptr) == Forward_Ref_info );
-#endif
-
- TRACE_FOforwarded( FOptr, newAddress );
- ForeignObj_CLOSURE_LINK(newAddress) = new;
- new = newAddress;
- FO_no++;
- FOptr = ForeignObj_CLOSURE_LINK(FOptr);
- }
- }
-
- VALIDATE_ForeignObjList( new );
- *newFOList = new;
-}
-#endif /* _INFO_COPYING */
-\end{code}
-
-@freeForeigns@ summarily calls the finaliser routines for
-all live foreign objects, done when closing down.
-(code is just a rip off of the above).
-
-\begin{code}
-#if defined(_INFO_COPYING)
-
-#if defined(DEBUG)
-# if defined(GCgn)
-
-EXTDATA_RO(Forward_Ref_New_info);
-EXTDATA_RO(Forward_Ref_Old_info);
-EXTDATA_RO(OldRoot_Forward_Ref_info);
-
-# else
-
-EXTDATA_RO(Forward_Ref_info);
-
-# endif
-#endif
-
-/*
- Call the ForeignObj finalising routine on all the live FOs,
- used when shutting down.
-*/
-int
-freeForeigns(foList)
- P_ foList;
-{
- P_ FOptr, temp;
- I_ FO_deaths = 0;
-
- /* At this point, exitSM() has been called, the ForeignObjList is in an invalid state (since
- some info ptrs will have been mangled) so we can't validate
- it. ADR */
-
- DEBUG_STRING("Freeing all live Foreign Objects:");
- FOptr = foList;
- while ( FOptr != NULL ) {
-
- /* I'm not convinced that the situation of having
- indirections linked into the FO list can ever occur,
- but chasing indirections doesn't hurt. */
- while(IS_INDIRECTION(INFO_PTR(FOptr))) {
- FOptr = (P_) IND_CLOSURE_PTR(FOptr);
- }
- if ((P_) INFO_PTR(FOptr) == ForeignObj_info ) {
- TRACE_ForeignObj(FOptr);
- TRACE_FOdies(FOptr);
- /* ForeignObjs can have a zapped-out finaliser field, in which
- case we'll just drop the object silently.
- */
- if (ForeignObj_CLOSURE_FINALISER(FOptr) != NULL) {
- (*(void (*)(StgAddr))(ForeignObj_CLOSURE_FINALISER(FOptr)))((StgAddr)ForeignObj_CLOSURE_DATA(FOptr));
- FO_deaths++;
- }
-
- temp = FOptr;
- FOptr = ForeignObj_CLOSURE_LINK(FOptr);
-
- /* Now trash the closure to encourage bugs to show themselves */
- TRASH_ForeignObj_CLOSURE( temp );
- } else {
- fprintf(stderr, "Warning: Foreign object list contained unexpected element, bailing out of FO cleanup.\n");
- return 1;
- }
- }
- return 0;
-}
-#endif /* _INFO_COPYING */
-\end{code}
-
-\upsection
-
-\begin{code}
-#endif /* !PAR */
-\end{code}
+++ /dev/null
-\section[SMextensions-header]{Header file for SMextensions}
-
-\begin{code}
-#ifndef PAR
-
-void initExtensions PROTO((smInfo *sm));
-
-# if defined(_INFO_COPYING)
-
-void evacSPTable PROTO((smInfo *sm));
-void reportDeadForeignObjs PROTO((StgPtr oldMPList, StgPtr new, StgPtr *newMPLust));
-int freeForeigns PROTO((StgPtr foList));
-
-# endif /* _INFO_COPYING */
-
-# if defined(_INFO_COMPACTING)
-
-void sweepUpDeadForeignObjs PROTO((P_ ForeignObjList,
- P_ base,
- BitWord *bits
- ));
-
-# endif /* _INFO_COMPACTING */
-
-void TrashMem PROTO(( P_ from, P_ to ));
-
-# if defined(DEBUG)
-
-void Trash_ForeignObj_Closure PROTO((P_ mptr));
-void Validate_ForeignObj PROTO(( P_ ForeignObjList ));
-
-void Trace_FOdies PROTO((void));
-void Trace_FOlives PROTO((void));
-void Trace_FOforwarded PROTO(( P_ FOPtr, P_ newAddress ));
-
-# endif /* DEBUG */
-
-#endif /* !PAR */
-\end{code}
+++ /dev/null
-***************************************************************************
-
- GENERATIONAL GARBAGE COLLECTION
-
-Global heap requirements as for 1s and 2s collectors.
- ++ All closures in the old generation that are updated must be
- updated with indirections and placed on the linked list of
- updated old generation closures.
-
-
-Promotion collection:
----------------------
-
-Collects allocation area into 2nd semi-space and promotes new semi-space
-by collecting into old generation.
-
-evac < AllocGen ==> Collect to old generation (see _EvacuateP)
-
-Roots: Roots, Astk, Bstk, OldRoots, OldInNew, CAFlist, NewCAFlist
-
-OldRoots: Newly promoted closures may reference new semi-space.
-
- Discard OldInNew roots (promoted).
- This keeps recent new gen roots in new gen.
- Remember OldRoots in alloc (not promoted).
-
- When evacuating to new check if Scav in OldGen, if so
- allocate oldgen root ind and add to OldInNew.
- N.B. This includes evacuating a forward reference.
- Set special forward ref to this OldGen root closure.
- if oldgen evacs return oldgen root else return new gen.
-
-CAFlist: Remember NewCAFlist in OldCAFlist (promoted).
- Remember CAFlist in NewCAFlist (not promoted).
-
-***************************************************************************
-
-\begin{code}
-#if defined(GCgn)
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-
-REGDUMP(ScavRegDump);
-
-genData genInfo = {0, 0, 0, 0,
- 0, 0, /* Alloc */
- 0, {{0, 0}, {0, 0}}, /* New Gen */
- 0, 0, 0, 0, 0, 0, /* Old Gen */
- 0, 0, 0, 0, 0, 0, 0, /* OldRoots & CAfs */
- 0, {{0, 0}, {0, 0}} /* 2s */
- };
-
-P_ heap_space = 0; /* Address of first word of slab
- of memory allocated for heap */
-
-P_ hp_start; /* Value of Hp when reduction was resumed */
- /* Always allocbase - 1 */
-
-rtsBool
-initHeap(smInfo * sm)
-{
- I_ heap_error = 0;
- I_ bit_words;
-
- /* should cause link error */
- ADRpanic("Completely untested on SP and MP stuff... also doesn't benefit from commoning up in SMcopying and SMcompacting");
-
- if (heap_space == 0) { /* allocates if it doesn't already exist */
-
- /* Allocate the roots space */
- sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
-
- /* Allocate the heap */
- heap_space = (P_) stgMallocWords(SM_word_heap_size + EXTRA_HEAP_WORDS,
- "initHeap (heap)");
-
- if (RTSflags.GcFlags.force2s) {
- stat_init("TWOSPACE(GEN)",
- " No of Roots Caf Caf Astk Bstk",
- "Astk Bstk Reg No bytes bytes bytes");
- } else {
- stat_init("GEN",
- "Promote Old No of Roots Caf Mut- Old Old OldGen Collec Resid",
- " bytes roots Astk Bstk Reg No able Alc New bytes tion %heap");
- }
- }
-
- if (RTSflags.GcFlags.force2s) {
- genInfo.semi_space = RTSflags.GcFlags.heapSize / 2;
- genInfo.space[0].base = HEAP_FRAME_BASE(heap_space, genInfo.semi_space);
- genInfo.space[1].base = HEAP_FRAME_BASE(heap_space + genInfo.semi_space, genInfo.semi_space);
- genInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, genInfo.semi_space);
- genInfo.space[1].lim = HEAP_FRAME_LIMIT(heap_space + genInfo.semi_space, genInfo.semi_space);
- genInfo.semi_space = 0;
- genInfo.oldlim = heap_space - 1; /* Never in old generation */
-
- sm->hp = hp_start = genInfo.space[genInfo.semi_space].base - 1;
-
- if (! RTSflags.GcFlags.allocAreaSizeGiven) {
- sm->hplim = genInfo.space[genInfo.semi_space].lim;
- } else {
- sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
-
- RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
-
- if (sm->hplim > genInfo.space[genInfo.semi_space].lim) {
- fprintf(stderr, "Not enough heap for requested alloc size\n");
- return rtsFalse;
- }
- }
-
- sm->OldLim = genInfo.oldlim;
- sm->CAFlist = NULL;
-
-#ifndef PAR
- initExtensions( sm );
-#endif
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "GEN(2s) Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space - 1 + RTSflags.GcFlags.heapSize));
- fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %ld\n",
- genInfo.semi_space,
- (W_) genInfo.space[genInfo.semi_space].base,
- (W_) genInfo.space[genInfo.semi_space].lim,
- (W_) sm->hp, (W_) sm->hplim, (I_) (sm->hplim - sm->hp));
- }
- return rtsTrue;
- }
-
- genInfo.alloc_words = RTSflags.GcFlags.allocAreaSize;
- genInfo.new_words = RTSflags.GcFlags.allocAreaSize;
-
- genInfo.allocbase = heap_space + RTSflags.GcFlags.heapSize - genInfo.alloc_words;
- genInfo.alloclim = heap_space + RTSflags.GcFlags.heapSize - 1;
-
- genInfo.newgen[0].newbase = genInfo.allocbase - genInfo.new_words;
- genInfo.newgen[0].newlim = genInfo.newgen[0].newbase - 1;
-
- genInfo.newgen[1].newbase = genInfo.allocbase - 2 * genInfo.new_words;
- genInfo.newgen[1].newlim = genInfo.newgen[1].newbase - 1;
-
- genInfo.oldbase = heap_space;
-
- if (RTSflags.GcFlags.specifiedOldGenSize) {
- genInfo.old_words = RTSflags.GcFlags.specifiedOldGenSize;
- genInfo.oldend = heap_space + genInfo.old_words - 1;
- genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
- /* ToDo: extra old ind words not accounted for ! */
-
- bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
- /* bit vector in allocation area */
- genInfo.bit_vect = (BitWord *) genInfo.allocbase;
- if (genInfo.oldend >= genInfo.newgen[1].newbase) heap_error = 1;
- } else {
- /* bit area in free area */
- genInfo.bit_vect = (BitWord *) genInfo.oldend + 1;
- if (genInfo.bit_vect + bit_words >= (BitWord *) genInfo.newgen[1].newbase) heap_error = 1;
- }
- } else {
- genInfo.old_words = RTSflags.GcFlags.heapSize - genInfo.alloc_words - 2 * genInfo.new_words;
- genInfo.oldend = heap_space + genInfo.old_words - 1;
- genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
- /* ToDo: extra old ind words not accounted for ! */
-
- bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) {
- /* bit vector in allocation area */
- genInfo.bit_vect = (BitWord *) genInfo.allocbase;
- } else {
- /* bit vector in reserved space in old generation */
- bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
-
- genInfo.bit_vect = (BitWord *) heap_space;
- genInfo.oldbase += bit_words;
- genInfo.old_words -= bit_words;
- }
- if (genInfo.oldbase > genInfo.oldthresh) heap_error = 1;
- }
-
- if (heap_error) {
- fprintf(stderr, "initHeap: Requested heap size: %ld\n", RTSflags.GcFlags.heapSize);
- fprintf(stderr, " Alloc area %ld Delay area %ld Old area %ld Bit area %ld\n",
- genInfo.alloc_words, genInfo.new_words * 2, genInfo.old_words,
- genInfo.bit_vect == (BitWord *) genInfo.allocbase ? 0 : bit_words);
- fprintf(stderr, " Heap not large enough for generational gc with these specs\n");
- fprintf(stderr, " +RTS -H<size> option will increase heap size and/or\n");
- fprintf(stderr, " -A<size> option will decrease allocation area\n");
- return -1;
- }
-
-
- genInfo.oldlim = genInfo.oldbase - 1;
- genInfo.oldwas = genInfo.oldbase - 1;
-
- genInfo.curnew = 0;
- genInfo.OldInNew = 0;
- genInfo.OldInNewno = 0;
- genInfo.NewCAFlist = NULL;
- genInfo.NewCAFno = 0;
- genInfo.OldCAFlist = NULL;
- genInfo.OldCAFno = 0;
-
- genInfo.PromMutables = 0;
-
- sm->hp = hp_start = genInfo.allocbase - 1;
- sm->hplim = genInfo.alloclim;
-
- sm->OldLim = genInfo.oldlim;
- sm->CAFlist = NULL;
-
-#ifndef PAR
- initExtensions( sm );
-#endif
-
- if (RTSflags.GcFlags.trace) {
- fprintf(stderr, "GEN Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space + RTSflags.GcFlags.heapSize - 1));
- fprintf(stderr, " alloc %ld, new %ld, old %ld, bit %ld\n",
- genInfo.alloc_words, genInfo.new_words, genInfo.old_words, bit_words);
- fprintf(stderr, " allocbase 0x%lx, alloclim 0x%lx\n",
- (W_) genInfo.allocbase, (W_) genInfo.alloclim);
- fprintf(stderr, " newbases 0x%lx 0x%lx\n",
- (W_) genInfo.newgen[0].newbase, (W_) genInfo.newgen[1].newbase);
- fprintf(stderr, " oldbase 0x%lx oldthresh 0x%lx bits 0x%lx\n",
- (W_) genInfo.oldbase, (W_) genInfo.oldthresh, (W_) genInfo.bit_vect);
- fprintf(stderr, " hp 0x%lx, hplim 0x%lx\n",
- (W_) sm->hp, (W_) sm->hplim);
- }
-
- return 0;
-}
-
-I_
-collect2s(reqsize, sm)
- W_ reqsize;
- smInfo *sm;
-{
- I_ root, bstk_roots, caf_roots, extra_caf_words;
- PP_ stackptr;
- P_ CAFptr, updateFramePtr, caf_start;
-
- I_ free_space, /* No of words of free space following GC */
- alloc, /* Number of words allocated since last GC */
- resident; /* Number of words remaining after GC */
-
- SAVE_REGS(&ScavRegDump); /* Save registers */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
- genInfo.semi_space,
- (W_) genInfo.space[genInfo.semi_space].base,
- (W_) genInfo.space[genInfo.semi_space].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_)));
-
- alloc = sm->hp - hp_start;
- stat_startGC(alloc);
-
- genInfo.semi_space = NEXT_SEMI_SPACE(genInfo.semi_space);
- ToHp = genInfo.space[genInfo.semi_space].base - 1;
- Scav = genInfo.space[genInfo.semi_space].base;
- OldGen = sm->OldLim; /* always evac ! */
-
- DEBUG_STRING("Setting Evac & Upd CAFs:");
- for (CAFptr = sm->CAFlist; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
- }
-
-#ifdef PAR
- EvacuateLocalGAs(rtsTrue);
-#else
- /* evacSPTable( sm ); stable pointers now reachable via sm->roots */
-#endif /* PAR */
-
- DEBUG_STRING("Evacuate Roots:");
- for (root = 0; root < sm->rootno; root++) {
- P_ evac = sm->roots[root];
- sm->roots[root] = EVACUATE_CLOSURE(evac);
- }
-
-#if defined(GRAN)
- /* ToDo: Add evacuation of events and sparks here */
-#if defined(KLINGON_ERROR_MESSAGES)
- fprintf(stderr,"no' veQ boSwI' yeq {GranSim}\n");
- EXIT(EXIT_FAILURE);
-#else
- fprintf(stderr,"Sorry, GranSim doesn't support generational GC yet\n");
- EXIT(EXIT_FAILURE);
-#endif
-#endif
-
-#if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
-
- DEBUG_STRING("Evacuate A Stack:");
- for (stackptr = MAIN_SpA;
- SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
- /* botA points to bottom-most word */
- stackptr = stackptr + AREL(1)) {
- P_ evac = *stackptr;
- *stackptr = EVACUATE_CLOSURE(evac);
- }
- DEBUG_STRING("Evacuate B Stack:");
- bstk_roots = 0;
- for (updateFramePtr = MAIN_SuB; /* SuB points to topmost update frame */
- SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
- /* botB points to bottom-most word */
- /* re-initialiser given explicitly */) {
-
- P_ evac = GRAB_UPDATEE(updateFramePtr);
- PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
- bstk_roots++;
-
- updateFramePtr = GRAB_SuB(updateFramePtr);
- }
-#endif /* PAR */
-
- DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
- while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
- DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
-
- DEBUG_STRING("Evacuate & Scavenge CAFs:");
- caf_roots = 0;
- caf_start = ToHp;
- for (CAFptr = sm->CAFlist; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
-
- EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
- caf_roots++;
-
- DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
- while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
- DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
-
- /* this_extra_caf_words = ToHp - this_caf_start; */
- /* ToDo: Report individual CAF space */
- }
- extra_caf_words = ToHp - caf_start;
-
-#ifdef PAR
- RebuildGAtables(rtsTrue);
-#else
- reportDeadForeignObjs( sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
-#endif /* PAR */
-
- /* TIDY UP AND RETURN */
-
- sm->hp = hp_start = ToHp; /* Last allocated word */
- sm->hplim = genInfo.space[genInfo.semi_space].lim;
-
- resident = sm->hp - (genInfo.space[genInfo.semi_space].base - 1);
- /* DONT_DO_MAX_RESIDENCY -- because this collector is utterly hosed */
- free_space = sm->hplim - sm->hp;
-
- if (RTSflags.GcFlags.giveStats) {
- char comment_str[BIG_STRING_LEN];
-#ifndef PAR
- sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s",
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
- bstk_roots, sm->rootno,
- caf_roots, extra_caf_words*sizeof(W_),
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
- (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
-#else
- /* ToDo: come up with some interesting statistics for the parallel world */
- sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s",
- 0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
-#endif
- stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
- } else {
- stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
- }
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- genInfo.semi_space,
- (W_) genInfo.space[genInfo.semi_space].base,
- (W_) genInfo.space[genInfo.semi_space].lim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating. */
- TrashMem(sm->hp+1, sm->hplim);
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- if ((RTSflags.GcFlags.allocAreaSize > free_space) || (reqsize > free_space))
- return(-1); /* Heap exhausted */
-
- return(0); /* Heap OK */
-}
-
-
-I_
-collectHeap(reqsize, sm)
- W_ reqsize;
- smInfo *sm;
-{
- PP_ stackptr, botA;
- P_ mutptr, prevmut, updateFramePtr, botB,
- CAFptr, prevCAF, oldroot, oldstartToHp, oldstartOldHp,
- oldscav, newscav;
- I_ root, rootno, bstk_roots, mutable, alloc_cafs, new_cafs,
- alloc_oldroots, new_oldroots, old_words;
-
- I_ bit_words;
- P_ oldlim;
- PP_ CAFlocs, CAFloc;
-
- I_ alloc, /* number of words allocated since last GC */
- collect, /* number of words collected */
- promote, /* number of words promoted */
- resident, /* number of words remaining */
- total_resident; /* total number of words remaining after major collection */
-
- fflush(stdout); /* Flush stdout at start of GC */
-
- if (RTSflags.GcFlags.force2s) {
- return collect2s(reqsize, sm);
- }
-
-
- if (reqsize > genInfo.alloc_words) {
- fprintf(stderr, "collectHeap: Required size %ld greater then allocation area %ld!\n",
- reqsize, genInfo.alloc_words);
- fprintf(stderr, " Rerun using +RTS -A<size> to increase allocation area\n");
- EXIT(EXIT_FAILURE);
- }
-
- SAVE_REGS(&ScavRegDump); /* Save registers */
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "GEN Start: hp 0x%lx, hplim 0x%lx, req %ld Minor\n",
- (W_) sm->hp, (W_) sm->hplim, (I_) (reqsize * sizeof(W_)));
-
- alloc = sm->hp - hp_start;
- stat_startGC(alloc);
-
- /* MINOR COLLECTION WITH PROMOTION */
-
- collect = alloc + (genInfo.newgen[genInfo.curnew].newlim - genInfo.newgen[genInfo.curnew].newbase + 1);
- genInfo.curnew = (genInfo.curnew + 1) % 2;
-
- ToHp = genInfo.newgen[genInfo.curnew].newbase - 1;
- OldGen = genInfo.oldend; /* <= OldGen indicates in the old generation */
-
- AllocGen = genInfo.allocbase; /* < AllocGen indicates in delay bucket -> promote */
- OldHp = genInfo.oldlim;
-
- newscav = genInfo.newgen[genInfo.curnew].newbase; /* Point to (info field of) first closure */
- oldscav = genInfo.oldlim + 1; /* Point to (info field of) first closure */
-
-
- DEBUG_STRING("Setting Evac & Upd CAFs:");
- for (CAFptr = sm->CAFlist; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
- }
- for (CAFptr = genInfo.NewCAFlist; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info;
- }
-
-
- /* FIRST: Evacuate and scavenge OldMutable, Roots, AStk & BStk */
- /* Ensure these roots don't use old generation root indirection when evacuated */
- Scav = newscav;
-
- DEBUG_STRING("Evacuate Roots:");
- for (root = 0, rootno = sm->rootno; root < rootno; root++) {
- P_ evac = sm->roots[root];
- if (evac > OldGen) {
- sm->roots[root] = EVACUATE_CLOSURE(evac);
- }
- }
-
-#if defined(GRAN)
- /* ToDo: Add evacuation of events and sparks here */
-#if defined(KLINGON_ERROR_MESSAGES)
- fprintf(stderr,"no' veQ boSwI' yeq {GranSim}\n");
- EXIT(EXIT_FAILURE);
-#else
- fprintf(stderr,"Sorry, GranSim doesn't support generational GC yet\n");
- EXIT(EXIT_FAILURE);
-#endif
-#endif
-
-#if !defined(PAR)
- DEBUG_STRING("Evacuate A Stack:");
- for (stackptr = MAIN_SpA, botA = stackInfo.botA;
- SUBTRACT_A_STK(stackptr, botA) >= 0;
- stackptr = stackptr + AREL(1)) {
- P_ evac = *stackptr;
- if (evac > OldGen) {
- *stackptr = EVACUATE_CLOSURE(evac);
- }
- }
- DEBUG_STRING("Evacuate B Stack:");
- bstk_roots = 0;
- for (updateFramePtr = MAIN_SuB, botB = stackInfo.botB;
- SUBTRACT_B_STK(updateFramePtr, botB) > 0;
- /* re-initialiser given explicitly */) {
-
- /* Evacuate the thing to be updated */
- P_ evac = GRAB_UPDATEE(updateFramePtr);
- if (evac > OldGen) {
- PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac));
- }
- bstk_roots++;
-
- updateFramePtr = GRAB_SuB(updateFramePtr);
- }
-#endif /* PAR */
-
- DEBUG_STRING("Evacuate Mutable Roots:");
- mutable = 0;
- mutptr = sm->OldMutables;
- prevmut = ((P_)&sm->OldMutables) - FIXED_HS;
- /* See MUT_LINK */
- while ( mutptr ) {
-
- /* Scavenge the OldMutable closure */
- P_ info = (P_) INFO_PTR(mutptr);
- StgScavPtr scav_code = SCAV_CODE(info);
- Scav = mutptr;
- (scav_code)();
-
- /* Remove from OldMutables if no longer mutable */
- /* HACK ALERT: See comment in SMap.lc
- about why we do this terrible pointer comparison.
- */
- if (info == ImMutArrayOfPtrs_info) { /* ToDo: use different test? (WDP 94/11) */
- P_ tmp = mutptr;
- MUT_LINK(prevmut) = MUT_LINK(mutptr);
- mutptr = (P_) MUT_LINK(mutptr);
- MUT_LINK(tmp) = MUT_NOT_LINKED;
- } else {
- prevmut = mutptr;
- mutptr = (P_) MUT_LINK(mutptr);
- }
- mutable++;
- }
-
-#ifdef PAR
- EvacuateLocalGAs(rtsFalse);
-#else
- /* evacSPTable( sm ); stable pointers now reachable via sm->roots
- (see above)
- */
-#endif /* PAR */
-
- while ((newscav <= ToHp) || (oldscav <= OldHp)) {
- Scav = newscav;
- DEBUG_SCAN("Scav: NewScav", Scav, "ToHp", ToHp);
- while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
- newscav = Scav;
-
- Scav = oldscav;
- DEBUG_SCAN("Scav: OldScav", Scav, "OldHp", OldHp);
- while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
- oldscav = Scav;
- }
-
-
- /* SECOND: Evacuate & Scavenge CAFs and OldGen roots */
- /* Ensure these roots don't use old generation root indirection when evacuated */
- Scav = newscav;
-
- oldstartToHp = ToHp;
- oldstartOldHp = OldHp;
-
-
- DEBUG_STRING("Evacuate CAFs and old generation roots:");
- /* Evacuate CAFs in allocation region to New semispace */
- /* Evacuate CAFs in New semispace to OldGen */
- /* OldCAFlist = NewCAFlist ++ OldCAFlist */
- /* NewCAFlist = CAFlist */
- /* CAFlist = NULL */
-
- alloc_cafs = 0;
- for (CAFptr = sm->CAFlist; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- EVACUATE_CLOSURE(CAFptr); /* evac & upd */
- alloc_cafs++;
- }
-
- for (CAFptr = genInfo.NewCAFlist,
- prevCAF = ((P_)(&genInfo.NewCAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */
- CAFptr; CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- EVACUATE_CLOSURE(CAFptr); /* evac & upd */
- prevCAF = CAFptr;
- }
- new_cafs = genInfo.NewCAFno;
-
- IND_CLOSURE_LINK(prevCAF) = (W_) genInfo.OldCAFlist;
- genInfo.OldCAFlist = genInfo.NewCAFlist;
- genInfo.OldCAFno += genInfo.NewCAFno;
-
- genInfo.NewCAFlist = sm->CAFlist;
- genInfo.NewCAFno = alloc_cafs;
- sm->CAFlist = NULL;
-
-
- /* Evacuate OldRoots roots to New semispace */
- /* Evacuate OldInNew roots to OldGen, discard these roots */
- /* OldInNew = OldRoots */
- /* OldRoots = 0 */
-
- for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
- P_ evac = (P_) IND_CLOSURE_PTR(oldroot);
- if (evac > OldGen) {
- IND_CLOSURE_PTR(oldroot) = (W_) EVACUATE_CLOSURE(evac);
- }
- }
- new_oldroots = genInfo.OldInNewno;
-
- DEBUG_STRING("Scavenge evacuated old generation roots:");
- while ((newscav <= ToHp) || (oldscav <= OldHp)) {
- Scav = newscav;
- DEBUG_SCAN("Scav: NewScav", Scav, "ToHp", ToHp);
- while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
- newscav = Scav;
-
- Scav = oldscav;
- DEBUG_SCAN("Scav: OldScav", Scav, "OldHp", OldHp);
- while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))();
- oldscav = Scav;
- }
-
- old_words = OldHp - oldstartOldHp; /* + (ToHp - oldstartToHp) */
-
-
- /* record newly promoted mutuple roots */
- MUT_LINK(prevmut) = (W_) genInfo.PromMutables;
- genInfo.PromMutables = 0;
-
-
- promote = OldHp - genInfo.oldlim;
- resident = (ToHp - genInfo.newgen[genInfo.curnew].newbase + 1) + promote;
-
- genInfo.newgen[genInfo.curnew].newlim = ToHp;
- genInfo.oldlim = OldHp;
-
- genInfo.minor_since_major++;
-
-#ifdef PAR
- RebuildGAtables(rtsFalse);
-#else
- reportDeadForeignObjs(sm->ForeignObjList,
- sm->OldForeignObjList,
- &(sm->OldForeignObjList));
- sm->ForeignObjList = NULL; /* all (new) ForeignObjs have been promoted */
-#endif /* PAR */
-
- if (RTSflags.GcFlags.giveStats) {
- char minor_str[BIG_STRING_LEN];
-#ifndef PAR
- sprintf(minor_str, "%6lu %4lu %4lu %4ld %3ld %3ld %4ld %3ld %3ld %6ld Minor",
- promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots,
- (I_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
- bstk_roots, sm->rootno, alloc_cafs + new_cafs,
- mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
-#else
- /* ToDo: come up with some interesting statistics for the parallel world */
- sprintf(minor_str, "%6lu %4lu %4lu %4ld %3ld %3ld %4ld %3ld %3ld %6ld Minor",
- promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots, 0,
- 0, sm->rootno, alloc_cafs + new_cafs,
- mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_));
-#endif
- stat_endGC(alloc, collect, resident, minor_str);
- } else {
- stat_endGC(alloc, collect, resident, "");
- }
-
- /* ToDo: Decide to do major early ! */
-
- if (genInfo.oldlim <= genInfo.oldthresh && !do_full_collection) {
-
- sm->hp = hp_start = genInfo.allocbase - 1;
- sm->hplim = genInfo.alloclim;
- sm->OldLim = genInfo.oldlim;
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "GEN End: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
- (W_) genInfo.newgen[genInfo.curnew].newbase,
- (W_) genInfo.newgen[genInfo.curnew].newlim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- return GC_SUCCESS; /* Heap OK -- Enough space to continue */
- }
-
-
- DEBUG_STRING("Major Collection Required");
- stat_startGC(0);
-
- alloc = genInfo.oldlim - genInfo.oldbase + 1;
-
- /* Zero bit vector for marking phase of major collection */
-
- bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- { BitWord *ptr = genInfo.bit_vect,
- *end = genInfo.bit_vect + bit_words;
- while (ptr < end) { *(ptr++) = 0; };
- }
-
- /* Set are for old gen CAFs to be linked */
-
- CAFlocs = (PP_) genInfo.newgen[(genInfo.curnew + 1) % 2].newbase;
- if (genInfo.new_words < genInfo.OldCAFno) {
- fprintf(stderr, "colectHeap: Too many CAFs %ld to link in new semi-space %ld\n",
- genInfo.OldCAFno, genInfo.alloc_words);
- fprintf(stderr, " Rerun using +RTS -A<size> to increase allocation area\n");
- EXIT(EXIT_FAILURE);
- }
-
- /* Change old generation root indirections to special OldRoot indirections */
- /* These will be marked and not short circuted (like SPEC 2,1 closure) */
-
- for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) {
- INFO_PTR(oldroot) = (W_) OldRoot_info;
- }
-
- /* Discard OldInNew roots: Scanning OldRoots will reconstruct live OldInNew root list */
- genInfo.OldInNew = 0;
- genInfo.OldInNewno = 0;
-
- /* Discard OldMutable roots: Scanning Mutables will reconstruct live OldMutables root list */
- sm->OldMutables = 0;
-
- /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */
- RESTORE_REGS(&ScavRegDump);
-
- markHeapRoots(sm, genInfo.NewCAFlist, genInfo.OldCAFlist,
- genInfo.oldbase, genInfo.oldlim, genInfo.bit_vect);
-
- SAVE_REGS(&ScavRegDump);
- /* end of bracket */
-
-#ifndef PAR
- sweepUpDeadForeignObjs(sm->OldForeignObjList,
- appelInfo.oldbase,
- appelInfo.bits
- );
-#endif /* !PAR */
-
- oldlim = genInfo.oldlim;
-
- DEBUG_STRING("Linking Dummy CAF Ptr Locations:");
- CAFloc = CAFlocs;
- for (CAFptr = genInfo.OldCAFlist; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- DEBUG_LINK_CAF(CAFptr, CAFloc);
- *CAFloc = (P_) IND_CLOSURE_PTR(CAFptr);
- LINK_LOCATION_TO_CLOSURE(CAFloc, oldlim);
- CAFloc++;
- }
-
- DEBUG_STRING("Linking Roots:");
- for (root = 0; root < sm->rootno; root++) {
- LINK_LOCATION_TO_CLOSURE(sm->roots+root, oldlim);
- }
-
-#ifdef PAR
- fall over here until we figure out how to link GAs
-#else
-/* stable pointer root now included in sm->roots
- DEBUG_STRING("Linking Stable Pointer Table:");
- LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable, oldlim);
-*/
- DEBUG_STRING("Linking A Stack:");
- for (stackptr = MAIN_SpA;
- SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
- stackptr = stackptr + AREL(1)) {
- LINK_LOCATION_TO_CLOSURE(stackptr, oldlim);
- }
- DEBUG_STRING("Linking B Stack:");
- for (updateFramePtr = MAIN_SuB; /* SuB points to topmost update frame */
- SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0;
- /* re-initialiser given explicitly */) {
-
- P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE);
- LINK_LOCATION_TO_CLOSURE(updateClosurePtr, oldlim);
-
- updateFramePtr = GRAB_SuB(updateFramePtr);
- }
-#endif /* PAR */
-
- /* Do Inplace Compaction */
- /* Returns start of next closure, -1 gives last allocated word */
-
- genInfo.oldlim = Inplace_Compaction(genInfo.oldbase,
- genInfo.oldlim,
- genInfo.newgen[genInfo.curnew].newbase,
- genInfo.newgen[genInfo.curnew].newlim,
- genInfo.bit_vect, bit_words) - 1;
-
- resident = (genInfo.oldlim - genInfo.oldbase) + 1;
- total_resident = genInfo.newgen[genInfo.curnew].newlim -
- genInfo.newgen[genInfo.curnew].newbase + 1 + resident;
-
- sm->hp = hp_start = genInfo.allocbase - 1;
- sm->hplim = genInfo.alloclim;
- sm->OldLim = genInfo.oldlim;
-
- genInfo.oldwas = genInfo.oldlim;
- genInfo.minor_since_major = 0;
-
- if (RTSflags.GcFlags.giveStats) {
- char major_str[BIG_STRING_LEN];
-#ifndef PAR
- sprintf(major_str, "%6d %4ld %4u %4ld %3ld %3ld %4d %3d %3d %6.6s *Major* %4.1f%%",
- 0, genInfo.OldInNewno,
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
- bstk_roots, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
- 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
-#else
- sprintf(major_str, "%6d %4ld %4u %4ld %3ld %3ld %4d %3d %3d %6.6s *Major* %4.1f%%",
- 0, genInfo.OldInNewno,
- 0, 0, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
- 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
-#endif
- stat_endGC(0, alloc, resident, major_str);
- } else {
- stat_endGC(0, alloc, resident, "");
- }
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "GEN Major: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
- (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
- (W_) genInfo.newgen[genInfo.curnew].newbase,
- (W_) genInfo.newgen[genInfo.curnew].newlim,
- (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
-
-#ifdef DEBUG
- /* To help flush out bugs, we trash the part of the heap from
- which we're about to start allocating. */
- TrashMem(sm->hp+1, sm->hplim);
-#endif /* DEBUG */
-
- RESTORE_REGS(&ScavRegDump); /* Restore Registers */
-
- if (genInfo.oldlim > genInfo.oldthresh)
- return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */
- else
- return GC_SUCCESS; /* Heap OK */
-}
-
-#endif /* GCgn */
-
-\end{code}
-
+++ /dev/null
-\section[storage-manager-init]{Initialising the storage manager}
-
-To initialise the storage manager, we pass it:
-\begin{itemize}
-\item
-An @argc@/@argv@ combo, which are the command-line arguments that have
-been deemed to belong to the runtime system. The initialisation
-routine can slurp around in there for information of interest to
-it.
-
-\item
-A filehandle to which any storage-manager statistics should be written.
-\end{itemize}
-
-\begin{code}
-#define NULL_REG_MAP
-#include "SMinternal.h"
-\end{code}
-
-\section[storage-manager-exit]{Winding up the storage manager}
-
-\begin{code}
-rtsBool
-exitSM (smInfo *sm_info)
-{
-#ifndef PAR
- int rc;
- /* Upon closing down the storage manager, we free all foreign objects
- (in new *and* old generations)
- */
- rc = freeForeigns(sm_info->ForeignObjList);
-# if defined(GCap) || defined(GCgn)
- rc = freeForeigns(sm_info->OldForeignObjList);
-# endif
-
-#endif
- /* Return code ignored for now */
- stat_exit(sm_info->hp - hp_start);
-
- return rtsTrue; /* I'm happy */
-}
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1992-1994
-%
-\begin{code}
-#ifndef SMinternals_H
-#define SMinternals_H
-\end{code}
-
-This stuff needs to be documented. KH
-
-\begin{code}
-/* In the Storage Manager we use the global register mapping */
-/* We turn off STG-machine register declarations */
-
-#if ! (defined(MAIN_REG_MAP) || defined(NULL_REG_MAP) || defined(MARK_REG_MAP) || defined(SCAN_REG_MAP) || defined(SCAV_REG_MAP))
-**** please set your REG_MAP ****
-#endif
-
-#include "rtsdefs.h"
-
-#ifdef HAVE_SYS_VADVISE_H
-#include <sys/vadvise.h>
-#endif
-
-extern P_ heap_space;
-extern P_ hp_start;
-
-void stat_init PROTO((char *collector, char *c1, char *c2));
-void stat_startGC PROTO((I_ alloc));
-void stat_endGC PROTO((I_ alloc, I_ collect, I_ live, char *comment));
-void stat_exit PROTO((I_ alloc));
-
-extern I_ MaxResidency; /* in words; for stats only */
-extern I_ ResidencySamples; /* for stats only */
-
-#define DO_MAX_RESIDENCY(r) /* saves typing */ \
- do { \
- I_ resid = (r); \
- ResidencySamples++; \
- if (resid > MaxResidency) { \
- MaxResidency = resid; \
- } \
- } while (0)
-
-StgFunPtr _Dummy_entry(STG_NO_ARGS);
-
-#if defined(DEBUG)
-#define DEBUG_SCAN(str, pos, to, topos) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "%s: 0x%lx, %s 0x%lx\n", str, pos, to, topos)
-#define DEBUG_STRING(str) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "%s\n", str)
-#else
-#define DEBUG_SCAN(str, pos, to, topos)
-#define DEBUG_STRING(str)
-#endif
-
-#define NEXT_SEMI_SPACE(space) ((space + 1) % 2)
-
-/************************ Random stuff **********************/
-
-/* This should be really big */
-#define BIG_STRING_LEN 512
-
-/************************** TWO SPACE COPYING (2s) **************************/
-
-#if defined(GC2s)
-
-typedef struct {
- P_ base; /* First word allocatable in semispace */
- P_ lim; /* Last word allocatable in semispace */
-} semispaceData;
-
-extern I_ semispace; /* 0 or 1 -- indexes semispaceInfo */
-extern semispaceData semispaceInfo[2];
-
-#endif /* GC2s */
-
-
-/*********************** SINGLE SPACE COMPACTION (1s) ***********************/
-
-#if defined(GC1s)
-
-typedef struct {
- P_ base; /* First word allocatable in heap */
- P_ lim; /* Last word allocatable in heap */
- BitWord *bits; /* Area for marking bits */
- I_ bit_words; /* Size of marking bit area (in words) */
- I_ heap_words; /* Size of heap area (in words) */
-} compactingData;
-
-extern compactingData compactingInfo;
-
-#endif /* GC1s */
-
-
-/****************************** DUAL MODE (du) ******************************/
-
-#if defined(GCdu)
-
-typedef struct {
- I_ mode;
- StgFloat resid_to_compact;
- StgFloat resid_from_compact;
- struct {
- P_ base; /* First word allocatable in this mode */
- P_ lim; /* Last word allocatable in this mode */
- I_ heap_words; /* Size of area (in words) */
- char *name;
- } modeinfo[3];
- BitWord *bits; /* Area for marking bits */
- I_ bit_words; /* Size of marking bit area (in words) */
-} dualmodeData;
-
-extern dualmodeData dualmodeInfo;
-
-#define DEFAULT_RESID_TO_COMPACT 0.25
-#define DEFAULT_RESID_FROM_COMPACT 0.20
-
-#define TWO_SPACE_BOT 0
-#define TWO_SPACE_TOP 1
-#define COMPACTING 2
-
-#endif /* GCdu */
-
-/*************************** APPELS COLLECTOR (ap) **************************/
-
-#if defined(GCap)
-
-typedef struct {
- P_ oldbase; /* first word allocatable in oldgen */
- P_ oldlim; /* last word allocated in oldgen */
- P_ oldlast; /* oldlim after last major collection */
- P_ oldthresh; /* threshold of oldgen occupancy */
- P_ oldmax; /* maximum allocatable in oldgen before heap deemed full */
-
- I_ newfixed; /* The size of the new generation, if fixed */
- I_ newmin; /* The minimum size of the new generation */
- P_ newbase; /* First word allocatable in newgen top space */
- P_ newlim; /* Last word allocatable in newgen top space */
-
- BitWord *bits; /* Area for marking bits */
-
- P_ OldCAFlist; /* CAFs promoted to old generation */
- I_ OldCAFno; /* No of CAFs promoted to old generation */
- I_ bit_words; /* Size of marking bit area (in words) */
-
- P_ PromMutables; /* List of recently promoted mutable closures */
-
- I_ semi_space; /* -F forced 2s collector */
- struct {
- P_ base; /* First word allocatable in semispace */
- P_ lim; /* Last word allocatable in semispace */
- } space[2];
-
-} appelData;
-
-/* UPDATE INFO - Stored in sm info structure:
- Additional info required when updating to keep track of
- new generation roots residing in the old generation
- (old -> new inter-generation pointers)
-*/
-
-extern appelData appelInfo;
-
-#endif /* GCap */
-
-
-/************************ GENERATIONAL COLLECTOR (gn) ***********************/
-
-#if defined(GCgn)
-
-typedef struct {
- I_ alloc_words; /* Size of allocation space */
- /* May be large enough for bit array */
- I_ new_words; /* Size of new generation semi-space */
- /* Must be large enough for bit array */
- I_ old_words; /* Size of old generation */
-
- I_ minor_since_major;
- /* No of minor collections since last major */
-
- P_ allocbase; /* First word allocatable in oldgen */
- P_ alloclim; /* Last word allocatable in oldgen */
-
- I_ curnew; /* New gen semi-space currently in use */
- struct {
- P_ newbase; /* First word allocatable in newgen semispace */
- P_ newlim; /* Last word allocated in new semi-space */
- } newgen[2];
-
- P_ oldbase; /* First word allocatable in oldgen */
- P_ oldend; /* Last word allocatable in oldgen */
- P_ oldwas; /* Limit of oldgen after last major collection */
- P_ oldlim; /* Last word allocated in oldgen */
- P_ oldthresh; /* Oldgen threshold: less than new_words free */
- BitWord *bit_vect; /* Marking bits -- alloc area or old generation */
-
- P_ OldInNew; /* Old roots pointing to new generation */
- I_ OldInNewno; /* No of Old roots pointing to new generation */
- P_ NewCAFlist; /* CAFs in new generation */
- I_ NewCAFno; /* No of CAFs in new generation */
- P_ OldCAFlist; /* CAFs promoted to old generation */
- I_ OldCAFno; /* No of CAFs promoted to old generation */
-
- P_ PromMutables; /* List of recently promoted mutable closures */
-
- I_ semi_space; /* -F forced 2s collector */
- struct {
- P_ base; /* First word allocatable in semispace */
- P_ lim; /* Last word allocatable in semispace */
- } space[2];
-} genData;
-
-extern genData genInfo;
-
-/* Update INFO - Stored in sm info structure:
- Additional info required when updating to keep track of
- new generation roots residing in the old generation
- (old -> new inter-generation pointers)
-*/
-
-#endif /* GCap */
-
-/****************************** COPYING ******************************/
-
-
-#if defined(_INFO_COPYING)
-
-#define EVAC_CODE(infoptr) ((StgEvacPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET])
-#define SCAV_CODE(infoptr) ((StgScavPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET+1])
-
-void Scavenge(STG_NO_ARGS);
-void _Scavenge_Forward_Ref(STG_NO_ARGS);
-
-/* Note: any change to FORWARD_ADDRESS should be
- reflected in layout of MallocPtrs (includes/SMClosures.lh)
-*/
-
-#define FORWARD_ADDRESS(closure) (*(((P_)(closure)) + FIXED_HS))
-
-#define FORWARDREF_ITBL(infolbl,entry,localness,evac_forward) \
-CAT_DECLARE(infolbl,INTERNAL_KIND,"FORWARD_REF","FORWARD_REF") \
-localness W_ infolbl[] = { \
- (W_) entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(,evac_forward,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-P_ _Evacuate_Old_Forward_Ref PROTO((P_));
-P_ _Evacuate_New_Forward_Ref PROTO((P_));
-P_ _Evacuate_OldRoot_Forward PROTO((P_));
-P_ _Evacuate_Forward_Ref PROTO((P_));
-
-MAYBE_DECLARE_RTBL(,_Evacuate_Old_Forward_Ref,)
-MAYBE_DECLARE_RTBL(,_Evacuate_New_Forward_Ref,)
-MAYBE_DECLARE_RTBL(,_Evacuate_OldRoot_Forward,)
-MAYBE_DECLARE_RTBL(,_Evacuate_Forward_Ref,)
-
-#define FORWARDREF_RTBL(evac_forward) \
- const W_ MK_REP_LBL(,evac_forward,)[] = { \
- INCLUDE_TYPE_INFO(INTERNAL) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(evac_forward,_Scavenge_Forward_Ref)\
- INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \
- }
-
-EXTDATA_RO(Caf_Evac_Upd_info);
-extern StgEvacFun _Evacuate_Caf_Evac_Upd;
-
-#define CAF_EVAC_UPD_ITBL(infolbl,entry,localness) \
-CAT_DECLARE(infolbl,INTERNAL_KIND,"CAF_EVAC_UPD","CAF_EVAC_UPD") \
-localness W_ infolbl[] = { \
- (W_) entry \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(Caf_Evac_Upd,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(Caf_Evac_Upd,,)
-
-#define CAF_EVAC_UPD_RTBL() \
- const W_ MK_REP_LBL(Caf_Evac_Upd,,)[] = { \
- INCLUDE_TYPE_INFO(INTERNAL) \
- INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Caf_Evac_Upd,_Scavenge_Caf) \
- INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \
- }
-
-#define EVACUATE_CLOSURE(closure) \
- (EVAC_CODE(INFO_PTR(closure)))(closure)
-
-#endif /* _INFO_COPYING */
-
-
-/****************************** MARKING ******************************/
-
-#if defined(_INFO_MARKING)
-
-I_ markHeapRoots PROTO((smInfo *sm, P_ cafs1, P_ cafs2,
- P_ base, P_ lim, BitWord *bit_array));
-
-#define PRMARK_CODE(infoptr) \
- (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+1])
-
-/* Applied to unmarked or marking info pointer */
-#define PRRETURN_CODE(infoptr) \
- (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+3])
-
-/* This placed on bottom of PR Marking Stack */
-
-#define DUMMY_PRRETURN_CLOSURE(closure_name, table_name, prreturn_code, dummy_code) \
-const W_ table_name[] = { \
- (W_) dummy_code \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(,prreturn_code,) \
- INCLUDE_PROFILING_INFO(Dummy_PrReturn) \
- }; \
-W_ closure_name = (W_) table_name
-
-EXTFUN(_Dummy_PRReturn_entry);
-EXTFUN(_PRMarking_MarkNextRoot);
-EXTFUN(_PRMarking_MarkNextCAF);
-
-#ifdef CONCURRENT
-EXTFUN(_PRMarking_MarkNextSpark);
-#endif
-
-#if defined(GRAN)
-EXTFUN(_PRMarking_MarkNextEvent);
-EXTFUN(_PRMarking_MarkNextClosureInFetchBuffer);
-#endif
-
-#ifdef PAR
-EXTFUN(_PRMarking_MarkNextGA);
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextGA,)
-#else
-
-EXTFUN(_PRMarking_MarkNextAStack);
-EXTFUN(_PRMarking_MarkNextBStack);
-
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextAStack,)
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextBStack,)
-
-#endif /* PAR */
-
-#ifdef CONCURRENT
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextSpark,)
-#endif
-
-#if defined(GRAN)
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextEvent,)
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextClosureInFetchBuffer,)
-#endif
-
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextRoot,)
-MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextCAF,)
-
-#define DUMMY_PRRETURN_RTBL(prreturn_code,dummy_code) \
- const W_ MK_REP_LBL(,prreturn_code,)[] = { \
- INCLUDE_TYPE_INFO(INTERNAL) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(dummy_code,dummy_code) \
- INCLUDE_COMPACTING_INFO(dummy_code,dummy_code,dummy_code,prreturn_code) \
- }
-
-/* Unused "Code to avoid explicit updating of CAF references" used to live here
- (WDP 94/11)
-*/
-
-#endif /* _INFO_MARKING */
-
-
-/****************************** COMPACTING ******************************/
-
-#if defined(_INFO_COMPACTING)
-
-#ifndef PAR
-P_ Inplace_Compaction PROTO((P_ base, P_ lim,
- P_ scanbase, P_ scablim,
- BitWord *bit_array, I_ bit_array_words,
- StgPtr *MallocPtrList));
-#else
-P_ Inplace_Compaction PROTO((P_ base, P_ lim,
- P_ scanbase, P_ scablim,
- BitWord *bit_array, I_ bit_array_words));
-#endif
-/* Applied to marked info pointers */
-
-#define SCAN_LINK_CODE(infoptr) \
- ((StgScanPtr) ((P_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET])
-#define SCAN_MOVE_CODE(infoptr) \
- ((StgScanPtr) ((P_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+2])
-
-/*
- This fragment tests whether we're in global garbage collection during parallel
- evaluation. If so, then we check the global address of the closure \tr{loc}
- and evacuate it in the IMUs if it's a legal global address.
-*/
-
-#define LINK_GLOBALADDRESS(loc)
-
-#if defined(GCgn)
-
-extern StgScavFun _Scavenge_OldRoot; /* Allocated Old -> New root, just skip */
-extern StgEvacFun _Evacuate_OldRoot; /* Should not occur */
-
-extern StgFunPtr _PRStart_OldRoot(STG_NO_ARGS); /* Marking old root -- Short circut if points to oldgen */
-extern StgScanFun _ScanMove_OldRoot; /* Scanning old root -- Rebuild old root list */
-
-EXTDATA_RO(OldRoot_info);
-
-#define OLDROOT_ITBL(infolbl,ind_code,localness,entry_localness)\
- CAT_DECLARE(infolbl,INTERNAL_KIND,"OLDROOT","OLDROOT") \
- entry_localness(ind_code); \
- localness W_ infolbl[] = { \
- (W_) ind_code \
- ,(W_) INFO_OTHER_TAG \
- ,(W_) MK_REP_REF(OldRoot,,) \
- INCLUDE_PROFILING_INFO(infolbl) \
- }
-
-MAYBE_DECLARE_RTBL(OldRoot,,)
-
-#define OLDROOT_RTBL() \
- const W_ MK_REP_LBL(OldRoot,,)[] = { \
- INCLUDE_TYPE_INFO(SPEC_U) \
- INCLUDE_SIZE_INFO(2,1) /* deeply hardwired size/ptrs */ \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_OldRoot,_Scavenge_OldRoot) \
- SPEC_COMPACTING_INFO(_ScanLink_2_1,_PRStart_OldRoot,_ScanMove_OldRoot,_PRIn_1) \
- }
-
-#define LINK_LOCATION_TO_CLOSURE(loc,linklim) \
- { P_ _temp = (P_) *(loc); \
- DEBUG_LINK_LOCATION(loc, _temp, linklim); \
- if (DYNAMIC_CLOSURE(_temp) && (_temp <= linklim)) { \
- *((P_)(loc)) = (W_) INFO_PTR(_temp); \
- INFO_PTR(_temp) = MARK_LOCATION(loc); \
- }}
-
-#else /* ! GCgn */
-
-#define LINK_LOCATION_TO_CLOSURE(loc) \
- { P_ _temp = (P_) *(loc); \
- DEBUG_LINK_LOCATION(loc, _temp); \
- if (DYNAMIC_CLOSURE(_temp)) { \
- *((P_)(loc)) = (W_) INFO_PTR(_temp); \
- INFO_PTR(_temp) = MARK_LOCATION(loc); \
- }}
-
-#endif /* ! GCgn */
-
-#if defined(DEBUG)
-
-#if defined(GCgn)
-#define DEBUG_LINK_LOCATION(location, closure, linklim) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) { \
- if (DYNAMIC_CLOSURE(closure) && (closure <= linklim)) \
- fprintf(stderr, " Link Loc: 0x%lx to 0x%lx\n", location, closure); \
- else if (! DYNAMIC_CLOSURE(closure)) \
- fprintf(stderr, " Link Loc: 0x%lx to 0x%lx Static Closure -- Not Done\n", location, closure); \
- else \
- fprintf(stderr, " Link Loc: 0x%lx to 0x%lx OutOfRange Closure -- Not Done\n", location, closure); \
- }
-#else /* ! GCgn */
-#define DEBUG_LINK_LOCATION(location, closure) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) { \
- if (DYNAMIC_CLOSURE(closure)) \
- fprintf(stderr, " Link Loc: 0x%lx to 0x%lx\n", location, closure); \
- else \
- fprintf(stderr, " Link Loc: 0x%lx to 0x%lx Static Closure -- Not Done\n", location, closure); \
- }
-#endif /* ! GCgn */
-
-#define DEBUG_UNLINK_LOCATION(location, closure, newlocation) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) \
- fprintf(stderr, " UnLink Loc: 0x%lx, 0x%lx -> 0x%lx\n", location, closure, newlocation)
-
-#define DEBUG_LINK_CAF(caf) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) \
- fprintf(stderr, "Caf: 0x%lx Closure: 0x%lx\n", caf, IND_CLOSURE_PTR(caf))
-
-#define DEBUG_SET_MARK(closure, hp_word) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, " Set Mark Bit: 0x%lx, word %ld, bit_word %ld, bit %d\n", closure, hp_word, hp_word / BITS_IN(BitWord), hp_word & (BITS_IN(BitWord) - 1))
-
-#else
-#if defined(GCgn)
-#define DEBUG_LINK_LOCATION(location, closure, linklim)
-#else
-#define DEBUG_LINK_LOCATION(location, closure)
-#endif
-#define DEBUG_UNLINK_LOCATION(location, closure, newlocation)
-#define DEBUG_LINK_CAF(caf)
-#define DEBUG_SET_MARK(closure, hp_word)
-#endif
-
-#endif /* _INFO_COMPACTING */
-
-#endif /* SMinternals_H */
-
-\end{code}
+++ /dev/null
-%****************************************************************************
-%
-\section[SMmark.lhc]{Pointer-Reversing Mark code}
-%
-% (c) P. Sansom, K. Hammond, OBFUSCATION-THROUGH-GRATUITOUS-PREPROCESSOR-ABUSE
-% Project, Glasgow University, January 26th 1993.
-%
-%****************************************************************************
-
-This module contains the specialised and generic code to perform
-pointer reversal marking. These routines are placed in the info
-tables of the appropriate closures.
-
-Some of the dirt is hidden in macros defined in SMmarkDefs.lh.
-
-%****************************************************************************
-%
-\subsection[mark-overview]{Overview of Marking}
-%
-%****************************************************************************
-
-This module uses a pointer-reversal algorithm to mark a closure.
-To mark a closure, first set a bit indicating that the closure
-has been marked, then mark each pointer in the closure. The mark
-bit is used to determine whether a node has already been
-marked before we mark it. Because we set the bit before marking
-the children of a node, this avoids cycles.
-
-Given a closure containing a number of pointers, $n$, $n > 0$ the mark
-code for that closure can be divided into three parts:
-\begin{enumerate}
-\item
-The mark (or ``start'') code for the closure. Called when an attempt is made
-to mark the closure, it initialises the mark position in the
-closure, then jumps to the mark code for the first pointer.
-\item
-The return (or ``in'') code for the closure. Called when a closure is
-returned to after a child is marked, it increments the mark position
-and jumps to the mark entry for the next pointer
-\item
-The last (or ``in-last'') code for the closure. Called when all children
-have been marked, it just returns to its parent through the appropriate
-return code.
-\end{enumerate}
-
-For non-\tr{SPEC} closures, the return and last codes are merged in most
-cases, so the return code checks explicitly whether all pointers have
-been marked, and returns if so.
-
-%****************************************************************************
-%
-\subsubsection[mark-registers]{Registers used when marking}
-%
-%****************************************************************************
-
-Two registers are used:
-\begin{description}
-\item[Mark]
-Points to the closure being marked.
-\item[MStack]
-Points to the closure on the top of the marking stack.
-The first closure on the stack contains the continuation to
-enter when marking is complete.
-\end{description}
-
-The following registers are used by Pointer Reversal Marking:
-
-\begin{description}
-\item[@MStack@]
-The top of the mark stack.
-\item[@Mark@]
-The node being processed.
-\item[@BitArray@]
-The bit array (what's that? KH) to mark.
-\item[@HeapBase@]
-The base of the heap (to calculate bit to mark).
-\item[@HeapLim@]
-The limit of the heap. For generational garbage collection,
-only closures whose address is $<$ @HeapLim@ will be marked
-\end{description}
-
-To answer KH's question, the @BitArray@ is used to store marks. This
-avoids the need to include space for a mark bit in the closure itself.
-The array consists of one bit per word of heap memory that is handled
-by the compacting collector or the old generation in the generational
-collector. [ADR]
-
-%****************************************************************************
-%
-\subsubsection[mark-conventions]{Calling and Return Conventions}
-%
-%****************************************************************************
-
-When a child closure is returned from, the registers have the following
-values.
-
-\begin{description}
-\item[@Mark@]
-points to the closure just marked (this may be updated with a new
-address to short-circuit indirections).
-\item[MStack]
-points to the closure whose return code has been entered
-(this closure is now at the top of the pointer-reversal marking stack).
-\end{description}
-
-The macros @JUMP_MARK@ and @JUMP_MARK_RETURN@ jump to the start code
-pointed to by the @Mark@ register, or the return code pointed to by
-the @MStack@ register respectively.
-
-
-%%%% GOT THIS FAR -- KH %%%%
-
-Marking A Closure:
- @_PRStart_N@
-
- Retrieved using PRMARK_CODE(infoptr)
-
-Uses pointer reversal marking to mark a closure which contains N ptrs.
-If the closure has 0 pointers it sets it to a marked state and returns
-to the closure on top of the PR mark stack (_PRStart_0).
-
-If Not (@_PRStart_N@ ($N > 0$))
- sets to a state of marking the first pointer
- pushes this closure on the PR marking stack (in the first ptr location)
- marks the first child -- enters its marking code
-
-A closure that is already marked just indicates this by returning to the
-closure on the top of the PR mark stack.
-
- Calling Conventions:
- Mark -- points to the closure to mark
- MStack -- points to the closure on the top of the PR marking stack
- If the stack is empty it points to a closure which contains
- the continuation to enter when marking is complete.
-
- User Invokation:
- Have root to mark
- MStack set to a closure containing the continuation to be called when
- the root has been marked.
- Mark pointing to the closure
-
- Entering MStack Continuation:
- Mark points to new value of the closure (indirection short circut)
- *** Update root being marked with this value.
-
-
-Returning To A Closure Being Marked:
- _PRIn_I
- _PRInLast_N
-
- Retrieved using PRRETURN_CODE(infoptr)
-
-Starts marking the next pointer (_PRIn_I).
- updates the current poointer being marked with new Mark
- sets state to next pointer
- marks the next child
-If not, (_PRInLast_N), it returns to the closure on the top of the PR
-marking stack.
-
- Calling Conventions:
- Mark -- points to the closure just marked (may be updated with new
- address to short indirections)
- MStack -- points to it -- the closure on the top of the PR marking stack
-
-
-
-The following registers are used by Pointer Reversal Marking:
-
-MStack -- The MarkStack register
-Mark -- Points to the Node being processed
-BitArray -- The bit array to mark
-HeapBase -- The base of the heap (to calculate bit to mark)
-HeapLim -- The limit of the heap
- -- For gen gc: only closures < HeapLim will be marked
- -- OldRoots pointing < HeapLim
-
-\input{SMmarkDefs.lh}
-
-%****************************************************************************
-%
-\subsection[mark-code]{The actual Marking Code}
-%
-%****************************************************************************
-
-This code is only used if @_INFO_MARKING@ is defined.
-
-\begin{code}
-#include "SMmarkDefs.h"
-
-#if defined(_INFO_MARKING)
-\end{code}
-
-First the necessary forward declarations.
-
-\begin{code}
-/* #define MARK_REG_MAP -- Must be done on command line for threaded code */
-#include "SMinternal.h"
-
-#if defined(GRAN)
-extern P_ ret_MRoot, ret_Mark;
-#endif
-\end{code}
-
-Define appropriate variables as potential register variables.
-Assume GC code saves and restores any global registers used.
-
-\begin{code}
-RegisterTable MarkRegTable;
-\end{code}
-
-@_startMarkWorld@ restores registers if necessary, then marks the
-root pointed to by @Mark@.
-
-\begin{code}
-STGFUN(_startMarkWorld)
-{
- FUNBEGIN;
-#if defined(__STG_GCC_REGS__) && defined(__GNUC__)
- /* If using registers load from _SAVE (see SMmarking.lc) */
-
- /* I deeply suspect this should be RESTORE_REGS(...) [WDP 95/02] */
-#ifdef REG_MarkBase
- MarkBaseReg = &MarkRegTable;
-#endif
- Mark = SAVE_Mark;
- MRoot = SAVE_MRoot;
- MStack = SAVE_MStack;
- BitArray = SAVE_BitArray;
- HeapBase = SAVE_HeapBase;
- HeapLim = SAVE_HeapLim;
-#endif
-
- JUMP_MARK;
- FUNEND;
-}
-\end{code}
-
-This is the pointer reversal start code for \tr{SPEC} closures with 0
-pointers.
-
-\begin{code}
-STGFUN(_PRStart_0)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else
- INIT_MARK_NODE("SPEC",0);
-
- JUMP_MARK_RETURN;
- FUNEND;
-}
-\end{code}
-
-
-This macro defines the format of the pointer reversal start code for a
-number of pointers \tr{ptrs}, $>$ 0.
-
-\begin{code}
-
-#define SPEC_PRStart_N_CODE(ptrs) \
-STGFUN(CAT2(_PRStart_,ptrs)) \
-{ \
- FUNBEGIN; \
- if (IS_MARK_BIT_SET(Mark)) { \
- DEBUG_PR_MARKED; \
- JUMP_MARK_RETURN; \
- } else { \
- INIT_MARK_NODE("SPEC",ptrs); \
- INIT_MSTACK(SPEC_CLOSURE_PTR); \
- } \
- FUNEND; \
-}
-
-\end{code}
-
-The definitions of the start code for \tr{SPEC} closures with 1-12
-pointers.
-
-\begin{code}
-SPEC_PRStart_N_CODE(1)
-SPEC_PRStart_N_CODE(2)
-SPEC_PRStart_N_CODE(3)
-SPEC_PRStart_N_CODE(4)
-SPEC_PRStart_N_CODE(5)
-SPEC_PRStart_N_CODE(6)
-SPEC_PRStart_N_CODE(7)
-SPEC_PRStart_N_CODE(8)
-SPEC_PRStart_N_CODE(9)
-SPEC_PRStart_N_CODE(10)
-SPEC_PRStart_N_CODE(11)
-SPEC_PRStart_N_CODE(12)
-
-\end{code}
-
-Start code for revertible black holes with underlying @SPEC@ types.
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-#define SPEC_RBH_PRStart_N_CODE(ptrs) \
-STGFUN(CAT2(_PRStart_RBH_,ptrs)) \
-{ \
- FUNBEGIN; \
- if (IS_MARK_BIT_SET(Mark)) { \
- DEBUG_PR_MARKED; \
- JUMP_MARK_RETURN; \
- } else { \
- INIT_MARK_NODE("SRBH",ptrs-1); \
- INIT_MSTACK(SPEC_RBH_CLOSURE_PTR); \
- } \
- FUNEND; \
-}
-
-SPEC_RBH_PRStart_N_CODE(2)
-SPEC_RBH_PRStart_N_CODE(3)
-SPEC_RBH_PRStart_N_CODE(4)
-SPEC_RBH_PRStart_N_CODE(5)
-SPEC_RBH_PRStart_N_CODE(6)
-SPEC_RBH_PRStart_N_CODE(7)
-SPEC_RBH_PRStart_N_CODE(8)
-SPEC_RBH_PRStart_N_CODE(9)
-SPEC_RBH_PRStart_N_CODE(10)
-SPEC_RBH_PRStart_N_CODE(11)
-SPEC_RBH_PRStart_N_CODE(12)
-
-#endif
-
-\end{code}
-
-@SPEC_PRIn_N_CODE@ has two different meanings, depending on the world
-in which we use it:
-\begin{itemize}
-\item
-In the commoned-info-table world, it
-defines the ``in'' code for a particular number
-of pointers, and subsumes the functionality of @SPEC_PRInLast_N_NODE@ below.
-\item
-Otherwise, it defines the ``in'' code for a particular pointer in a
-\tr{SPEC} closure.
-\end{itemize}
-
-\begin{code}
-
-#define SPEC_PRIn_N_CODE(ptrs) \
-STGFUN(CAT2(_PRIn_,ptrs)) \
-{ \
- BitWord mbw; \
- FUNBEGIN; \
- GET_MARKED_PTRS(mbw,MStack,ptrs); \
- if (++mbw < ptrs) { \
- SET_MARKED_PTRS(MStack,ptrs,mbw); \
- CONTINUE_MARKING_NODE("SPEC",mbw); \
- MOVE_TO_NEXT_PTR(SPEC_CLOSURE_PTR,mbw); \
- } else { \
- SET_MARKED_PTRS(MStack,ptrs,0L); \
- POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,ptrs); \
- } \
- FUNEND; \
-}
-
-\end{code}
-
-Now @SPEC_PRIn_N_CODE@ is used to define the individual entries for \tr{SPEC} closures
-with 1-12 pointers.
-
-\begin{code}
-STGFUN(_PRIn_0)
-{
- FUNBEGIN;
- fprintf(stderr,"Called _PRIn_0\nShould never occur!\n");
- abort();
- FUNEND;
-}
-STGFUN(_PRIn_1)
-{
- FUNBEGIN;
- POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,1);
- FUNEND;
-}
-SPEC_PRIn_N_CODE(2)
-SPEC_PRIn_N_CODE(3)
-SPEC_PRIn_N_CODE(4)
-SPEC_PRIn_N_CODE(5)
-SPEC_PRIn_N_CODE(6)
-SPEC_PRIn_N_CODE(7)
-SPEC_PRIn_N_CODE(8)
-SPEC_PRIn_N_CODE(9)
-SPEC_PRIn_N_CODE(10)
-SPEC_PRIn_N_CODE(11)
-SPEC_PRIn_N_CODE(12)
-\end{code}
-
-In code for revertible black holes with underlying @SPEC@ types.
-
-\begin{code}
-#if defined(PAR) || defined(GRAN)
-#define SPEC_RBH_PRIn_N_CODE(ptrs) \
-STGFUN(CAT2(_PRIn_RBH_,ptrs)) \
-{ \
- BitWord mbw; \
- FUNBEGIN; \
- GET_MARKED_PTRS(mbw,MStack,ptrs-1); \
- if (++mbw < ptrs-1) { \
- SET_MARKED_PTRS(MStack,ptrs-1,mbw); \
- CONTINUE_MARKING_NODE("SRBH",mbw); \
- MOVE_TO_NEXT_PTR(SPEC_RBH_CLOSURE_PTR,mbw); \
- } else { \
- SET_MARKED_PTRS(MStack,ptrs-1,0L); \
- POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,ptrs-1); \
- } \
- FUNEND; \
-}
-
-STGFUN(_PRIn_RBH_2)
-{
- FUNBEGIN;
- POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,1);
- FUNEND;
-}
-
-SPEC_RBH_PRIn_N_CODE(3)
-SPEC_RBH_PRIn_N_CODE(4)
-SPEC_RBH_PRIn_N_CODE(5)
-SPEC_RBH_PRIn_N_CODE(6)
-SPEC_RBH_PRIn_N_CODE(7)
-SPEC_RBH_PRIn_N_CODE(8)
-SPEC_RBH_PRIn_N_CODE(9)
-SPEC_RBH_PRIn_N_CODE(10)
-SPEC_RBH_PRIn_N_CODE(11)
-SPEC_RBH_PRIn_N_CODE(12)
-#endif
-
-\end{code}
-
-Foreign Objs are in the non-parallel world only.
-
-\begin{code}
-
-#ifndef PAR
-
-STGFUN(_PRStart_ForeignObj)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else
- INIT_MARK_NODE("ForeignObj ",0);
- JUMP_MARK_RETURN;
- FUNEND;
-}
-#endif /* !PAR */
-\end{code}
-
-This defines the start code for generic (\tr{GEN}) closures.
-
-\begin{code}
-STGFUN(_PRStart_N)
-{
- W_ ptrs;
-
- FUNBEGIN;
-
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- }
- ptrs = GEN_CLOSURE_NoPTRS(Mark);
- INIT_MARK_NODE("GEN ",ptrs);
- if (ptrs == 0) {
- JUMP_MARK_RETURN;
- } else {
- INIT_MSTACK(GEN_CLOSURE_PTR);
- }
- FUNEND;
-}
-\end{code}
-
-Now the ``in'' code for \tr{GEN} closures.
-
-\begin{code}
-STGFUN(_PRIn_I)
-{
- W_ ptrs;
- BitWord pos;
-
- FUNBEGIN;
-
- ptrs = GEN_CLOSURE_NoPTRS(MStack);
- GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
-
- if (++pos < ptrs) {
- SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
- CONTINUE_MARKING_NODE("GEN",pos);
- MOVE_TO_NEXT_PTR(GEN_CLOSURE_PTR,pos);
- } else {
- SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
- POP_MSTACK("GEN ",GEN_CLOSURE_PTR,ptrs);
- }
- FUNEND;
-}
-\end{code}
-
-And the start/in code for a revertible black hole with an underlying @GEN@ closure.
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-
-STGFUN(_PRStart_RBH_N)
-{
- W_ ptrs;
-
- FUNBEGIN;
-
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- }
-
- /*
- * Get pointer count from original closure and adjust for one pointer
- * in the first two words of the RBH.
- */
- ptrs = GEN_RBH_CLOSURE_NoPTRS(Mark);
- if (ptrs < 2)
- ptrs = 1;
- else
- ptrs--;
-
- INIT_MARK_NODE("GRBH", ptrs);
- INIT_MSTACK(GEN_RBH_CLOSURE_PTR);
- FUNEND;
-}
-
-STGFUN(_PRIn_RBH_I)
-{
- W_ ptrs;
- BitWord pos;
-
- FUNBEGIN;
-
- /*
- * Get pointer count from original closure and adjust for one pointer
- * in the first two words of the RBH.
- */
- ptrs = GEN_RBH_CLOSURE_NoPTRS(MStack);
- if (ptrs < 2)
- ptrs = 1;
- else
- ptrs--;
-
- GET_GEN_MARKED_PTRS(pos, MStack, ptrs);
-
- if (++pos < ptrs) {
- SET_GEN_MARKED_PTRS(MStack, ptrs, pos);
- CONTINUE_MARKING_NODE("GRBH", pos);
- MOVE_TO_NEXT_PTR(GEN_RBH_CLOSURE_PTR, pos);
- } else {
- SET_GEN_MARKED_PTRS(MStack, ptrs, 0L);
- POP_MSTACK("GRBH", GEN_RBH_CLOSURE_PTR, ptrs);
- }
- FUNEND;
-}
-
-#endif
-
-\end{code}
-
-Start code for dynamic (\tr{DYN}) closures. There is no \tr{DYN}
-closure with 0 pointers -- \tr{DATA} is used instead.
-
-\begin{code}
-STGFUN(_PRStart_Dyn)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("DYN ", DYN_CLOSURE_NoPTRS(Mark));
- INIT_MSTACK(DYN_CLOSURE_PTR);
- }
- FUNEND;
-}
-\end{code}
-
-and the corresponding ``in'' code.
-
-\begin{code}
-STGFUN(_PRIn_I_Dyn)
-{
- W_ ptrs;
- BitWord pos;
-
- FUNBEGIN;
- ptrs = DYN_CLOSURE_NoPTRS(MStack);
- GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
-
- if (++pos < ptrs) {
- SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
- CONTINUE_MARKING_NODE("DYN",pos);
- MOVE_TO_NEXT_PTR(DYN_CLOSURE_PTR,pos);
- } else {
- SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
- POP_MSTACK("DYN ",DYN_CLOSURE_PTR,ptrs);
- }
- FUNEND;
-}
-\end{code}
-
-
-The start code for \tr{TUPLE} (all-pointer) objects. There can be no
-such object without any pointers, so we don't check for this case.
-
-\begin{code}
-STGFUN(_PRStart_Tuple)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("TUPL", TUPLE_CLOSURE_NoPTRS(Mark));
- INIT_MSTACK(TUPLE_CLOSURE_PTR);
- }
- FUNEND;
-}
-\end{code}
-
-Now the ``in'' case.
-
-\begin{code}
-STGFUN(_PRIn_I_Tuple)
-{
- W_ ptrs;
- BitWord pos;
-
- FUNBEGIN;
- ptrs = TUPLE_CLOSURE_NoPTRS(MStack);
- GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
-
- if (++pos < ptrs) {
- SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
- CONTINUE_MARKING_NODE("TUPL",pos);
- MOVE_TO_NEXT_PTR(TUPLE_CLOSURE_PTR,pos);
- } else {
- SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
- POP_MSTACK("TUPL",TUPLE_CLOSURE_PTR,ptrs);
- }
- FUNEND;
-}
-\end{code}
-
-
-\begin{code}
-/*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
-/* Only if special GC treatment required */
-
-#ifdef GC_MUT_REQUIRED
-
-STGFUN(_PRStart_MuTuple)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("MUT ", MUTUPLE_CLOSURE_NoPTRS(Mark));
- if (MUTUPLE_CLOSURE_NoPTRS(Mark) > 0) {
- INIT_MSTACK(MUTUPLE_CLOSURE_PTR);
- } else {
- JUMP_MARK;
- }
- }
- FUNEND;
-}
-
-STGFUN(_PRIn_I_MuTuple)
-{
- W_ ptrs;
- BitWord pos;
-
- FUNBEGIN;
- ptrs = MUTUPLE_CLOSURE_NoPTRS(MStack);
- GET_GEN_MARKED_PTRS(pos,MStack,ptrs);
-
- if (++pos < ptrs) {
- SET_GEN_MARKED_PTRS(MStack,ptrs,pos);
- CONTINUE_MARKING_NODE("MUT",pos);
- MOVE_TO_NEXT_PTR(MUTUPLE_CLOSURE_PTR,pos);
- } else {
- SET_GEN_MARKED_PTRS(MStack,ptrs,0L);
- POP_MSTACK("MUT ",MUTUPLE_CLOSURE_PTR,ptrs);
- }
- FUNEND;
-}
-
-#endif /* GCap || GCgn */
-\end{code}
-
-There are no pointers in a \tr{DATA} closure, so just mark the
-closure and return.
-
-\begin{code}
-STGFUN(_PRStart_Data)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else
- INIT_MARK_NODE("DATA", 0);
- JUMP_MARK_RETURN;
- FUNEND;
-}
-\end{code}
-
-%****************************************************************************
-%
-\subsubsection[mark-specials]{Special cases}
-%
-%****************************************************************************
-
-Black hole closures simply mark themselves and return.
-
-\begin{code}
-STGFUN(_PRStart_BH)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else
- INIT_MARK_NODE("BH ", 0);
- JUMP_MARK_RETURN;
- FUNEND;
-}
-\end{code}
-
-Marking a Static Closure -- Just return as if Marked
-
-\begin{code}
-STGFUN(_PRStart_Static)
-{
- FUNBEGIN;
- DEBUG_PR_STAT;
- JUMP_MARK_RETURN;
- FUNEND;
-}
-\end{code}
-
-Marking an Indirection -- Set Mark to ind addr and mark this.
-Updating of reference when we return will short indirection.
-
-\begin{code}
-STGFUN(_PRStart_Ind)
-{
- FUNBEGIN;
- DEBUG_PR_IND;
- GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
-
- Mark = (P_) IND_CLOSURE_PTR(Mark);
- JUMP_MARK;
- FUNEND;
-}
-\end{code}
-
-``Permanent indirection''---used in profiling. Works basically
-like @_PRStart_1@ (one pointer).
-\begin{code}
-#if defined(PROFILING) || defined(TICKY_TICKY)
-
-STGFUN(_PRStart_PI)
-{
- FUNBEGIN;
-
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("PI ",1);
- /* the "1" above is dodgy (i.e. wrong), but it is never
- used except in debugging info. ToDo??? WDP 95/07
- */
- INIT_MSTACK(PERM_IND_CLOSURE_PTR);
- }
- FUNEND;
-}
-
-STGFUN(_PRIn_PI)
-{
- FUNBEGIN;
- POP_MSTACK("PI ",PERM_IND_CLOSURE_PTR,1);
- /* the "1" above is dodgy (i.e. wrong), but it is never
- used except in debugging info. ToDo??? WDP 95/07
- */
- FUNEND;
-}
-
-#endif /* PROFILING or TICKY */
-\end{code}
-
-Marking a ``selector closure'': This is a size-2 SPEC thunk that
-selects word $n$; if the thunk's pointee is evaluated, then we short
-out the selection, {\em just like an indirection}. If it is still
-unevaluated, then we behave {\em exactly as for a SPEC-2 thunk}.
-
-{\em Should we select ``on the way down'' (in \tr{_PRStart_Selector})
-or ``on the way back up'' (\tr{_PRIn_Selector})?} Answer: probably on
-the way down. Downside: we are flummoxed by indirections, so we'll
-have to wait until the {\em next} major GC to do the selections (after
-the indirections are shorted out in this GC). But the downside of
-doing selections on the way back up is that we are then in a world of
-reversed pointers, and selecting a reversed pointer---we've see this
-on selectors for very recursive structures---is a total disaster.
-(WDP 94/12)
-
-\begin{code}
-#if defined(DEBUG)
-#define IF_GC_DEBUG(x) x
-#else
-#define IF_GC_DEBUG(x) /*nothing*/
-#endif
-
-#if !defined(CONCURRENT)
-# define NOT_BLACKHOLING (! RTSflags.GcFlags.lazyBlackHoling)
-#else
-# define NOT_BLACKHOLING 0
-#endif
-
-/* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
-
-#define MARK_SELECTOR(n) \
-STGFUN(CAT2(_PRStartSelector_,n)) \
-{ \
- P_ maybe_con; \
- FUNBEGIN; \
- \
- /* must be a SPEC 2 1 closure */ \
- ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2); \
- ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1); \
- ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */ \
- \
- if (IS_MARK_BIT_SET(Mark)) { /* already marked */ \
- DEBUG_PR_MARKED; \
- JUMP_MARK_RETURN; \
- } \
- \
- maybe_con = (P_) *(Mark + _FHS); \
- \
- IF_GC_DEBUG( \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) { \
- fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, info 0x%lx", \
- (n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)), \
- INFO_NoPTRS(INFO_PTR(Mark)), \
- maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/ \
- INFO_PTR(maybe_con)); \
- fprintf(stderr, ", tag %ld, size %ld, ptrs %ld", \
- INFO_TAG(INFO_PTR(maybe_con)), \
- INFO_SIZE(INFO_PTR(maybe_con)), \
- INFO_NoPTRS(INFO_PTR(maybe_con))); \
- if (INFO_TAG(INFO_PTR(maybe_con)) >=0) { \
- fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]); \
- } \
- fprintf(stderr, "\n"); \
- } ) \
- \
- if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\
- || IS_MARK_BIT_SET(maybe_con) /* been here: may be mangled */ \
- || INFO_TAG(INFO_PTR(maybe_con)) < 0 /* not in WHNF */ \
- || NOT_BLACKHOLING /* see "price of laziness" paper */ \
- || (! RTSflags.GcFlags.doSelectorsAtGC )) \
- /* see below for OLD test we used here (WDP 95/04) */ \
- /* ToDo: decide WHNFness another way? */ \
- JMP_(_PRStart_1); \
- \
- /* some things should be true about the pointee */ \
- ASSERT(INFO_TAG(INFO_PTR(maybe_con)) == 0); \
- /* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \
- \
- /* OK, it is evaluated: behave just like an indirection */ \
- GC_SEL_MAJOR(); /* ticky-ticky */ \
- \
- Mark = (P_) (maybe_con[_FHS + (n)]); \
- /* Mark now has the result of the selection */ \
- JUMP_MARK; \
- \
- FUNEND; \
-}
-
-#if 0
-/* OLD test:
- the IS_STATIC test was to protect the IS_MARK_BIT_SET check;
- but the IS_MARK_BIT_SET test was only there to avoid
- mangled pointers, but we cannot have mangled pointers anymore
- (after RTBLs came our way).
- SUMMARY: we toss both of the "guard" tests.
- */
- if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */
- || IS_MARK_BIT_SET(maybe_con) /* been here: may be mangled */
- || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
-#endif /* 0 */
-
-MARK_SELECTOR(0)
-MARK_SELECTOR(1)
-MARK_SELECTOR(2)
-MARK_SELECTOR(3)
-MARK_SELECTOR(4)
-MARK_SELECTOR(5)
-MARK_SELECTOR(6)
-MARK_SELECTOR(7)
-MARK_SELECTOR(8)
-MARK_SELECTOR(9)
-MARK_SELECTOR(10)
-MARK_SELECTOR(11)
-MARK_SELECTOR(12)
-
-#undef IF_GC_DEBUG /* get rid of it */
-\end{code}
-
-Marking a Constant Closure -- Set Mark to corresponding static
-closure. Updating of reference will redirect reference to the static
-closure.
-
-\begin{code}
-STGFUN(_PRStart_Const)
-{
- FUNBEGIN;
- DEBUG_PR_CONST;
-
-#ifndef TICKY_TICKY
- /* normal stuff */
- Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
-
-#else /* TICKY */
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else {
- if (!AllFlags.doUpdEntryCounts) {
-
- GC_COMMON_CONST(); /* ticky */
-
- Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
-
- } else { /* no commoning */
- INIT_MARK_NODE("CONST ",0);
- }
- }
-#endif /* TICKY */
-
- JUMP_MARK_RETURN;
- FUNEND;
-}
-\end{code}
-
-Marking a CharLike Closure -- Set Mark to corresponding static
-closure. Updating of reference will redirect reference to the static
-closure.
-
-\begin{code}
-STGFUN(_PRStart_CharLike)
-{
-#ifdef TICKY_TICKY
- I_ val;
-#endif
-
- FUNBEGIN;
-
- DEBUG_PR_CHARLIKE;
-
-#ifndef TICKY_TICKY
- /* normal stuff */
-
- Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark));
-
-#else /* TICKY */
-
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else {
- val = CHARLIKE_VALUE(Mark);
-
- if (!AllFlags.doUpdEntryCounts) {
- GC_COMMON_CHARLIKE(); /* ticky */
-
- INFO_PTR(Mark) = (W_) Ind_info;
- IND_CLOSURE_PTR(Mark) = (W_) CHARLIKE_CLOSURE(val);
- Mark = (P_) IND_CLOSURE_PTR(Mark);
-
- } else { /* no commoning */
- INIT_MARK_NODE("CHAR ",0);
- }
- }
-#endif /* TICKY */
-
- JUMP_MARK_RETURN;
- FUNEND;
-}
-\end{code}
-
-Marking an IntLike Closure -- Set Mark to corresponding static closure
-if in range. Updating of reference to this will redirect reference to
-the static closure.
-
-\begin{code}
-STGFUN(_PRStart_IntLike)
-{
- I_ val;
-
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else {
- val = INTLIKE_VALUE(Mark);
-
- if (val >= MIN_INTLIKE
- && val <= MAX_INTLIKE
-#ifdef TICKY_TICKY
- && !AllFlags.doUpdEntryCounts
-#endif
- ) {
- DEBUG_PR_INTLIKE_TO_STATIC;
- GC_COMMON_INTLIKE(); /* ticky */
-
- INFO_PTR(Mark) = (W_) Ind_info;
- IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val);
- Mark = (P_) IND_CLOSURE_PTR(Mark);
-
- } else { /* out of range of static closures */
- DEBUG_PR_INTLIKE_IN_HEAP;
-#ifdef TICKY_TICKY
- if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
-#endif
- INIT_MARK_NODE("INT ",0);
- }
- }
- JUMP_MARK_RETURN;
- FUNEND;
-}
-\end{code}
-
-Special error routine, used for closures which should never call their
-``in'' code.
-
-\begin{code}
-STGFUN(_PRIn_Error)
-{
- FUNBEGIN;
- fprintf(stderr,"Called _PRIn_Error\nShould never occur!\n");
- abort();
- FUNEND;
-}
-\end{code}
-
-%****************************************************************************
-%
-\subsubsection[mark-fetchme]{Marking FetchMe Objects (parallel only)}
-%
-%****************************************************************************
-
-\begin{code}
-#ifdef PAR
-\end{code}
-
-FetchMe's present a unique problem during global GC. Since the IMU short-circuits
-indirections during its evacuation, it may return a PLC as the new global address
-for a @FetchMe@ node. This has the effect of turning the @FetchMe@ into an
-indirection during local garbage collection. Of course, we'd like to short-circuit
-this indirection immediately.
-
-\begin{code}
-STGFUN(_PRStart_FetchMe)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- } else
- INIT_MARK_NODE("FME ", 0);
-
- JUMP_MARK_RETURN;
- FUNEND;
-}
-
-STGFUN(_PRStart_BF)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("BF ", BF_CLOSURE_NoPTRS(dummy));
- INIT_MSTACK(BF_CLOSURE_PTR);
- }
- FUNEND;
-}
-
-STGFUN(_PRIn_BF)
-{
- BitWord mbw;
-
- FUNBEGIN;
- GET_MARKED_PTRS(mbw, MStack, BF_CLOSURE_NoPTRS(dummy));
- if (++mbw < BF_CLOSURE_NoPTRS(dummy)) {
- SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), mbw);
- CONTINUE_MARKING_NODE("BF ", mbw);
- MOVE_TO_NEXT_PTR(BF_CLOSURE_PTR, mbw);
- } else {
- SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), 0L);
- POP_MSTACK("BF ", BF_CLOSURE_PTR, BF_CLOSURE_NoPTRS(dummy));
- }
- FUNEND;
-}
-
-#endif /* PAR */
-\end{code}
-
-%****************************************************************************
-%
-\subsubsection[mark-tso]{Marking Thread State Objects (threaded only)}
-%
-%****************************************************************************
-
-First mark the link, then mark all live registers (StkO plus the VanillaRegs
-indicated by Liveness).
-
-CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
-
-\begin{code}
-
-#ifdef CONCURRENT
-
-STGFUN(_PRStart_BQ)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("BQ ", BQ_CLOSURE_NoPTRS(Mark));
- INIT_MSTACK(BQ_CLOSURE_PTR);
- }
- FUNEND;
-}
-
-STGFUN(_PRIn_BQ)
-{
- FUNBEGIN;
- POP_MSTACK("BQ ",BQ_CLOSURE_PTR,1);
- FUNEND;
-}
-
-STGFUN(_PRStart_TSO)
-{
- P_ temp;
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("TSO ", 0);
- temp = TSO_LINK(Mark);
- TSO_LINK(Mark) = MStack;
- MStack = Mark;
- Mark = temp;
- JUMP_MARK;
- }
- FUNEND;
-}
-\end{code}
-
-When we're in the TSO, pos 0 is the link, 1 is the StkO, and 2-10 correspond to
-the vanilla registers r[pos-2].
-
-\begin{code}
-STGFUN(_PRIn_TSO)
-{
- W_ liveness;
- BitWord oldpos, newpos;
- STGRegisterTable *r;
- P_ temp, mstack;
-
- FUNBEGIN;
- GET_MARKED_PTRS(oldpos,MStack,TSO_PTRS);
- r = TSO_INTERNAL_PTR(MStack);
-
- switch(oldpos) {
- case 0:
- /* Just did the link; now do the StkO */
- SET_MARKED_PTRS(MStack,TSO_PTRS,1L);
- temp = r->rStkO;
- r->rStkO = TSO_LINK(MStack);
- TSO_LINK(MStack) = Mark;
- Mark = temp;
- DEBUG_PRIN("TSO ", 1);
- JUMP_MARK;
- break;
- case 1:
- /* Just did the StkO; just update it, saving the old mstack */
- mstack = r->rStkO;
- r->rStkO = Mark;
- break;
- default:
- /* update the register we just did; save the old mstack */
- mstack = r->rR[oldpos - 2].p;
- r->rR[oldpos - 2].p = Mark;
- break;
- }
-
- /* liveness of the remaining registers */
- liveness = r->rLiveness >> (oldpos - 1);
-
- if (liveness == 0) {
- /* Restore MStack and return */
- SET_MARKED_PTRS(MStack,TSO_PTRS,0L);
- DEBUG_PRLAST("TSO ", oldpos);
- Mark = MStack;
- MStack = mstack;
- JUMP_MARK_RETURN;
- }
-
- /* More to do in this TSO */
-
- /* Shift past non-ptr registers */
- for(newpos = oldpos + 1; (liveness & 1) == 0; liveness >>= 1) {
- newpos++;
- }
-
- /* Mark the next one */
- SET_MARKED_PTRS(MStack,TSO_PTRS,newpos);
- Mark = r->rR[newpos - 2].p;
- r->rR[newpos - 2].p = mstack;
- DEBUG_PRIN("TSO ", oldpos);
- JUMP_MARK;
-
- FUNEND;
-}
-
-\end{code}
-
-%****************************************************************************
-%
-\subsubsection[mark-stko]{Marking Stack Objects (threaded only)}
-%
-%****************************************************************************
-
-First mark the A stack, then mark all updatees in the B stack.
-
-\begin{code}
-
-STGFUN(_PRStart_StkO)
-{
- P_ temp;
- I_ size;
- I_ cts_size;
-
- FUNBEGIN;
-
- /* ToDo: ASSERT(sanityChk_StkO(Mark)); ??? */
-
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("STKO", 0);
- size = STKO_CLOSURE_SIZE(Mark);
- cts_size = STKO_CLOSURE_CTS_SIZE(Mark);
- SET_GEN_MARKED_PTRS(Mark,size,(BitWord)(cts_size + 1));
- temp = STKO_LINK(Mark);
- STKO_LINK(Mark) = MStack;
- MStack = Mark;
- Mark = temp;
- JUMP_MARK;
- }
- FUNEND;
-}
-\end{code}
-
-Now the ``in'' code for \tr{STKO} closures. First the A stack is flushed,
-then we chain down the update frames in the B stack, marking the update
-nodes. When all have been marked we pop the stack and return.
-
-\begin{code}
-STGFUN(_PRIn_StkO)
-{
- BitWord oldpos, newpos;
- P_ mstack;
- I_ size;
-
- FUNBEGIN;
-
- size = STKO_CLOSURE_SIZE(MStack);
- GET_GEN_MARKED_PTRS(oldpos, MStack, size);
-
- if (oldpos > STKO_CLOSURE_CTS_SIZE(MStack)) {
- /* Update the link, saving the old mstack */
- mstack = STKO_LINK(MStack);
- STKO_LINK(MStack) = Mark;
- } else {
- /* Update the pointer, saving the old mstack */
- mstack = (P_) STKO_CLOSURE_PTR(MStack, oldpos);
- STKO_CLOSURE_PTR(MStack, oldpos) = (W_) Mark;
- }
-
- /* Calculate the next position to mark */
- if (oldpos > STKO_SpA_OFFSET(MStack)) {
- /* Just walk backwards down the A stack */
- newpos = oldpos - 1;
- SET_GEN_MARKED_PTRS(MStack,size,newpos);
- Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos);
- STKO_CLOSURE_PTR(MStack, newpos) = (W_) mstack;
- DEBUG_PRIN("STKA", oldpos);
- JUMP_MARK;
- } else if (oldpos <= STKO_SuB_OFFSET(MStack)) {
- /* We're looking at an updatee in the B stack; find the next SuB up the chain */
- P_ subptr;
-
- subptr = GRAB_SuB(STKO_CLOSURE_ADDR(MStack, oldpos - BREL(UF_UPDATEE)));
- newpos = STKO_CLOSURE_OFFSET(MStack,subptr);
- } else {
- /* Just fell off the end of the A stack; grab the first SuB */
- newpos = STKO_SuB_OFFSET(MStack);
- }
-
- if (newpos == 0) { /* Grrr... newpos is 1-based */
- /* Restore MStack and return */
- SET_GEN_MARKED_PTRS(MStack,size,0L);
- DEBUG_PRLAST("STKO", oldpos);
- Mark = MStack;
- MStack = mstack;
- JUMP_MARK_RETURN;
- }
-
- /* newpos is actually the SuB; we want the corresponding updatee */
- SET_GEN_MARKED_PTRS(MStack,size,newpos + BREL(UF_UPDATEE));
- Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE));
- STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)) = (W_) mstack;
- DEBUG_PRIN("STKB", oldpos);
- JUMP_MARK;
-
- FUNEND;
-}
-#endif /* CONCURRENT */
-\end{code}
-
-%****************************************************************************
-%
-\subsubsection[mark-caf]{Marking CAFs}
-%
-%****************************************************************************
-
-A CAF is shorted out as if it were an indirection.
-The CAF reference is explicitly updated by the garbage collector.
-
-\begin{code}
-STGFUN(_PRStart_Caf)
-{
- FUNBEGIN;
- DEBUG_PR_CAF;
- GC_SHORT_CAF(); /* ticky */
-
- Mark = (P_) IND_CLOSURE_PTR(Mark);
- JUMP_MARK;
- FUNEND;
-}
-\end{code}
-
-%****************************************************************************
-%
-\subsection[mark-root]{Root Marking Code}
-%
-%****************************************************************************
-
-Used by \tr{SMmarking.lc} -- but needs to be in \tr{.lhc} file.
-
-These are routines placed in closures at the bottom of the marking stack
-
-\begin{code}
-STGFUN(_Dummy_PRReturn_entry)
-{
- FUNBEGIN;
- fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n");
- abort();
- FUNEND;
-}
-
-/* various ways to call _Dummy_PRReturn_entry: */
-
-INTFUN(_PRMarking_MarkNextRoot_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-#ifdef CONCURRENT
-INTFUN(_PRMarking_MarkNextSpark_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-#endif
-#ifdef PAR
-INTFUN(_PRMarking_MarkNextGA_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-#endif
-# if 1 /* !defined(CONCURRENT) */ /* HWL */
-INTFUN(_PRMarking_MarkNextAStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-INTFUN(_PRMarking_MarkNextBStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-# endif
-INTFUN(_PRMarking_MarkNextCAF_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-
-#if defined(GRAN)
-INTFUN(_PRMarking_MarkNextEvent_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-INTFUN(_PRMarking_MarkNextClosureInFetchBuffer_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
-#endif
-
-/* end of various ways to call _Dummy_PRReturn_entry */
-
-EXTFUN(_PRMarking_MarkNextRoot);
-EXTFUN(_PRMarking_MarkNextCAF);
-
-#ifdef CONCURRENT
-EXTFUN(_PRMarking_MarkNextSpark);
-#endif
-
-#ifdef PAR
-EXTFUN(_PRMarking_MarkNextGA);
-#else
-# if 1 /* !defined(CONCURRENT) */ /* HWL */
-EXTFUN(_PRMarking_MarkNextAStack);
-EXTFUN(_PRMarking_MarkNextBStack);
-# endif
-#endif /* not parallel */
-
-CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN")
- /* just one, shared */
-
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure,
- _PRMarking_MarkNextRoot_info,
- _PRMarking_MarkNextRoot,
- _PRMarking_MarkNextRoot_entry);
-
-#ifdef CONCURRENT
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure,
- _PRMarking_MarkNextSpark_info,
- _PRMarking_MarkNextSpark,
- _PRMarking_MarkNextSpark_entry);
-#endif
-
-#if defined(GRAN)
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextEvent_closure,
- _PRMarking_MarkNextEvent_info,
- _PRMarking_MarkNextEvent,
- _PRMarking_MarkNextEvent_entry);
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextClosureInFetchBuffer_closure,
- _PRMarking_MarkNextClosureInFetchBuffer_info,
- _PRMarking_MarkNextClosureInFetchBuffer,
- _PRMarking_MarkNextClosureInFetchBuffer_entry);
-#endif
-
-#ifdef PAR
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
- _PRMarking_MarkNextGA_info,
- _PRMarking_MarkNextGA,
- _PRMarking_MarkNextGA_entry);
-#else
-# if 1 /* !defined(CONCURRENT) */ /* HWL */
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
- _PRMarking_MarkNextAStack_info,
- _PRMarking_MarkNextAStack,
- _PRMarking_MarkNextAStack_entry);
-
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure,
- _PRMarking_MarkNextBStack_info,
- _PRMarking_MarkNextBStack,
- _PRMarking_MarkNextBStack_entry);
-# endif
-#endif /* PAR */
-
-DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
- _PRMarking_MarkNextCAF_info,
- _PRMarking_MarkNextCAF,
- _PRMarking_MarkNextCAF_entry);
-
-extern P_ sm_roots_end; /* &roots[rootno] -- one beyond the end */
-
-STGFUN(_PRMarking_MarkNextRoot)
-{
- FUNBEGIN;
- /* Update root -- may have short circuited Ind */
- *MRoot = (W_) Mark;
-
- /* Is the next off the end */
- if (++MRoot >= sm_roots_end)
- RESUME_(miniInterpretEnd);
-
- Mark = (P_) *MRoot;
- JUMP_MARK;
- FUNEND;
-}
-
-#if defined(CONCURRENT)
-# if !defined(GRAN)
-extern P_ sm_roots_end; /* PendingSparksTl[pool] */
-
-STGFUN(_PRMarking_MarkNextSpark)
-{
- FUNBEGIN;
- /* Update root -- may have short circuited Ind */
- *MRoot = (W_) Mark;
-
- /* Is the next off the end */
- if (++MRoot >= sm_roots_end)
- RESUME_(miniInterpretEnd);
-
- Mark = (P_) *MRoot;
- JUMP_MARK;
- FUNEND;
-}
-#else /* GRAN */
-STGFUN(_PRMarking_MarkNextSpark)
-{
- /* This is more similar to MarkNextGA than to the MarkNextSpark in
- concurrent-but-not-gran land
- NB: MRoot is a spark (with an embedded pointer to a closure) */
- FUNBEGIN;
- /* Update root -- may have short circuited Ind */
- SPARK_NODE( ((sparkq) MRoot) ) = Mark;
- MRoot = (P_) SPARK_NEXT( ((sparkq) MRoot) );
-
- /* Is the next off the end */
- if (MRoot == NULL)
- RESUME_(miniInterpretEnd);
-
- Mark = (P_) SPARK_NODE( ((sparkq) MRoot) );
- JUMP_MARK;
- FUNEND;
-}
-#endif /* GRAN */
-#endif /* CONCURRENT */
-\end{code}
-
-Note: Events are GranSim-only.
-Marking events is similar to marking GALA entries in parallel-land.
-The major difference is that depending on the type of the event we have
-to mark different field of the event (possibly several fields).
-Even worse, in the case of bulk fetching
-(@RTSflags.GranFlags.DoGUMMFetching@) we find a buffer of pointers to
-closures we have to mark (similar to sparks in concurrent-but-not-gransim
-setup).
-
-\begin{code}
-#if defined(GRAN)
-STGFUN(_PRMarking_MarkNextEvent)
-{
- rtsBool found = rtsFalse;
-
- FUNBEGIN;
-
- /* First update the right component of the old event */
- switch (EVENT_TYPE( ((eventq) MRoot) )) {
- case CONTINUETHREAD:
- case STARTTHREAD:
- case RESUMETHREAD:
- case MOVETHREAD:
- EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
- break;
- case MOVESPARK:
- SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) )) = (P_) Mark;
- break;
- case FETCHNODE:
- switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
- case 0:
- EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
- EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
- Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
- JUMP_MARK;
- break;
- case 1:
- EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0; /* reset flag */
- break;
- default:
- fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
- ((eventq) MRoot) );
- EXIT(EXIT_FAILURE);
- }
- break;
- case FETCHREPLY:
- switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
- case 0:
- EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
- EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
- /* In the case of packet fetching, EVENT_NODE(event) points to */
- /* the packet (currently, malloced). The packet is just a list of */
- /* closure addresses, with the length of the list at index 1 (the */
- /* structure of the packet is defined in Pack.lc). */
- if ( RTSflags.GranFlags.DoGUMMFetching ) {
- P_ buffer = (P_) EVENT_NODE( ((eventq) MRoot) );
- int size = (int) buffer[PACK_SIZE_LOCN];
-
- /* was: for (i = PACK_HDR_SIZE; i <= size-1; i++) ... */
- sm_roots_end = buffer + PACK_HDR_SIZE + size;
- MRoot = (P_) buffer + PACK_HDR_SIZE;
- ret_MRoot = MRoot;
- Mark = (P_) *MRoot;
- ret_Mark = Mark;
- MStack = (P_) _PRMarking_MarkNextClosureInFetchBuffer_closure;
- JUMP_MARK;
- } else {
- Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
- JUMP_MARK;
- }
- break;
- case 1:
- if ( RTSflags.GranFlags.DoGUMMFetching ) {
- /* no update necessary; fetch buffers are malloced */
- } else {
- EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
- }
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0; /* reset flag */
- break;
- default:
- fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHREPLY event @ %#x\n",
- ((eventq) MRoot) );
- EXIT(EXIT_FAILURE);
- }
- break;
-
- case GLOBALBLOCK:
- switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
- case 0:
- EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
- EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
- Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
- JUMP_MARK;
- break;
- break;
- case 1:
- EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0; /* reset flag */
- break;
- default:
- fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of GLOBALBLOCK event @ %#x\n",
- ((eventq) MRoot) );
- EXIT(EXIT_FAILURE);
- }
- break;
- case UNBLOCKTHREAD:
- EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
- break;
- case FINDWORK:
- break;
- default:
- fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
- ((eventq) MRoot) );
- EXIT(EXIT_FAILURE);
- }
-
- do {
- MRoot = (P_) EVENT_NEXT( ((eventq) MRoot) );
- /* Is the next off the end */
- if (MRoot == NULL)
- RESUME_(miniInterpretEnd);
-
- switch (EVENT_TYPE( ((eventq) MRoot) )) {
- case CONTINUETHREAD:
- case STARTTHREAD:
- case RESUMETHREAD:
- case MOVETHREAD:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- found = rtsTrue;
- break;
- case MOVESPARK:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) ));
- found = rtsTrue;
- break;
- case FETCHNODE:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- found = rtsTrue;
- break;
- case FETCHREPLY:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- found = rtsTrue;
- break;
- case GLOBALBLOCK:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- found = rtsTrue;
- break;
- case UNBLOCKTHREAD:
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- found = rtsTrue;
- break;
- case FINDWORK:
- found = rtsFalse;
- break;
- default:
- fprintf(stderr,"Unknown event type %d (event @ %#x) in SMmarking_NextEvent\n",
- EVENT_TYPE( ((eventq) MRoot) ), MRoot);
- EXIT(EXIT_FAILURE);
- }
- } while (!found && MRoot!=NULL);
-
- JUMP_MARK;
-
- FUNEND;
-}
-
-STGFUN(_PRMarking_MarkNextClosureInFetchBuffer)
-{
- FUNBEGIN;
- /* Update root -- may have short circuited Ind */
- *MRoot = Mark;
-
- /* Is the next off the end */
- if (++MRoot >= sm_roots_end) {
- /* We know that marking a fetch buffer is only called from within
- marking a FETCHREPLY event; we have saved the important
- registers before that */
- MRoot = ret_MRoot;
- Mark = ret_Mark;
- MStack = (P_) _PRMarking_MarkNextEvent_closure;
- JUMP_MARK;
- }
-
- Mark = *MRoot;
- JUMP_MARK;
- FUNEND;
-}
-#endif
-
-#ifdef PAR
-STGFUN(_PRMarking_MarkNextGA)
-{
- FUNBEGIN;
- /* Update root -- may have short circuited Ind */
- ((GALA *)MRoot)->la = Mark;
-
- do {
- MRoot = (P_) ((GALA *) MRoot)->next;
- } while (MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT);
-
- /* Is the next off the end */
- if (MRoot == NULL)
- RESUME_(miniInterpretEnd);
-
- Mark = ((GALA *)MRoot)->la;
- JUMP_MARK;
- FUNEND;
-}
-
-#else
-STGFUN(_PRMarking_MarkNextAStack)
-{
- FUNBEGIN;
- /* Update root -- may have short circuited Ind */
- *MRoot = (W_) Mark;
-
- /* Is the next off the end */
- if (SUBTRACT_A_STK( (PP_) ++MRoot, stackInfo.botA) < 0)
- RESUME_(miniInterpretEnd);
-
- Mark = (P_) *MRoot;
- JUMP_MARK;
- FUNEND;
-}
-
-
-STGFUN(_PRMarking_MarkNextBStack)
-{
- FUNBEGIN;
- /* Update root -- may have short circuited Ind */
- PUSH_UPDATEE(MRoot, Mark);
-
- MRoot = GRAB_SuB(MRoot);
-
- /* Is the next off the end */
- if (SUBTRACT_B_STK(MRoot, stackInfo.botB) < 0)
- RESUME_(miniInterpretEnd);
-
- Mark = GRAB_UPDATEE(MRoot);
- JUMP_MARK;
- FUNEND;
-}
-#endif /* PAR */
-\end{code}
-
-Mark the next CAF in the CAF list.
-
-\begin{code}
-STGFUN(_PRMarking_MarkNextCAF)
-{
- FUNBEGIN;
-
- /* Update root -- may have short circuited Ind */
- IND_CLOSURE_PTR(MRoot) = (W_) Mark;
-
- MRoot = (P_) IND_CLOSURE_LINK(MRoot);
-
- /* Is the next CAF the end of the list */
- if (MRoot == 0)
- RESUME_(miniInterpretEnd);
-
- GC_SHORT_CAF(); /* ticky (ToDo: wrong?) */
-
- Mark = (P_) IND_CLOSURE_PTR(MRoot);
- JUMP_MARK;
- FUNEND;
-}
-\end{code}
-
-Multi-slurp protection.
-
-\begin{code}
-#endif /* _INFO_MARKING */
-\end{code}
+++ /dev/null
-%****************************************************************************
-%
-\section[SMmarkDefs.lh]{Definitions used by Pointer-Reversing Mark code}
-%
-% (c) P. Sansom, K. Hammond, Glasgow University, January 26th 1993.
-%
-%****************************************************************************
-
-Describe how to set the mark bit for a closure.
-
-\begin{code}
-#ifndef SMMARKDEFS_H
-#define SMMARKDEFS_H
-
-#if defined(GCgn)
-
-#define SET_MARK_BIT(closure) \
- do { \
- if (closure <= HeapLim) /* tested heap range for GCgn */ \
- { \
- long _hp_word = ((P_)closure) - HeapBase; \
- ASSERT(!IS_STATIC(INFO_PTR(closure))); \
- DEBUG_SET_MARK(closure, _hp_word); \
- BitArray[_hp_word / BITS_IN(BitWord)] |= \
- 1L << (_hp_word & (BITS_IN(BitWord) - 1)); \
- } \
- } while(0)
-
-#define CLEAR_MARK_BIT(closure) \
- do { \
- long _hp_word = ((P_)closure) - HeapBase; \
- ASSERT(!IS_STATIC(INFO_PTR(closure))); \
- BitArray[_hp_word / BITS_IN(BitWord)] &= \
- ~(1L << (_hp_word & (BITS_IN(BitWord) - 1))); \
- } while (0)
-
-#else
-
-#define SET_MARK_BIT(closure) \
- do { \
- long _hp_word = ((P_)closure) - HeapBase; \
- ASSERT(!IS_STATIC(INFO_PTR(closure))); \
- DEBUG_SET_MARK(closure, _hp_word); \
- BitArray[_hp_word / BITS_IN(BitWord)] |= \
- 1L << (_hp_word & (BITS_IN(BitWord) - 1)); \
- } while (0)
-
-#define CLEAR_MARK_BIT(closure) \
- do { \
- long _hp_word = ((P_)closure) - HeapBase; \
- ASSERT(!IS_STATIC(INFO_PTR(closure))); \
- BitArray[_hp_word / BITS_IN(BitWord)] &= \
- ~(1L << (_hp_word & (BITS_IN(BitWord) - 1))); \
- } while (0)
-
-\end{code}
-
-Macros from hell for frobbing bits in the bit array while marking. We
-maintain a counter after the mark bit that tells us which pointers
-we've visited in a closure. The bits in this counter may span word
-boundaries, and require some considerable ickiness to get munged into
-one word so Mr C Programmer can use them.
-
-Three variants follow. The first is for closures which contain fewer
-pointers than there are bits in a word.
-
-\begin{code}
-
-#define GM_MASK(x) ((1L << (x)) - 1)
-
-#define GET_MARKED_PTRS(dest,closure,ptrs) \
- do { \
- long hw = ((P_)(closure)) - HeapBase + 1; \
- BitWord *bw = BitArray + (hw / BITS_IN(BitWord)); \
- int offset = hw & (BITS_IN(BitWord) - 1); \
- int bat = BITS_IN(BitWord) - offset; \
- \
- ASSERT(!IS_STATIC(INFO_PTR(closure))); \
- \
- (dest) = (ptrs) <= bat ? \
- bw[0] >> offset & GM_MASK(ptrs) : \
- bw[0] >> offset | \
- (bw[1] & GM_MASK((ptrs) - bat)) << bat; \
- } while (0)
-
-/* hw is the offset in words of closure from HeapBase + 1.
-
- bw points to the BitArray word containing the bit corresponding
- to the *second* word of the closure [hence +1 above]
- (the bit corresp first word is the mark bit)
-
- offset is the offset (in bits, from LS end, zero indexed) within *bw
- of the first bit of value in *bw,
-
- bat is offset from the other end of the word; that's the same
- as the number of bits available to store value in *bw.
-
-
-NOTA BENE: this code is awfully conservative. In order to store a
-value which ranges 0--ptrs we use a field of ptrs bits wide. We
-only need a field of log(ptrs) wide!
-
-*/
-
-/* "ptrs" is actually used as the width of the bit-field
- in which we store "val". */
-
-#define SET_MARKED_PTRS(closure,ptrs,val) \
- do { \
- long hw = ((P_)(closure)) - HeapBase + 1; \
- BitWord *bw = BitArray + (hw / BITS_IN(BitWord)); \
- int offset = hw & (BITS_IN(BitWord) - 1); \
- int bat = BITS_IN(BitWord) - offset; \
- BitWord bits; \
- \
- ASSERT( (ptrs) < BITS_IN(BitWord) ); \
- ASSERT(!IS_STATIC(INFO_PTR(closure))); \
- \
- bits = bw[0] & ~(GM_MASK(ptrs) << offset); \
- bw[0] = bits | (val) << offset; \
- if ((ptrs) > bat) { \
- bits = bw[1] & ~GM_MASK((ptrs) - bat); \
- bw[1] = bits | ((val) >> bat); \
- } \
- } while (0)
-/* NB Since ptrs < BITS_IN(BitWord)
- we can be sure that the conditional will only happen if bat is strictly
- *smaller* than BITS_IN(BitWord), and hence the right shift in the
- last line is ok */
-
-/*
- * These are for the GEN family, which may blow up the GM_MASK macro.
- */
-
- /* If there are more ptrs than bits in a word, we still
- use just one word to store the value; value is bound to
- be < 2**(bits-in-word - 1) */
-
-#define __MIN__(a,b) (((a) < (b)) ? (a) : (b))
-
-#define GET_GEN_MARKED_PTRS(dest,closure,ptrs) \
- GET_MARKED_PTRS(dest,closure,__MIN__(ptrs,BITS_IN(BitWord)-1))
-
-#define SET_GEN_MARKED_PTRS(closure,ptrs,val) \
- SET_MARKED_PTRS(closure,__MIN__(ptrs,BITS_IN(BitWord)-1),val)
-
-/* Be very careful to use the following macro only for dynamic closures! */
-
-#define IS_MARK_BIT_SET(closure) \
- ((BitArray[(((P_)closure) - HeapBase) / BITS_IN(BitWord)] >> \
- ((((P_)closure) - HeapBase) & (BITS_IN(BitWord) - 1))) & 0x1)
-
-#endif
-\end{code}
-
-Don't set the mark bit when changing to marking in the next pointer.
-
-\begin{code}
-#define INIT_MARK_NODE(dbg,ptrs) \
- do { \
- DEBUG_PRSTART(dbg, ptrs); \
- LINK_GLOBALADDRESS(Mark); \
- SET_MARK_BIT(Mark); \
- } while (0)
-
-#define CONTINUE_MARKING_NODE(dbg,pos) \
- do { \
- DEBUG_PRIN(dbg, pos); \
- } while (0)
-\end{code}
-
-@JUMP_MARK@ and @JUMP_MARK_RETURN@ define how to jump to the marking
-entry code for a child closure (\tr{Mark}), or to the return code for
-its parent (\tr{MStack}), when marking's been completed.
-
-\begin{code}
-#define JUMP_MARK \
- JMP_(PRMARK_CODE(INFO_PTR(Mark)))
-
-#define JUMP_MARK_RETURN \
- JMP_(PRRETURN_CODE(INFO_PTR(MStack)))
-\end{code}
-
-Initialise the marking stack to mark from the first pointer in the
-closure (as specified by \tr{first_ptr}). The type of the closure is
-given by \tr{closure_ptr}.
-
-\begin{code}
-#define INIT_MSTACK_FROM(closure_ptr,first_ptr) \
- do { \
- P_ temp = (P_) closure_ptr(Mark, first_ptr); \
- closure_ptr(Mark, first_ptr) = (W_) MStack; \
-/*fprintf(stderr,"first_ptr=%d;temp=%lx;Mark=%lx;MStack=%lx\n",first_ptr,temp,Mark,MStack);*/ \
- MStack = Mark; \
- Mark = temp; \
- JUMP_MARK; \
- } while (0)
-\end{code}
-
-Initialise the marking stack to mark from the first pointer in
-the closure. The type of the closure is given by \tr{closure_ptr}.
-
-\begin{code}
-#define INIT_MSTACK(closure_ptr) \
- INIT_MSTACK_FROM(closure_ptr,1)
-\end{code}
-
-Move to the next pointer after \tr{pos} in the closure whose
-type is given by \tr{closure_ptr}.
-
-\begin{code}
-#define MOVE_TO_NEXT_PTR(closure_ptr,pos) \
- do { \
- P_ temp = (P_) closure_ptr(MStack, pos+1); \
- closure_ptr(MStack, pos+1) = closure_ptr(MStack, pos); \
- closure_ptr(MStack, pos) = (W_) Mark; \
- Mark = temp; \
- JUMP_MARK; \
- } while(0)
-\end{code}
-
-Pop the mark stack at \tr{pos}, having flushed all pointers in
-a closure.
-
-\begin{code}
-#define POP_MSTACK(dbg,closure_ptr,pos) \
- do { \
- RESTORE_MSTACK(dbg,closure_ptr,pos); \
- JUMP_MARK_RETURN; \
- } while (0)
-
-#define RESTORE_MSTACK(dbg,closure_ptr,pos) \
- do { \
- P_ temp = Mark; \
- DEBUG_PRLAST(dbg, pos); \
- Mark = MStack; \
- MStack = (P_) closure_ptr(Mark, pos); \
- closure_ptr(Mark, pos) = (W_) temp; \
- } while (0)
-\end{code}
-
-Define some debugging macros.
-
-\begin{code}
-#if defined(DEBUG)
-
-#define DEBUG_PRSTART(type, ptrsvar) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark Start (%s): 0x%lx, info 0x%lx ptrs %ld\n", \
- type, Mark, INFO_PTR(Mark), ptrsvar)
-
-#define DEBUG_PRIN(type, posvar) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRRet In (%s): 0x%lx, info 0x%lx pos %ld\n", \
- type, MStack, INFO_PTR(MStack), posvar)
-
-#define DEBUG_PRLAST(type, ptrvar) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRRet Last (%s): 0x%lx, info 0x%lx ptrs %ld\n", \
- type, MStack, INFO_PTR(MStack), ptrvar)
-
-#define DEBUG_PR_MARKED \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark Marked : 0x%lx, info 0x%lx\n", \
- Mark, INFO_PTR(Mark))
-
-#define DEBUG_PR_STAT \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark Static : 0x%lx, info 0x%lx\n", \
- Mark, INFO_PTR(Mark))
-
-#define DEBUG_PR_IND \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
- Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
-
-#define DEBUG_PR_CAF \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark Caf : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
- Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
-
-#define DEBUG_PR_CONST \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark Const : 0x%lx -> 0x%lx, info 0x%lx\n", \
- Mark, CONST_STATIC_CLOSURE(INFO_PTR(Mark)), INFO_PTR(Mark))
-
-#define DEBUG_PR_CHARLIKE \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark CharLike (%lx) : 0x%lx -> 0x%lx, info 0x%lx\n", \
- CHARLIKE_VALUE(Mark), Mark, CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark)), INFO_PTR(Mark))
-
-#define DEBUG_PR_INTLIKE_TO_STATIC \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark IntLike to Static (%ld) : 0x%lx -> 0x%lx, info 0x%lx\n", \
- INTLIKE_VALUE(Mark), Mark, INTLIKE_CLOSURE(INTLIKE_VALUE(Mark)), INFO_PTR(Mark))
-
-#define DEBUG_PR_INTLIKE_IN_HEAP \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark IntLike in Heap (%ld) : 0x%lx, info 0x%lx\n", \
- INTLIKE_VALUE(Mark), Mark, INFO_PTR(Mark))
-
-#define DEBUG_PR_OLDIND \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
- fprintf(stderr, "PRMark OldRoot Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
- Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
-
-#else
-
-#define DEBUG_PRSTART(type, ptrvar)
-#define DEBUG_PRIN(type, posvar)
-#define DEBUG_PRLAST(type, ptrvar)
-#define DEBUG_PR_MARKED
-#define DEBUG_PR_STAT
-#define DEBUG_PR_IND
-#define DEBUG_PR_CAF
-#define DEBUG_PR_CONST
-#define DEBUG_PR_CHARLIKE
-#define DEBUG_PR_INTLIKE_TO_STATIC
-#define DEBUG_PR_INTLIKE_IN_HEAP
-#define DEBUG_PR_OLDIND
-
-#endif
-
-#endif /* SMMARKDEFS_H */
-\end{code}
-
+++ /dev/null
-/*************************************************************************
- MARKING OF ROOTS
-*************************************************************************/
-
-[Something needed here to explain what this is doing. KH]
-
-\begin{code}
-
-#define MARK_REG_MAP
-#include "SMinternal.h"
-
-#if defined(_INFO_MARKING)
-
-#if defined (__STG_GCC_REGS__) /* If we are using registers load _SAVE */
-
-/* If we are using registers load _SAVE */
-#define Mark SAVE_Mark
-#define MRoot SAVE_MRoot
-#define MStack SAVE_MStack
-#define BitArray SAVE_BitArray
-#define HeapBase SAVE_HeapBase
-#define HeapLim SAVE_HeapLim
-
-#endif /* registerized */
-
-/* These in SMmark.lhc -- need to be in .hc file */
-EXTFUN(_startMarkWorld);
-
-EXTFUN(_PRMarking_MarkNextRoot);
-EXTFUN(_PRMarking_MarkNextCAF);
-EXTDATA(_PRMarking_MarkNextRoot_closure);
-EXTDATA(_PRMarking_MarkNextCAF_closure);
-
-#ifdef CONCURRENT
-EXTFUN(_PRMarking_MarkNextSpark);
-EXTDATA(_PRMarking_MarkNextSpark_closure);
-#endif
-
-#if defined(GRAN)
-EXTFUN(_PRMarking_MarkNextEvent);
-EXTDATA(_PRMarking_MarkNextEvent_closure);
-EXTFUN(_PRMarking_MarkNextClosureInFetchBuffer);
-EXTDATA(_PRMarking_MarkNextClosureInFetchBuffer_closure);
-#endif
-
-#ifdef PAR
-EXTFUN(_PRMarking_MarkNextGA);
-EXTDATA(_PRMarking_MarkNextGA_closure);
-#else
-EXTFUN(_PRMarking_MarkNextAStack);
-EXTFUN(_PRMarking_MarkNextBStack);
-EXTDATA(_PRMarking_MarkNextAStack_closure);
-EXTDATA(_PRMarking_MarkNextBStack_closure);
-#endif /* not parallel */
-
-P_ sm_roots_end;
-#if defined(GRAN)
-P_ ret_MRoot, ret_Mark;
-#endif
-
-I_
-markHeapRoots(sm, cafs1, cafs2, base, lim, bit_array)
- smInfo *sm;
- P_ cafs1, cafs2; /* Pointer to CAF lists */
- P_ base; /* Heap closure in range only tested for by GCgn */
- P_ lim;
- BitWord *bit_array;
-{
-#ifdef CONCURRENT
- int pool;
-#endif
-#if defined(GRAN)
- PROC proc;
- eventq event;
- sparkq spark;
- rtsBool found = rtsFalse;
-#endif
-
- BitArray = bit_array;
- HeapBase = base;
- HeapLim = lim;
-
- DEBUG_STRING("Marking Roots:");
- if (sm->rootno > 0) {
- sm_roots_end = (P_) &sm->roots[sm->rootno];
- MRoot = (P_) sm->roots;
- Mark = (P_) *MRoot;
- MStack = (P_) _PRMarking_MarkNextRoot_closure;
-
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
-
-#if defined(GRAN)
- DEBUG_STRING("Marking Events (GRAN): ");
- MRoot = (P_) EventHd;
- found = rtsFalse;
- do {
- if (MRoot != NULL) {
- /* inlined version of MarkNextEvent */
- switch (EVENT_TYPE( ((eventq) MRoot) )) {
- case CONTINUETHREAD:
- case STARTTHREAD:
- case RESUMETHREAD:
- case MOVETHREAD:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- MStack = (P_) _PRMarking_MarkNextEvent_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- found = rtsTrue;
- break;
- case MOVESPARK:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) ));
- MStack = (P_) _PRMarking_MarkNextEvent_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- found = rtsTrue;
- break;
- case FETCHNODE:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- MStack = (P_) _PRMarking_MarkNextEvent_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- found = rtsTrue;
- break;
- case FETCHREPLY:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- MStack = (P_) _PRMarking_MarkNextEvent_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- found = rtsTrue;
- break;
- case GLOBALBLOCK:
- EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- MStack = (P_) _PRMarking_MarkNextEvent_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- found = rtsTrue;
- break;
- case UNBLOCKTHREAD:
- Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
- MStack = (P_) _PRMarking_MarkNextEvent_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- found = rtsTrue;
- break;
- case FINDWORK:
- MRoot = (P_) EVENT_NEXT( ((eventq) MRoot) );
- found = rtsFalse;
- break;
- default:
- fprintf(stderr,"Unknown event type %d (event @ %#x) in SMmarking_NextEvent\n",
- EVENT_TYPE( ((eventq) MRoot) ), MRoot);
- EXIT(EXIT_FAILURE);
- }
- }
- } while (!found && MRoot != NULL);
-
- DEBUG_STRING("Marking Sparks (GRAN):");
- for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
- for(pool = 0; pool < SPARK_POOLS; pool++) {
- MRoot = (P_) PendingSparksHd[proc][pool];
- if (MRoot != NULL) {
- Mark = (P_) SPARK_NODE( ((sparkq) MRoot) );
- MStack = (P_) _PRMarking_MarkNextSpark_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
- } /* forall pool .. */
- } /* forall proc ... */
-#endif /* GRAN */
-
-#if defined(CONCURRENT) && !defined(GRAN)
- for(pool = 0; pool < SPARK_POOLS; pool++) {
- if (PendingSparksHd[pool] < PendingSparksTl[pool]) {
- sm_roots_end = (P_) PendingSparksTl[pool];
- MRoot = (P_) PendingSparksHd[pool];
- Mark = (P_) *MRoot;
- MStack = (P_) _PRMarking_MarkNextSpark_closure;
-
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
- }
-#endif
-
-#ifdef PAR
- DEBUG_STRING("Marking GA Roots:");
- MRoot = (P_) liveIndirections;
- while(MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT)
- MRoot = (P_) ((GALA *)MRoot)->next;
- if (MRoot != NULL) {
- Mark = ((GALA *)MRoot)->la;
- MStack = (P_) _PRMarking_MarkNextGA_closure;
-
- miniInterpret((StgFunPtr) _startMarkWorld);
- }
-#else
- /* Note: no *external* stacks in parallel/concurrent world */
-
- DEBUG_STRING("Marking A Stack:");
- if (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) >= 0) {
- MRoot = (P_) MAIN_SpA;
- Mark = (P_) *MRoot;
- MStack = (P_) _PRMarking_MarkNextAStack_closure;
-
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
-
- DEBUG_STRING("Marking B Stack:");
- if (SUBTRACT_B_STK(MAIN_SuB, stackInfo.botB) > 0) {
- MRoot = MAIN_SuB;
- Mark = GRAB_UPDATEE(MRoot);
- MStack = (P_) _PRMarking_MarkNextBStack_closure;
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
-#endif /* PAR */
-
- DEBUG_STRING("Marking & Updating CAFs:");
- if (cafs1) {
- MRoot = cafs1;
- Mark = (P_) IND_CLOSURE_PTR(MRoot);
- MStack = (P_) _PRMarking_MarkNextCAF_closure;
-
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
-
- if (cafs2) {
- MRoot = cafs2;
- Mark = (P_) IND_CLOSURE_PTR(MRoot);
- MStack = (P_) _PRMarking_MarkNextCAF_closure;
-
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
-
- return 0;
-}
-
-#endif /* _INFO_MARKING */
-\end{code}
-
-
-CODE REQUIRED (expressed as a loop):
-
-MARK ROOTS
-
- MStack = _PRMarking_MarkNextRoot_closure;
- for (MRoot = (P_) sm->roots;
- MRoot < (P_) &sm->roots[sm->rootno];
- MRoot++) {
- Mark = (P_) *MRoot;
- (PRMARK_CODE(INFO_PTR(Mark)))();
-_PRMarking_MarkNextRoot:
- *MRoot = (W_) Mark;
- }
-
-
-MARK AStack
-
- MStack = _PRMarking_MarkNextAStack_closure;
- for (MRoot = MAIN_SpA;
- SUBTRACT_A_STK(MRoot, stackInfo.botA) >= 0;
- MRoot = MRoot + AREL(1)) {
- Mark = (P_) *MRoot;
- (PRMARK_CODE(INFO_PTR(Mark)))();
-_PRMarking_MarkNextAStack:
- *MRoot = (W_) Mark;
- }
-
-
-MARK BStack
-
- MStack = _PRMarking_MarkNextBStack_closure;
- for (MRoot = MAIN_SuB; --- Topmost Update Frame
- SUBTRACT_B_STK(MRoot, stackInfo.botB) > 0;
- MRoot = GRAB_SuB(MRoot)) {
-
- Mark = GRAB_UPDATEE(MRoot);
- (PRMARK_CODE(INFO_PTR(Mark)))();
-_PRMarking_MarkNextBStack:
- PUSH_UPDATEE(MRoot, Mark);
- }
-
-
-MARK CAFs
-
- MStack = _PRMarking_MarkNextCAF_closure;
- for (MRoot = sm->CAFlist;
- MRoot;
- MRoot = (P_) IND_CLOSURE_LINK(MRoot))
-
- Mark = IND_CLOSURE_PTR(MRoot);
- (PRMARK_CODE(INFO_PTR(Mark)))();
-_PRMarking_MarkNextCAF:
- IND_CLOSURE_PTR(MRoot) = (W_) Mark;
- }
+++ /dev/null
-/*************************************************************************
- SCANNING CODE
-
-This file contains the basic routines required for inplace compacting
-garbage collection. It is based on Jonkers's algorithm.
-
-There is a compacting routine as well as all the basic routines which
-are placed in the info tables of the appropriate closures.
-
- ToDo: Remove Fillers -- Compiler
- Remove Dummy Filler Macros -- SMupdate.lh
- Remove special "shrinking" info_upd stuff -- Compiler
- Remove special "shrinking" info_upd stuff -- SMinterface.lh
-
- Updateable closure size can now be relaxed
- MinUpdSize is now 1
- May want to allocate larger closures to enable updates inplace
- eg Int 1 MkInt etc fit
- List 2 Nil,List fit
- STree 3 Leaf(2) Branch(3) fit
- STree 2 Leaf(2) fits, Branch(3) fails
- Tuple4 1 MkTuple4 fails
-
- Need BHs of appropriate sizes (reserve BHed space for update)
- For Appel will require BH_1 to grow to size 2 when collected.
-
-*************************************************************************/
-
-\begin{code}
-
-#define SCAN_REG_MAP
-#include "SMinternal.h"
-
-#if defined(_INFO_COMPACTING)
-
-/* Define appropriate global variables as potential register variables */
-/* Assume GC code saves and restores global registers used */
-
-RegisterTable ScanRegTable;
-
-#ifndef PAR
-/* As we perform compaction, those ForeignObjs which are still alive get
- added to this list. [ADR] */
-StgPtr NewForeignObjList;
-#endif /* !PAR */
-
-P_
-Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words
-#ifndef PAR
-, ForeignObjList
-#endif
-)
- P_ base;
- P_ lim;
- P_ scanbase;
- P_ scanlim;
- BitWord *bit_array;
- I_ bit_array_words;
-#ifndef PAR
- StgPtr *ForeignObjList;
-#endif
-{
- BitWord *bit_array_ptr, *bit_array_end;
- P_ scan_w_start, info;
- I_ size;
-
- LinkLim = lim; /* Only checked for generational collection */
-
-#if defined(GCgn)
-
- /* Scan collected new gen semi-space linking pointers to old gen */
- /* No closures to unlink (no new ptrs will be linked) */
- /* Have to reset closure to unmarked if it has been marked */
- /* If not marked, we will still link (and unlink) as we need to */
- /* get the size to find next closure. */
- /* It will be collected next minor collection as no root exists*/
-
- DEBUG_SCAN("Scan Link Area: Base", scanbase, "Lim", scanlim);
-
- Scan = scanbase;
- New = 0; /* unused -- except by debugging message */
-
- while (Scan < scanlim) {
- info = (P_) UNMARK_LOCATION(INFO_PTR(Scan));
- Scan += (*SCAN_LINK_CODE(info))();
- }
-#endif /* GCgn */
-
- DEBUG_SCAN("Scan Link Bits: Base", base, "Bits", bit_array);
-
- bit_array_ptr = bit_array;
- bit_array_end = bit_array + bit_array_words;
- scan_w_start = base;
- New = base; /* used to unwind */
-
-#ifndef PAR
- NewForeignObjList = NULL; /* initialise new ForeignObjList */
- /* As we move ForeignObjs over, we'll add them to this list. */
-#endif /* !PAR */
-
- while (bit_array_ptr < bit_array_end) {
- BitWord w = *(bit_array_ptr++);
-
- Scan = scan_w_start;
- while (w) {
-
- if (! (w & 0x1)) { /* bit not set */
- Scan++; /* look at next bit */
- w >>= 1;
-
- } else { /* Bit Set -- Enter ScanLink for closure */
- info = (P_) INFO_PTR(Scan);
- while (MARKED_LOCATION(info)) {
- P_ next;
- info = UNMARK_LOCATION(info);
- next = (P_) *info;
- DEBUG_UNLINK_LOCATION(info, Scan, New);
- *info = (W_) New;
- info = next;
- }
- INFO_PTR(Scan) = (W_) info;
-
- size = (*SCAN_LINK_CODE(info))();
-
- ASSERT( size >= 0 );
- New += size; /* set New address of next closure */
-
- Scan += size; /* skip size bits */
-
- if ((W_) size >= BITS_IN(BitWord)) break;
- /* NOTA BENE: if size >= # bits in BitWord, then the result
- of this operation is undefined! Hence the need for
- this break! */
- w >>= size;
- }
- }
- scan_w_start += BITS_IN(BitWord);
- }
- DEBUG_SCAN("Scan Link Bits: End", Scan, "New", New);
-
- bit_array_ptr = bit_array;
- bit_array_end = bit_array + bit_array_words;
- scan_w_start = base; /* Points to the heap word corresponding to the
- first bit of *bit_array_ptr */
-
- New = base; /* used to unwind and move */
-
- DEBUG_SCAN("Scan Move Bits: Base", base, "Bits", bit_array);
- while (bit_array_ptr < bit_array_end) {
-
- /* Grab bit word and clear (its the last scan) */
- /* Dont need to clear for Appel or Generational major collection */
- /* Why not??? I think it's because they have a pass which zaps all
- the bit array to zero. But why do they need it? Or, why
- doesn't dual-mode need it?
-
- It's probably easier just to *always* to zap at the beginning of
- GC, and remove this conditional compilation here. */
-#if defined(GCap) || defined(GCgn)
- BitWord w = (I_) *(bit_array_ptr++);
-#else
- BitWord w = (I_) *bit_array_ptr;
- *(bit_array_ptr++) = 0;
-#endif
-
- Scan = scan_w_start;
- while (w) {
- if (! (w & 0x1)) { /* bit not set */
- Scan++; /* look at next bit */
- w >>= 1;
-
- } else { /* Bit Set -- Enter ScanMove for closure*/
- info = (P_) INFO_PTR(Scan);
- while (MARKED_LOCATION(info)) {
- P_ next;
- info = UNMARK_LOCATION(info);
- next = (P_) *info;
- DEBUG_UNLINK_LOCATION(info, Scan, New);
- *info = (W_) New;
- info = next;
- }
- INFO_PTR(New) = (W_) info;
-
- size = (*SCAN_MOVE_CODE(info))();
- New += size; /* set New address of next closure */
- Scan += size; /* skip size bits */
-
- if ((W_) size >= BITS_IN(BitWord)) break;
- /* NOTA BENE: if size >= # bits in BitWord, then the result
- of this operation is undefined! Hence the need for
- this break! */
- w >>= size; /* NB: comment above about shifts */
- }
- }
-
- /* At this point we've exhausted one word of mark bits */
- /* Make scan_w_start point to the heap word corresponding to the
- first bit of the next word of mark bits */
- scan_w_start += BITS_IN(BitWord);
- }
- DEBUG_SCAN("Scan Link Bits: End", Scan, "New", New);
-
-#ifdef PAR
- RebuildLAGAtable();
-#else
- VALIDATE_ForeignObjList( NewForeignObjList );
- *ForeignObjList = NewForeignObjList;
-#endif /* PAR */
-
- return(New);
-}
-
-\end{code}
-
-/*************************************************************************
- Basic SCAN LINK and SCAN MOVE Routines
-
-First Scan on Closures
- _ScanLink_S_N
-
- Retrieved using SCAN_LINK_CODE(infoptr) (for a true unmarked infoptr)
-
-Links the closure's ptr locations to the info pointer of the closure's
-they actually point. Returns the size of the closure so New can be updated
-to point to next closure. This also allows sequential scan (if there are no
-holes i.e. it has already been collected).
-
-Must first unwind the locations linked to this closure updating with
-the new location of this closure before entering the code. The code
-can only be access from the info pointer at the end of this location
-list, which must be restored before entering.
-
- Calling Conventions (After unwinding and updating locations pointed to):
- Scan -- points to this closure
- LinkLim -- points to end of heap are requiring pointer to be linked
-
- New (optional) -- points to the new location that this closure will reside
- this is only required for meaningful debugging meassge
-
-Second Scan on Closures
- _ScanMove_S
-
- Retrieved using SCAN_MOVE_CODE(infoptr) (for a true unmarked infoptr)
-
-Slides the closure down to its new location, New. Returns the size of
-the closure so New can be updated to point to the next closure.
-
-Must first unwind the locations linked to this closure updating with
-the new location of this closure before entering the code. The code
-can only be access from the info pointer at the end of this location
-list, which must be restored before entering.
-
- Calling Conventions (After unwinding and updating locations pointed to):
- Scan -- points to this closure
- New -- points to the new location that this closure will reside
-
-
-Will have MARKING routines in info tables as well:
-
-Marking A Closure:
- _PRStart_N
-
- Retrieved using PRMARK_CODE(infoptr)
-
-Returning To A Closure Being Marked:
- _PRIn_I
- _PRInLast_N
-
- Retrieved using PRRETURN_CODE(infoptr)
-
-
-
-May have COPYING routines in info tables as well:
-
-Evacuation code: _Evacuate_S
-Scavenging code: _Scavenge_S_N
-
- See GCscav.lhc GCevac.lc
-
-
-
-The following registers are used by the Compacting collection:
-
-New -- The new address of a closure
-Scan -- The current address of a closure
-LinkLim -- The limit of the heap requiring to be linked & moved
-
-**************************************************************************/
-
-\begin{code}
-
-#if defined(GCgn)
-#define LINK_LOCATION(i) LINK_LOCATION_TO_CLOSURE((Scan+(i)),LinkLim)
-#else /* ! GCgn */
-#define LINK_LOCATION(i) LINK_LOCATION_TO_CLOSURE(Scan+(i))
-#endif /* ! GCgn */
-
-/* Link location of nth pointer in SPEC/STKO closure (starting at 1) */
-#define SPEC_LINK_LOCATION(ptr) LINK_LOCATION((SPEC_HS-1) + (ptr))
-#define STKO_LINK_LOCATION(ptr) LINK_LOCATION((STKO_HS-1) + (ptr))
-
-
-/* Slide the ith word (starting at 0) */
-#define SLIDE_WORD(position) New[position] = Scan[position]
-
-/* Slide the ith ptr (starting at 0), adjusting by offset */
-#define ADJUST_WORD(pos,off) ((PP_)New)[pos] += (off)
-
-/* Slide the nth free var word in a SPEC closure (starting at 1) */
-#define SPEC_SLIDE_WORD(n) SLIDE_WORD((SPEC_HS-1) + (n))
-
-#ifndef PAR
-/* Don't slide the ForeignObj list link - instead link moved object into
- @NewForeignObjList@ */
-
-#define ForeignObj_SLIDE_DATA \
- ForeignObj_CLOSURE_DATA(New) = ForeignObj_CLOSURE_DATA(Scan); \
- ForeignObj_CLOSURE_FINALISER(New) = ForeignObj_CLOSURE_FINALISER(Scan)
-#define ForeignObj_RELINK \
-{ \
- ForeignObj_CLOSURE_LINK(New) = NewForeignObjList; \
- NewForeignObjList = New; \
-}
-#endif /* !PAR */
-
-/* The SLIDE_FIXED_HDR macro is dependent on the No of FIXED_HS */
-
-#if FIXED_HS == 1
-#define SLIDE_FIXED_HDR /* Already Assigned INFO_PTR */
-#else
-#if FIXED_HS == 2
-#define SLIDE_FIXED_HDR SLIDE_WORD(1)
-#else
-#if FIXED_HS == 3
-#define SLIDE_FIXED_HDR SLIDE_WORD(1);SLIDE_WORD(2)
-#else
-/* I don't think this will be needed (ToDo: #error?) */
-#endif
-#endif
-#endif
-
-
-#if defined(DEBUG)
-
-#define DEBUG_SCAN_LINK(type, sizevar, ptrvar) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scan Link (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
- type, Scan, New, INFO_PTR(Scan), sizevar, ptrvar)
-
-#define DEBUG_SCAN_MOVE(type, sizevar) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scan Move (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \
- type, Scan, New, INFO_PTR(New), sizevar)
-
-
-#else
-
-#define DEBUG_SCAN_LINK(type, sizevar, ptrvar)
-#define DEBUG_SCAN_MOVE(type, sizevar)
-
-#endif
-
-/*** LINKING CLOSURES ***/
-
-#ifdef TICKY_TICKY
-I_
-_ScanLink_0_0(STG_NO_ARGS) {
- I_ size = 0; /* NB: SPEC_VHS is *defined* to be zero */
- DEBUG_SCAN_LINK("SPEC", size, 0);
- return(FIXED_HS + size);
-}
-#endif
-
-I_
-_ScanLink_1_0(STG_NO_ARGS) {
- I_ size = 1; /* NB: SPEC_VHS is *defined* to be zero */
- DEBUG_SCAN_LINK("SPEC", size, 0);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_1_1(STG_NO_ARGS) {
- I_ size = 1;
- DEBUG_SCAN_LINK("SPEC", size, 1);
- SPEC_LINK_LOCATION(1);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_2_0(STG_NO_ARGS) {
- I_ size = 2;
- DEBUG_SCAN_LINK("SPEC", size, 0);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_2_1(STG_NO_ARGS) {
- I_ size = 2;
- DEBUG_SCAN_LINK("SPEC", size, 1);
- SPEC_LINK_LOCATION(1);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_2_2(STG_NO_ARGS) {
- I_ size = 2;
- DEBUG_SCAN_LINK("SPEC", size, 2);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_3_0(STG_NO_ARGS) {
- I_ size = 3;
- DEBUG_SCAN_LINK("SPEC", size, 0);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_3_1(STG_NO_ARGS) {
- I_ size = 3;
- DEBUG_SCAN_LINK("SPEC", size, 1);
- SPEC_LINK_LOCATION(1);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_3_2(STG_NO_ARGS) {
- I_ size = 3;
- DEBUG_SCAN_LINK("SPEC", size, 2);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_3_3(STG_NO_ARGS) {
- I_ size = 3;
- DEBUG_SCAN_LINK("SPEC", size, 3);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_4_0(STG_NO_ARGS) {
- I_ size = 4;
- DEBUG_SCAN_LINK("SPEC", size, 0);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_4_4(STG_NO_ARGS) {
- I_ size = 4;
- DEBUG_SCAN_LINK("SPEC", size, 4);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_5_0(STG_NO_ARGS) {
- I_ size = 5;
- DEBUG_SCAN_LINK("SPEC", size, 0);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_5_5(STG_NO_ARGS) {
- I_ size = 5;
- DEBUG_SCAN_LINK("SPEC", size, 5);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_6_6(STG_NO_ARGS) {
- I_ size = 6;
- DEBUG_SCAN_LINK("SPEC", size, 6);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- SPEC_LINK_LOCATION(6);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_7_7(STG_NO_ARGS) {
- I_ size = 7;
- DEBUG_SCAN_LINK("SPEC", size, 7);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- SPEC_LINK_LOCATION(6);
- SPEC_LINK_LOCATION(7);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_8_8(STG_NO_ARGS) {
- I_ size = 8;
- DEBUG_SCAN_LINK("SPEC", size, 8);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- SPEC_LINK_LOCATION(6);
- SPEC_LINK_LOCATION(7);
- SPEC_LINK_LOCATION(8);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_9_9(STG_NO_ARGS) {
- I_ size = 9;
- DEBUG_SCAN_LINK("SPEC", size, 9);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- SPEC_LINK_LOCATION(6);
- SPEC_LINK_LOCATION(7);
- SPEC_LINK_LOCATION(8);
- SPEC_LINK_LOCATION(9);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_10_10(STG_NO_ARGS) {
- I_ size = 10;
- DEBUG_SCAN_LINK("SPEC", size, 10);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- SPEC_LINK_LOCATION(6);
- SPEC_LINK_LOCATION(7);
- SPEC_LINK_LOCATION(8);
- SPEC_LINK_LOCATION(9);
- SPEC_LINK_LOCATION(10);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_11_11(STG_NO_ARGS) {
- I_ size = 11;
- DEBUG_SCAN_LINK("SPEC", size, 11);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- SPEC_LINK_LOCATION(6);
- SPEC_LINK_LOCATION(7);
- SPEC_LINK_LOCATION(8);
- SPEC_LINK_LOCATION(9);
- SPEC_LINK_LOCATION(10);
- SPEC_LINK_LOCATION(11);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_12_12(STG_NO_ARGS) {
- I_ size = 12;
- DEBUG_SCAN_LINK("SPEC", size, 12);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- SPEC_LINK_LOCATION(3);
- SPEC_LINK_LOCATION(4);
- SPEC_LINK_LOCATION(5);
- SPEC_LINK_LOCATION(6);
- SPEC_LINK_LOCATION(7);
- SPEC_LINK_LOCATION(8);
- SPEC_LINK_LOCATION(9);
- SPEC_LINK_LOCATION(10);
- SPEC_LINK_LOCATION(11);
- SPEC_LINK_LOCATION(12);
- return(FIXED_HS + size);
-}
-\end{code}
-
-Scan-linking revertible black holes with underlying @SPEC@ closures.
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-I_
-_ScanLink_RBH_2_1(STG_NO_ARGS)
-{
- I_ size = 2 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_3_1(STG_NO_ARGS)
-{
- I_ size = 3 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_3_3(STG_NO_ARGS)
-{
- I_ size = 3 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_4_1(STG_NO_ARGS)
-{
- I_ size = 4 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_4_4(STG_NO_ARGS)
-{
- I_ size = 4 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 4);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_5_1(STG_NO_ARGS)
-{
- I_ size = 5 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_5_5(STG_NO_ARGS)
-{
- I_ size = 5 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 5);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_6_6(STG_NO_ARGS)
-{
- I_ size = 6 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 6);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_7_7(STG_NO_ARGS)
-{
- I_ size = 7 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 7);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_8_8(STG_NO_ARGS)
-{
- I_ size = 8 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 8);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_9_9(STG_NO_ARGS)
-{
- I_ size = 9 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 9);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_10_10(STG_NO_ARGS)
-{
- I_ size = 10 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 10);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_11_11(STG_NO_ARGS)
-{
- I_ size = 11 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 11);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9);
- return(FIXED_HS + size);
-}
-I_
-_ScanLink_RBH_12_12(STG_NO_ARGS)
-{
- I_ size = 12 + SPEC_RBH_VHS;
- DEBUG_SCAN_LINK("SRBH", size, 12);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9);
- LINK_LOCATION(SPEC_RBH_BQ_LOCN + 10);
- return(FIXED_HS + size);
-}
-#endif
-\end{code}
-
-Scan-linking a ForeignObj is straightforward: exactly the same as
-@_ScanLink_[ForeignObj_SIZE]_0@.
-
-\begin{code}
-#ifndef PAR
-I_
-_ScanLink_ForeignObj(STG_NO_ARGS) {
- I_ size = ForeignObj_SIZE;
- DEBUG_SCAN_LINK("ForeignObj", size, 0);
- return(FIXED_HS + size);
-}
-#endif /* !PAR */
-\end{code}
-
-Back to the main feature...
-
-\begin{code}
-
-/*** MOVING CLOSURES ***/
-
-#ifdef TICKY_TICKY
-I_
-_ScanMove_0(STG_NO_ARGS) {
- I_ size = 0; /* NB: SPEC_VHS defined to be zero, so 0 really is the "size" */
- DEBUG_SCAN_MOVE("CONST", size);
- SLIDE_FIXED_HDR;
- return(FIXED_HS + size);
-}
-#endif
-I_
-_ScanMove_1(STG_NO_ARGS) {
- I_ size = 1; /* NB: SPEC_VHS defined to be zero, so 1 really is the "size" */
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_2(STG_NO_ARGS) {
- I_ size = 2;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_3(STG_NO_ARGS) {
- I_ size = 3;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_4(STG_NO_ARGS) {
- I_ size = 4;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_5(STG_NO_ARGS) {
- I_ size = 5;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_6(STG_NO_ARGS) {
- I_ size = 6;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- SPEC_SLIDE_WORD(6);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_7(STG_NO_ARGS) {
- I_ size = 7;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- SPEC_SLIDE_WORD(6);
- SPEC_SLIDE_WORD(7);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_8(STG_NO_ARGS) {
- I_ size = 8;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- SPEC_SLIDE_WORD(6);
- SPEC_SLIDE_WORD(7);
- SPEC_SLIDE_WORD(8);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_9(STG_NO_ARGS) {
- I_ size = 9;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- SPEC_SLIDE_WORD(6);
- SPEC_SLIDE_WORD(7);
- SPEC_SLIDE_WORD(8);
- SPEC_SLIDE_WORD(9);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_10(STG_NO_ARGS) {
- I_ size = 10;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- SPEC_SLIDE_WORD(6);
- SPEC_SLIDE_WORD(7);
- SPEC_SLIDE_WORD(8);
- SPEC_SLIDE_WORD(9);
- SPEC_SLIDE_WORD(10);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_11(STG_NO_ARGS) {
- I_ size = 11;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- SPEC_SLIDE_WORD(6);
- SPEC_SLIDE_WORD(7);
- SPEC_SLIDE_WORD(8);
- SPEC_SLIDE_WORD(9);
- SPEC_SLIDE_WORD(10);
- SPEC_SLIDE_WORD(11);
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_12(STG_NO_ARGS) {
- I_ size = 12;
- DEBUG_SCAN_MOVE("SPEC", size);
- SLIDE_FIXED_HDR;
- SPEC_SLIDE_WORD(1);
- SPEC_SLIDE_WORD(2);
- SPEC_SLIDE_WORD(3);
- SPEC_SLIDE_WORD(4);
- SPEC_SLIDE_WORD(5);
- SPEC_SLIDE_WORD(6);
- SPEC_SLIDE_WORD(7);
- SPEC_SLIDE_WORD(8);
- SPEC_SLIDE_WORD(9);
- SPEC_SLIDE_WORD(10);
- SPEC_SLIDE_WORD(11);
- SPEC_SLIDE_WORD(12);
- return(FIXED_HS + size);
-}
-
-#if (defined(PAR) || defined(GRAN)) && defined(GC_MUT_REQUIRED)
-I_
-_ScanMove_RBH_2(STG_NO_ARGS) {
- I_ size = 2 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_3(STG_NO_ARGS) {
- I_ size = 3 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_4(STG_NO_ARGS) {
- I_ size = 4 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_5(STG_NO_ARGS) {
- I_ size = 5 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_6(STG_NO_ARGS) {
- I_ size = 6 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
- SLIDE_WORD(SPEC_RBH_HS + 4);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_7(STG_NO_ARGS) {
- I_ size = 7 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
- SLIDE_WORD(SPEC_RBH_HS + 4);
- SLIDE_WORD(SPEC_RBH_HS + 5);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_8(STG_NO_ARGS) {
- I_ size = 8 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
- SLIDE_WORD(SPEC_RBH_HS + 4);
- SLIDE_WORD(SPEC_RBH_HS + 5);
- SLIDE_WORD(SPEC_RBH_HS + 6);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_9(STG_NO_ARGS) {
- I_ size = 9 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
- SLIDE_WORD(SPEC_RBH_HS + 4);
- SLIDE_WORD(SPEC_RBH_HS + 5);
- SLIDE_WORD(SPEC_RBH_HS + 6);
- SLIDE_WORD(SPEC_RBH_HS + 7);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_10(STG_NO_ARGS) {
- I_ size = 10 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
- SLIDE_WORD(SPEC_RBH_HS + 4);
- SLIDE_WORD(SPEC_RBH_HS + 5);
- SLIDE_WORD(SPEC_RBH_HS + 6);
- SLIDE_WORD(SPEC_RBH_HS + 7);
- SLIDE_WORD(SPEC_RBH_HS + 8);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_11(STG_NO_ARGS) {
- I_ size = 11 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
- SLIDE_WORD(SPEC_RBH_HS + 4);
- SLIDE_WORD(SPEC_RBH_HS + 5);
- SLIDE_WORD(SPEC_RBH_HS + 6);
- SLIDE_WORD(SPEC_RBH_HS + 7);
- SLIDE_WORD(SPEC_RBH_HS + 8);
- SLIDE_WORD(SPEC_RBH_HS + 9);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-I_
-_ScanMove_RBH_12(STG_NO_ARGS) {
- I_ size = 12 + SPEC_RBH_VHS;
- DEBUG_SCAN_MOVE("SRBH", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(SPEC_RBH_HS + 0);
- SLIDE_WORD(SPEC_RBH_HS + 1);
- SLIDE_WORD(SPEC_RBH_HS + 2);
- SLIDE_WORD(SPEC_RBH_HS + 3);
- SLIDE_WORD(SPEC_RBH_HS + 4);
- SLIDE_WORD(SPEC_RBH_HS + 5);
- SLIDE_WORD(SPEC_RBH_HS + 6);
- SLIDE_WORD(SPEC_RBH_HS + 7);
- SLIDE_WORD(SPEC_RBH_HS + 8);
- SLIDE_WORD(SPEC_RBH_HS + 9);
- SLIDE_WORD(SPEC_RBH_HS + 10);
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-#endif
-\end{code}
-
-Moving a Foreign Object is a little tricky: we want to copy the actual
-pointer unchanged (easy) but we want to link the ForeignObj into the
-new ForeignObj list.
-
-\begin{code}
-#ifndef PAR
-I_
-_ScanMove_ForeignObj(STG_NO_ARGS) {
- I_ size = ForeignObj_SIZE;
- DEBUG_SCAN_MOVE("ForeignObj", size);
-
-#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr,"Moving ForeignObj(%x)=<%x,%x,%x>", Scan, Scan[0], Scan[1], Scan[2]);
- fprintf(stderr," Data = %x, Finaliser = %x, Next = %x\n",
- ForeignObj_CLOSURE_DATA(Scan),
- ForeignObj_CLOSURE_FINALISER(Scan),
- ForeignObj_CLOSURE_LINK(Scan) );
- }
-#endif
-
- SLIDE_FIXED_HDR;
- ForeignObj_SLIDE_DATA;
- ForeignObj_RELINK;
-
-#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
- fprintf(stderr,"Moved ForeignObj(%x)=<%x,_,%x,%x,%x>", New, New[0], New[1], New[2], New[3]);
- fprintf(stderr," Data = %x, Finaliser = %x, Next = %x",
- ForeignObj_CLOSURE_DATA(New),
- ForeignObj_CLOSURE_FINALISER(New),
- ForeignObj_CLOSURE_LINK(New) );
- fprintf(stderr,", NewForeignObjList = %x\n", NewForeignObjList );
- }
-#endif
-
- return(FIXED_HS + size);
-}
-#endif /* !PAR */
-\end{code}
-
-Now back to the main feature...
-
-\begin{code}
-
-/*** GENERIC Linking and Marking Routines */
-
-I_
-_ScanLink_S_N(STG_NO_ARGS) {
- I_ count = GEN_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + GEN_CLOSURE_NoPTRS(Scan);
- /* Offset of last ptr word */
- I_ size = GEN_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_LINK("GEN ", size, ptrs);
- while (++count <= ptrs) {
- LINK_LOCATION(count);
- }
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_S(STG_NO_ARGS) {
- I_ count = FIXED_HS - 1;
- I_ size = GEN_CLOSURE_SIZE(New);
-
- DEBUG_SCAN_MOVE("GEN ", size);
-
- SLIDE_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- SLIDE_WORD(count);
- }
- return(FIXED_HS + size);
-}
-
-\end{code}
-
-The linking code for revertible black holes with underlying @GEN@ closures.
-
-\begin{code}
-#if defined(PAR) || defined(GRAN)
-
-I_
-_ScanLink_RBH_N(STG_NO_ARGS)
-{
- I_ count = GEN_RBH_HS - 1; /* Offset of first ptr word, less 1 */
- I_ ptrs = GEN_RBH_CLOSURE_NoPTRS(Scan);
- I_ size = GEN_RBH_CLOSURE_SIZE(Scan);
-
- /*
- * Get pointer count from original closure and adjust for one pointer
- * in the first two words of the RBH.
- */
- if (ptrs < 2)
- ptrs = 1;
- else
- ptrs--;
-
- ptrs += count; /* Offset of last ptr word */
-
- DEBUG_SCAN_LINK("GRBH", size, ptrs);
- while (++count <= ptrs) {
- LINK_LOCATION(count);
- }
- return(FIXED_HS + size);
-}
-
-#ifdef GC_MUT_REQUIRED
-
-I_
-_ScanMove_RBH_S(STG_NO_ARGS) {
- I_ count = GEN_RBH_HS - 1;
- I_ size = GEN_RBH_CLOSURE_SIZE(New);
-
- DEBUG_SCAN_MOVE("GRBH", size);
-
- SLIDE_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- SLIDE_WORD(count);
- }
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-
-#endif
-
-#endif
-
-\end{code}
-
-\begin{code}
-I_
-_ScanLink_Dyn(STG_NO_ARGS) {
- I_ count = DYN_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + DYN_CLOSURE_NoPTRS(Scan);
- /* Offset of last ptr word */
- I_ size = DYN_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_LINK("DYN ", size, ptrs-count);
-
- while (++count <= ptrs) {
- LINK_LOCATION(count);
- }
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_Dyn(STG_NO_ARGS) {
- I_ count = FIXED_HS - 1;
- I_ size = DYN_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_MOVE("DYN ", size);
-
- SLIDE_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- SLIDE_WORD(count);
- }
- return(FIXED_HS + size);
-}
-
-I_
-_ScanLink_Tuple(STG_NO_ARGS) {
- I_ count = TUPLE_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + TUPLE_CLOSURE_NoPTRS(Scan);
- /* Offset of last ptr word */
- I_ size = TUPLE_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_LINK("TUPL", size, ptrs-count);
-
- while (++count <= ptrs) {
- LINK_LOCATION(count);
- }
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_Tuple(STG_NO_ARGS) {
- I_ count = FIXED_HS - 1;
- I_ size = TUPLE_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_MOVE("TUPL", size);
-
- SLIDE_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- SLIDE_WORD(count);
- }
- return(FIXED_HS + size);
-}
-
-/*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
-/* Only if special GC treatment required */
-
-#ifdef GC_MUT_REQUIRED
-I_
-_ScanLink_MuTuple(STG_NO_ARGS) {
- I_ count = MUTUPLE_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + MUTUPLE_CLOSURE_NoPTRS(Scan);
- /* Offset of last ptr word */
- I_ size = MUTUPLE_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_LINK("MUT ", size, ptrs-count);
-
- while (++count <= ptrs) {
- LINK_LOCATION(count);
- }
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_MuTuple(STG_NO_ARGS) {
- I_ count = FIXED_HS - 1;
- I_ size = MUTUPLE_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_MOVE("MUT ", size);
-
- SLIDE_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- SLIDE_WORD(count);
- }
-
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_ImmuTuple(STG_NO_ARGS) {
- I_ count = FIXED_HS - 1;
- I_ size = MUTUPLE_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_MOVE("IMUT", size);
-
- SLIDE_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- SLIDE_WORD(count);
- }
-
- /* Dont add to OldMutables list */
-
- return(FIXED_HS + size);
-}
-#endif /* GCap || GCgn */
-
-
-I_
-_ScanLink_Data(STG_NO_ARGS) {
- I_ size = DATA_CLOSURE_SIZE(Scan);
- DEBUG_SCAN_LINK("DATA", size, 0);
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_Data(STG_NO_ARGS) {
- I_ count = FIXED_HS - 1;
- I_ size = DATA_CLOSURE_SIZE(Scan);
-
- DEBUG_SCAN_MOVE("DATA", size);
-
- SLIDE_FIXED_HDR;
- while (++count <= size + (FIXED_HS - 1)) {
- SLIDE_WORD(count);
- }
- return(FIXED_HS + size);
-}
-
-
-I_
-_ScanLink_BH_U(STG_NO_ARGS) {
- I_ size = BH_U_SIZE;
- DEBUG_SCAN_LINK("BH ", size, 0);
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_BH_U(STG_NO_ARGS) {
- I_ size = BH_U_SIZE;
- DEBUG_SCAN_MOVE("BH ", size);
- SLIDE_FIXED_HDR;
- return(FIXED_HS + size);
-}
-
-I_
-_ScanLink_BH_N(STG_NO_ARGS) {
- I_ size = BH_N_SIZE;
- DEBUG_SCAN_LINK("BH N", size, 0);
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_BH_N(STG_NO_ARGS) {
- I_ size = BH_N_SIZE;
- DEBUG_SCAN_MOVE("BH N", size);
- SLIDE_FIXED_HDR;
- return(FIXED_HS + size);
-}
-
-#if defined(PROFILING) || defined(TICKY_TICKY)
-I_
-_ScanLink_PI(STG_NO_ARGS) {
- I_ size = IND_CLOSURE_SIZE(dummy);
- DEBUG_SCAN_LINK("PI ", size, 1);
- LINK_LOCATION(IND_HS);
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_PI(STG_NO_ARGS) {
- I_ size = IND_CLOSURE_SIZE(dummy);
- DEBUG_SCAN_MOVE("PI ", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(IND_HS);
- return(FIXED_HS + size);
-}
-#endif
-
-\end{code}
-
-Linking and Marking Routines for FetchMes and stack objects.
-
-\begin{code}
-
-#if defined(CONCURRENT)
-
-#if defined(PAR)
-
-I_
-_ScanLink_FetchMe(STG_NO_ARGS) {
- I_ size = FETCHME_CLOSURE_SIZE(dummy);
- DEBUG_SCAN_LINK("FME ", size, 0);
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_FetchMe(STG_NO_ARGS) {
- I_ size = FETCHME_CLOSURE_SIZE(dummy);
- DEBUG_SCAN_MOVE("FME ", size);
- SLIDE_FIXED_HDR;
- SLIDE_WORD(FETCHME_GA_LOCN);
- ASSERT(GALAlookup(FETCHME_GA(New)) != NULL);
-
-#ifdef GC_MUT_REQUIRED
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-#endif
-
- return(FIXED_HS + size);
-}
-
-I_
-_ScanLink_BF(STG_NO_ARGS)
-{
- I_ size = BF_CLOSURE_SIZE(dummy);
- DEBUG_SCAN_LINK("BF", size, 2);
-
- LINK_LOCATION(BF_LINK_LOCN);
- LINK_LOCATION(BF_NODE_LOCN);
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_BF(STG_NO_ARGS)
-{
- I_ count;
- I_ size = BF_CLOSURE_SIZE(dummy);
-
- SLIDE_FIXED_HDR;
- for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) {
- SLIDE_WORD(count);
- }
- SLIDE_WORD(BF_LINK_LOCN);
- SLIDE_WORD(BF_NODE_LOCN);
- SLIDE_WORD(BF_GTID_LOCN);
- SLIDE_WORD(BF_SLOT_LOCN);
- SLIDE_WORD(BF_WEIGHT_LOCN);
-
-#ifdef GC_MUT_REQUIRED
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-#endif
-
- return(FIXED_HS + size);
-}
-
-#endif /* PAR */
-
-I_
-_ScanLink_BQ(STG_NO_ARGS) {
- I_ size = BQ_CLOSURE_SIZE(dummy);
- DEBUG_SCAN_LINK("BQ ", size, BQ_CLOSURE_NoPTRS(Scan));
- LINK_LOCATION(BQ_HS);
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_BQ(STG_NO_ARGS) {
- I_ size = BQ_CLOSURE_SIZE(dummy);
- DEBUG_SCAN_MOVE("BQ ", size);
-
- SLIDE_FIXED_HDR;
- SLIDE_WORD(BQ_HS);
-
-#ifdef GC_MUT_REQUIRED
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-#endif
-
- return(FIXED_HS + size);
-}
-
-I_
-_ScanLink_TSO(STG_NO_ARGS)
-{
- STGRegisterTable *r = TSO_INTERNAL_PTR(Scan);
- W_ liveness = r->rLiveness;
- I_ i;
- I_ size = TSO_VHS + TSO_CTS_SIZE;
-
- DEBUG_SCAN_LINK("TSO", size, 0/*wrong*/);
-
- LINK_LOCATION(TSO_LINK_LOCN);
- LINK_LOCATION(((P_) &r->rStkO) - Scan);
- for(i = 0; liveness != 0; liveness >>= 1, i++) {
- if (liveness & 1) {
- LINK_LOCATION(((P_) &r->rR[i].p) - Scan)
- }
- }
- return(FIXED_HS + size);
-}
-
-I_
-_ScanMove_TSO(STG_NO_ARGS)
-{
- I_ count;
- I_ size = TSO_VHS + TSO_CTS_SIZE;
-
- SLIDE_FIXED_HDR;
- for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) {
- SLIDE_WORD(count);
- }
-
- for(count = 0; count < BYTES_TO_STGWORDS(sizeof(STGRegisterTable)); count++)
- /* Do it this way in case there's a shift of just one word */
- ((P_) TSO_INTERNAL_PTR(New))[count] = ((P_) TSO_INTERNAL_PTR(Scan))[count];
-
-#ifdef GC_MUT_REQUIRED
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-#endif
-
- return(FIXED_HS + size);
-}
-
-I_
-_ScanLink_StkO(STG_NO_ARGS) {
- I_ count;
- I_ size = STKO_CLOSURE_SIZE(Scan);
- I_ cts_size = STKO_CLOSURE_CTS_SIZE(Scan);
- I_ sub = STKO_SuB_OFFSET(Scan); /* Offset of first update frame in B stack */
-
- /* Link the link */
- LINK_LOCATION(STKO_LINK_LOCN);
-
- /* Link the locations in the A stack */
- DEBUG_SCAN_LINK("STKO", size, cts_size - STKO_SpA_OFFSET(Scan) + 1);
- for (count = STKO_SpA_OFFSET(Scan); count <= cts_size; count++) {
- STKO_LINK_LOCATION(count);
- }
-
- /* Now link the updatees in the update stack */
- while(sub > 0) {
- P_ subptr;
-
- STKO_LINK_LOCATION(sub + BREL(UF_UPDATEE));
- subptr = GRAB_SuB(STKO_CLOSURE_ADDR(Scan,sub));
- sub = STKO_CLOSURE_OFFSET(Scan, subptr);
- }
-
- ASSERT(sanityChk_StkO(Scan));
-
- return(FIXED_HS + size);
-}
-
-/* We move first and then repair, so that we can handle an overlapping source
- and destination.
- */
-
-I_
-_ScanMove_StkO(STG_NO_ARGS) {
- I_ count;
- I_ size = STKO_CLOSURE_SIZE(Scan);
- I_ cts_size = STKO_CLOSURE_CTS_SIZE(Scan);
- I_ spa_offset = STKO_SpA_OFFSET(Scan);
- I_ spb_offset = STKO_SpB_OFFSET(Scan);
- I_ sub_offset = STKO_SuB_OFFSET(Scan);
- I_ offset;
-
- DEBUG_SCAN_MOVE("STKO", size);
-
- SLIDE_FIXED_HDR;
-#ifdef TICKY_TICKY
- SLIDE_WORD(STKO_ADEP_LOCN);
- SLIDE_WORD(STKO_BDEP_LOCN);
-#endif
- SLIDE_WORD(STKO_SIZE_LOCN);
- SLIDE_WORD(STKO_RETURN_LOCN);
- SLIDE_WORD(STKO_LINK_LOCN);
-
- /* Adjust the four stack pointers...*IN ORDER* */
- offset = New - Scan;
- STKO_SuB(New) = STKO_SuB(Scan) + offset;
- STKO_SpB(New) = STKO_SpB(Scan) + offset;
- STKO_SpA(New) = STKO_SpA(Scan) + offset;
- STKO_SuA(New) = STKO_SuA(Scan) + offset;
-
- /* Slide the B stack */
- for (count = 1; count <= spb_offset; count++) {
- SLIDE_WORD((STKO_HS-1) + count);
- }
-
- /* Slide the A stack */
- for (count = spa_offset; count <= cts_size; count++) {
- SLIDE_WORD((STKO_HS-1) + count);
- }
-
- /* Repair internal pointers */
- while (sub_offset > 0) {
- P_ subptr;
- ADJUST_WORD((STKO_HS-1) + sub_offset + BREL(UF_SUA),offset);
- ADJUST_WORD((STKO_HS-1) + sub_offset + BREL(UF_SUB),offset);
- subptr = GRAB_SuB(STKO_CLOSURE_ADDR(New,sub_offset));
- sub_offset = STKO_CLOSURE_OFFSET(New, subptr);
- }
-
-#ifdef GC_MUT_REQUIRED
- /* Build new OldMutables list */
- MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
- StorageMgrInfo.OldMutables = (P_) New;
-#endif
-
- /* ToDo: ASSERT(sanityChk_StkO(Scan or New)); ??? */
-
- return(FIXED_HS + size);
-}
-
-#endif /* CONCURRENT */
-
-\end{code}
-
-\begin{code}
-/*** Dummy Entries -- Should not be entered ***/
-
-/* Should not be in a .lc file either... --JSM */
-
-STGFUN(_Dummy_Static_entry) {
- fprintf(stderr,"Called _Dummy_Static_entry\nShould never occur!\n");
- abort();
-}
-
-STGFUN(_Dummy_Ind_entry) {
- fprintf(stderr,"Called _Dummy_Ind_entry\nShould never occur!\n");
- abort();
-}
-
-STGFUN(_Dummy_Caf_entry) {
- fprintf(stderr,"Called _Dummy_Caf_Ind_entry\nShould never occur!\n");
- abort();
-}
-
-STGFUN(_Dummy_Const_entry) {
- fprintf(stderr,"Called _Dummy_Const_entry\nShould never occur!\n");
- abort();
-}
-
-STGFUN(_Dummy_CharLike_entry) {
- fprintf(stderr,"Called _Dummy_CharLike_entry\nShould never occur!\n");
- abort();
-}
-
-#endif /* _INFO_COMPACTING */
-\end{code}
+++ /dev/null
-****************************************************************************
-
-The files SMevac.lc and SMscav.lhc contain the basic routines required
-for two-space copying garbage collection.
-
-Two files are required as the evac routines are conventional call/return
-routines while the scavenge routines are continuation routines.
-
-This file SMscav.lhc contains the scavenging routines ...
-
-****************************************************************************
-
-
-All the routines are placed in the info tables of the appropriate closures.
-
-
-Evacuation code: _Evacuate_...
-
-USE: new = EVACUATE_CLOSURE(evac)
-
-Evacuates a closure of size S words. Note the size excludes the info
-and any other preceding fields (eg global address in Grip implementation)
-Returns the address of the closures new location via the Evac register.
-
- Calling Conventions:
- arg -- points to the closure
- ToHp -- points to the last allocated word in to-space
- Return Conventions:
- ret -- points to the new address of the closure
- ToHp -- points to the last allocated word in to-space
-
- Example: Cons cell requires _Evacuate_2
-
-Scavenging code: _Scavenge_S_N
-
- Retrieved using SCAV_CODE(infoptr)
-
-Scavenges a closure of size S words, with N pointers and returns.
-If more closures are required to be scavenged the code to
-scan the next closure can be called.
-
- Calling Conventions:
- Scav -- points to the current closure
- ToHp -- points to the last allocated word in to-space
-
- OldGen -- Points to end of old generation (Appels collector only)
-
- Return Conventions:
- Scav -- points to the next closure
- ToHp -- points to the (possibly new) location of the last allocated word
-
- Example: Cons cell requires _Scavenge_2_2
-
-
-The following registers are used by a two-space collection:
-
-Scav -- Points to the current closure being scavenged
- (PS paper = Hscav)
-
-ToHp -- Points to the last word allocated in two-space
- (PS paper = Hnext)
-
-A copying pass is started by:
- -- Setting ToHp to 1 before the start of to-space
- -- Evacuating the roots pointing into from-space
- -- root = EVACUATE_CLOSURE(root)
- -- Setting Scav to point to the first closure in to-space
- -- Execute while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
-
-When Done ToHp will point to the last word allocated in to-space
-
-
-\begin{code}
-/* The #define and #include come before the test because SMinternal.h
- will suck in includes/SMinterface whcih defines (or doesn't)
- _INFO_COPYING [ADR] */
-
-#define SCAV_REG_MAP
-#include "SMinternal.h"
-
-#if defined(_INFO_COPYING)
-
-RegisterTable ScavRegTable;
-
-/* Moves Scav to point at the info pointer of the next closure to Scavenge */
-#define NEXT_Scav(size) Scav += (size) + FIXED_HS
-
-/*
- When doing a new generation copy collection for Appel's collector
- only evacuate references that point to the new generation.
- OldGen must be set to point to the end of old space.
-*/
-
-#if defined(GCgn)
-
-#define DO_EVACUATE(closure, pos) \
- { P_ evac = (P_) *(((P_)(closure))+(pos)); \
- if (evac > OldGen) { \
- *(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); \
- }}
-
-#else
-#if defined(GCap)
-
-#define DO_EVACUATE(closure, pos) \
- { P_ evac = (P_) *(((P_)(closure))+(pos)); \
- if (evac > OldGen) { \
- *(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); \
- }}
-
-#else /* ! GCgn && ! GCap */
-
-#define DO_EVACUATE(closure, pos) \
- { P_ evac = (P_) *(((P_)(closure))+(pos)); \
- *(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); }
-
-#endif /* ! GCgn && ! GCap */
-#endif
-
-
-/* Evacuate nth pointer in SPEC closure (starting at 1) */
-#define SPEC_DO_EVACUATE(ptr) DO_EVACUATE(Scav, (SPEC_HS-1) + (ptr))
-#define STKO_DO_EVACUATE(ptr) DO_EVACUATE(Scav, (STKO_HS-1) + (ptr))
-
-
-/*** DEBUGGING MACROS ***/
-
-#if defined(DEBUG)
-
-#define DEBUG_SCAV(s,p) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), s, p)
-
-#define DEBUG_SCAV_GEN(s,p) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, Gen info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), s, p)
-
-#define DEBUG_SCAV_DYN \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, Dyn info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), DYN_CLOSURE_SIZE(Scav), DYN_CLOSURE_NoPTRS(Scav))
-
-#define DEBUG_SCAV_TUPLE \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, Tuple info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), TUPLE_CLOSURE_SIZE(Scav), TUPLE_CLOSURE_NoPTRS(Scav))
-
-#define DEBUG_SCAV_MUTUPLE \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, MuTuple info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), MUTUPLE_CLOSURE_SIZE(Scav), MUTUPLE_CLOSURE_NoPTRS(Scav))
-
-#define DEBUG_SCAV_DATA \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, Data info 0x%lx, size %ld\n", \
- Scav, INFO_PTR(Scav), DATA_CLOSURE_SIZE(Scav))
-
-#define DEBUG_SCAV_BH(s) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, BH info 0x%lx, size %ld\n", \
- Scav, INFO_PTR(Scav), s)
-
-#define DEBUG_SCAV_IND \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, IND info 0x%lx, size %ld\n", \
- Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav))
-
-#define DEBUG_SCAV_PERM_IND \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: 0x%lx, PI info 0x%lx, size %ld\n", \
- Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav))
-
-#define DEBUG_SCAV_OLDROOT(s) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
- fprintf(stderr, "Scav: OLDROOT 0x%lx, info 0x%lx, size %ld\n", \
- Scav, INFO_PTR(Scav), s)
-
-#ifdef CONCURRENT
-#define DEBUG_SCAV_BQ \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Scav: 0x%lx, BQ info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), BQ_CLOSURE_SIZE(Scav), BQ_CLOSURE_NoPTRS(Scav))
-
-#define DEBUG_SCAV_TSO \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Scav TSO: 0x%lx\n", \
- Scav)
-
-#define DEBUG_SCAV_STKO \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Scav StkO: 0x%lx\n", \
- Scav)
-
-# if defined(PAR) || defined(GRAN)
-# define DEBUG_SCAV_RBH(s,p) \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Scav RBH: 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), s, p)
-
-# define DEBUG_SCAV_BF \
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
- fprintf(stderr, "Scav: 0x%lx, BF info 0x%lx, size %ld, ptrs %ld\n", \
- Scav, INFO_PTR(Scav), BF_CLOSURE_SIZE(dummy), 0)
-# endif
-#endif
-
-#else
-
-#define DEBUG_SCAV(s,p)
-#define DEBUG_SCAV_GEN(s,p)
-#define DEBUG_SCAV_DYN
-#define DEBUG_SCAV_TUPLE
-#define DEBUG_SCAV_MUTUPLE
-#define DEBUG_SCAV_DATA
-#define DEBUG_SCAV_BH(s)
-#define DEBUG_SCAV_IND
-#define DEBUG_SCAV_PERM_IND
-#define DEBUG_SCAV_OLDROOT(s)
-
-#ifdef CONCURRENT
-# define DEBUG_SCAV_BQ
-# define DEBUG_SCAV_TSO
-# define DEBUG_SCAV_STKO
-# if defined(PAR) || defined(GRAN)
-# define DEBUG_SCAV_RBH(s,p)
-# define DEBUG_SCAV_BF
-# endif
-#endif
-
-#endif
-
-#define PROFILE_CLOSURE(closure,size) \
- HEAP_PROFILE_CLOSURE(closure,size)
-
-/*** SPECIALISED CODE ***/
-
-#ifdef TICKY_TICKY
-void
-_Scavenge_0_0(STG_NO_ARGS)
-{
- DEBUG_SCAV(0,0);
- PROFILE_CLOSURE(Scav,0);
- NEXT_Scav(0); /* because "size" is defined to be 0 (size SPEC_VHS == 0) */
- return;
-}
-#endif
-
-void
-_Scavenge_1_0(STG_NO_ARGS)
-{
- DEBUG_SCAV(1,0);
- PROFILE_CLOSURE(Scav,1);
- NEXT_Scav(1); /* because "size" is defined to be 1 (size SPEC_VHS == 0) */
- return;
-}
-void
-_Scavenge_1_1(STG_NO_ARGS)
-{
- DEBUG_SCAV(1,1);
- PROFILE_CLOSURE(Scav,1);
- SPEC_DO_EVACUATE(1);
- NEXT_Scav(1);
- return;
-}
-void
-_Scavenge_2_0(STG_NO_ARGS)
-{
- DEBUG_SCAV(2,0);
- PROFILE_CLOSURE(Scav,2);
- NEXT_Scav(2);
- return;
-}
-void
-_Scavenge_2_1(STG_NO_ARGS)
-{
- DEBUG_SCAV(2,1);
- PROFILE_CLOSURE(Scav,2);
- SPEC_DO_EVACUATE(1);
- NEXT_Scav(2);
- return;
-}
-void
-_Scavenge_2_2(STG_NO_ARGS)
-{
- DEBUG_SCAV(2,2);
- PROFILE_CLOSURE(Scav,2);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- NEXT_Scav(2);
- return;
-}
-void
-_Scavenge_3_0(STG_NO_ARGS)
-{
- DEBUG_SCAV(3,0);
- PROFILE_CLOSURE(Scav,3);
- NEXT_Scav(3);
- return;
-}
-void
-_Scavenge_3_1(STG_NO_ARGS)
-{
- DEBUG_SCAV(3,1);
- PROFILE_CLOSURE(Scav,3);
- SPEC_DO_EVACUATE(1);
- NEXT_Scav(3);
- return;
-}
-void
-_Scavenge_3_2(STG_NO_ARGS)
-{
- DEBUG_SCAV(3,2);
- PROFILE_CLOSURE(Scav,3);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- NEXT_Scav(3);
- return;
-}
-void
-_Scavenge_3_3(STG_NO_ARGS)
-{
- DEBUG_SCAV(3,3);
- PROFILE_CLOSURE(Scav,3);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- NEXT_Scav(3);
- return;
-}
-void
-_Scavenge_4_0(STG_NO_ARGS)
-{
- DEBUG_SCAV(4,0);
- PROFILE_CLOSURE(Scav,4);
- NEXT_Scav(4);
- return;
-}
-void
-_Scavenge_4_4(STG_NO_ARGS)
-{
- DEBUG_SCAV(4,4);
- PROFILE_CLOSURE(Scav,4);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- NEXT_Scav(4);
- return;
-}
-void
-_Scavenge_5_0(STG_NO_ARGS)
-{
- DEBUG_SCAV(5,0);
- PROFILE_CLOSURE(Scav,5);
- NEXT_Scav(5);
- return;
-}
-void
-_Scavenge_5_5(STG_NO_ARGS)
-{
- DEBUG_SCAV(5,5);
- PROFILE_CLOSURE(Scav,5);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- NEXT_Scav(5);
- return;
-}
-void
-_Scavenge_6_6(STG_NO_ARGS)
-{
- DEBUG_SCAV(6,6);
- PROFILE_CLOSURE(Scav,6);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- SPEC_DO_EVACUATE(6);
- NEXT_Scav(6);
- return;
-}
-void
-_Scavenge_7_7(STG_NO_ARGS)
-{
- DEBUG_SCAV(7,7);
- PROFILE_CLOSURE(Scav,7);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- SPEC_DO_EVACUATE(6);
- SPEC_DO_EVACUATE(7);
- NEXT_Scav(7);
- return;
-}
-void
-_Scavenge_8_8(STG_NO_ARGS)
-{
- DEBUG_SCAV(8,8);
- PROFILE_CLOSURE(Scav,8);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- SPEC_DO_EVACUATE(6);
- SPEC_DO_EVACUATE(7);
- SPEC_DO_EVACUATE(8);
- NEXT_Scav(8);
- return;
-}
-void
-_Scavenge_9_9(STG_NO_ARGS)
-{
- DEBUG_SCAV(9,9);
- PROFILE_CLOSURE(Scav,9);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- SPEC_DO_EVACUATE(6);
- SPEC_DO_EVACUATE(7);
- SPEC_DO_EVACUATE(8);
- SPEC_DO_EVACUATE(9);
- NEXT_Scav(9);
- return;
-}
-void
-_Scavenge_10_10(STG_NO_ARGS)
-{
- DEBUG_SCAV(10,10);
- PROFILE_CLOSURE(Scav,10);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- SPEC_DO_EVACUATE(6);
- SPEC_DO_EVACUATE(7);
- SPEC_DO_EVACUATE(8);
- SPEC_DO_EVACUATE(9);
- SPEC_DO_EVACUATE(10);
- NEXT_Scav(10);
- return;
-}
-void
-_Scavenge_11_11(STG_NO_ARGS)
-{
- DEBUG_SCAV(11,11);
- PROFILE_CLOSURE(Scav,11);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- SPEC_DO_EVACUATE(6);
- SPEC_DO_EVACUATE(7);
- SPEC_DO_EVACUATE(8);
- SPEC_DO_EVACUATE(9);
- SPEC_DO_EVACUATE(10);
- SPEC_DO_EVACUATE(11);
- NEXT_Scav(11);
- return;
-}
-void
-_Scavenge_12_12(STG_NO_ARGS)
-{
- DEBUG_SCAV(12,12);
- PROFILE_CLOSURE(Scav,12);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
- SPEC_DO_EVACUATE(3);
- SPEC_DO_EVACUATE(4);
- SPEC_DO_EVACUATE(5);
- SPEC_DO_EVACUATE(6);
- SPEC_DO_EVACUATE(7);
- SPEC_DO_EVACUATE(8);
- SPEC_DO_EVACUATE(9);
- SPEC_DO_EVACUATE(10);
- SPEC_DO_EVACUATE(11);
- SPEC_DO_EVACUATE(12);
- NEXT_Scav(12);
- return;
-}
-\end{code}
-
-The scavenge routines for revertible black holes with underlying @SPEC@
-closures.
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-
-# if defined(GCgn)
-
-# define SCAVENGE_SPEC_RBH_N_1(n) \
-void \
-CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS) \
-{ \
- I_ size = n + SPEC_RBH_VHS; \
- P_ save_Scav; \
- DEBUG_SCAV_RBH(size,1); \
- save_Scav = Scav; \
- Scav = OldGen + 1; \
- DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN); \
- Scav = save_Scav; \
- PROFILE_CLOSURE(Scav,size); \
- NEXT_Scav(size); \
-}
-
-# define SCAVENGE_SPEC_RBH_N_N(n) \
-void \
-CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \
-{ \
- I_ size = n + SPEC_RBH_VHS; \
- int i; \
- P_ save_Scav; \
- DEBUG_SCAV_RBH(size,size-1); \
- save_Scav = Scav; \
- Scav = OldGen + 1; \
- for(i = 0; i < n - 1; i++) { \
- DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN + i); \
- } \
- Scav = save_Scav; \
- PROFILE_CLOSURE(Scav,size); \
- NEXT_Scav(size); \
-}
-
-# else
-
-# define SCAVENGE_SPEC_RBH_N_1(n) \
-void \
-CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS) \
-{ \
- I_ size = n + SPEC_RBH_VHS; \
- DEBUG_SCAV_RBH(size,1); \
- DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN);\
- PROFILE_CLOSURE(Scav,size); \
- NEXT_Scav(size); \
-}
-
-# define SCAVENGE_SPEC_RBH_N_N(n) \
-void \
-CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \
-{ \
- I_ size = n + SPEC_RBH_VHS; \
- int i; \
- DEBUG_SCAV_RBH(size,size-1); \
- for(i = 0; i < n - 1; i++) { \
- DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN + i); \
- } \
- PROFILE_CLOSURE(Scav,size); \
- NEXT_Scav(size); \
-}
-
-# endif
-
-SCAVENGE_SPEC_RBH_N_1(2)
-
-SCAVENGE_SPEC_RBH_N_1(3)
-SCAVENGE_SPEC_RBH_N_N(3)
-
-SCAVENGE_SPEC_RBH_N_1(4)
-SCAVENGE_SPEC_RBH_N_N(4)
-
-SCAVENGE_SPEC_RBH_N_1(5)
-SCAVENGE_SPEC_RBH_N_N(5)
-
-SCAVENGE_SPEC_RBH_N_N(6)
-SCAVENGE_SPEC_RBH_N_N(7)
-SCAVENGE_SPEC_RBH_N_N(8)
-SCAVENGE_SPEC_RBH_N_N(9)
-SCAVENGE_SPEC_RBH_N_N(10)
-SCAVENGE_SPEC_RBH_N_N(11)
-SCAVENGE_SPEC_RBH_N_N(12)
-
-#endif
-
-\end{code}
-
-\begin{code}
-
-#ifndef PAR
-/*** Foreign Object -- NOTHING TO SCAVENGE ***/
-
-/* (The ForeignObjList is updated at the end of GC and any unevacuated
- ForeignObjs are finalised) [ADR][SOF]
-*/
-
-void
-_Scavenge_ForeignObj(STG_NO_ARGS)
-{
- I_ size = ForeignObj_SIZE;
- DEBUG_SCAV(size,0);
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-#endif /* !PAR */
-
-/*** GENERAL CASE CODE ***/
-
-void
-_Scavenge_S_N(STG_NO_ARGS)
-{
- I_ count = GEN_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + GEN_CLOSURE_NoPTRS(Scav);
- /* Offset of last ptr word */
- I_ size = GEN_CLOSURE_SIZE(Scav);
-
- DEBUG_SCAV_GEN(size, GEN_CLOSURE_NoPTRS(Scav));
-
- while (++count <= ptrs) {
- DO_EVACUATE(Scav, count);
- }
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-\end{code}
-
-The scavenge code for revertible black holes with underlying @GEN@ closures
-
-\begin{code}
-
-#if defined(PAR) || defined(GRAN)
-
-void
-_Scavenge_RBH_N(STG_NO_ARGS)
-{
-#if defined(GCgn)
- P_ save_Scav;
-#endif
-
- I_ count = GEN_RBH_HS - 1; /* Offset of first ptr word, less 1 */
- I_ ptrs = GEN_RBH_CLOSURE_NoPTRS(Scav);
- I_ size = GEN_RBH_CLOSURE_SIZE(Scav);
-
- /*
- * Get pointer count from original closure and adjust for one pointer
- * in the first two words of the RBH.
- */
- if (ptrs < 2)
- ptrs = 1;
- else
- ptrs--;
-
- ptrs += count; /* Offset of last ptr word */
-
- DEBUG_SCAV_GEN(size, ptrs);
-
-#if defined(GCgn)
- /* No old generation roots should be created for mutable */
- /* pointer fields as they will be explicitly collected */
- /* Ensure this by pointing Scav at the new generation */
- save_Scav = Scav;
- Scav = OldGen + 1;
-
- while (++count <= ptrs) {
- DO_EVACUATE(save_Scav, count);
- }
- Scav = save_Scav;
-#else
- while (++count <= ptrs) {
- DO_EVACUATE(Scav, count);
- }
-#endif
-
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-#endif
-
-\end{code}
-
-\begin{code}
-
-/*** DYNAMIC CLOSURE -- SIZE & PTRS STORED IN CLOSURE ***/
-
-void
-_Scavenge_Dyn(STG_NO_ARGS)
-{
- I_ count = DYN_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + DYN_CLOSURE_NoPTRS(Scav);
- /* Offset of last ptr word */
- I_ size = DYN_CLOSURE_SIZE(Scav);
-
- DEBUG_SCAV_DYN;
- while (++count <= ptrs) {
- DO_EVACUATE(Scav, count);
- }
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-/*** TUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/
-
-void
-_Scavenge_Tuple(STG_NO_ARGS)
-{
- I_ count = TUPLE_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + TUPLE_CLOSURE_NoPTRS(Scav);
- /* Offset of last ptr word */
- I_ size = TUPLE_CLOSURE_SIZE(Scav);
-
- DEBUG_SCAV_TUPLE;
- while (++count <= ptrs) {
- DO_EVACUATE(Scav, count);
- }
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-/*** DATA CLOSURE -- SIZE STORED IN CLOSURE -- NO POINTERS ***/
-
-void
-_Scavenge_Data(STG_NO_ARGS)
-{
- I_ size = DATA_CLOSURE_SIZE(Scav);
-
- DEBUG_SCAV_DATA;
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-/*** MUTUPLE CLOSURE -- ONLY PTRS STORED IN CLOSURE -- NO DATA ***/
-/* Only if special GC treatment required */
-
-#ifdef GC_MUT_REQUIRED
-void
-_Scavenge_MuTuple(STG_NO_ARGS)
-{
-#if defined(GCgn)
- P_ save_Scav;
-#endif
- I_ count = MUTUPLE_HS - 1;
- /* Offset of first ptr word, less 1 */
- I_ ptrs = count + MUTUPLE_CLOSURE_NoPTRS(Scav);
- /* Offset of last ptr word */
- I_ size = MUTUPLE_CLOSURE_SIZE(Scav);
-
- DEBUG_SCAV_MUTUPLE;
-
-#if defined(GCgn)
- /* No old generation roots should be created for mutable */
- /* pointer fields as they will be explicitly collected */
- /* Ensure this by pointing Scav at the new generation */
- save_Scav = Scav;
- Scav = OldGen + 1;
- while (++count <= ptrs) {
- DO_EVACUATE(save_Scav, count);
- }
- Scav = save_Scav;
-#else /* GCap */
- while (++count <= ptrs) {
- DO_EVACUATE(Scav, count);
- }
-#endif /* GCap */
-
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-#endif /* something generational */
-
-/*** BH CLOSURES -- NO POINTERS ***/
-
-void
-_Scavenge_BH_U(STG_NO_ARGS)
-{
- I_ size = BH_U_SIZE;
- DEBUG_SCAV_BH(size);
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-void
-_Scavenge_BH_N(STG_NO_ARGS)
-{
- I_ size = BH_N_SIZE;
- DEBUG_SCAV_BH(size);
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-/* This is needed for scavenging indirections that "hang around";
- e.g., because they are on the OldMutables list, or
- because we have "turned off" shorting-out of indirections
- (in SMevac.lc).
-*/
-void
-_Scavenge_Ind(STG_NO_ARGS)
-{
- I_ size = IND_CLOSURE_SIZE(dummy);
- DEBUG_SCAV_IND;
- PROFILE_CLOSURE(Scav,size);
- DO_EVACUATE(Scav, IND_HS);
- NEXT_Scav(size);
- return;
-}
-
-void
-_Scavenge_Caf(STG_NO_ARGS)
-{
- I_ size = IND_CLOSURE_SIZE(dummy);
- DEBUG_SCAV_IND;
- PROFILE_CLOSURE(Scav,size);
- DO_EVACUATE(Scav, IND_HS);
- NEXT_Scav(size);
- return;
-}
-
-#if defined(PROFILING) || defined(TICKY_TICKY)
-
-/* Special permanent indirection for lexical scoping.
- As for _Scavenge_Ind but no PROFILE_CLOSURE.
-*/
-
-void
-_Scavenge_PI(STG_NO_ARGS)
-{
- I_ size = IND_CLOSURE_SIZE(dummy);
- DEBUG_SCAV_PERM_IND;
- /* PROFILE_CLOSURE(Scav,size); */
- DO_EVACUATE(Scav, IND_HS);
- NEXT_Scav(size);
- return;
-}
-#endif /* PROFILING or TICKY */
-
-#ifdef CONCURRENT
-
-void
-_Scavenge_BQ(STG_NO_ARGS)
-{
- I_ size = BQ_CLOSURE_SIZE(dummy);
-#if defined(GCgn)
- P_ save_Scav;
-#endif
-
- DEBUG_SCAV_BQ;
-
-#if defined(GCgn)
- /* No old generation roots should be created for mutable */
- /* pointer fields as they will be explicitly collected */
- /* Ensure this by pointing Scav at the new generation */
- save_Scav = Scav;
- Scav = OldGen + 1;
- DO_EVACUATE(save_Scav, BQ_HS);
- Scav = save_Scav;
-#else /* !GCgn */
- DO_EVACUATE(Scav, BQ_HS);
-#endif /* GCgn */
-
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-void
-_Scavenge_TSO(STG_NO_ARGS)
-{
- I_ size = TSO_VHS + TSO_CTS_SIZE;
-#if defined(GCgn)
- P_ save_Scav;
-#endif
- STGRegisterTable *r = TSO_INTERNAL_PTR(Scav);
- W_ liveness = r->rLiveness;
- I_ i;
-
- DEBUG_SCAV_TSO;
-
-#if defined(GCgn)
- /* old and probably wrong -- deleted (WDP 95/12) */
-#else
- DO_EVACUATE(Scav, TSO_LINK_LOCN);
-
- DO_EVACUATE(Scav, ((P_) &r->rStkO) - Scav);
-
- for (i = 0; liveness != 0; liveness >>= 1, i++) {
- if (liveness & 1) {
- DO_EVACUATE(Scav, ((P_) &r->rR[i].p) - Scav)
- }
- }
-#endif
-
- PROFILE_CLOSURE(Scav, size);
- NEXT_Scav(size);
- return;
-}
-
-int /* ToDo: move? */
-sanityChk_StkO(P_ stko)
-{
- I_ size = STKO_CLOSURE_SIZE(stko);
- I_ cts_size = STKO_CLOSURE_CTS_SIZE(stko);
- I_ count;
- I_ sub = STKO_SuB_OFFSET(stko); /* Offset of first update frame in B stack */
- I_ prev_sub;
- P_ begin_stko = STKO_CLOSURE_ADDR(stko, 0);
- P_ beyond_stko = STKO_CLOSURE_ADDR(stko, cts_size+1);
-
- /*fprintf(stderr, "stko=%lx; SpA offset=%ld; first SuB=%ld, size=%ld; next=%lx\n",stko,STKO_SpA_OFFSET(stko),sub,STKO_CLOSURE_CTS_SIZE(stko),STKO_LINK(stko));*/
-
- /* Evacuate the locations in the A stack */
- for (count = STKO_SpA_OFFSET(stko); count <= cts_size; count++) {
- ASSERT(count >= 0);
- }
-
- while(sub > 0) {
- P_ subptr;
- PP_ suaptr;
- P_ updptr;
- P_ retptr;
-
- ASSERT(sub >= 1);
- ASSERT(sub <= cts_size);
-
- retptr = GRAB_RET(STKO_CLOSURE_ADDR(stko,sub));
- subptr = GRAB_SuB(STKO_CLOSURE_ADDR(stko,sub));
- suaptr = GRAB_SuA(STKO_CLOSURE_ADDR(stko,sub));
- updptr = GRAB_UPDATEE(STKO_CLOSURE_ADDR(stko,sub));
-
- ASSERT(subptr >= begin_stko);
- ASSERT(subptr < beyond_stko);
-
- ASSERT(suaptr >= begin_stko);
- ASSERT(suaptr <= beyond_stko);
-
- /* ToDo: would be nice to chk that retptr is in text space */
-
- sub = STKO_CLOSURE_OFFSET(stko, subptr);
- }
-
- return 1;
-}
-
-void
-_Scavenge_StkO(STG_NO_ARGS)
-{
- I_ size = STKO_CLOSURE_SIZE(Scav);
-#if defined(GCgn)
- P_ save_Scav;
-#endif
- I_ count;
- I_ sub = STKO_SuB_OFFSET(Scav); /* Offset of first update frame in B stack */
-
- DEBUG_SCAV_STKO;
-
-#if defined(GCgn)
- /* deleted; probably wrong */
-#else
- ASSERT(sanityChk_StkO(Scav));
-
- /* Evacuate the link */
- DO_EVACUATE(Scav, STKO_LINK_LOCN);
-
- /* Evacuate the locations in the A stack */
- for (count = STKO_SpA_OFFSET(Scav); count <= STKO_CLOSURE_CTS_SIZE(Scav); count++) {
- STKO_DO_EVACUATE(count);
- }
-
- /* Now evacuate the updatees in the update stack */
- while(sub > 0) {
- P_ subptr;
-
- STKO_DO_EVACUATE(sub + BREL(UF_UPDATEE));
- subptr = GRAB_SuB(STKO_CLOSURE_ADDR(Scav,sub));
-
- sub = STKO_CLOSURE_OFFSET(Scav, subptr);
- }
-
-#endif
- PROFILE_CLOSURE(Scav, size);
- NEXT_Scav(size);
- return;
-}
-
-#ifdef PAR
-
-void
-_Scavenge_FetchMe(STG_NO_ARGS)
-{
- I_ size = FETCHME_CLOSURE_SIZE(dummy);
- DEBUG_SCAV(size,0);
- PROFILE_CLOSURE(Scav,size);
- NEXT_Scav(size);
- return;
-}
-
-void
-_Scavenge_BF(STG_NO_ARGS)
-{
- I_ size = BF_CLOSURE_SIZE(dummy);
-#if defined(GCgn)
- P_ save_Scav;
-#endif
-
- DEBUG_SCAV_BF;
-
-#if defined(GCgn)
- /* No old generation roots should be created for mutable */
- /* pointer fields as they will be explicitly collected */
- /* Ensure this by pointing Scav at the new generation */
- save_Scav = Scav;
- Scav = OldGen + 1;
-
- DO_EVACUATE(save_Scav, BF_LINK_LOCN);
- DO_EVACUATE(save_Scav, BF_NODE_LOCN);
- Scav = save_Scav;
-#else
- DO_EVACUATE(Scav, BF_LINK_LOCN);
- DO_EVACUATE(Scav, BF_NODE_LOCN);
-#endif
-
- PROFILE_CLOSURE(Scav, size);
- NEXT_Scav(size);
- return;
-}
-
-#endif /* PAR */
-#endif /* CONCURRENT */
-
-#if defined(GCgn)
-
-/* Recently allocated old roots for promoted objects refernecing
- the new generation will be scavenged -- Just move to the next
-*/
-
-void
-_Scavenge_OldRoot(STG_NO_ARGS)
-{
- I_ size = ?????
- DEBUG_SCAV_OLDROOT(size);
- NEXT_Scav(size);
- return;
-}
-
-P_
-_Evacuate_OldRoot(evac)
-P_ evac;
-{
- fprintf(stderr,"Called _Evacuate_OldRoot: Closure %lx Info %lx\nShould never occur!\n",
- (W_) evac, (W_) INFO_PTR(evac));
- abort();
-}
-
-#endif /* GCgn */
-
-void
-_Scavenge_Forward_Ref(STG_NO_ARGS)
-{
- fprintf(stderr,"Called _Scavenge_Forward_Ref: Closure %lx Info %lx\nShould never occur!\n",
- (W_) Scav, (W_) INFO_PTR(Scav));
- abort();
-}
-
-
-#endif /* _INFO_COPYING */
-
-\end{code}
+++ /dev/null
-\section[SMstacks.lc]{Stack allocation (sequential)}
-
-Routine that allocates the A and B stack (sequential only).
-
-\begin{code}
-#ifndef PAR
-# define NULL_REG_MAP
-# include "SMinternal.h"
-
-#if 1 /* ndef CONCURRENT */ /* HWL */
-stackData stackInfo;
-#endif
-
-P_ stks_space = 0;
-
-#ifdef CONCURRENT
-EXTDATA_RO(StkO_static_info);
-P_ MainStkO;
-#endif
-
-rtsBool
-initStacks(smInfo *sm)
-{
- /*
- * Allocate them if they don't exist. One space does for both stacks, since they
- * grow towards each other
- */
- if (stks_space == 0) {
-#ifndef CONCURRENT
- stks_space = (P_) stgMallocWords(RTSflags.GcFlags.stksSize, "initStacks");
-#else
- MainStkO = (P_) stgMallocWords(STKO_HS + RTSflags.GcFlags.stksSize, "initStacks");
- stks_space = MainStkO + STKO_HS;
- SET_STKO_HDR(MainStkO, StkO_static_info, CC_SUBSUMED);
- STKO_SIZE(MainStkO) = RTSflags.GcFlags.stksSize + STKO_VHS;
- STKO_SpB(MainStkO) = STKO_SuB(MainStkO) = STKO_BSTK_BOT(MainStkO) + BREL(1);
- STKO_SpA(MainStkO) = STKO_SuA(MainStkO) = STKO_ASTK_BOT(MainStkO) + AREL(1);
- STKO_LINK(MainStkO) = PrelBase_Z91Z93_closure;
- STKO_RETURN(MainStkO) = NULL;
-
- ASSERT(sanityChk_StkO(MainStkO));
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "STACK init: botA, spa: 0x%lx, 0x%lx\n botB, spb: 0x%lx, 0x%lx\n",
- (W_) STKO_ASTK_BOT(MainStkO), (W_) STKO_SpA(MainStkO), (W_) STKO_BSTK_BOT(MainStkO), (W_) STKO_SpB(MainStkO));
-#endif
- }
-
-# if STACK_CHECK_BY_PAGE_FAULT
- unmapMiddleStackPage((char *) stks_space, RTSflags.GcFlags.stksSize * sizeof(W_));
-# endif
-
- /* Initialise Stack Info and pointers */
-#if 1 /* ndef CONCURRENT */ /* HWL */
- stackInfo.botA = STK_A_FRAME_BASE(stks_space, RTSflags.GcFlags.stksSize);
- stackInfo.botB = STK_B_FRAME_BASE(stks_space, RTSflags.GcFlags.stksSize);
-
- MAIN_SuA = MAIN_SpA = stackInfo.botA + AREL(1);
- MAIN_SuB = MAIN_SpB = stackInfo.botB + BREL(1);
-
- if (RTSflags.GcFlags.trace)
- fprintf(stderr, "STACK init: botA, spa: 0x%lx, 0x%lx\n botB, spb: 0x%lx, 0x%lx\n",
- (W_) stackInfo.botA, (W_) MAIN_SpA, (W_) stackInfo.botB, (W_) MAIN_SpB);
-#endif /* !CONCURRENT */
-
- return rtsTrue;
-}
-
-#endif /* not parallel */
-\end{code}
+++ /dev/null
-***************************************************************************
-
- STATIC closures -- INTLIKE and CHARLIKE stuff.
-
-***************************************************************************
-
-@Prelude_CZh_entry@, @Prelude_CZh_static_info@, @Prelude_IZh_entry@ and @Prelude_IZh_static_info@
-are built by the compiler from {\tr uTys.hs}.
-
-\begin{code}
-#define NULL_REG_MAP
-#include "SMinternal.h"
-
-EXTDATA_RO(PrelBase_CZh_static_info);
-EXTDATA_RO(PrelBase_IZh_static_info);
-
-#define __CHARLIKE_CLOSURE(n) (CHARLIKE_closures+((n)*(CHARLIKE_HS+1)))
-#define __INTLIKE_CLOSURE(n) (INTLIKE_closures_def+(((n)-MIN_INTLIKE)*(INTLIKE_HS+1)))
-
-#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),PrelBase_CZh_static_info,CC_DONTZuCARE), (W_) n
-
-#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),PrelBase_IZh_static_info,CC_DONTZuCARE), (W_) n
-
-#ifndef aix_TARGET_OS /* AIX gives link errors with consts in this file (RO assembler section) */
-const
-#endif
- W_ CHARLIKE_closures[] = {
- CHARLIKE_HDR(0),
- CHARLIKE_HDR(1),
- CHARLIKE_HDR(2),
- CHARLIKE_HDR(3),
- CHARLIKE_HDR(4),
- CHARLIKE_HDR(5),
- CHARLIKE_HDR(6),
- CHARLIKE_HDR(7),
- CHARLIKE_HDR(8),
- CHARLIKE_HDR(9),
- CHARLIKE_HDR(10),
- CHARLIKE_HDR(11),
- CHARLIKE_HDR(12),
- CHARLIKE_HDR(13),
- CHARLIKE_HDR(14),
- CHARLIKE_HDR(15),
- CHARLIKE_HDR(16),
- CHARLIKE_HDR(17),
- CHARLIKE_HDR(18),
- CHARLIKE_HDR(19),
- CHARLIKE_HDR(20),
- CHARLIKE_HDR(21),
- CHARLIKE_HDR(22),
- CHARLIKE_HDR(23),
- CHARLIKE_HDR(24),
- CHARLIKE_HDR(25),
- CHARLIKE_HDR(26),
- CHARLIKE_HDR(27),
- CHARLIKE_HDR(28),
- CHARLIKE_HDR(29),
- CHARLIKE_HDR(30),
- CHARLIKE_HDR(31),
- CHARLIKE_HDR(32),
- CHARLIKE_HDR(33),
- CHARLIKE_HDR(34),
- CHARLIKE_HDR(35),
- CHARLIKE_HDR(36),
- CHARLIKE_HDR(37),
- CHARLIKE_HDR(38),
- CHARLIKE_HDR(39),
- CHARLIKE_HDR(40),
- CHARLIKE_HDR(41),
- CHARLIKE_HDR(42),
- CHARLIKE_HDR(43),
- CHARLIKE_HDR(44),
- CHARLIKE_HDR(45),
- CHARLIKE_HDR(46),
- CHARLIKE_HDR(47),
- CHARLIKE_HDR(48),
- CHARLIKE_HDR(49),
- CHARLIKE_HDR(50),
- CHARLIKE_HDR(51),
- CHARLIKE_HDR(52),
- CHARLIKE_HDR(53),
- CHARLIKE_HDR(54),
- CHARLIKE_HDR(55),
- CHARLIKE_HDR(56),
- CHARLIKE_HDR(57),
- CHARLIKE_HDR(58),
- CHARLIKE_HDR(59),
- CHARLIKE_HDR(60),
- CHARLIKE_HDR(61),
- CHARLIKE_HDR(62),
- CHARLIKE_HDR(63),
- CHARLIKE_HDR(64),
- CHARLIKE_HDR(65),
- CHARLIKE_HDR(66),
- CHARLIKE_HDR(67),
- CHARLIKE_HDR(68),
- CHARLIKE_HDR(69),
- CHARLIKE_HDR(70),
- CHARLIKE_HDR(71),
- CHARLIKE_HDR(72),
- CHARLIKE_HDR(73),
- CHARLIKE_HDR(74),
- CHARLIKE_HDR(75),
- CHARLIKE_HDR(76),
- CHARLIKE_HDR(77),
- CHARLIKE_HDR(78),
- CHARLIKE_HDR(79),
- CHARLIKE_HDR(80),
- CHARLIKE_HDR(81),
- CHARLIKE_HDR(82),
- CHARLIKE_HDR(83),
- CHARLIKE_HDR(84),
- CHARLIKE_HDR(85),
- CHARLIKE_HDR(86),
- CHARLIKE_HDR(87),
- CHARLIKE_HDR(88),
- CHARLIKE_HDR(89),
- CHARLIKE_HDR(90),
- CHARLIKE_HDR(91),
- CHARLIKE_HDR(92),
- CHARLIKE_HDR(93),
- CHARLIKE_HDR(94),
- CHARLIKE_HDR(95),
- CHARLIKE_HDR(96),
- CHARLIKE_HDR(97),
- CHARLIKE_HDR(98),
- CHARLIKE_HDR(99),
- CHARLIKE_HDR(100),
- CHARLIKE_HDR(101),
- CHARLIKE_HDR(102),
- CHARLIKE_HDR(103),
- CHARLIKE_HDR(104),
- CHARLIKE_HDR(105),
- CHARLIKE_HDR(106),
- CHARLIKE_HDR(107),
- CHARLIKE_HDR(108),
- CHARLIKE_HDR(109),
- CHARLIKE_HDR(110),
- CHARLIKE_HDR(111),
- CHARLIKE_HDR(112),
- CHARLIKE_HDR(113),
- CHARLIKE_HDR(114),
- CHARLIKE_HDR(115),
- CHARLIKE_HDR(116),
- CHARLIKE_HDR(117),
- CHARLIKE_HDR(118),
- CHARLIKE_HDR(119),
- CHARLIKE_HDR(120),
- CHARLIKE_HDR(121),
- CHARLIKE_HDR(122),
- CHARLIKE_HDR(123),
- CHARLIKE_HDR(124),
- CHARLIKE_HDR(125),
- CHARLIKE_HDR(126),
- CHARLIKE_HDR(127),
- CHARLIKE_HDR(128),
- CHARLIKE_HDR(129),
- CHARLIKE_HDR(130),
- CHARLIKE_HDR(131),
- CHARLIKE_HDR(132),
- CHARLIKE_HDR(133),
- CHARLIKE_HDR(134),
- CHARLIKE_HDR(135),
- CHARLIKE_HDR(136),
- CHARLIKE_HDR(137),
- CHARLIKE_HDR(138),
- CHARLIKE_HDR(139),
- CHARLIKE_HDR(140),
- CHARLIKE_HDR(141),
- CHARLIKE_HDR(142),
- CHARLIKE_HDR(143),
- CHARLIKE_HDR(144),
- CHARLIKE_HDR(145),
- CHARLIKE_HDR(146),
- CHARLIKE_HDR(147),
- CHARLIKE_HDR(148),
- CHARLIKE_HDR(149),
- CHARLIKE_HDR(150),
- CHARLIKE_HDR(151),
- CHARLIKE_HDR(152),
- CHARLIKE_HDR(153),
- CHARLIKE_HDR(154),
- CHARLIKE_HDR(155),
- CHARLIKE_HDR(156),
- CHARLIKE_HDR(157),
- CHARLIKE_HDR(158),
- CHARLIKE_HDR(159),
- CHARLIKE_HDR(160),
- CHARLIKE_HDR(161),
- CHARLIKE_HDR(162),
- CHARLIKE_HDR(163),
- CHARLIKE_HDR(164),
- CHARLIKE_HDR(165),
- CHARLIKE_HDR(166),
- CHARLIKE_HDR(167),
- CHARLIKE_HDR(168),
- CHARLIKE_HDR(169),
- CHARLIKE_HDR(170),
- CHARLIKE_HDR(171),
- CHARLIKE_HDR(172),
- CHARLIKE_HDR(173),
- CHARLIKE_HDR(174),
- CHARLIKE_HDR(175),
- CHARLIKE_HDR(176),
- CHARLIKE_HDR(177),
- CHARLIKE_HDR(178),
- CHARLIKE_HDR(179),
- CHARLIKE_HDR(180),
- CHARLIKE_HDR(181),
- CHARLIKE_HDR(182),
- CHARLIKE_HDR(183),
- CHARLIKE_HDR(184),
- CHARLIKE_HDR(185),
- CHARLIKE_HDR(186),
- CHARLIKE_HDR(187),
- CHARLIKE_HDR(188),
- CHARLIKE_HDR(189),
- CHARLIKE_HDR(190),
- CHARLIKE_HDR(191),
- CHARLIKE_HDR(192),
- CHARLIKE_HDR(193),
- CHARLIKE_HDR(194),
- CHARLIKE_HDR(195),
- CHARLIKE_HDR(196),
- CHARLIKE_HDR(197),
- CHARLIKE_HDR(198),
- CHARLIKE_HDR(199),
- CHARLIKE_HDR(200),
- CHARLIKE_HDR(201),
- CHARLIKE_HDR(202),
- CHARLIKE_HDR(203),
- CHARLIKE_HDR(204),
- CHARLIKE_HDR(205),
- CHARLIKE_HDR(206),
- CHARLIKE_HDR(207),
- CHARLIKE_HDR(208),
- CHARLIKE_HDR(209),
- CHARLIKE_HDR(210),
- CHARLIKE_HDR(211),
- CHARLIKE_HDR(212),
- CHARLIKE_HDR(213),
- CHARLIKE_HDR(214),
- CHARLIKE_HDR(215),
- CHARLIKE_HDR(216),
- CHARLIKE_HDR(217),
- CHARLIKE_HDR(218),
- CHARLIKE_HDR(219),
- CHARLIKE_HDR(220),
- CHARLIKE_HDR(221),
- CHARLIKE_HDR(222),
- CHARLIKE_HDR(223),
- CHARLIKE_HDR(224),
- CHARLIKE_HDR(225),
- CHARLIKE_HDR(226),
- CHARLIKE_HDR(227),
- CHARLIKE_HDR(228),
- CHARLIKE_HDR(229),
- CHARLIKE_HDR(230),
- CHARLIKE_HDR(231),
- CHARLIKE_HDR(232),
- CHARLIKE_HDR(233),
- CHARLIKE_HDR(234),
- CHARLIKE_HDR(235),
- CHARLIKE_HDR(236),
- CHARLIKE_HDR(237),
- CHARLIKE_HDR(238),
- CHARLIKE_HDR(239),
- CHARLIKE_HDR(240),
- CHARLIKE_HDR(241),
- CHARLIKE_HDR(242),
- CHARLIKE_HDR(243),
- CHARLIKE_HDR(244),
- CHARLIKE_HDR(245),
- CHARLIKE_HDR(246),
- CHARLIKE_HDR(247),
- CHARLIKE_HDR(248),
- CHARLIKE_HDR(249),
- CHARLIKE_HDR(250),
- CHARLIKE_HDR(251),
- CHARLIKE_HDR(252),
- CHARLIKE_HDR(253),
- CHARLIKE_HDR(254),
- CHARLIKE_HDR(255)
-};
-
-static
-#ifndef aix_TARGET_OS /* AIX gives link errors with consts in this file (RO assembler section) */
- const
-#endif
- W_ INTLIKE_closures_def[] = {
- INTLIKE_HDR(-16), /* MIN_INTLIKE == -16 */
- INTLIKE_HDR(-15),
- INTLIKE_HDR(-14),
- INTLIKE_HDR(-13),
- INTLIKE_HDR(-12),
- INTLIKE_HDR(-11),
- INTLIKE_HDR(-10),
- INTLIKE_HDR(-9),
- INTLIKE_HDR(-8),
- INTLIKE_HDR(-7),
- INTLIKE_HDR(-6),
- INTLIKE_HDR(-5),
- INTLIKE_HDR(-4),
- INTLIKE_HDR(-3),
- INTLIKE_HDR(-2),
- INTLIKE_HDR(-1),
- INTLIKE_HDR(0),
- INTLIKE_HDR(1),
- INTLIKE_HDR(2),
- INTLIKE_HDR(3),
- INTLIKE_HDR(4),
- INTLIKE_HDR(5),
- INTLIKE_HDR(6),
- INTLIKE_HDR(7),
- INTLIKE_HDR(8),
- INTLIKE_HDR(9),
- INTLIKE_HDR(10),
- INTLIKE_HDR(11),
- INTLIKE_HDR(12),
- INTLIKE_HDR(13),
- INTLIKE_HDR(14),
- INTLIKE_HDR(15),
- INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */
-};
-
-const P_ INTLIKE_closures = (const P_) __INTLIKE_CLOSURE(0);
-
-\end{code}
+++ /dev/null
-*********************************************************************
-
- Stuff for printing out GC statistics
-
-usertime() -- The current user time in seconds
-elapsedtime() -- The current elapsed time in seconds
-
-stat_init
-stat_startGC
-stat_endGC
-stat_exit
-
-*********************************************************************
-
-\begin{code}
-#if !defined(_AIX)
-#define NON_POSIX_SOURCE /*needed for solaris2 only?*/
-#endif
-
-#define NULL_REG_MAP
-#include "SMinternal.h"
-#include "Ticky.h"
-
-#ifdef hpux_TARGET_OS
-#define _INCLUDE_HPUX_SOURCE
-#endif
-
-#ifdef solaris2_TARGET_OS
-#define __EXTENSIONS__
-#endif
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_SYS_TIMES_H
-#include <sys/times.h>
-#endif
-
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#endif
-
-#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS
-#include <sys/resource.h>
-#endif
-
-#ifdef HAVE_SYS_TIMEB_H
-#include <sys/timeb.h>
-#endif
-
-#ifdef hpux_TARGET_OS
-#include <sys/syscall.h>
-#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
-#define HAVE_GETRUSAGE
-#endif
-
-/*
- getrusage() is not the preferred way of getting at process-specific
- info under Solaris...at least it wasn't. It was supported via a BSD
- compatibility library in 2.4, whereas 2.5 has it in libc.
-
- The upshot of this change of heart is that we cannot rely on getrusage()
- being available via libc, i.e., 2.5 binaries will not run under 2.4
- without some extra work. Could use libucb under 2.5 as well, but
- a simpler solution is simply to avoid the problem and stay away
- from getrusage() for Solaris -- SOF
-*/
-#if solaris2_TARGET_OS
-#include <sys/fcntl.h>
-#include <sys/signal.h>
-#include <sys/procfs.h>
-#endif
-
-static StgDouble GC_start_time, GC_tot_time = 0; /* User GC Time */
-static StgDouble GCe_start_time, GCe_tot_time = 0; /* Elapsed GC time */
-
-#if defined(GCap) || defined(GCgn)
-static StgDouble GC_min_time = 0;
-static StgDouble GCe_min_time = 0;
-
-static I_ GC_min_no = 0;
-static I_ GC_min_since_maj = 0;
-static I_ GC_live_maj = 0; /* Heap live at last major collection */
-static I_ GC_alloc_since_maj = 0; /* Heap alloc since collection major */
-#endif
-
-static I_ GC_maj_no = 0;
-static ullong GC_tot_alloc = 0; /* Total heap allocated -- 64 bits? */
-
-static I_ GC_start_faults = 0, GC_end_faults = 0;
-
-char *
-ullong_format_string(ullong x, char *s, rtsBool with_commas)
-{
- if (x < (ullong)1000)
- sprintf(s, "%ld", (I_)x);
- else if (x < (ullong)1000000)
- sprintf(s, (with_commas) ? "%ld,%3.3ld" : "%ld%3.3ld",
- (I_)((x)/(ullong)1000),
- (I_)((x)%(ullong)1000));
- else if (x < (ullong)1000000000)
- sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld",
- (I_)((x)/(ullong)1000000),
- (I_)((x)/(ullong)1000%(ullong)1000),
- (I_)((x)%(ullong)1000));
- else
- sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld%3.3ld",
- (I_)((x)/(ullong)1000000000),
- (I_)((x)/(ullong)1000000%(ullong)1000),
- (I_)((x)/(ullong)1000%(ullong)1000),
- (I_)((x)%(ullong)1000));
- return s;
-}
-
-/* "constants" for "usertime" and "elapsedtime" */
-
-static StgDouble ElapsedTimeStart = 0.0; /* setup when beginning things */
-static StgDouble TicksPerSecond = 0.0; /* ditto */
-
-/* usertime() -- The current user time in seconds */
-
-StgDouble
-usertime()
-{
-#if ! (defined(HAVE_GETRUSAGE) || defined(HAVE_TIMES))
- /* We will #ifdef around the fprintf for machines
- we *know* are unsupported. (WDP 94/05)
- */
- fprintf(stderr, "NOTE: `usertime' does nothing!\n");
- return 0.0;
-
-#else /* not stumped */
-
-# if defined(HAVE_TIMES)
- struct tms t;
-
- times(&t);
- return(((StgDouble)(t.tms_utime))/TicksPerSecond);
-
-#else /* HAVE_GETRUSAGE */
- struct rusage t;
-
- getrusage(RUSAGE_SELF, &t);
- return(t.ru_utime.tv_sec + 1e-6*t.ru_utime.tv_usec);
-
-# endif /* HAVE_GETRUSAGE */
-#endif /* not stumped */
-}
-
-
-/* elapsedtime() -- The current elapsed time in seconds */
-
-StgDouble
-elapsedtime()
-{
-#if ! (defined(HAVE_TIMES) || defined(HAVE_FTIME))
- /* We will #ifdef around the fprintf for machines
- we *know* are unsupported. (WDP 94/05)
- */
- fprintf(stderr, "NOTE: `elapsedtime' does nothing!\n");
- return 0.0;
-
-#else /* not stumped */
-
-/* "ftime" may be nicer, but "times" is more standard;
- but, on a Sun, if you do not get the SysV one, you are *hosed*...
- */
-
-# if defined(HAVE_TIMES) && ! sunos4_TARGET_OS
- struct tms t;
-
- return (((StgDouble) times(&t))/TicksPerSecond - ElapsedTimeStart);
-
-# else /* HAVE_FTIME */
- struct timeb t;
-
- ftime(&t);
- return (fabs(t.time + 1e-3*t.millitm - ElapsedTimeStart));
-
-# endif /* HAVE_FTIME */
-#endif /* not stumped */
-}
-
-void
-start_time(STG_NO_ARGS)
-{
- long ticks;
-
- /* Determine TicksPerSecond ... */
-#ifdef HAVE_SYSCONF
- ticks = sysconf(_SC_CLK_TCK);
- if ( ticks == -1 ) {
- fprintf(stderr, "stat_init: bad call to 'sysconf'!\n");
- EXIT(EXIT_FAILURE);
- }
- TicksPerSecond = (StgDouble) ticks;
-
-#else /* no "sysconf"; had better guess */
-# ifdef HZ
- TicksPerSecond = (StgDouble) (HZ);
-
-# else /* had better guess wildly */
- /* We will #ifdef around the fprintf for machines
- we *know* are unsupported. (WDP 94/05)
- */
- fprintf(stderr, "NOTE: Guessing `TicksPerSecond = 60'!\n");
- TicksPerSecond = 60.0;
- return;
-# endif
-#endif
- ElapsedTimeStart = elapsedtime();
-}
-
-static StgDouble InitUserTime = 0.0; /* user time taken for initialization */
-static StgDouble InitElapsedTime = 0.0; /* elapsed time taken for initialization */
-
-void end_init(STG_NO_ARGS)
-{
- InitUserTime = usertime();
- InitElapsedTime = elapsedtime();
-}
-
-#if defined(solaris2_TARGET_OS)
-static I_
-pagefaults(STG_NO_ARGS)
-{
- int fd;
- char proc[30]; /* Will break when PIDs are repr. by more than 64bits */
- prusage_t prusage;
-
- /* Under Solaris, we get at the number of major page faults
- via the process file descriptor and ioctl()ing with
- PIOCUSAGE to get the prusage_t structure.
- (as per proc(4) man page and Solaris porting FAQ).
- */
- sprintf(proc,"/proc/%d", getpid()); /* ToDo: this string is static
- per process, optimise? */
-
- while ((fd = open(proc, O_RDONLY)) == -1 ) {
- if ( errno != EINTR ) {
- fflush(stdout);
- fprintf(stderr,"pagefaults: open() failed\n");
- EXIT(EXIT_FAILURE);
- }
- }
- while (ioctl(fd, PIOCUSAGE, &prusage) == -1 ) {
- if (errno != EINTR) {
- fflush(stdout);
- fprintf(stderr,"pagefaults: ioctl() failed\n");
- EXIT(EXIT_FAILURE);
- }
- }
- while ((close(fd)) == -1 ) {
- if (errno != EINTR) {
- fflush(stdout);
- fprintf(stderr, "pagefaults: close() failed\n");
- EXIT(EXIT_FAILURE);
- }
- }
- return prusage.pr_majf;
-}
-#else
-
-static I_
-pagefaults(STG_NO_ARGS)
-{
-# if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS
- return 0;
-# else
- struct rusage t;
-
- getrusage(RUSAGE_SELF, &t);
- /* cygwin32 note: Last time I looked (b18), the ru_majflt field
- was always filled in with a 0. -- SOF (ToDo: Win32ify?)
- */
- return(t.ru_majflt);
-# endif
-}
-#endif
-
-/* Called at the beginning of execution of the program */
-/* Writes the command line and inits stats header */
-
-void
-stat_init(char *collector, char *comment1, char *comment2)
-{
- FILE *sf = RTSflags.GcFlags.statsFile;
-
- if (sf != NULL) {
- char temp[BIG_STRING_LEN];
- ullong_format_string( (ullong)RTSflags.GcFlags.heapSize*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(sf, "\nCollector: %s HeapSize: %s (bytes)\n\n", collector, temp);
- if (RTSflags.GcFlags.giveStats) {
-#if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS
- fprintf(sf, "NOTE: `pagefaults' does nothing!\n");
-#endif
- fprintf(sf,
-/*######## ####### ####### ##.# ##.## ##.## ####.## ####.## #### ####*/
- " Alloc Collect Live Resid GC GC TOT TOT Page Flts %s\n",
- comment1);
- fprintf(sf,
- " bytes bytes bytes ency user elap user elap GC MUT %s\n",
- comment2);
- }
-
-#if defined(GCap) || defined(GCgn)
- else {
- fprintf(sf,
-/*######## ####### ##.# ####### ##.# ### ##.## ##.## ##.## ##.## ####.## ####.## #### ####*/
- " Alloc Promote Promo Live Resid Minor Minor Minor Major Major TOT TOT Page Flts\n");
- fprintf(sf,
- " bytes bytes ted bytes ency No user elap user elap user elap MUT Major\n");
- }
-#endif /* generational */
-
- fflush(sf);
- }
-}
-
-/* Called at the beginning of each GC */
-static I_ rub_bell = 0;
-
-void
-stat_startGC(I_ alloc)
-{
- FILE *sf = RTSflags.GcFlags.statsFile;
-
-#if defined(GCap) || defined(GCgn)
- I_ bell = alloc == 0 ? RTSflags.GcFlags.ringBell : 0;
-#else /* ! generational */
- I_ bell = RTSflags.GcFlags.ringBell;
-#endif /* ! generational */
-
- if (bell) {
- if (bell > 1) {
- fprintf(stderr, " GC ");
- rub_bell = 1;
- } else {
- fprintf(stderr, "\007");
- }
- }
-
- if (sf != NULL) {
- GC_start_time = usertime();
- GCe_start_time = elapsedtime();
-
-#if defined(GCap) || defined(GCgn)
- if (RTSflags.GcFlags.giveStats || alloc == 0) {
- GC_start_faults = pagefaults();
- }
-#else /* ! generational */
- if (RTSflags.GcFlags.giveStats) {
- GC_start_faults = pagefaults();
- }
-#endif /* ! generational */
-
- }
-}
-
-/* Called at the end of each GC */
-
-void
-stat_endGC(I_ alloc, I_ collect, I_ live, char *comment)
-{
- FILE *sf = RTSflags.GcFlags.statsFile;
-
- if (sf != NULL) {
- StgDouble time = usertime();
- StgDouble etime = elapsedtime();
-
- if (RTSflags.GcFlags.giveStats) {
- I_ faults = pagefaults();
-
- fprintf(sf, "%8ld %7ld %7ld %5.1f%%",
- alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_), collect == 0 ? 0.0 : (live / (StgDouble) collect * 100));
- fprintf(sf, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld %s\n",
- (time-GC_start_time),
- (etime-GCe_start_time),
- time,
- etime,
- faults - GC_start_faults,
- GC_start_faults - GC_end_faults,
- comment);
-
- GC_end_faults = faults;
- fflush(sf);
- }
-
-#if defined(GCap) || defined(GCgn)
- else if(alloc == 0 && collect != 0) {
- I_ faults = pagefaults();
-
- fprintf(sf, "%8ld %7ld %5.1f%% %7ld %5.1f%%",
- GC_alloc_since_maj*sizeof(W_), (collect - GC_live_maj)*sizeof(W_),
- (collect - GC_live_maj) / (StgDouble) GC_alloc_since_maj * 100,
- live*sizeof(W_), live / (StgDouble) RTSflags.GcFlags.heapSize * 100);
- fprintf(sf, " %3ld %5.2f %5.2f %5.2f %5.2f %7.2f %7.2f %4ld %4ld\n",
- GC_min_since_maj, GC_min_time, GCe_min_time,
- (time-GC_start_time),
- (etime-GCe_start_time),
- time,
- etime,
- faults - GC_start_faults,
- GC_start_faults - GC_end_faults
- );
-
- GC_end_faults = faults;
- fflush(sf);
- }
-#endif /* generational */
-
-#if defined(GCap) || defined(GCgn)
- if (alloc == 0 && collect != 0) {
- GC_maj_no++;
- GC_live_maj = live;
- GC_min_no += GC_min_since_maj;
- GC_min_since_maj = 0;
- GC_tot_alloc += (ullong) GC_alloc_since_maj;
- GC_alloc_since_maj = 0;
- GC_tot_time += time-GC_start_time + GC_min_time;
- GC_min_time = 0;
- GCe_tot_time += etime-GCe_start_time + GCe_min_time;
- GCe_min_time = 0;
- } else {
- GC_min_since_maj++;
- GC_alloc_since_maj += alloc;
- GC_min_time += time-GC_start_time;
- GCe_min_time += etime-GCe_start_time;
- }
-#else /* ! generational */
- GC_maj_no++;
- GC_tot_alloc += (ullong) alloc;
- GC_tot_time += time-GC_start_time;
- GCe_tot_time += etime-GCe_start_time;
-#endif /* ! generational */
-
- }
-
- if (rub_bell) {
- fprintf(stderr, "\b\b\b \b\b\b");
- rub_bell = 0;
- }
-}
-
-/* Called at the end of execution -- to print a summary of statistics */
-
-void
-stat_exit(I_ alloc)
-{
- FILE *sf = RTSflags.GcFlags.statsFile;
-
- if (sf != NULL){
- char temp[BIG_STRING_LEN];
- StgDouble time = usertime();
- StgDouble etime = elapsedtime();
-
- /* avoid divide by zero if time is measured as 0.00 seconds -- SDM */
- if (time == 0.0) time = 0.0001;
- if (etime == 0.0) etime = 0.0001;
-
-
- if (RTSflags.GcFlags.giveStats) {
- fprintf(sf, "%8ld\n\n", alloc*sizeof(W_));
- }
-
-#if defined(GCap) || defined (GCgn)
- else {
- fprintf(sf, "%8ld %7.7s %6.6s %7.7s %6.6s",
- (GC_alloc_since_maj + alloc)*sizeof(W_), "", "", "", "");
- fprintf(sf, " %3ld %5.2f %5.2f\n\n",
- GC_min_since_maj, GC_min_time, GCe_min_time);
- }
- GC_min_no += GC_min_since_maj;
- GC_tot_time += GC_min_time;
- GCe_tot_time += GCe_min_time;
- GC_tot_alloc += (ullong) (GC_alloc_since_maj + alloc);
- ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(sf, "%11s bytes allocated in the heap\n", temp);
- if ( ResidencySamples > 0 ) {
- ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(sf, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
- temp,
- MaxResidency / (StgDouble) RTSflags.GcFlags.heapSize * 100,
- ResidencySamples);
- }
- fprintf(sf, "%11ld garbage collections performed (%ld major, %ld minor)\n\n",
- GC_maj_no + GC_min_no, GC_maj_no, GC_min_no);
-
-#else /* ! generational */
-
- GC_tot_alloc += (ullong) alloc;
- ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(sf, "%11s bytes allocated in the heap\n", temp);
- if ( ResidencySamples > 0 ) {
- ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(sf, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
- temp,
- MaxResidency / (StgDouble) RTSflags.GcFlags.heapSize * 100,
- ResidencySamples);
- }
- fprintf(sf, "%11ld garbage collections performed\n\n", GC_maj_no);
-
-#endif /* ! generational */
-
- fprintf(sf, " INIT time %6.2fs (%6.2fs elapsed)\n",
- InitUserTime, InitElapsedTime);
- fprintf(sf, " MUT time %6.2fs (%6.2fs elapsed)\n",
- time - GC_tot_time - InitUserTime,
- etime - GCe_tot_time - InitElapsedTime);
- fprintf(sf, " GC time %6.2fs (%6.2fs elapsed)\n",
- GC_tot_time, GCe_tot_time);
- fprintf(sf, " Total time %6.2fs (%6.2fs elapsed)\n\n",
- time, etime);
-
- fprintf(sf, " %%GC time %5.1f%% (%.1f%% elapsed)\n\n",
- GC_tot_time*100./time, GCe_tot_time*100./etime);
-
- if (time - GC_tot_time == 0.0)
- ullong_format_string((ullong)0, temp, rtsTrue/*commas*/);
- else
- ullong_format_string((ullong)(GC_tot_alloc*sizeof(W_)/(time - GC_tot_time)),
- temp, rtsTrue/*commas*/);
-
- fprintf(sf, " Alloc rate %s bytes per MUT second\n\n", temp);
-
- fprintf(sf, " Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n",
- (time - GC_tot_time - InitUserTime) * 100. / time,
- (time - GC_tot_time - InitUserTime) * 100. / etime);
- fflush(sf);
- fclose(sf);
- }
-}
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1995
-%
-%************************************************************************
-%* *
-\section[mprotect.lc]{Memory Protection}
-%* *
-%************************************************************************
-
-Is @mprotect@ POSIX now? [Yup, POSIX.4 -- sof]
-
-\begin{code}
-#if STACK_CHECK_BY_PAGE_FAULT
-
-/* #define STK_CHK_DEBUG */
-
-#include "rtsdefs.h"
-
-# ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-# endif
-
-# ifdef HAVE_SYS_MMAN_H
-# include <sys/mman.h>
-# endif
-
-# if defined(_SC_PAGE_SIZE) && !defined(_SC_PAGESIZE)
- /* Death to HP-UX. What are standards for, anyway??? */
-# define _SC_PAGESIZE _SC_PAGE_SIZE
-# endif
-
-# if defined(_SC_PAGESIZE)
-# define GETPAGESIZE() sysconf(_SC_PAGESIZE)
-# else
-# if defined(HAVE_GETPAGESIZE)
-# define GETPAGESIZE() getpagesize()
-# else
-# if defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS)
-# /* it has it, but it is in BSD land; easier to just say so */
-# define GETPAGESIZE() getpagesize()
-# else
-# error getpagesize
-# endif
-# endif
-# endif
-
-#if defined(sunos4_TARGET_OS)
-int getpagesize PROTO((void));
-int mprotect PROTO((caddr_t, size_t, int));
-#endif
-
-#if defined(aix_TARGET_OS)
-/* PROT_NONE doesn't work on aix, PROT_READ works and should suit the job */
-#define PROT_NONE PROT_READ
-#endif
-
-/* Needed for FreeBSD (SDM, 96/03) */
-#ifndef PROT_NONE
-#define PROT_NONE 0
-#endif
-
-/* For VirtualProtect() and its flags */
-#if defined(cygwin32_TARGET_OS)
-#include <windows.h>
-#endif
-
-void
-unmapMiddleStackPage(addr, size)
-char * /*caddr_t*/ addr;
-int size;
-{
- int pagesize = GETPAGESIZE();
- char * middle = (char *) (((W_) (addr + size / 2)) / pagesize * pagesize);
-#if defined(cygwin32_TARGET_OS)
- unsigned int old_prot;
-#endif
-
-# ifdef STK_CHK_DEBUG
- fprintf(stderr, "pagesize: %x\nstack start: %08lx\nstack size: %08lx\nstack middle: %08lx\n",
- pagesize, addr, size, middle);
-# endif
-
- if (middle < addr || middle + pagesize > addr + size) {
- fprintf(stderr, "Stack too small; stack overflow trap disabled.\n");
- return;
- }
-/* mprotect() is broken in beta18, so we use the native Win32
- call instead
-*/
-#if defined(cygwin32_TARGET_OS)
- if (VirtualProtect(middle, pagesize, PAGE_NOACCESS, &old_prot) == 0) {
-#else
- if (mprotect(middle, pagesize, PROT_NONE) == -1) {
-#endif
- perror("mprotect");
- EXIT(EXIT_FAILURE);
- }
- if (install_segv_handler()) {
- fprintf(stderr, "Can't install SIGSEGV handler for stack overflow check.\n");
- EXIT(EXIT_FAILURE);
- }
-}
-
-#endif /* STACK_CHECK_BY_PAGE_FAULT */
-\end{code}
SCRIPT_OBJS=mkdependHS.prl
SCRIPT_SUBST_VARS= \
TOP_PWD \
- INSTALLING \
- ProjectVersionInt
+ INSTALLING
INTERP=perl
#
# RAWCPP TMPDIR TOP_PWD
# libdir libexecdir datadir INSTALLING
-# ProjectVersionInt SED
+# SED
#
# tries to work like mkdependC - capable of dealing with:
#
$Makefile = '';
@Src_files = ();
$Include_prelude = 0;
+@Defines = ();
# Delete temp. file if script is halted.
sub quit_upon_signal { print STDERR "Deleting $Tmp_prefix.hs .. \n"; unlink "$Tmp_prefix.hs"; }
exit(1);
}
-push(@Defines,
- ( #OLD: "-D__HASKELL1__=$Haskell_1",
- "-D__GLASGOW_HASKELL__=$ProjectVersionInt"));
-
@Import_dirs = split(/:/,$Import_dirs);
@Include_dirs = split(/\s+/,$Include_dirs); # still has -I's in it
while (dp = readdir (df)) {
if (dp->d_name[strlen(dp->d_name) - 1] == '~')
continue;
- if (dp->d_name[0] == '.' && dp->d_name[1] == '#') /* 'non-conflict files' left behind by CVS */
- continue;
strcpy (p, dp->d_name);
if (n_dirs > 0) {
$Begin_magic_str = "# DO NOT DELETE: Beginning of C dependencies\n";
$End_magic_str = "# DO NOT DELETE: End of C dependencies\n";
-$Obj_suffix = 'o';
+$Obj_suffix = '.o';
@Defines = ();
$Include_dirs = '';
$Makefile = '';
@Src_files = ();
-@File_suffix = ();
if ( $ENV{'TMPDIR'} ) { # where to make tmp file names
$Tmp_prefix = $ENV{'TMPDIR'} . "/mkdependC$$";
# a de-commenter (not implemented);
# builds up @Depend_lines
print STDERR "Here we go for source file: $sf\n" if $Verbose;
- ($bf = $sf) =~ s/\.(c|hc)$//;
+ ($of = $sf) =~ s/\.(c|hc)$/$Obj_suffix/;
&slurp_file($sf, 'fh00');
}
$Makefile = &grab_arg_arg($_);
} elsif ( /^-o/ ) {
$Obj_suffix = &grab_arg_arg($_);
- } elsif ( /^-s/ ) {
- local($suff) = &grab_arg_arg($_);
- push(@File_suffix, $suff);
} elsif ( /^-bs/ ) {
$Begin_magic_str = &grab_arg_arg($_) . "\n";
} elsif ( /^-es/ ) {
# don't bother w/ dependencies on /usr/include stuff
# don't bother if it looks like a GCC built-in hdr file
# don't bother with funny yacc-ish files
+ # don't bother with "literate" .h files (.lh); we'll just
+ # depend on the de-litified versions (which have better info)
# don't let a file depend on itself
next line if /^\/usr\/include/;
- # Hack - the cygwin32 dir structupre is odd!
+ # Hack - the cygwin32 dir structure is odd!
next line if /H-i386-cygwin32\/i386-cygwin32/;
next line if /H-i386-cygwin32\/lib\/gcc-lib\/i386-cygwin32/;
next line if /\/gcc-lib\/[^\/\n]+\/[\.0-9]+\/include\//;
next line if /\/gnu\/[^-\/]+-[^-\/]+-[^-\/]+\/include\//;
next line if /\/yaccpar/;
next line if /\/bison\.(simple|hairy)/;
+ next line if /\.lh$/;
next line if $_ eq $fname;
print STDERR "$fname :: $_\n" if $Verbose;
# ToDo: some sanity checks that we still have something reasonable?
- $int_file = $_;
- $depend = "$bf.$Obj_suffix ";
- foreach $suff (@File_suffix) {
- $depend .= "$bf.${suff}_$Obj_suffix ";
- }
- $depend .= " : $int_file\n";
-
+ $depend = "$of : $_\n";
next line if $Depend_seen{$depend}; # already seen this one...
- # OK, it's a new one.
- $Depend_seen{$depend} = 1;
+ # OK, it's a new one.
push (@Depend_lines, $depend);
+ $Depend_seen{$depend} = 1;
}
close($fhandle);
unlink($tempfile);
foreach $out_file ( @PgmStdoutFile ) {
if ( ! -f $out_file && !$SaveStdout ) {
- print STDERR "$Pgm: warning: expected-stderr file missing: $out_file\n";
+ print STDERR "$Pgm: warning: expected-stdout file missing: $out_file\n";
pop(@PgmStdoutFile);
}
}
/* Define if using alloca.c. */
#undef C_ALLOCA
-/* Define if text section appear before data section in exec. */
-#undef CODE_BEFORE_DATA
-
/* Define to empty if the keyword does not work. */
#undef const
This function is required for alloca.c support on those systems. */
#undef CRAY_STACKSEG_END
-/* Define to decl that terminates data section. */
-#undef DATA_SECTION_END_MARKER_DECL
-
-/* Define to section that terminates data section. */
-#undef DATA_SECTION_END_MARKER
-
/* Define if you have alloca, as a function or macro. */
#undef HAVE_ALLOCA
/* Define to alignment constraint on unsigned int - whichever is the greater */
#undef ALIGNMENT_UNSIGNED_INT
+/* Define if code lives before data in memory */
+#undef CODE_BEFORE_DATA
+
+/* Define as the symbol which marks the end of the data section */
+#undef DATA_SECTION_END_MARKER
+
+/* Define as the decl which terminates the data section */
+#undef DATA_SECTION_END_MARKER_DECL
+
/* Define if time.h or sys/time.h define the altzone variable */
#undef HAVE_ALTZONE
+/* Define if you have /bin/sh */
+#define HAVE_BIN_SH 0
+
+/* Define if you have the GetModuleFileName function. */
+#define HAVE_GETMODULEFILENAME 0
+
/* Define if C compiler supports long long types */
#undef HAVE_LONG_LONG
/* Define if fcntl.h defines O_BINARY */
#undef HAVE_O_BINARY
+/* Define if compiler supports prototypes. */
+#define HAVE_PROTOTYPES 0
+
+/* Define if you have the WinExec function. */
+#define HAVE_WINEXEC 0
+
/* Define if C Symbols have a leading underscore added by the compiler */
#undef LEADING_UNDERSCORE
+/* Define as the symbol which marks the end of the text section */
+#undef TEXT_SECTION_END_MARKER
+
+/* Define to decl that terminates text section. */
+#undef TEXT_SECTION_END_MARKER_DECL
+
/* Define to the type of the timezone variable (usually long or time_t) */
#undef TYPE_TIMEZONE
+/* Define if signal handlers have type void (*)(int)
+ * (Otherwise, they're assumed to have type int (*)(void).)
+ */
+#define VOID_INT_SIGNALS 0
+
/* The number of bytes in a double. */
#undef SIZEOF_DOUBLE
/* The number of bytes in a void *. */
#undef SIZEOF_VOID_P
+/* Define if you have the PBHSetVolSync function. */
+#undef HAVE_PBHSETVOLSYNC
+
+/* Define if you have the _fullpath function. */
+#undef HAVE__FULLPATH
+
+/* Define if you have the _pclose function. */
+#undef HAVE__PCLOSE
+
+/* Define if you have the _popen function. */
+#undef HAVE__POPEN
+
+/* Define if you have the _snprintf function. */
+#undef HAVE__SNPRINTF
+
+/* Define if you have the _stricmp function. */
+#undef HAVE__STRICMP
+
+/* Define if you have the _vsnprintf function. */
+#undef HAVE__VSNPRINTF
+
/* Define if you have the access function. */
#undef HAVE_ACCESS
+/* Define if you have the farcalloc function. */
+#undef HAVE_FARCALLOC
+
+/* Define if you have the fgetpos function. */
+#undef HAVE_FGETPOS
+
+/* Define if you have the fseek function. */
+#undef HAVE_FSEEK
+
+/* Define if you have the fsetpos function. */
+#undef HAVE_FSETPOS
+
+/* Define if you have the ftell function. */
+#undef HAVE_FTELL
+
/* Define if you have the ftime function. */
#undef HAVE_FTIME
/* Define if you have the gettimeofday function. */
#undef HAVE_GETTIMEOFDAY
+/* Define if you have the macsystem function. */
+#undef HAVE_MACSYSTEM
+
/* Define if you have the mktime function. */
#undef HAVE_MKTIME
/* Define if you have the mprotect function. */
#undef HAVE_MPROTECT
+/* Define if you have the pclose function. */
+#undef HAVE_PCLOSE
+
+/* Define if you have the popen function. */
+#undef HAVE_POPEN
+
+/* Define if you have the readlink function. */
+#undef HAVE_READLINK
+
+/* Define if you have the realpath function. */
+#undef HAVE_REALPATH
+
/* Define if you have the setitimer function. */
#undef HAVE_SETITIMER
+/* Define if you have the snprintf function. */
+#undef HAVE_SNPRINTF
+
/* Define if you have the stat function. */
#undef HAVE_STAT
+/* Define if you have the strcasecmp function. */
+#undef HAVE_STRCASECMP
+
+/* Define if you have the strcmp function. */
+#undef HAVE_STRCMP
+
+/* Define if you have the strcmpi function. */
+#undef HAVE_STRCMPI
+
+/* Define if you have the stricmp function. */
+#undef HAVE_STRICMP
+
+/* Define if you have the symlink function. */
+#undef HAVE_SYMLINK
+
/* Define if you have the sysconf function. */
#undef HAVE_SYSCONF
/* Define if you have the vadvise function. */
#undef HAVE_VADVISE
+/* Define if you have the valloc function. */
+#undef HAVE_VALLOC
+
/* Define if you have the vfork function. */
#undef HAVE_VFORK
+/* Define if you have the vsnprintf function. */
+#undef HAVE_VSNPRINTF
+
+/* Define if you have the <Files.h> header file. */
+#undef HAVE_FILES_H
+
+/* Define if you have the <assert.h> header file. */
+#undef HAVE_ASSERT_H
+
/* Define if you have the <bfd.h> header file. */
#undef HAVE_BFD_H
+/* Define if you have the <conio.h> header file. */
+#undef HAVE_CONIO_H
+
+/* Define if you have the <console.h> header file. */
+#undef HAVE_CONSOLE_H
+
+/* Define if you have the <ctype.h> header file. */
+#undef HAVE_CTYPE_H
+
/* Define if you have the <dirent.h> header file. */
#undef HAVE_DIRENT_H
+/* Define if you have the <dl.h> header file. */
+#undef HAVE_DL_H
+
+/* Define if you have the <dlfcn.h> header file. */
+#undef HAVE_DLFCN_H
+
+/* Define if you have the <dos.h> header file. */
+#undef HAVE_DOS_H
+
+/* Define if you have the <errno.h> header file. */
+#undef HAVE_ERRNO_H
+
/* Define if you have the <fcntl.h> header file. */
#undef HAVE_FCNTL_H
+/* Define if you have the <float.h> header file. */
+#undef HAVE_FLOAT_H
+
+/* Define if you have the <ftw.h> header file. */
+#undef HAVE_FTW_H
+
/* Define if you have the <grp.h> header file. */
#undef HAVE_GRP_H
+/* Define if you have the <ieee754.h> header file. */
+#undef HAVE_IEEE754_H
+
+/* Define if you have the <io.h> header file. */
+#undef HAVE_IO_H
+
/* Define if you have the <malloc.h> header file. */
#undef HAVE_MALLOC_H
/* Define if you have the <nlist.h> header file. */
#undef HAVE_NLIST_H
+/* Define if you have the <pascal.h> header file. */
+#undef HAVE_PASCAL_H
+
/* Define if you have the <pwd.h> header file. */
#undef HAVE_PWD_H
/* Define if you have the <readline/readline.h> header file. */
#undef HAVE_READLINE_READLINE_H
-/* Define if you have the readlink function. */
-#undef HAVE_READLINK
+/* Define if you have the <sgtty.h> header file. */
+#undef HAVE_SGTTY_H
/* Define if you have the <siginfo.h> header file. */
#undef HAVE_SIGINFO_H
/* Define if you have the <signal.h> header file. */
#undef HAVE_SIGNAL_H
+/* Define if you have the <stat.h> header file. */
+#undef HAVE_STAT_H
+
+/* Define if you have the <std.h> header file. */
+#undef HAVE_STD_H
+
+/* Define if you have the <stdarg.h> header file. */
+#undef HAVE_STDARG_H
+
/* Define if you have the <stdlib.h> header file. */
#undef HAVE_STDLIB_H
/* Define if you have the <string.h> header file. */
#undef HAVE_STRING_H
-/* Define if you have the symlink function. */
-#undef HAVE_SYMLINK
-
/* Define if you have the <sys/fault.h> header file. */
#undef HAVE_SYS_FAULT_H
/* Define if you have the <sys/file.h> header file. */
#undef HAVE_SYS_FILE_H
+/* Define if you have the <sys/ioctl.h> header file. */
+#undef HAVE_SYS_IOCTL_H
+
/* Define if you have the <sys/mman.h> header file. */
#undef HAVE_SYS_MMAN_H
/* Define if you have the <sys/wait.h> header file. */
#undef HAVE_SYS_WAIT_H
+/* Define if you have the <termio.h> header file. */
+#undef HAVE_TERMIO_H
+
/* Define if you have the <termios.h> header file. */
#undef HAVE_TERMIOS_H
/* Define if you have the <utime.h> header file. */
#undef HAVE_UTIME_H
+/* Define if you have the <values.h> header file. */
+#undef HAVE_VALUES_H
+
/* Define if you have the <vfork.h> header file. */
#undef HAVE_VFORK_H
+/* Define if you have the <windows.h> header file. */
+#undef HAVE_WINDOWS_H
+
/* Define if you have the bfd library (-lbfd). */
#undef HAVE_LIBBFD
/* Define if you have the iberty library (-liberty). */
#undef HAVE_LIBIBERTY
-
-/* Define to decl that terminates text section. */
-#undef TEXT_SECTION_END_MARKER_DECL
-
-/* Define to symbol that terminates text section. */
-#undef TEXT_SECTION_END_MARKER
-
# Building various ways?
# (right now, empty if not).
BuildingParallel=$(subst mp,YES,$(filter mp,$(WAYS)))
-BuildingConcurrent=$(subst mc,YES,$(filter mc,$(WAYS)))
BuildingProfiling=$(subst p,YES,$(filter p,$(WAYS)))
BuildingGranSim=$(subst mg,YES,$(filter mg,$(WAYS)))
-BuildingProfilingConcurrent=$(subst mr,YES,$(filter mr,$(WAYS)))
#---------------------------------------------------------------
#
GhcLibHcOpts=-O -split-objs -odir $*
endif
+# Option flags to pass to GHC when it's compiling RTS modules
+# This is a good way to set things like -optc-g and -optc-DDEBUG for the RTS.
+# GhcRtsHcOpts is used when compiling .hc files.
+# GhcRtsCcOpts is used when compiling .c files.
+
+GhcRtsHcOpts=
+GhcRtsCcOpts=
+
# Build the Haskell Readline bindings?
#
GhcLibsWithReadline=NO
# Include compiler support for letting the compiler (optionally) report
# your compilation to a central server for generation of fun stats.
#
-GhcReportCompiles=NO
+GhcReportCompiles=YES
#################################################################################
#
endif
#-----------------------------------------------------------------------------
-# GMP Library
+# GMP Library (version 2.0.x or above)
#
HaveLibGmp = @HaveLibGmp@
LibGmp = @LibGmp@
#
# The ways currently defined.
#
-ALL_WAYS=p t u mc mr mt mp mg 1s 2s du a b c d e f g h i j k l m n o A B
+ALL_WAYS=p t u mp mg a b c d e f g h i j k l m n o A B
#
-# The following ways currently have treated specially, p u t mc mt my mp mg 1s 2d du,
+# The following ways currently have treated specially, p u t mg,
# as the driver script treats these guys specially and needs to carefully be told
# about the options for these. Hence, we hide the required command line options
# for these in the ghc/driver, as this is the only place they are needed.
#
# If you want to add to these default options, fill in the variables below:
-#
+
+# Way 'p':
WAY_p_NAME=profiling
WAY_p_HC_OPTS= -prof
-# Way t:
+# Way 't':
WAY_t_NAME=ticky-ticky profiling
WAY_t_HC_OPTS= -ticky
WAY_u_NAME=unregisterized (using portable C only)
WAY_u_HC_OPTS=
-# Way `mc': concurrent
-WAY_mc_NAME=concurrent
-WAY_mc_HC_OPTS=-concurrent
-
-# Way `mr':
-WAY_mr_NAME=profiled concurrent
-WAY_mr_HC_OPTS=-prof -concurrent
-
-# Way `mt':
-WAY_mt_NAME=ticky-ticky concurrent
-WAY_mt_HC_OPTS=-ticky -concurrent
-
# Way `mp':
WAY_mp_NAME=parallel
WAY_mp_HC_OPTS=-parallel
-#
# Way `mg':
-#
WAY_mg_NAME=GranSim
WAY_mg_HC_OPTS=-gransim
#
-# Ways for different garbage collectors
-#
-WAY_2s_NAME=2-space GC
-WAY_2s_HC_OPTS=-2s
-
-WAY_1s_NAME=1-space GC
-WAY_1s_HC_OPTS=-1s
-
-WAY_du_NAME=dual-mode GC
-WAY_du_HC_OPTS=-du
-
-#
# Add user-way configurations here:
#
WAY_A_NAME=
HS_SRCS=$(filter %.lhs %.hs %.hc,$(SRCS) $(BOOT_SRCS))
HS_OBJS=$(addsuffix .$(way_)o,$(basename $(HS_SRCS)))
+HS_HCS=$(addsuffix .$(way_)hc,$(basename $(HS_SRCS)))
HS_IFACES=$(addsuffix .$(way_)hi,$(basename $(HS_SRCS)))
C_SRCS=$(filter %.lc %.c,$(SRCS))
#
#
MOSTLY_CLEAN_FILES += $(HS_OBJS) $(C_OBJS)
-CLEAN_FILES += $(HS_PROG) $(C_PROG) $(SCRIPT_PROG) $(PROG) $(LIBRARY) \
- $(HS_IFACES) \
- a.out core
+CLEAN_FILES += $(HS_PROG) $(C_PROG) $(SCRIPT_PROG) $(PROG) \
+ $(LIBRARY) $(HS_IFACES) $(HS_HCS) \
+ a.out
+
MAINTAINER_CLEAN_FILES += .depend $(BOOT_SRCS)
#
$(HC) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
$(HC_POST_OPTS)
+%.$(way_)o : %.hc
+ $(HC_PRE_OPTS)
+ $(HC) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
+ $(HC_POST_OPTS)
+
%.$(way_)s : %.$(way_)hc
$(HC_PRE_OPTS)
$(HC) $(HC_OPTS) -S $< -o $@ -osuf $(subst .,,$(suffix $@))
$(MKDEPENDLIT) -o .depend $(MKDEPENDLIT_OPTS) $(filter %.lit,$(DOC_SRCS))
endif
ifneq "$(MKDEPENDC_SRCS)" ""
- $(MKDEPENDC) -f .depend $(MKDEPENDC_OPTS) -- $(CC_OPTS) -- $(MKDEPENDC_SRCS)
+ $(MKDEPENDC) -f .depend $(MKDEPENDC_OPTS) $(foreach way,$(WAYS),-s $(way)) -- $(CC_OPTS) -- $(MKDEPENDC_SRCS)
endif
ifneq "$(MKDEPENDHS_SRCS)" ""
$(MKDEPENDHS) -M -optdep-f -optdep.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-optdep-o -optdep$(obj)) $(MKDEPENDHS_OPTS) $(patsubst -odir,,$(HC_OPTS)) $(MKDEPENDHS_SRCS)
# multi-file SGML document: main document name is specified in $(SGML_DOC),
# sub-documents (.sgml files) listed in $(SGML_SRCS).
-$(SGML_DOC).sgml : $(SGML_SRCS)
- cat $(SGML_SRCS) > $(SGML_DOC).sgml
-
-SGML_DVI = $(SGML_DOC).dvi
-SGML_PS = $(SGML_DOC).ps
-SGML_INFO = $(SGML_DOC).info
-SGML_HTML = $(SGML_DOC).html
-SGML_TEXT = $(SGML_DOC).txt
-
-else # no SGML_DOC
-
ifeq "$(VSGML_SRCS)" ""
VSGML_SRCS = $(wildcard *.vsgml)
endif
ifeq "$(SGML_SRCS)" ""
ifneq "$(VSGML_SRCS)" ""
-SGML_SRCS = $(addsuffix .sgml, $(basename $(VSGML_SRCS)))
+SGML_SRCS = $(patsubst %.vsgml, %.sgml, $(VSGML_SRCS))
else
-SGML_SRCS = $(wildcard *.sgml)
+SGML_SRCS = $(wildcard *.sgml)
endif
endif
-SGML_DVI = $(addsuffix .dvi, $(basename $(SGML_SRCS)))
-SGML_PS = $(addsuffix .ps, $(basename $(SGML_SRCS)))
-SGML_INFO = $(addsuffix .info, $(basename $(SGML_SRCS)))
-SGML_HTML = $(addsuffix .html, $(basename $(SGML_SRCS)))
-SGML_TEXT = $(addsuffix .txt, $(basename $(SGML_SRCS)))
+SGML_DVI = $(SGML_DOC).dvi
+SGML_PS = $(SGML_DOC).ps
+SGML_INFO = $(SGML_DOC).info
+SGML_HTML = $(SGML_DOC).html
+SGML_TEXT = $(SGML_DOC).txt
-endif # SGML_DOC
+$(SGML_DVI) $(SGML_PS) $(SGML_INFO) $(SGML_HTML) $(SGML_TEXT) :: $(SGML_SRCS)
dvi :: $(SGML_DVI)
info :: $(SGML_INFO)
txt :: $(SGML_TXT)
ps :: $(SGML_PS)
-CLEAN_FILES += $(SGML_TEXT) $(SGML_HTML) $(SGML_PS) $(SGML_DVI)
+CLEAN_FILES += $(SGML_TEXT) $(SGML_DOC)*.html $(SGML_PS) $(SGML_DVI)
+
+endif
###########################################
#
projects / ghc-hetmet.git / commitdiff